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
39 # if defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L && !defined(__VMS)
48 /* Missing proto on LynxOS */
49 char *gconvert(double, int, int, char *);
52 #ifdef PERL_NEW_COPY_ON_WRITE
53 # ifndef SV_COW_THRESHOLD
54 # define SV_COW_THRESHOLD 0 /* COW iff len > K */
56 # ifndef SV_COWBUF_THRESHOLD
57 # define SV_COWBUF_THRESHOLD 1250 /* COW iff len > K */
59 # ifndef SV_COW_MAX_WASTE_THRESHOLD
60 # define SV_COW_MAX_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */
62 # ifndef SV_COWBUF_WASTE_THRESHOLD
63 # define SV_COWBUF_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */
65 # ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD
66 # define SV_COW_MAX_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */
68 # ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD
69 # define SV_COWBUF_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */
72 /* Work around compiler warnings about unsigned >= THRESHOLD when thres-
75 # define GE_COW_THRESHOLD(cur) ((cur) >= SV_COW_THRESHOLD)
77 # define GE_COW_THRESHOLD(cur) 1
79 #if SV_COWBUF_THRESHOLD
80 # define GE_COWBUF_THRESHOLD(cur) ((cur) >= SV_COWBUF_THRESHOLD)
82 # define GE_COWBUF_THRESHOLD(cur) 1
84 #if SV_COW_MAX_WASTE_THRESHOLD
85 # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COW_MAX_WASTE_THRESHOLD)
87 # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) 1
89 #if SV_COWBUF_WASTE_THRESHOLD
90 # define GE_COWBUF_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COWBUF_WASTE_THRESHOLD)
92 # define GE_COWBUF_WASTE_THRESHOLD(cur,len) 1
94 #if SV_COW_MAX_WASTE_FACTOR_THRESHOLD
95 # define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COW_MAX_WASTE_FACTOR_THRESHOLD * (cur))
97 # define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) 1
99 #if SV_COWBUF_WASTE_FACTOR_THRESHOLD
100 # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COWBUF_WASTE_FACTOR_THRESHOLD * (cur))
102 # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) 1
105 #define CHECK_COW_THRESHOLD(cur,len) (\
106 GE_COW_THRESHOLD((cur)) && \
107 GE_COW_MAX_WASTE_THRESHOLD((cur),(len)) && \
108 GE_COW_MAX_WASTE_FACTOR_THRESHOLD((cur),(len)) \
110 #define CHECK_COWBUF_THRESHOLD(cur,len) (\
111 GE_COWBUF_THRESHOLD((cur)) && \
112 GE_COWBUF_WASTE_THRESHOLD((cur),(len)) && \
113 GE_COWBUF_WASTE_FACTOR_THRESHOLD((cur),(len)) \
115 /* void Gconvert: on Linux at least, gcvt (which Gconvert gets deffed to),
116 * has a mandatory return value, even though that value is just the same
119 #ifdef PERL_UTF8_CACHE_ASSERT
120 /* if adding more checks watch out for the following tests:
121 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
122 * lib/utf8.t lib/Unicode/Collate/t/index.t
125 # define ASSERT_UTF8_CACHE(cache) \
126 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
127 assert((cache)[2] <= (cache)[3]); \
128 assert((cache)[3] <= (cache)[1]);} \
131 # define ASSERT_UTF8_CACHE(cache) NOOP
134 #ifdef PERL_OLD_COPY_ON_WRITE
135 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
136 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
139 /* ============================================================================
141 =head1 Allocation and deallocation of SVs.
142 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
143 sv, av, hv...) contains type and reference count information, and for
144 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
145 contains fields specific to each type. Some types store all they need
146 in the head, so don't have a body.
148 In all but the most memory-paranoid configurations (ex: PURIFY), heads
149 and bodies are allocated out of arenas, which by default are
150 approximately 4K chunks of memory parcelled up into N heads or bodies.
151 Sv-bodies are allocated by their sv-type, guaranteeing size
152 consistency needed to allocate safely from arrays.
154 For SV-heads, the first slot in each arena is reserved, and holds a
155 link to the next arena, some flags, and a note of the number of slots.
156 Snaked through each arena chain is a linked list of free items; when
157 this becomes empty, an extra arena is allocated and divided up into N
158 items which are threaded into the free list.
160 SV-bodies are similar, but they use arena-sets by default, which
161 separate the link and info from the arena itself, and reclaim the 1st
162 slot in the arena. SV-bodies are further described later.
164 The following global variables are associated with arenas:
166 PL_sv_arenaroot pointer to list of SV arenas
167 PL_sv_root pointer to list of free SV structures
169 PL_body_arenas head of linked-list of body arenas
170 PL_body_roots[] array of pointers to list of free bodies of svtype
171 arrays are indexed by the svtype needed
173 A few special SV heads are not allocated from an arena, but are
174 instead directly created in the interpreter structure, eg PL_sv_undef.
175 The size of arenas can be changed from the default by setting
176 PERL_ARENA_SIZE appropriately at compile time.
178 The SV arena serves the secondary purpose of allowing still-live SVs
179 to be located and destroyed during final cleanup.
181 At the lowest level, the macros new_SV() and del_SV() grab and free
182 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
183 to return the SV to the free list with error checking.) new_SV() calls
184 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
185 SVs in the free list have their SvTYPE field set to all ones.
187 At the time of very final cleanup, sv_free_arenas() is called from
188 perl_destruct() to physically free all the arenas allocated since the
189 start of the interpreter.
191 The function visit() scans the SV arenas list, and calls a specified
192 function for each SV it finds which is still live - ie which has an SvTYPE
193 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
194 following functions (specified as [function that calls visit()] / [function
195 called by visit() for each SV]):
197 sv_report_used() / do_report_used()
198 dump all remaining SVs (debugging aid)
200 sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
201 do_clean_named_io_objs(),do_curse()
202 Attempt to free all objects pointed to by RVs,
203 try to do the same for all objects indir-
204 ectly referenced by typeglobs too, and
205 then do a final sweep, cursing any
206 objects that remain. Called once from
207 perl_destruct(), prior to calling sv_clean_all()
210 sv_clean_all() / do_clean_all()
211 SvREFCNT_dec(sv) each remaining SV, possibly
212 triggering an sv_free(). It also sets the
213 SVf_BREAK flag on the SV to indicate that the
214 refcnt has been artificially lowered, and thus
215 stopping sv_free() from giving spurious warnings
216 about SVs which unexpectedly have a refcnt
217 of zero. called repeatedly from perl_destruct()
218 until there are no SVs left.
220 =head2 Arena allocator API Summary
222 Private API to rest of sv.c
226 new_XPVNV(), del_XPVGV(),
231 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
235 * ========================================================================= */
238 * "A time to plant, and a time to uproot what was planted..."
242 # define MEM_LOG_NEW_SV(sv, file, line, func) \
243 Perl_mem_log_new_sv(sv, file, line, func)
244 # define MEM_LOG_DEL_SV(sv, file, line, func) \
245 Perl_mem_log_del_sv(sv, file, line, func)
247 # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP
248 # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP
251 #ifdef DEBUG_LEAKING_SCALARS
252 # define FREE_SV_DEBUG_FILE(sv) STMT_START { \
253 if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \
255 # define DEBUG_SV_SERIAL(sv) \
256 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
257 PTR2UV(sv), (long)(sv)->sv_debug_serial))
259 # define FREE_SV_DEBUG_FILE(sv)
260 # define DEBUG_SV_SERIAL(sv) NOOP
264 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
265 # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val))
266 /* Whilst I'd love to do this, it seems that things like to check on
268 # define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
270 # define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
271 PoisonNew(&SvREFCNT(sv), 1, U32)
273 # define SvARENA_CHAIN(sv) SvANY(sv)
274 # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val)
275 # define POSION_SV_HEAD(sv)
278 /* Mark an SV head as unused, and add to free list.
280 * If SVf_BREAK is set, skip adding it to the free list, as this SV had
281 * its refcount artificially decremented during global destruction, so
282 * there may be dangling pointers to it. The last thing we want in that
283 * case is for it to be reused. */
285 #define plant_SV(p) \
287 const U32 old_flags = SvFLAGS(p); \
288 MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
289 DEBUG_SV_SERIAL(p); \
290 FREE_SV_DEBUG_FILE(p); \
292 SvFLAGS(p) = SVTYPEMASK; \
293 if (!(old_flags & SVf_BREAK)) { \
294 SvARENA_CHAIN_SET(p, PL_sv_root); \
300 #define uproot_SV(p) \
303 PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \
308 /* make some more SVs by adding another arena */
314 char *chunk; /* must use New here to match call to */
315 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
316 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
321 /* new_SV(): return a new, empty SV head */
323 #ifdef DEBUG_LEAKING_SCALARS
324 /* provide a real function for a debugger to play with */
326 S_new_SV(pTHX_ const char *file, int line, const char *func)
333 sv = S_more_sv(aTHX);
337 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
338 sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
344 sv->sv_debug_inpad = 0;
345 sv->sv_debug_parent = NULL;
346 sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
348 sv->sv_debug_serial = PL_sv_serial++;
350 MEM_LOG_NEW_SV(sv, file, line, func);
351 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
352 PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
356 # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
364 (p) = S_more_sv(aTHX); \
368 MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \
373 /* del_SV(): return an empty SV head to the free list */
386 S_del_sv(pTHX_ SV *p)
388 PERL_ARGS_ASSERT_DEL_SV;
393 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
394 const SV * const sv = sva + 1;
395 const SV * const svend = &sva[SvREFCNT(sva)];
396 if (p >= sv && p < svend) {
402 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
403 "Attempt to free non-arena SV: 0x%"UVxf
404 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
411 #else /* ! DEBUGGING */
413 #define del_SV(p) plant_SV(p)
415 #endif /* DEBUGGING */
419 =head1 SV Manipulation Functions
421 =for apidoc sv_add_arena
423 Given a chunk of memory, link it to the head of the list of arenas,
424 and split it into a list of free SVs.
430 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
432 SV *const sva = MUTABLE_SV(ptr);
436 PERL_ARGS_ASSERT_SV_ADD_ARENA;
438 /* The first SV in an arena isn't an SV. */
439 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
440 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
441 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
443 PL_sv_arenaroot = sva;
444 PL_sv_root = sva + 1;
446 svend = &sva[SvREFCNT(sva) - 1];
449 SvARENA_CHAIN_SET(sv, (sv + 1));
453 /* Must always set typemask because it's always checked in on cleanup
454 when the arenas are walked looking for objects. */
455 SvFLAGS(sv) = SVTYPEMASK;
458 SvARENA_CHAIN_SET(sv, 0);
462 SvFLAGS(sv) = SVTYPEMASK;
465 /* visit(): call the named function for each non-free SV in the arenas
466 * whose flags field matches the flags/mask args. */
469 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
474 PERL_ARGS_ASSERT_VISIT;
476 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
477 const SV * const svend = &sva[SvREFCNT(sva)];
479 for (sv = sva + 1; sv < svend; ++sv) {
480 if (SvTYPE(sv) != (svtype)SVTYPEMASK
481 && (sv->sv_flags & mask) == flags
494 /* called by sv_report_used() for each live SV */
497 do_report_used(pTHX_ SV *const sv)
499 if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
500 PerlIO_printf(Perl_debug_log, "****\n");
507 =for apidoc sv_report_used
509 Dump the contents of all SVs not yet freed (debugging aid).
515 Perl_sv_report_used(pTHX)
518 visit(do_report_used, 0, 0);
524 /* called by sv_clean_objs() for each live SV */
527 do_clean_objs(pTHX_ SV *const ref)
531 SV * const target = SvRV(ref);
532 if (SvOBJECT(target)) {
533 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
534 if (SvWEAKREF(ref)) {
535 sv_del_backref(target, ref);
541 SvREFCNT_dec_NN(target);
548 /* clear any slots in a GV which hold objects - except IO;
549 * called by sv_clean_objs() for each live GV */
552 do_clean_named_objs(pTHX_ SV *const sv)
555 assert(SvTYPE(sv) == SVt_PVGV);
556 assert(isGV_with_GP(sv));
560 /* freeing GP entries may indirectly free the current GV;
561 * hold onto it while we mess with the GP slots */
564 if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
565 DEBUG_D((PerlIO_printf(Perl_debug_log,
566 "Cleaning named glob SV object:\n "), sv_dump(obj)));
568 SvREFCNT_dec_NN(obj);
570 if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
571 DEBUG_D((PerlIO_printf(Perl_debug_log,
572 "Cleaning named glob AV object:\n "), sv_dump(obj)));
574 SvREFCNT_dec_NN(obj);
576 if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
577 DEBUG_D((PerlIO_printf(Perl_debug_log,
578 "Cleaning named glob HV object:\n "), sv_dump(obj)));
580 SvREFCNT_dec_NN(obj);
582 if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
583 DEBUG_D((PerlIO_printf(Perl_debug_log,
584 "Cleaning named glob CV object:\n "), sv_dump(obj)));
586 SvREFCNT_dec_NN(obj);
588 SvREFCNT_dec_NN(sv); /* undo the inc above */
591 /* clear any IO slots in a GV which hold objects (except stderr, defout);
592 * called by sv_clean_objs() for each live GV */
595 do_clean_named_io_objs(pTHX_ SV *const sv)
598 assert(SvTYPE(sv) == SVt_PVGV);
599 assert(isGV_with_GP(sv));
600 if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
604 if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
605 DEBUG_D((PerlIO_printf(Perl_debug_log,
606 "Cleaning named glob IO object:\n "), sv_dump(obj)));
608 SvREFCNT_dec_NN(obj);
610 SvREFCNT_dec_NN(sv); /* undo the inc above */
613 /* Void wrapper to pass to visit() */
615 do_curse(pTHX_ SV * const sv) {
616 if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
617 || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
623 =for apidoc sv_clean_objs
625 Attempt to destroy all objects not yet freed.
631 Perl_sv_clean_objs(pTHX)
634 PL_in_clean_objs = TRUE;
635 visit(do_clean_objs, SVf_ROK, SVf_ROK);
636 /* Some barnacles may yet remain, clinging to typeglobs.
637 * Run the non-IO destructors first: they may want to output
638 * error messages, close files etc */
639 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
640 visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
641 /* And if there are some very tenacious barnacles clinging to arrays,
642 closures, or what have you.... */
643 visit(do_curse, SVs_OBJECT, SVs_OBJECT);
644 olddef = PL_defoutgv;
645 PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
646 if (olddef && isGV_with_GP(olddef))
647 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
648 olderr = PL_stderrgv;
649 PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
650 if (olderr && isGV_with_GP(olderr))
651 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
652 SvREFCNT_dec(olddef);
653 PL_in_clean_objs = FALSE;
656 /* called by sv_clean_all() for each live SV */
659 do_clean_all(pTHX_ SV *const sv)
661 if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
662 /* don't clean pid table and strtab */
665 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
666 SvFLAGS(sv) |= SVf_BREAK;
671 =for apidoc sv_clean_all
673 Decrement the refcnt of each remaining SV, possibly triggering a
674 cleanup. This function may have to be called multiple times to free
675 SVs which are in complex self-referential hierarchies.
681 Perl_sv_clean_all(pTHX)
684 PL_in_clean_all = TRUE;
685 cleaned = visit(do_clean_all, 0,0);
690 ARENASETS: a meta-arena implementation which separates arena-info
691 into struct arena_set, which contains an array of struct
692 arena_descs, each holding info for a single arena. By separating
693 the meta-info from the arena, we recover the 1st slot, formerly
694 borrowed for list management. The arena_set is about the size of an
695 arena, avoiding the needless malloc overhead of a naive linked-list.
697 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
698 memory in the last arena-set (1/2 on average). In trade, we get
699 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
700 smaller types). The recovery of the wasted space allows use of
701 small arenas for large, rare body types, by changing array* fields
702 in body_details_by_type[] below.
705 char *arena; /* the raw storage, allocated aligned */
706 size_t size; /* its size ~4k typ */
707 svtype utype; /* bodytype stored in arena */
712 /* Get the maximum number of elements in set[] such that struct arena_set
713 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
714 therefore likely to be 1 aligned memory page. */
716 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
717 - 2 * sizeof(int)) / sizeof (struct arena_desc))
720 struct arena_set* next;
721 unsigned int set_size; /* ie ARENAS_PER_SET */
722 unsigned int curr; /* index of next available arena-desc */
723 struct arena_desc set[ARENAS_PER_SET];
727 =for apidoc sv_free_arenas
729 Deallocate the memory used by all arenas. Note that all the individual SV
730 heads and bodies within the arenas must already have been freed.
736 Perl_sv_free_arenas(pTHX)
742 /* Free arenas here, but be careful about fake ones. (We assume
743 contiguity of the fake ones with the corresponding real ones.) */
745 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
746 svanext = MUTABLE_SV(SvANY(sva));
747 while (svanext && SvFAKE(svanext))
748 svanext = MUTABLE_SV(SvANY(svanext));
755 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
758 struct arena_set *current = aroot;
761 assert(aroot->set[i].arena);
762 Safefree(aroot->set[i].arena);
770 i = PERL_ARENA_ROOTS_SIZE;
772 PL_body_roots[i] = 0;
779 Here are mid-level routines that manage the allocation of bodies out
780 of the various arenas. There are 5 kinds of arenas:
782 1. SV-head arenas, which are discussed and handled above
783 2. regular body arenas
784 3. arenas for reduced-size bodies
787 Arena types 2 & 3 are chained by body-type off an array of
788 arena-root pointers, which is indexed by svtype. Some of the
789 larger/less used body types are malloced singly, since a large
790 unused block of them is wasteful. Also, several svtypes dont have
791 bodies; the data fits into the sv-head itself. The arena-root
792 pointer thus has a few unused root-pointers (which may be hijacked
793 later for arena types 4,5)
795 3 differs from 2 as an optimization; some body types have several
796 unused fields in the front of the structure (which are kept in-place
797 for consistency). These bodies can be allocated in smaller chunks,
798 because the leading fields arent accessed. Pointers to such bodies
799 are decremented to point at the unused 'ghost' memory, knowing that
800 the pointers are used with offsets to the real memory.
803 =head1 SV-Body Allocation
807 Allocation of SV-bodies is similar to SV-heads, differing as follows;
808 the allocation mechanism is used for many body types, so is somewhat
809 more complicated, it uses arena-sets, and has no need for still-live
812 At the outermost level, (new|del)_X*V macros return bodies of the
813 appropriate type. These macros call either (new|del)_body_type or
814 (new|del)_body_allocated macro pairs, depending on specifics of the
815 type. Most body types use the former pair, the latter pair is used to
816 allocate body types with "ghost fields".
818 "ghost fields" are fields that are unused in certain types, and
819 consequently don't need to actually exist. They are declared because
820 they're part of a "base type", which allows use of functions as
821 methods. The simplest examples are AVs and HVs, 2 aggregate types
822 which don't use the fields which support SCALAR semantics.
824 For these types, the arenas are carved up into appropriately sized
825 chunks, we thus avoid wasted memory for those unaccessed members.
826 When bodies are allocated, we adjust the pointer back in memory by the
827 size of the part not allocated, so it's as if we allocated the full
828 structure. (But things will all go boom if you write to the part that
829 is "not there", because you'll be overwriting the last members of the
830 preceding structure in memory.)
832 We calculate the correction using the STRUCT_OFFSET macro on the first
833 member present. If the allocated structure is smaller (no initial NV
834 actually allocated) then the net effect is to subtract the size of the NV
835 from the pointer, to return a new pointer as if an initial NV were actually
836 allocated. (We were using structures named *_allocated for this, but
837 this turned out to be a subtle bug, because a structure without an NV
838 could have a lower alignment constraint, but the compiler is allowed to
839 optimised accesses based on the alignment constraint of the actual pointer
840 to the full structure, for example, using a single 64 bit load instruction
841 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
843 This is the same trick as was used for NV and IV bodies. Ironically it
844 doesn't need to be used for NV bodies any more, because NV is now at
845 the start of the structure. IV bodies don't need it either, because
846 they are no longer allocated.
848 In turn, the new_body_* allocators call S_new_body(), which invokes
849 new_body_inline macro, which takes a lock, and takes a body off the
850 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
851 necessary to refresh an empty list. Then the lock is released, and
852 the body is returned.
854 Perl_more_bodies allocates a new arena, and carves it up into an array of N
855 bodies, which it strings into a linked list. It looks up arena-size
856 and body-size from the body_details table described below, thus
857 supporting the multiple body-types.
859 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
860 the (new|del)_X*V macros are mapped directly to malloc/free.
862 For each sv-type, struct body_details bodies_by_type[] carries
863 parameters which control these aspects of SV handling:
865 Arena_size determines whether arenas are used for this body type, and if
866 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
867 zero, forcing individual mallocs and frees.
869 Body_size determines how big a body is, and therefore how many fit into
870 each arena. Offset carries the body-pointer adjustment needed for
871 "ghost fields", and is used in *_allocated macros.
873 But its main purpose is to parameterize info needed in
874 Perl_sv_upgrade(). The info here dramatically simplifies the function
875 vs the implementation in 5.8.8, making it table-driven. All fields
876 are used for this, except for arena_size.
878 For the sv-types that have no bodies, arenas are not used, so those
879 PL_body_roots[sv_type] are unused, and can be overloaded. In
880 something of a special case, SVt_NULL is borrowed for HE arenas;
881 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
882 bodies_by_type[SVt_NULL] slot is not used, as the table is not
887 struct body_details {
888 U8 body_size; /* Size to allocate */
889 U8 copy; /* Size of structure to copy (may be shorter) */
891 unsigned int type : 4; /* We have space for a sanity check. */
892 unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
893 unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
894 unsigned int arena : 1; /* Allocated from an arena */
895 size_t arena_size; /* Size of arena to allocate */
903 /* With -DPURFIY we allocate everything directly, and don't use arenas.
904 This seems a rather elegant way to simplify some of the code below. */
905 #define HASARENA FALSE
907 #define HASARENA TRUE
909 #define NOARENA FALSE
911 /* Size the arenas to exactly fit a given number of bodies. A count
912 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
913 simplifying the default. If count > 0, the arena is sized to fit
914 only that many bodies, allowing arenas to be used for large, rare
915 bodies (XPVFM, XPVIO) without undue waste. The arena size is
916 limited by PERL_ARENA_SIZE, so we can safely oversize the
919 #define FIT_ARENA0(body_size) \
920 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
921 #define FIT_ARENAn(count,body_size) \
922 ( count * body_size <= PERL_ARENA_SIZE) \
923 ? count * body_size \
924 : FIT_ARENA0 (body_size)
925 #define FIT_ARENA(count,body_size) \
927 ? FIT_ARENAn (count, body_size) \
928 : FIT_ARENA0 (body_size)
930 /* Calculate the length to copy. Specifically work out the length less any
931 final padding the compiler needed to add. See the comment in sv_upgrade
932 for why copying the padding proved to be a bug. */
934 #define copy_length(type, last_member) \
935 STRUCT_OFFSET(type, last_member) \
936 + sizeof (((type*)SvANY((const SV *)0))->last_member)
938 static const struct body_details bodies_by_type[] = {
939 /* HEs use this offset for their arena. */
940 { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
942 /* IVs are in the head, so the allocation size is 0. */
944 sizeof(IV), /* This is used to copy out the IV body. */
945 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
946 NOARENA /* IVS don't need an arena */, 0
949 { sizeof(NV), sizeof(NV),
950 STRUCT_OFFSET(XPVNV, xnv_u),
951 SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
953 { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
954 copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
955 + STRUCT_OFFSET(XPV, xpv_cur),
956 SVt_PV, FALSE, NONV, HASARENA,
957 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
959 { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur),
960 copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur),
961 + STRUCT_OFFSET(XPV, xpv_cur),
962 SVt_INVLIST, TRUE, NONV, HASARENA,
963 FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) },
965 { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
966 copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
967 + STRUCT_OFFSET(XPV, xpv_cur),
968 SVt_PVIV, FALSE, NONV, HASARENA,
969 FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
971 { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
972 copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
973 + STRUCT_OFFSET(XPV, xpv_cur),
974 SVt_PVNV, FALSE, HADNV, HASARENA,
975 FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
977 { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
978 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
983 SVt_REGEXP, TRUE, NONV, HASARENA,
984 FIT_ARENA(0, sizeof(regexp))
987 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
988 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
990 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
991 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
994 copy_length(XPVAV, xav_alloc),
996 SVt_PVAV, TRUE, NONV, HASARENA,
997 FIT_ARENA(0, sizeof(XPVAV)) },
1000 copy_length(XPVHV, xhv_max),
1002 SVt_PVHV, TRUE, NONV, HASARENA,
1003 FIT_ARENA(0, sizeof(XPVHV)) },
1008 SVt_PVCV, TRUE, NONV, HASARENA,
1009 FIT_ARENA(0, sizeof(XPVCV)) },
1014 SVt_PVFM, TRUE, NONV, NOARENA,
1015 FIT_ARENA(20, sizeof(XPVFM)) },
1020 SVt_PVIO, TRUE, NONV, HASARENA,
1021 FIT_ARENA(24, sizeof(XPVIO)) },
1024 #define new_body_allocated(sv_type) \
1025 (void *)((char *)S_new_body(aTHX_ sv_type) \
1026 - bodies_by_type[sv_type].offset)
1028 /* return a thing to the free list */
1030 #define del_body(thing, root) \
1032 void ** const thing_copy = (void **)thing; \
1033 *thing_copy = *root; \
1034 *root = (void*)thing_copy; \
1039 #define new_XNV() safemalloc(sizeof(XPVNV))
1040 #define new_XPVNV() safemalloc(sizeof(XPVNV))
1041 #define new_XPVMG() safemalloc(sizeof(XPVMG))
1043 #define del_XPVGV(p) safefree(p)
1047 #define new_XNV() new_body_allocated(SVt_NV)
1048 #define new_XPVNV() new_body_allocated(SVt_PVNV)
1049 #define new_XPVMG() new_body_allocated(SVt_PVMG)
1051 #define del_XPVGV(p) del_body(p + bodies_by_type[SVt_PVGV].offset, \
1052 &PL_body_roots[SVt_PVGV])
1056 /* no arena for you! */
1058 #define new_NOARENA(details) \
1059 safemalloc((details)->body_size + (details)->offset)
1060 #define new_NOARENAZ(details) \
1061 safecalloc((details)->body_size + (details)->offset, 1)
1064 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
1065 const size_t arena_size)
1067 void ** const root = &PL_body_roots[sv_type];
1068 struct arena_desc *adesc;
1069 struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1073 const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1074 #if defined(DEBUGGING) && defined(PERL_GLOBAL_STRUCT)
1077 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1078 static bool done_sanity_check;
1080 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1081 * variables like done_sanity_check. */
1082 if (!done_sanity_check) {
1083 unsigned int i = SVt_LAST;
1085 done_sanity_check = TRUE;
1088 assert (bodies_by_type[i].type == i);
1094 /* may need new arena-set to hold new arena */
1095 if (!aroot || aroot->curr >= aroot->set_size) {
1096 struct arena_set *newroot;
1097 Newxz(newroot, 1, struct arena_set);
1098 newroot->set_size = ARENAS_PER_SET;
1099 newroot->next = aroot;
1101 PL_body_arenas = (void *) newroot;
1102 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1105 /* ok, now have arena-set with at least 1 empty/available arena-desc */
1106 curr = aroot->curr++;
1107 adesc = &(aroot->set[curr]);
1108 assert(!adesc->arena);
1110 Newx(adesc->arena, good_arena_size, char);
1111 adesc->size = good_arena_size;
1112 adesc->utype = sv_type;
1113 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
1114 curr, (void*)adesc->arena, (UV)good_arena_size));
1116 start = (char *) adesc->arena;
1118 /* Get the address of the byte after the end of the last body we can fit.
1119 Remember, this is integer division: */
1120 end = start + good_arena_size / body_size * body_size;
1122 /* computed count doesn't reflect the 1st slot reservation */
1123 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1124 DEBUG_m(PerlIO_printf(Perl_debug_log,
1125 "arena %p end %p arena-size %d (from %d) type %d "
1127 (void*)start, (void*)end, (int)good_arena_size,
1128 (int)arena_size, sv_type, (int)body_size,
1129 (int)good_arena_size / (int)body_size));
1131 DEBUG_m(PerlIO_printf(Perl_debug_log,
1132 "arena %p end %p arena-size %d type %d size %d ct %d\n",
1133 (void*)start, (void*)end,
1134 (int)arena_size, sv_type, (int)body_size,
1135 (int)good_arena_size / (int)body_size));
1137 *root = (void *)start;
1140 /* Where the next body would start: */
1141 char * const next = start + body_size;
1144 /* This is the last body: */
1145 assert(next == end);
1147 *(void **)start = 0;
1151 *(void**) start = (void *)next;
1156 /* grab a new thing from the free list, allocating more if necessary.
1157 The inline version is used for speed in hot routines, and the
1158 function using it serves the rest (unless PURIFY).
1160 #define new_body_inline(xpv, sv_type) \
1162 void ** const r3wt = &PL_body_roots[sv_type]; \
1163 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
1164 ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1165 bodies_by_type[sv_type].body_size,\
1166 bodies_by_type[sv_type].arena_size)); \
1167 *(r3wt) = *(void**)(xpv); \
1173 S_new_body(pTHX_ const svtype sv_type)
1176 new_body_inline(xpv, sv_type);
1182 static const struct body_details fake_rv =
1183 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1186 =for apidoc sv_upgrade
1188 Upgrade an SV to a more complex form. Generally adds a new body type to the
1189 SV, then copies across as much information as possible from the old body.
1190 It croaks if the SV is already in a more complex form than requested. You
1191 generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
1192 before calling C<sv_upgrade>, and hence does not croak. See also
1199 Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
1203 const svtype old_type = SvTYPE(sv);
1204 const struct body_details *new_type_details;
1205 const struct body_details *old_type_details
1206 = bodies_by_type + old_type;
1207 SV *referant = NULL;
1209 PERL_ARGS_ASSERT_SV_UPGRADE;
1211 if (old_type == new_type)
1214 /* This clause was purposefully added ahead of the early return above to
1215 the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1216 inference by Nick I-S that it would fix other troublesome cases. See
1217 changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1219 Given that shared hash key scalars are no longer PVIV, but PV, there is
1220 no longer need to unshare so as to free up the IVX slot for its proper
1221 purpose. So it's safe to move the early return earlier. */
1223 if (new_type > SVt_PVMG && SvIsCOW(sv)) {
1224 sv_force_normal_flags(sv, 0);
1227 old_body = SvANY(sv);
1229 /* Copying structures onto other structures that have been neatly zeroed
1230 has a subtle gotcha. Consider XPVMG
1232 +------+------+------+------+------+-------+-------+
1233 | NV | CUR | LEN | IV | MAGIC | STASH |
1234 +------+------+------+------+------+-------+-------+
1235 0 4 8 12 16 20 24 28
1237 where NVs are aligned to 8 bytes, so that sizeof that structure is
1238 actually 32 bytes long, with 4 bytes of padding at the end:
1240 +------+------+------+------+------+-------+-------+------+
1241 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1242 +------+------+------+------+------+-------+-------+------+
1243 0 4 8 12 16 20 24 28 32
1245 so what happens if you allocate memory for this structure:
1247 +------+------+------+------+------+-------+-------+------+------+...
1248 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1249 +------+------+------+------+------+-------+-------+------+------+...
1250 0 4 8 12 16 20 24 28 32 36
1252 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1253 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1254 started out as zero once, but it's quite possible that it isn't. So now,
1255 rather than a nicely zeroed GP, you have it pointing somewhere random.
1258 (In fact, GP ends up pointing at a previous GP structure, because the
1259 principle cause of the padding in XPVMG getting garbage is a copy of
1260 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1261 this happens to be moot because XPVGV has been re-ordered, with GP
1262 no longer after STASH)
1264 So we are careful and work out the size of used parts of all the
1272 referant = SvRV(sv);
1273 old_type_details = &fake_rv;
1274 if (new_type == SVt_NV)
1275 new_type = SVt_PVNV;
1277 if (new_type < SVt_PVIV) {
1278 new_type = (new_type == SVt_NV)
1279 ? SVt_PVNV : SVt_PVIV;
1284 if (new_type < SVt_PVNV) {
1285 new_type = SVt_PVNV;
1289 assert(new_type > SVt_PV);
1290 assert(SVt_IV < SVt_PV);
1291 assert(SVt_NV < SVt_PV);
1298 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1299 there's no way that it can be safely upgraded, because perl.c
1300 expects to Safefree(SvANY(PL_mess_sv)) */
1301 assert(sv != PL_mess_sv);
1302 /* This flag bit is used to mean other things in other scalar types.
1303 Given that it only has meaning inside the pad, it shouldn't be set
1304 on anything that can get upgraded. */
1305 assert(!SvPAD_TYPED(sv));
1308 if (UNLIKELY(old_type_details->cant_upgrade))
1309 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1310 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1313 if (UNLIKELY(old_type > new_type))
1314 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1315 (int)old_type, (int)new_type);
1317 new_type_details = bodies_by_type + new_type;
1319 SvFLAGS(sv) &= ~SVTYPEMASK;
1320 SvFLAGS(sv) |= new_type;
1322 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1323 the return statements above will have triggered. */
1324 assert (new_type != SVt_NULL);
1327 assert(old_type == SVt_NULL);
1328 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1332 assert(old_type == SVt_NULL);
1333 SvANY(sv) = new_XNV();
1338 assert(new_type_details->body_size);
1341 assert(new_type_details->arena);
1342 assert(new_type_details->arena_size);
1343 /* This points to the start of the allocated area. */
1344 new_body_inline(new_body, new_type);
1345 Zero(new_body, new_type_details->body_size, char);
1346 new_body = ((char *)new_body) - new_type_details->offset;
1348 /* We always allocated the full length item with PURIFY. To do this
1349 we fake things so that arena is false for all 16 types.. */
1350 new_body = new_NOARENAZ(new_type_details);
1352 SvANY(sv) = new_body;
1353 if (new_type == SVt_PVAV) {
1357 if (old_type_details->body_size) {
1360 /* It will have been zeroed when the new body was allocated.
1361 Lets not write to it, in case it confuses a write-back
1367 #ifndef NODEFAULT_SHAREKEYS
1368 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1370 /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
1371 HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
1374 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1375 The target created by newSVrv also is, and it can have magic.
1376 However, it never has SvPVX set.
1378 if (old_type == SVt_IV) {
1380 } else if (old_type >= SVt_PV) {
1381 assert(SvPVX_const(sv) == 0);
1384 if (old_type >= SVt_PVMG) {
1385 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1386 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1388 sv->sv_u.svu_array = NULL; /* or svu_hash */
1393 /* XXX Is this still needed? Was it ever needed? Surely as there is
1394 no route from NV to PVIV, NOK can never be true */
1395 assert(!SvNOKp(sv));
1408 assert(new_type_details->body_size);
1409 /* We always allocated the full length item with PURIFY. To do this
1410 we fake things so that arena is false for all 16 types.. */
1411 if(new_type_details->arena) {
1412 /* This points to the start of the allocated area. */
1413 new_body_inline(new_body, new_type);
1414 Zero(new_body, new_type_details->body_size, char);
1415 new_body = ((char *)new_body) - new_type_details->offset;
1417 new_body = new_NOARENAZ(new_type_details);
1419 SvANY(sv) = new_body;
1421 if (old_type_details->copy) {
1422 /* There is now the potential for an upgrade from something without
1423 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1424 int offset = old_type_details->offset;
1425 int length = old_type_details->copy;
1427 if (new_type_details->offset > old_type_details->offset) {
1428 const int difference
1429 = new_type_details->offset - old_type_details->offset;
1430 offset += difference;
1431 length -= difference;
1433 assert (length >= 0);
1435 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1439 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1440 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1441 * correct 0.0 for us. Otherwise, if the old body didn't have an
1442 * NV slot, but the new one does, then we need to initialise the
1443 * freshly created NV slot with whatever the correct bit pattern is
1445 if (old_type_details->zero_nv && !new_type_details->zero_nv
1446 && !isGV_with_GP(sv))
1450 if (UNLIKELY(new_type == SVt_PVIO)) {
1451 IO * const io = MUTABLE_IO(sv);
1452 GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1455 /* Clear the stashcache because a new IO could overrule a package
1457 DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
1458 hv_clear(PL_stashcache);
1460 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1461 IoPAGE_LEN(sv) = 60;
1463 if (UNLIKELY(new_type == SVt_REGEXP))
1464 sv->sv_u.svu_rx = (regexp *)new_body;
1465 else if (old_type < SVt_PV) {
1466 /* referant will be NULL unless the old type was SVt_IV emulating
1468 sv->sv_u.svu_rv = referant;
1472 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1473 (unsigned long)new_type);
1476 if (old_type > SVt_IV) {
1480 /* Note that there is an assumption that all bodies of types that
1481 can be upgraded came from arenas. Only the more complex non-
1482 upgradable types are allowed to be directly malloc()ed. */
1483 assert(old_type_details->arena);
1484 del_body((void*)((char*)old_body + old_type_details->offset),
1485 &PL_body_roots[old_type]);
1491 =for apidoc sv_backoff
1493 Remove any string offset. You should normally use the C<SvOOK_off> macro
1500 Perl_sv_backoff(SV *const sv)
1503 const char * const s = SvPVX_const(sv);
1505 PERL_ARGS_ASSERT_SV_BACKOFF;
1508 assert(SvTYPE(sv) != SVt_PVHV);
1509 assert(SvTYPE(sv) != SVt_PVAV);
1511 SvOOK_offset(sv, delta);
1513 SvLEN_set(sv, SvLEN(sv) + delta);
1514 SvPV_set(sv, SvPVX(sv) - delta);
1515 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1516 SvFLAGS(sv) &= ~SVf_OOK;
1523 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1524 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1525 Use the C<SvGROW> wrapper instead.
1530 static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
1533 Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
1537 PERL_ARGS_ASSERT_SV_GROW;
1541 if (SvTYPE(sv) < SVt_PV) {
1542 sv_upgrade(sv, SVt_PV);
1543 s = SvPVX_mutable(sv);
1545 else if (SvOOK(sv)) { /* pv is offset? */
1547 s = SvPVX_mutable(sv);
1548 if (newlen > SvLEN(sv))
1549 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1553 if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0);
1554 s = SvPVX_mutable(sv);
1557 #ifdef PERL_NEW_COPY_ON_WRITE
1558 /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1559 * to store the COW count. So in general, allocate one more byte than
1560 * asked for, to make it likely this byte is always spare: and thus
1561 * make more strings COW-able.
1562 * If the new size is a big power of two, don't bother: we assume the
1563 * caller wanted a nice 2^N sized block and will be annoyed at getting
1569 #if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size)
1570 #define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1573 if (newlen > SvLEN(sv)) { /* need more room? */
1574 STRLEN minlen = SvCUR(sv);
1575 minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1576 if (newlen < minlen)
1578 #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1580 /* Don't round up on the first allocation, as odds are pretty good that
1581 * the initial request is accurate as to what is really needed */
1583 newlen = PERL_STRLEN_ROUNDUP(newlen);
1586 if (SvLEN(sv) && s) {
1587 s = (char*)saferealloc(s, newlen);
1590 s = (char*)safemalloc(newlen);
1591 if (SvPVX_const(sv) && SvCUR(sv)) {
1592 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1596 #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1597 /* Do this here, do it once, do it right, and then we will never get
1598 called back into sv_grow() unless there really is some growing
1600 SvLEN_set(sv, Perl_safesysmalloc_size(s));
1602 SvLEN_set(sv, newlen);
1609 =for apidoc sv_setiv
1611 Copies an integer into the given SV, upgrading first if necessary.
1612 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1618 Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
1620 PERL_ARGS_ASSERT_SV_SETIV;
1622 SV_CHECK_THINKFIRST_COW_DROP(sv);
1623 switch (SvTYPE(sv)) {
1626 sv_upgrade(sv, SVt_IV);
1629 sv_upgrade(sv, SVt_PVIV);
1633 if (!isGV_with_GP(sv))
1640 /* diag_listed_as: Can't coerce %s to %s in %s */
1641 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1645 (void)SvIOK_only(sv); /* validate number */
1651 =for apidoc sv_setiv_mg
1653 Like C<sv_setiv>, but also handles 'set' magic.
1659 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1661 PERL_ARGS_ASSERT_SV_SETIV_MG;
1668 =for apidoc sv_setuv
1670 Copies an unsigned integer into the given SV, upgrading first if necessary.
1671 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1677 Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1679 PERL_ARGS_ASSERT_SV_SETUV;
1681 /* With the if statement to ensure that integers are stored as IVs whenever
1683 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1686 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1688 If you wish to remove the following if statement, so that this routine
1689 (and its callers) always return UVs, please benchmark to see what the
1690 effect is. Modern CPUs may be different. Or may not :-)
1692 if (u <= (UV)IV_MAX) {
1693 sv_setiv(sv, (IV)u);
1702 =for apidoc sv_setuv_mg
1704 Like C<sv_setuv>, but also handles 'set' magic.
1710 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1712 PERL_ARGS_ASSERT_SV_SETUV_MG;
1719 =for apidoc sv_setnv
1721 Copies a double into the given SV, upgrading first if necessary.
1722 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1728 Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1730 PERL_ARGS_ASSERT_SV_SETNV;
1732 SV_CHECK_THINKFIRST_COW_DROP(sv);
1733 switch (SvTYPE(sv)) {
1736 sv_upgrade(sv, SVt_NV);
1740 sv_upgrade(sv, SVt_PVNV);
1744 if (!isGV_with_GP(sv))
1751 /* diag_listed_as: Can't coerce %s to %s in %s */
1752 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1757 (void)SvNOK_only(sv); /* validate number */
1762 =for apidoc sv_setnv_mg
1764 Like C<sv_setnv>, but also handles 'set' magic.
1770 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1772 PERL_ARGS_ASSERT_SV_SETNV_MG;
1778 /* Return a cleaned-up, printable version of sv, for non-numeric, or
1779 * not incrementable warning display.
1780 * Originally part of S_not_a_number().
1781 * The return value may be != tmpbuf.
1785 S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1788 PERL_ARGS_ASSERT_SV_DISPLAY;
1791 SV *dsv = newSVpvs_flags("", SVs_TEMP);
1792 pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
1795 const char * const limit = tmpbuf + tmpbuf_size - 8;
1796 /* each *s can expand to 4 chars + "...\0",
1797 i.e. need room for 8 chars */
1799 const char *s = SvPVX_const(sv);
1800 const char * const end = s + SvCUR(sv);
1801 for ( ; s < end && d < limit; s++ ) {
1803 if (! isASCII(ch) && !isPRINT_LC(ch)) {
1807 /* Map to ASCII "equivalent" of Latin1 */
1808 ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1814 else if (ch == '\r') {
1818 else if (ch == '\f') {
1822 else if (ch == '\\') {
1826 else if (ch == '\0') {
1830 else if (isPRINT_LC(ch))
1849 /* Print an "isn't numeric" warning, using a cleaned-up,
1850 * printable version of the offending string
1854 S_not_a_number(pTHX_ SV *const sv)
1859 PERL_ARGS_ASSERT_NOT_A_NUMBER;
1861 pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1864 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1865 /* diag_listed_as: Argument "%s" isn't numeric%s */
1866 "Argument \"%s\" isn't numeric in %s", pv,
1869 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1870 /* diag_listed_as: Argument "%s" isn't numeric%s */
1871 "Argument \"%s\" isn't numeric", pv);
1875 S_not_incrementable(pTHX_ SV *const sv) {
1879 PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1881 pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1883 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1884 "Argument \"%s\" treated as 0 in increment (++)", pv);
1888 =for apidoc looks_like_number
1890 Test if the content of an SV looks like a number (or is a number).
1891 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1892 non-numeric warning), even if your atof() doesn't grok them. Get-magic is
1899 Perl_looks_like_number(pTHX_ SV *const sv)
1904 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1906 if (SvPOK(sv) || SvPOKp(sv)) {
1907 sbegin = SvPV_nomg_const(sv, len);
1910 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1911 return grok_number(sbegin, len, NULL);
1915 S_glob_2number(pTHX_ GV * const gv)
1917 PERL_ARGS_ASSERT_GLOB_2NUMBER;
1919 /* We know that all GVs stringify to something that is not-a-number,
1920 so no need to test that. */
1921 if (ckWARN(WARN_NUMERIC))
1923 SV *const buffer = sv_newmortal();
1924 gv_efullname3(buffer, gv, "*");
1925 not_a_number(buffer);
1927 /* We just want something true to return, so that S_sv_2iuv_common
1928 can tail call us and return true. */
1932 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1933 until proven guilty, assume that things are not that bad... */
1938 As 64 bit platforms often have an NV that doesn't preserve all bits of
1939 an IV (an assumption perl has been based on to date) it becomes necessary
1940 to remove the assumption that the NV always carries enough precision to
1941 recreate the IV whenever needed, and that the NV is the canonical form.
1942 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1943 precision as a side effect of conversion (which would lead to insanity
1944 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1945 1) to distinguish between IV/UV/NV slots that have a valid conversion cached
1946 where precision was lost, and IV/UV/NV slots that have a valid conversion
1947 which has lost no precision
1948 2) to ensure that if a numeric conversion to one form is requested that
1949 would lose precision, the precise conversion (or differently
1950 imprecise conversion) is also performed and cached, to prevent
1951 requests for different numeric formats on the same SV causing
1952 lossy conversion chains. (lossless conversion chains are perfectly
1957 SvIOKp is true if the IV slot contains a valid value
1958 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1959 SvNOKp is true if the NV slot contains a valid value
1960 SvNOK is true only if the NV value is accurate
1963 while converting from PV to NV, check to see if converting that NV to an
1964 IV(or UV) would lose accuracy over a direct conversion from PV to
1965 IV(or UV). If it would, cache both conversions, return NV, but mark
1966 SV as IOK NOKp (ie not NOK).
1968 While converting from PV to IV, check to see if converting that IV to an
1969 NV would lose accuracy over a direct conversion from PV to NV. If it
1970 would, cache both conversions, flag similarly.
1972 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1973 correctly because if IV & NV were set NV *always* overruled.
1974 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1975 changes - now IV and NV together means that the two are interchangeable:
1976 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1978 The benefit of this is that operations such as pp_add know that if
1979 SvIOK is true for both left and right operands, then integer addition
1980 can be used instead of floating point (for cases where the result won't
1981 overflow). Before, floating point was always used, which could lead to
1982 loss of precision compared with integer addition.
1984 * making IV and NV equal status should make maths accurate on 64 bit
1986 * may speed up maths somewhat if pp_add and friends start to use
1987 integers when possible instead of fp. (Hopefully the overhead in
1988 looking for SvIOK and checking for overflow will not outweigh the
1989 fp to integer speedup)
1990 * will slow down integer operations (callers of SvIV) on "inaccurate"
1991 values, as the change from SvIOK to SvIOKp will cause a call into
1992 sv_2iv each time rather than a macro access direct to the IV slot
1993 * should speed up number->string conversion on integers as IV is
1994 favoured when IV and NV are equally accurate
1996 ####################################################################
1997 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1998 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1999 On the other hand, SvUOK is true iff UV.
2000 ####################################################################
2002 Your mileage will vary depending your CPU's relative fp to integer
2006 #ifndef NV_PRESERVES_UV
2007 # define IS_NUMBER_UNDERFLOW_IV 1
2008 # define IS_NUMBER_UNDERFLOW_UV 2
2009 # define IS_NUMBER_IV_AND_UV 2
2010 # define IS_NUMBER_OVERFLOW_IV 4
2011 # define IS_NUMBER_OVERFLOW_UV 5
2013 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2015 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2017 S_sv_2iuv_non_preserve(pTHX_ SV *const sv
2023 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
2024 PERL_UNUSED_CONTEXT;
2026 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));
2027 if (SvNVX(sv) < (NV)IV_MIN) {
2028 (void)SvIOKp_on(sv);
2030 SvIV_set(sv, IV_MIN);
2031 return IS_NUMBER_UNDERFLOW_IV;
2033 if (SvNVX(sv) > (NV)UV_MAX) {
2034 (void)SvIOKp_on(sv);
2037 SvUV_set(sv, UV_MAX);
2038 return IS_NUMBER_OVERFLOW_UV;
2040 (void)SvIOKp_on(sv);
2042 /* Can't use strtol etc to convert this string. (See truth table in
2044 if (SvNVX(sv) <= (UV)IV_MAX) {
2045 SvIV_set(sv, I_V(SvNVX(sv)));
2046 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2047 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2049 /* Integer is imprecise. NOK, IOKp */
2051 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2054 SvUV_set(sv, U_V(SvNVX(sv)));
2055 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2056 if (SvUVX(sv) == UV_MAX) {
2057 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2058 possibly be preserved by NV. Hence, it must be overflow.
2060 return IS_NUMBER_OVERFLOW_UV;
2062 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2064 /* Integer is imprecise. NOK, IOKp */
2066 return IS_NUMBER_OVERFLOW_IV;
2068 #endif /* !NV_PRESERVES_UV*/
2071 S_sv_2iuv_common(pTHX_ SV *const sv)
2073 PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2076 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2077 * without also getting a cached IV/UV from it at the same time
2078 * (ie PV->NV conversion should detect loss of accuracy and cache
2079 * IV or UV at same time to avoid this. */
2080 /* IV-over-UV optimisation - choose to cache IV if possible */
2082 if (SvTYPE(sv) == SVt_NV)
2083 sv_upgrade(sv, SVt_PVNV);
2085 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2086 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2087 certainly cast into the IV range at IV_MAX, whereas the correct
2088 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2090 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2091 if (Perl_isnan(SvNVX(sv))) {
2097 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2098 SvIV_set(sv, I_V(SvNVX(sv)));
2099 if (SvNVX(sv) == (NV) SvIVX(sv)
2100 #ifndef NV_PRESERVES_UV
2101 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2102 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2103 /* Don't flag it as "accurately an integer" if the number
2104 came from a (by definition imprecise) NV operation, and
2105 we're outside the range of NV integer precision */
2109 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2111 /* scalar has trailing garbage, eg "42a" */
2113 DEBUG_c(PerlIO_printf(Perl_debug_log,
2114 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2120 /* IV not precise. No need to convert from PV, as NV
2121 conversion would already have cached IV if it detected
2122 that PV->IV would be better than PV->NV->IV
2123 flags already correct - don't set public IOK. */
2124 DEBUG_c(PerlIO_printf(Perl_debug_log,
2125 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2130 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2131 but the cast (NV)IV_MIN rounds to a the value less (more
2132 negative) than IV_MIN which happens to be equal to SvNVX ??
2133 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2134 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2135 (NV)UVX == NVX are both true, but the values differ. :-(
2136 Hopefully for 2s complement IV_MIN is something like
2137 0x8000000000000000 which will be exact. NWC */
2140 SvUV_set(sv, U_V(SvNVX(sv)));
2142 (SvNVX(sv) == (NV) SvUVX(sv))
2143 #ifndef NV_PRESERVES_UV
2144 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2145 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2146 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2147 /* Don't flag it as "accurately an integer" if the number
2148 came from a (by definition imprecise) NV operation, and
2149 we're outside the range of NV integer precision */
2155 DEBUG_c(PerlIO_printf(Perl_debug_log,
2156 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2162 else if (SvPOKp(sv)) {
2164 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2165 /* We want to avoid a possible problem when we cache an IV/ a UV which
2166 may be later translated to an NV, and the resulting NV is not
2167 the same as the direct translation of the initial string
2168 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2169 be careful to ensure that the value with the .456 is around if the
2170 NV value is requested in the future).
2172 This means that if we cache such an IV/a UV, we need to cache the
2173 NV as well. Moreover, we trade speed for space, and do not
2174 cache the NV if we are sure it's not needed.
2177 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2178 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2179 == IS_NUMBER_IN_UV) {
2180 /* It's definitely an integer, only upgrade to PVIV */
2181 if (SvTYPE(sv) < SVt_PVIV)
2182 sv_upgrade(sv, SVt_PVIV);
2184 } else if (SvTYPE(sv) < SVt_PVNV)
2185 sv_upgrade(sv, SVt_PVNV);
2187 /* If NVs preserve UVs then we only use the UV value if we know that
2188 we aren't going to call atof() below. If NVs don't preserve UVs
2189 then the value returned may have more precision than atof() will
2190 return, even though value isn't perfectly accurate. */
2191 if ((numtype & (IS_NUMBER_IN_UV
2192 #ifdef NV_PRESERVES_UV
2195 )) == IS_NUMBER_IN_UV) {
2196 /* This won't turn off the public IOK flag if it was set above */
2197 (void)SvIOKp_on(sv);
2199 if (!(numtype & IS_NUMBER_NEG)) {
2201 if (value <= (UV)IV_MAX) {
2202 SvIV_set(sv, (IV)value);
2204 /* it didn't overflow, and it was positive. */
2205 SvUV_set(sv, value);
2209 /* 2s complement assumption */
2210 if (value <= (UV)IV_MIN) {
2211 SvIV_set(sv, -(IV)value);
2213 /* Too negative for an IV. This is a double upgrade, but
2214 I'm assuming it will be rare. */
2215 if (SvTYPE(sv) < SVt_PVNV)
2216 sv_upgrade(sv, SVt_PVNV);
2220 SvNV_set(sv, -(NV)value);
2221 SvIV_set(sv, IV_MIN);
2225 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2226 will be in the previous block to set the IV slot, and the next
2227 block to set the NV slot. So no else here. */
2229 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2230 != IS_NUMBER_IN_UV) {
2231 /* It wasn't an (integer that doesn't overflow the UV). */
2232 SvNV_set(sv, Atof(SvPVX_const(sv)));
2234 if (! numtype && ckWARN(WARN_NUMERIC))
2237 #if defined(USE_LONG_DOUBLE)
2238 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2239 PTR2UV(sv), SvNVX(sv)));
2241 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2242 PTR2UV(sv), SvNVX(sv)));
2245 #ifdef NV_PRESERVES_UV
2246 (void)SvIOKp_on(sv);
2248 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2249 SvIV_set(sv, I_V(SvNVX(sv)));
2250 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2253 NOOP; /* Integer is imprecise. NOK, IOKp */
2255 /* UV will not work better than IV */
2257 if (SvNVX(sv) > (NV)UV_MAX) {
2259 /* Integer is inaccurate. NOK, IOKp, is UV */
2260 SvUV_set(sv, UV_MAX);
2262 SvUV_set(sv, U_V(SvNVX(sv)));
2263 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2264 NV preservse UV so can do correct comparison. */
2265 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2268 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
2273 #else /* NV_PRESERVES_UV */
2274 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2275 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2276 /* The IV/UV slot will have been set from value returned by
2277 grok_number above. The NV slot has just been set using
2280 assert (SvIOKp(sv));
2282 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2283 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2284 /* Small enough to preserve all bits. */
2285 (void)SvIOKp_on(sv);
2287 SvIV_set(sv, I_V(SvNVX(sv)));
2288 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2290 /* Assumption: first non-preserved integer is < IV_MAX,
2291 this NV is in the preserved range, therefore: */
2292 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2294 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);
2298 0 0 already failed to read UV.
2299 0 1 already failed to read UV.
2300 1 0 you won't get here in this case. IV/UV
2301 slot set, public IOK, Atof() unneeded.
2302 1 1 already read UV.
2303 so there's no point in sv_2iuv_non_preserve() attempting
2304 to use atol, strtol, strtoul etc. */
2306 sv_2iuv_non_preserve (sv, numtype);
2308 sv_2iuv_non_preserve (sv);
2312 #endif /* NV_PRESERVES_UV */
2313 /* It might be more code efficient to go through the entire logic above
2314 and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2315 gets complex and potentially buggy, so more programmer efficient
2316 to do it this way, by turning off the public flags: */
2318 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2322 if (isGV_with_GP(sv))
2323 return glob_2number(MUTABLE_GV(sv));
2325 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2327 if (SvTYPE(sv) < SVt_IV)
2328 /* Typically the caller expects that sv_any is not NULL now. */
2329 sv_upgrade(sv, SVt_IV);
2330 /* Return 0 from the caller. */
2337 =for apidoc sv_2iv_flags
2339 Return the integer value of an SV, doing any necessary string
2340 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2341 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2347 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2349 PERL_ARGS_ASSERT_SV_2IV_FLAGS;
2351 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2352 && SvTYPE(sv) != SVt_PVFM);
2354 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2360 if (flags & SV_SKIP_OVERLOAD)
2362 tmpstr = AMG_CALLunary(sv, numer_amg);
2363 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2364 return SvIV(tmpstr);
2367 return PTR2IV(SvRV(sv));
2370 if (SvVALID(sv) || isREGEXP(sv)) {
2371 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2372 the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2373 In practice they are extremely unlikely to actually get anywhere
2374 accessible by user Perl code - the only way that I'm aware of is when
2375 a constant subroutine which is used as the second argument to index.
2377 Regexps have no SvIVX and SvNVX fields.
2379 assert(isREGEXP(sv) || SvPOKp(sv));
2382 const char * const ptr =
2383 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2385 = grok_number(ptr, SvCUR(sv), &value);
2387 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2388 == IS_NUMBER_IN_UV) {
2389 /* It's definitely an integer */
2390 if (numtype & IS_NUMBER_NEG) {
2391 if (value < (UV)IV_MIN)
2394 if (value < (UV)IV_MAX)
2399 if (ckWARN(WARN_NUMERIC))
2402 return I_V(Atof(ptr));
2406 if (SvTHINKFIRST(sv)) {
2407 #ifdef PERL_OLD_COPY_ON_WRITE
2409 sv_force_normal_flags(sv, 0);
2412 if (SvREADONLY(sv) && !SvOK(sv)) {
2413 if (ckWARN(WARN_UNINITIALIZED))
2420 if (S_sv_2iuv_common(aTHX_ sv))
2424 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2425 PTR2UV(sv),SvIVX(sv)));
2426 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2430 =for apidoc sv_2uv_flags
2432 Return the unsigned integer value of an SV, doing any necessary string
2433 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2434 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2440 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2442 PERL_ARGS_ASSERT_SV_2UV_FLAGS;
2444 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2450 if (flags & SV_SKIP_OVERLOAD)
2452 tmpstr = AMG_CALLunary(sv, numer_amg);
2453 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2454 return SvUV(tmpstr);
2457 return PTR2UV(SvRV(sv));
2460 if (SvVALID(sv) || isREGEXP(sv)) {
2461 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2462 the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2463 Regexps have no SvIVX and SvNVX fields. */
2464 assert(isREGEXP(sv) || SvPOKp(sv));
2467 const char * const ptr =
2468 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2470 = grok_number(ptr, SvCUR(sv), &value);
2472 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2473 == IS_NUMBER_IN_UV) {
2474 /* It's definitely an integer */
2475 if (!(numtype & IS_NUMBER_NEG))
2479 if (ckWARN(WARN_NUMERIC))
2482 return U_V(Atof(ptr));
2486 if (SvTHINKFIRST(sv)) {
2487 #ifdef PERL_OLD_COPY_ON_WRITE
2489 sv_force_normal_flags(sv, 0);
2492 if (SvREADONLY(sv) && !SvOK(sv)) {
2493 if (ckWARN(WARN_UNINITIALIZED))
2500 if (S_sv_2iuv_common(aTHX_ sv))
2504 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2505 PTR2UV(sv),SvUVX(sv)));
2506 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2510 =for apidoc sv_2nv_flags
2512 Return the num value of an SV, doing any necessary string or integer
2513 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2514 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2520 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2522 PERL_ARGS_ASSERT_SV_2NV_FLAGS;
2524 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2525 && SvTYPE(sv) != SVt_PVFM);
2526 if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
2527 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2528 the same flag bit as SVf_IVisUV, so must not let them cache NVs.
2529 Regexps have no SvIVX and SvNVX fields. */
2531 if (flags & SV_GMAGIC)
2535 if (SvPOKp(sv) && !SvIOKp(sv)) {
2536 ptr = SvPVX_const(sv);
2538 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2539 !grok_number(ptr, SvCUR(sv), NULL))
2545 return (NV)SvUVX(sv);
2547 return (NV)SvIVX(sv);
2553 ptr = RX_WRAPPED((REGEXP *)sv);
2556 assert(SvTYPE(sv) >= SVt_PVMG);
2557 /* This falls through to the report_uninit near the end of the
2559 } else if (SvTHINKFIRST(sv)) {
2564 if (flags & SV_SKIP_OVERLOAD)
2566 tmpstr = AMG_CALLunary(sv, numer_amg);
2567 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2568 return SvNV(tmpstr);
2571 return PTR2NV(SvRV(sv));
2573 #ifdef PERL_OLD_COPY_ON_WRITE
2575 sv_force_normal_flags(sv, 0);
2578 if (SvREADONLY(sv) && !SvOK(sv)) {
2579 if (ckWARN(WARN_UNINITIALIZED))
2584 if (SvTYPE(sv) < SVt_NV) {
2585 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2586 sv_upgrade(sv, SVt_NV);
2587 #ifdef USE_LONG_DOUBLE
2589 STORE_NUMERIC_LOCAL_SET_STANDARD();
2590 PerlIO_printf(Perl_debug_log,
2591 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2592 PTR2UV(sv), SvNVX(sv));
2593 RESTORE_NUMERIC_LOCAL();
2597 STORE_NUMERIC_LOCAL_SET_STANDARD();
2598 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2599 PTR2UV(sv), SvNVX(sv));
2600 RESTORE_NUMERIC_LOCAL();
2604 else if (SvTYPE(sv) < SVt_PVNV)
2605 sv_upgrade(sv, SVt_PVNV);
2610 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2611 #ifdef NV_PRESERVES_UV
2617 /* Only set the public NV OK flag if this NV preserves the IV */
2618 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2620 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2621 : (SvIVX(sv) == I_V(SvNVX(sv))))
2627 else if (SvPOKp(sv)) {
2629 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2630 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2632 #ifdef NV_PRESERVES_UV
2633 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2634 == IS_NUMBER_IN_UV) {
2635 /* It's definitely an integer */
2636 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2638 SvNV_set(sv, Atof(SvPVX_const(sv)));
2644 SvNV_set(sv, Atof(SvPVX_const(sv)));
2645 /* Only set the public NV OK flag if this NV preserves the value in
2646 the PV at least as well as an IV/UV would.
2647 Not sure how to do this 100% reliably. */
2648 /* if that shift count is out of range then Configure's test is
2649 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2651 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2652 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2653 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2654 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2655 /* Can't use strtol etc to convert this string, so don't try.
2656 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2659 /* value has been set. It may not be precise. */
2660 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2661 /* 2s complement assumption for (UV)IV_MIN */
2662 SvNOK_on(sv); /* Integer is too negative. */
2667 if (numtype & IS_NUMBER_NEG) {
2668 SvIV_set(sv, -(IV)value);
2669 } else if (value <= (UV)IV_MAX) {
2670 SvIV_set(sv, (IV)value);
2672 SvUV_set(sv, value);
2676 if (numtype & IS_NUMBER_NOT_INT) {
2677 /* I believe that even if the original PV had decimals,
2678 they are lost beyond the limit of the FP precision.
2679 However, neither is canonical, so both only get p
2680 flags. NWC, 2000/11/25 */
2681 /* Both already have p flags, so do nothing */
2683 const NV nv = SvNVX(sv);
2684 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2685 if (SvIVX(sv) == I_V(nv)) {
2688 /* It had no "." so it must be integer. */
2692 /* between IV_MAX and NV(UV_MAX).
2693 Could be slightly > UV_MAX */
2695 if (numtype & IS_NUMBER_NOT_INT) {
2696 /* UV and NV both imprecise. */
2698 const UV nv_as_uv = U_V(nv);
2700 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2709 /* It might be more code efficient to go through the entire logic above
2710 and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2711 gets complex and potentially buggy, so more programmer efficient
2712 to do it this way, by turning off the public flags: */
2714 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2715 #endif /* NV_PRESERVES_UV */
2718 if (isGV_with_GP(sv)) {
2719 glob_2number(MUTABLE_GV(sv));
2723 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2725 assert (SvTYPE(sv) >= SVt_NV);
2726 /* Typically the caller expects that sv_any is not NULL now. */
2727 /* XXX Ilya implies that this is a bug in callers that assume this
2728 and ideally should be fixed. */
2731 #if defined(USE_LONG_DOUBLE)
2733 STORE_NUMERIC_LOCAL_SET_STANDARD();
2734 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2735 PTR2UV(sv), SvNVX(sv));
2736 RESTORE_NUMERIC_LOCAL();
2740 STORE_NUMERIC_LOCAL_SET_STANDARD();
2741 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2742 PTR2UV(sv), SvNVX(sv));
2743 RESTORE_NUMERIC_LOCAL();
2752 Return an SV with the numeric value of the source SV, doing any necessary
2753 reference or overload conversion. You must use the C<SvNUM(sv)> macro to
2754 access this function.
2760 Perl_sv_2num(pTHX_ SV *const sv)
2762 PERL_ARGS_ASSERT_SV_2NUM;
2767 SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2768 TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2769 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2770 return sv_2num(tmpsv);
2772 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2775 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2776 * UV as a string towards the end of buf, and return pointers to start and
2779 * We assume that buf is at least TYPE_CHARS(UV) long.
2783 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2785 char *ptr = buf + TYPE_CHARS(UV);
2786 char * const ebuf = ptr;
2789 PERL_ARGS_ASSERT_UIV_2BUF;
2801 *--ptr = '0' + (char)(uv % 10);
2810 =for apidoc sv_2pv_flags
2812 Returns a pointer to the string value of an SV, and sets *lp to its length.
2813 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a
2814 string if necessary. Normally invoked via the C<SvPV_flags> macro.
2815 C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
2821 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
2825 PERL_ARGS_ASSERT_SV_2PV_FLAGS;
2827 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2828 && SvTYPE(sv) != SVt_PVFM);
2829 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2834 if (flags & SV_SKIP_OVERLOAD)
2836 tmpstr = AMG_CALLunary(sv, string_amg);
2837 TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2838 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2840 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2844 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2845 if (flags & SV_CONST_RETURN) {
2846 pv = (char *) SvPVX_const(tmpstr);
2848 pv = (flags & SV_MUTABLE_RETURN)
2849 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2852 *lp = SvCUR(tmpstr);
2854 pv = sv_2pv_flags(tmpstr, lp, flags);
2867 SV *const referent = SvRV(sv);
2871 retval = buffer = savepvn("NULLREF", len);
2872 } else if (SvTYPE(referent) == SVt_REGEXP &&
2873 (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
2874 amagic_is_enabled(string_amg))) {
2875 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2879 /* If the regex is UTF-8 we want the containing scalar to
2880 have an UTF-8 flag too */
2887 *lp = RX_WRAPLEN(re);
2889 return RX_WRAPPED(re);
2891 const char *const typestr = sv_reftype(referent, 0);
2892 const STRLEN typelen = strlen(typestr);
2893 UV addr = PTR2UV(referent);
2894 const char *stashname = NULL;
2895 STRLEN stashnamelen = 0; /* hush, gcc */
2896 const char *buffer_end;
2898 if (SvOBJECT(referent)) {
2899 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2902 stashname = HEK_KEY(name);
2903 stashnamelen = HEK_LEN(name);
2905 if (HEK_UTF8(name)) {
2911 stashname = "__ANON__";
2914 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2915 + 2 * sizeof(UV) + 2 /* )\0 */;
2917 len = typelen + 3 /* (0x */
2918 + 2 * sizeof(UV) + 2 /* )\0 */;
2921 Newx(buffer, len, char);
2922 buffer_end = retval = buffer + len;
2924 /* Working backwards */
2928 *--retval = PL_hexdigit[addr & 15];
2929 } while (addr >>= 4);
2935 memcpy(retval, typestr, typelen);
2939 retval -= stashnamelen;
2940 memcpy(retval, stashname, stashnamelen);
2942 /* retval may not necessarily have reached the start of the
2944 assert (retval >= buffer);
2946 len = buffer_end - retval - 1; /* -1 for that \0 */
2958 if (flags & SV_MUTABLE_RETURN)
2959 return SvPVX_mutable(sv);
2960 if (flags & SV_CONST_RETURN)
2961 return (char *)SvPVX_const(sv);
2966 /* I'm assuming that if both IV and NV are equally valid then
2967 converting the IV is going to be more efficient */
2968 const U32 isUIOK = SvIsUV(sv);
2969 char buf[TYPE_CHARS(UV)];
2973 if (SvTYPE(sv) < SVt_PVIV)
2974 sv_upgrade(sv, SVt_PVIV);
2975 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2977 /* inlined from sv_setpvn */
2978 s = SvGROW_mutable(sv, len + 1);
2979 Move(ptr, s, len, char);
2984 else if (SvNOK(sv)) {
2985 if (SvTYPE(sv) < SVt_PVNV)
2986 sv_upgrade(sv, SVt_PVNV);
2987 if (SvNVX(sv) == 0.0) {
2988 s = SvGROW_mutable(sv, 2);
2993 /* The +20 is pure guesswork. Configure test needed. --jhi */
2994 s = SvGROW_mutable(sv, NV_DIG + 20);
2995 /* some Xenix systems wipe out errno here */
2997 #ifndef USE_LOCALE_NUMERIC
2998 PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
3002 DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
3003 PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
3005 /* If the radix character is UTF-8, and actually is in the
3006 * output, turn on the UTF-8 flag for the scalar */
3007 if (PL_numeric_local
3008 && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
3009 && instr(s, SvPVX_const(PL_numeric_radix_sv)))
3013 RESTORE_LC_NUMERIC();
3016 /* We don't call SvPOK_on(), because it may come to pass that the
3017 * locale changes so that the stringification we just did is no
3018 * longer correct. We will have to re-stringify every time it is
3025 else if (isGV_with_GP(sv)) {
3026 GV *const gv = MUTABLE_GV(sv);
3027 SV *const buffer = sv_newmortal();
3029 gv_efullname3(buffer, gv, "*");
3031 assert(SvPOK(buffer));
3035 *lp = SvCUR(buffer);
3036 return SvPVX(buffer);
3038 else if (isREGEXP(sv)) {
3039 if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
3040 return RX_WRAPPED((REGEXP *)sv);
3045 if (flags & SV_UNDEF_RETURNS_NULL)
3047 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3049 /* Typically the caller expects that sv_any is not NULL now. */
3050 if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
3051 sv_upgrade(sv, SVt_PV);
3056 const STRLEN len = s - SvPVX_const(sv);
3061 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3062 PTR2UV(sv),SvPVX_const(sv)));
3063 if (flags & SV_CONST_RETURN)
3064 return (char *)SvPVX_const(sv);
3065 if (flags & SV_MUTABLE_RETURN)
3066 return SvPVX_mutable(sv);
3071 =for apidoc sv_copypv
3073 Copies a stringified representation of the source SV into the
3074 destination SV. Automatically performs any necessary mg_get and
3075 coercion of numeric values into strings. Guaranteed to preserve
3076 UTF8 flag even from overloaded objects. Similar in nature to
3077 sv_2pv[_flags] but operates directly on an SV instead of just the
3078 string. Mostly uses sv_2pv_flags to do its work, except when that
3079 would lose the UTF-8'ness of the PV.
3081 =for apidoc sv_copypv_nomg
3083 Like sv_copypv, but doesn't invoke get magic first.
3085 =for apidoc sv_copypv_flags
3087 Implementation of sv_copypv and sv_copypv_nomg. Calls get magic iff flags
3094 Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
3096 PERL_ARGS_ASSERT_SV_COPYPV;
3098 sv_copypv_flags(dsv, ssv, 0);
3102 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3107 PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3109 if ((flags & SV_GMAGIC) && SvGMAGICAL(ssv))
3111 s = SvPV_nomg_const(ssv,len);
3112 sv_setpvn(dsv,s,len);
3120 =for apidoc sv_2pvbyte
3122 Return a pointer to the byte-encoded representation of the SV, and set *lp
3123 to its length. May cause the SV to be downgraded from UTF-8 as a
3126 Usually accessed via the C<SvPVbyte> macro.
3132 Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
3134 PERL_ARGS_ASSERT_SV_2PVBYTE;
3137 if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3138 || isGV_with_GP(sv) || SvROK(sv)) {
3139 SV *sv2 = sv_newmortal();
3140 sv_copypv_nomg(sv2,sv);
3143 sv_utf8_downgrade(sv,0);
3144 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3148 =for apidoc sv_2pvutf8
3150 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3151 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3153 Usually accessed via the C<SvPVutf8> macro.
3159 Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
3161 PERL_ARGS_ASSERT_SV_2PVUTF8;
3163 if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3164 || isGV_with_GP(sv) || SvROK(sv))
3165 sv = sv_mortalcopy(sv);
3168 sv_utf8_upgrade_nomg(sv);
3169 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3174 =for apidoc sv_2bool
3176 This macro is only used by sv_true() or its macro equivalent, and only if
3177 the latter's argument is neither SvPOK, SvIOK nor SvNOK.
3178 It calls sv_2bool_flags with the SV_GMAGIC flag.
3180 =for apidoc sv_2bool_flags
3182 This function is only used by sv_true() and friends, and only if
3183 the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags
3184 contain SV_GMAGIC, then it does an mg_get() first.
3191 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
3193 PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3196 if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3202 SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3203 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
3206 if(SvGMAGICAL(sv)) {
3208 goto restart; /* call sv_2bool */
3210 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
3211 else if(!SvOK(sv)) {
3214 else if(SvPOK(sv)) {
3215 svb = SvPVXtrue(sv);
3217 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
3218 svb = (SvIOK(sv) && SvIVX(sv) != 0)
3219 || (SvNOK(sv) && SvNVX(sv) != 0.0);
3223 goto restart; /* call sv_2bool_nomg */
3228 return SvRV(sv) != 0;
3232 RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
3233 return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
3237 =for apidoc sv_utf8_upgrade
3239 Converts the PV of an SV to its UTF-8-encoded form.
3240 Forces the SV to string form if it is not already.
3241 Will C<mg_get> on C<sv> if appropriate.
3242 Always sets the SvUTF8 flag to avoid future validity checks even
3243 if the whole string is the same in UTF-8 as not.
3244 Returns the number of bytes in the converted string
3246 This is not a general purpose byte encoding to Unicode interface:
3247 use the Encode extension for that.
3249 =for apidoc sv_utf8_upgrade_nomg
3251 Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
3253 =for apidoc sv_utf8_upgrade_flags
3255 Converts the PV of an SV to its UTF-8-encoded form.
3256 Forces the SV to string form if it is not already.
3257 Always sets the SvUTF8 flag to avoid future validity checks even
3258 if all the bytes are invariant in UTF-8.
3259 If C<flags> has C<SV_GMAGIC> bit set,
3260 will C<mg_get> on C<sv> if appropriate, else not.
3262 If C<flags> has SV_FORCE_UTF8_UPGRADE set, this function assumes that the PV
3263 will expand when converted to UTF-8, and skips the extra work of checking for
3264 that. Typically this flag is used by a routine that has already parsed the
3265 string and found such characters, and passes this information on so that the
3266 work doesn't have to be repeated.
3268 Returns the number of bytes in the converted string.
3270 This is not a general purpose byte encoding to Unicode interface:
3271 use the Encode extension for that.
3273 =for apidoc sv_utf8_upgrade_flags_grow
3275 Like sv_utf8_upgrade_flags, but has an additional parameter C<extra>, which is
3276 the number of unused bytes the string of 'sv' is guaranteed to have free after
3277 it upon return. This allows the caller to reserve extra space that it intends
3278 to fill, to avoid extra grows.
3280 C<sv_utf8_upgrade>, C<sv_utf8_upgrade_nomg>, and C<sv_utf8_upgrade_flags>
3281 are implemented in terms of this function.
3283 Returns the number of bytes in the converted string (not including the spares).
3287 (One might think that the calling routine could pass in the position of the
3288 first variant character when it has set SV_FORCE_UTF8_UPGRADE, so it wouldn't
3289 have to be found again. But that is not the case, because typically when the
3290 caller is likely to use this flag, it won't be calling this routine unless it
3291 finds something that won't fit into a byte. Otherwise it tries to not upgrade
3292 and just use bytes. But some things that do fit into a byte are variants in
3293 utf8, and the caller may not have been keeping track of these.)
3295 If the routine itself changes the string, it adds a trailing C<NUL>. Such a
3296 C<NUL> isn't guaranteed due to having other routines do the work in some input
3297 cases, or if the input is already flagged as being in utf8.
3299 The speed of this could perhaps be improved for many cases if someone wanted to
3300 write a fast function that counts the number of variant characters in a string,
3301 especially if it could return the position of the first one.
3306 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3308 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3310 if (sv == &PL_sv_undef)
3312 if (!SvPOK_nog(sv)) {
3314 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3315 (void) sv_2pv_flags(sv,&len, flags);
3317 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3321 (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3326 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3331 S_sv_uncow(aTHX_ sv, 0);
3334 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3335 sv_recode_to_utf8(sv, PL_encoding);
3336 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3340 if (SvCUR(sv) == 0) {
3341 if (extra) SvGROW(sv, extra);
3342 } else { /* Assume Latin-1/EBCDIC */
3343 /* This function could be much more efficient if we
3344 * had a FLAG in SVs to signal if there are any variant
3345 * chars in the PV. Given that there isn't such a flag
3346 * make the loop as fast as possible (although there are certainly ways
3347 * to speed this up, eg. through vectorization) */
3348 U8 * s = (U8 *) SvPVX_const(sv);
3349 U8 * e = (U8 *) SvEND(sv);
3351 STRLEN two_byte_count = 0;
3353 if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3355 /* See if really will need to convert to utf8. We mustn't rely on our
3356 * incoming SV being well formed and having a trailing '\0', as certain
3357 * code in pp_formline can send us partially built SVs. */
3361 if (NATIVE_BYTE_IS_INVARIANT(ch)) continue;
3363 t--; /* t already incremented; re-point to first variant */
3368 /* utf8 conversion not needed because all are invariants. Mark as
3369 * UTF-8 even if no variant - saves scanning loop */
3371 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3376 /* Here, the string should be converted to utf8, either because of an
3377 * input flag (two_byte_count = 0), or because a character that
3378 * requires 2 bytes was found (two_byte_count = 1). t points either to
3379 * the beginning of the string (if we didn't examine anything), or to
3380 * the first variant. In either case, everything from s to t - 1 will
3381 * occupy only 1 byte each on output.
3383 * There are two main ways to convert. One is to create a new string
3384 * and go through the input starting from the beginning, appending each
3385 * converted value onto the new string as we go along. It's probably
3386 * best to allocate enough space in the string for the worst possible
3387 * case rather than possibly running out of space and having to
3388 * reallocate and then copy what we've done so far. Since everything
3389 * from s to t - 1 is invariant, the destination can be initialized
3390 * with these using a fast memory copy
3392 * The other way is to figure out exactly how big the string should be
3393 * by parsing the entire input. Then you don't have to make it big
3394 * enough to handle the worst possible case, and more importantly, if
3395 * the string you already have is large enough, you don't have to
3396 * allocate a new string, you can copy the last character in the input
3397 * string to the final position(s) that will be occupied by the
3398 * converted string and go backwards, stopping at t, since everything
3399 * before that is invariant.
3401 * There are advantages and disadvantages to each method.
3403 * In the first method, we can allocate a new string, do the memory
3404 * copy from the s to t - 1, and then proceed through the rest of the
3405 * string byte-by-byte.
3407 * In the second method, we proceed through the rest of the input
3408 * string just calculating how big the converted string will be. Then
3409 * there are two cases:
3410 * 1) if the string has enough extra space to handle the converted
3411 * value. We go backwards through the string, converting until we
3412 * get to the position we are at now, and then stop. If this
3413 * position is far enough along in the string, this method is
3414 * faster than the other method. If the memory copy were the same
3415 * speed as the byte-by-byte loop, that position would be about
3416 * half-way, as at the half-way mark, parsing to the end and back
3417 * is one complete string's parse, the same amount as starting
3418 * over and going all the way through. Actually, it would be
3419 * somewhat less than half-way, as it's faster to just count bytes
3420 * than to also copy, and we don't have the overhead of allocating
3421 * a new string, changing the scalar to use it, and freeing the
3422 * existing one. But if the memory copy is fast, the break-even
3423 * point is somewhere after half way. The counting loop could be
3424 * sped up by vectorization, etc, to move the break-even point
3425 * further towards the beginning.
3426 * 2) if the string doesn't have enough space to handle the converted
3427 * value. A new string will have to be allocated, and one might
3428 * as well, given that, start from the beginning doing the first
3429 * method. We've spent extra time parsing the string and in
3430 * exchange all we've gotten is that we know precisely how big to
3431 * make the new one. Perl is more optimized for time than space,
3432 * so this case is a loser.
3433 * So what I've decided to do is not use the 2nd method unless it is
3434 * guaranteed that a new string won't have to be allocated, assuming
3435 * the worst case. I also decided not to put any more conditions on it
3436 * than this, for now. It seems likely that, since the worst case is
3437 * twice as big as the unknown portion of the string (plus 1), we won't
3438 * be guaranteed enough space, causing us to go to the first method,
3439 * unless the string is short, or the first variant character is near
3440 * the end of it. In either of these cases, it seems best to use the
3441 * 2nd method. The only circumstance I can think of where this would
3442 * be really slower is if the string had once had much more data in it
3443 * than it does now, but there is still a substantial amount in it */
3446 STRLEN invariant_head = t - s;
3447 STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3448 if (SvLEN(sv) < size) {
3450 /* Here, have decided to allocate a new string */
3455 Newx(dst, size, U8);
3457 /* If no known invariants at the beginning of the input string,
3458 * set so starts from there. Otherwise, can use memory copy to
3459 * get up to where we are now, and then start from here */
3461 if (invariant_head <= 0) {
3464 Copy(s, dst, invariant_head, char);
3465 d = dst + invariant_head;
3469 append_utf8_from_native_byte(*t, &d);
3473 SvPV_free(sv); /* No longer using pre-existing string */
3474 SvPV_set(sv, (char*)dst);
3475 SvCUR_set(sv, d - dst);
3476 SvLEN_set(sv, size);
3479 /* Here, have decided to get the exact size of the string.
3480 * Currently this happens only when we know that there is
3481 * guaranteed enough space to fit the converted string, so
3482 * don't have to worry about growing. If two_byte_count is 0,
3483 * then t points to the first byte of the string which hasn't
3484 * been examined yet. Otherwise two_byte_count is 1, and t
3485 * points to the first byte in the string that will expand to
3486 * two. Depending on this, start examining at t or 1 after t.
3489 U8 *d = t + two_byte_count;
3492 /* Count up the remaining bytes that expand to two */
3495 const U8 chr = *d++;
3496 if (! NATIVE_BYTE_IS_INVARIANT(chr)) two_byte_count++;
3499 /* The string will expand by just the number of bytes that
3500 * occupy two positions. But we are one afterwards because of
3501 * the increment just above. This is the place to put the
3502 * trailing NUL, and to set the length before we decrement */
3504 d += two_byte_count;
3505 SvCUR_set(sv, d - s);
3509 /* Having decremented d, it points to the position to put the
3510 * very last byte of the expanded string. Go backwards through
3511 * the string, copying and expanding as we go, stopping when we
3512 * get to the part that is invariant the rest of the way down */
3516 if (NATIVE_BYTE_IS_INVARIANT(*e)) {
3519 *d-- = UTF8_EIGHT_BIT_LO(*e);
3520 *d-- = UTF8_EIGHT_BIT_HI(*e);
3526 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3527 /* Update pos. We do it at the end rather than during
3528 * the upgrade, to avoid slowing down the common case
3529 * (upgrade without pos).
3530 * pos can be stored as either bytes or characters. Since
3531 * this was previously a byte string we can just turn off
3532 * the bytes flag. */
3533 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3535 mg->mg_flags &= ~MGf_BYTES;
3537 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3538 magic_setutf8(sv,mg); /* clear UTF8 cache */
3543 /* Mark as UTF-8 even if no variant - saves scanning loop */
3549 =for apidoc sv_utf8_downgrade
3551 Attempts to convert the PV of an SV from characters to bytes.
3552 If the PV contains a character that cannot fit
3553 in a byte, this conversion will fail;
3554 in this case, either returns false or, if C<fail_ok> is not
3557 This is not a general purpose Unicode to byte encoding interface:
3558 use the Encode extension for that.
3564 Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
3566 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3568 if (SvPOKp(sv) && SvUTF8(sv)) {
3572 int mg_flags = SV_GMAGIC;
3575 S_sv_uncow(aTHX_ sv, 0);
3577 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3579 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3580 if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
3581 mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
3582 SV_GMAGIC|SV_CONST_RETURN);
3583 mg_flags = 0; /* sv_pos_b2u does get magic */
3585 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3586 magic_setutf8(sv,mg); /* clear UTF8 cache */
3589 s = (U8 *) SvPV_flags(sv, len, mg_flags);
3591 if (!utf8_to_bytes(s, &len)) {
3596 Perl_croak(aTHX_ "Wide character in %s",
3599 Perl_croak(aTHX_ "Wide character");
3610 =for apidoc sv_utf8_encode
3612 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3613 flag off so that it looks like octets again.
3619 Perl_sv_utf8_encode(pTHX_ SV *const sv)
3621 PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3623 if (SvREADONLY(sv)) {
3624 sv_force_normal_flags(sv, 0);
3626 (void) sv_utf8_upgrade(sv);
3631 =for apidoc sv_utf8_decode
3633 If the PV of the SV is an octet sequence in UTF-8
3634 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3635 so that it looks like a character. If the PV contains only single-byte
3636 characters, the C<SvUTF8> flag stays off.
3637 Scans PV for validity and returns false if the PV is invalid UTF-8.
3643 Perl_sv_utf8_decode(pTHX_ SV *const sv)
3645 PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3648 const U8 *start, *c;
3651 /* The octets may have got themselves encoded - get them back as
3654 if (!sv_utf8_downgrade(sv, TRUE))
3657 /* it is actually just a matter of turning the utf8 flag on, but
3658 * we want to make sure everything inside is valid utf8 first.
3660 c = start = (const U8 *) SvPVX_const(sv);
3661 if (!is_utf8_string(c, SvCUR(sv)))
3663 e = (const U8 *) SvEND(sv);
3666 if (!UTF8_IS_INVARIANT(ch)) {
3671 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3672 /* XXX Is this dead code? XS_utf8_decode calls SvSETMAGIC
3673 after this, clearing pos. Does anything on CPAN
3675 /* adjust pos to the start of a UTF8 char sequence */
3676 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3678 I32 pos = mg->mg_len;
3680 for (c = start + pos; c > start; c--) {
3681 if (UTF8_IS_START(*c))
3684 mg->mg_len = c - start;
3687 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3688 magic_setutf8(sv,mg); /* clear UTF8 cache */
3695 =for apidoc sv_setsv
3697 Copies the contents of the source SV C<ssv> into the destination SV
3698 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3699 function if the source SV needs to be reused. Does not handle 'set' magic on
3700 destination SV. Calls 'get' magic on source SV. Loosely speaking, it
3701 performs a copy-by-value, obliterating any previous content of the
3704 You probably want to use one of the assortment of wrappers, such as
3705 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3706 C<SvSetMagicSV_nosteal>.
3708 =for apidoc sv_setsv_flags
3710 Copies the contents of the source SV C<ssv> into the destination SV
3711 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3712 function if the source SV needs to be reused. Does not handle 'set' magic.
3713 Loosely speaking, it performs a copy-by-value, obliterating any previous
3714 content of the destination.
3715 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3716 C<ssv> if appropriate, else not. If the C<flags>
3717 parameter has the C<SV_NOSTEAL> bit set then the
3718 buffers of temps will not be stolen. <sv_setsv>
3719 and C<sv_setsv_nomg> are implemented in terms of this function.
3721 You probably want to use one of the assortment of wrappers, such as
3722 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3723 C<SvSetMagicSV_nosteal>.
3725 This is the primary function for copying scalars, and most other
3726 copy-ish functions and macros use this underneath.
3732 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3734 I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3735 HV *old_stash = NULL;
3737 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3739 if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3740 const char * const name = GvNAME(sstr);
3741 const STRLEN len = GvNAMELEN(sstr);
3743 if (dtype >= SVt_PV) {
3749 SvUPGRADE(dstr, SVt_PVGV);
3750 (void)SvOK_off(dstr);
3751 isGV_with_GP_on(dstr);
3753 GvSTASH(dstr) = GvSTASH(sstr);
3755 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3756 gv_name_set(MUTABLE_GV(dstr), name, len,
3757 GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
3758 SvFAKE_on(dstr); /* can coerce to non-glob */
3761 if(GvGP(MUTABLE_GV(sstr))) {
3762 /* If source has method cache entry, clear it */
3764 SvREFCNT_dec(GvCV(sstr));
3765 GvCV_set(sstr, NULL);
3768 /* If source has a real method, then a method is
3771 GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3777 /* If dest already had a real method, that's a change as well */
3779 !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3780 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3785 /* We don't need to check the name of the destination if it was not a
3786 glob to begin with. */
3787 if(dtype == SVt_PVGV) {
3788 const char * const name = GvNAME((const GV *)dstr);
3791 /* The stash may have been detached from the symbol table, so
3793 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3797 const STRLEN len = GvNAMELEN(dstr);
3798 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3799 || (len == 1 && name[0] == ':')) {
3802 /* Set aside the old stash, so we can reset isa caches on
3804 if((old_stash = GvHV(dstr)))
3805 /* Make sure we do not lose it early. */
3806 SvREFCNT_inc_simple_void_NN(
3807 sv_2mortal((SV *)old_stash)
3812 SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
3815 gp_free(MUTABLE_GV(dstr));
3816 GvINTRO_off(dstr); /* one-shot flag */
3817 GvGP_set(dstr, gp_ref(GvGP(sstr)));
3818 if (SvTAINTED(sstr))
3820 if (GvIMPORTED(dstr) != GVf_IMPORTED
3821 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3823 GvIMPORTED_on(dstr);
3826 if(mro_changes == 2) {
3827 if (GvAV((const GV *)sstr)) {
3829 SV * const sref = (SV *)GvAV((const GV *)dstr);
3830 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3831 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3832 AV * const ary = newAV();
3833 av_push(ary, mg->mg_obj); /* takes the refcount */
3834 mg->mg_obj = (SV *)ary;
3836 av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3838 else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3840 mro_isa_changed_in(GvSTASH(dstr));
3842 else if(mro_changes == 3) {
3843 HV * const stash = GvHV(dstr);
3844 if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3850 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3851 if (GvIO(dstr) && dtype == SVt_PVGV) {
3852 DEBUG_o(Perl_deb(aTHX_
3853 "glob_assign_glob clearing PL_stashcache\n"));
3854 /* It's a cache. It will rebuild itself quite happily.
3855 It's a lot of effort to work out exactly which key (or keys)
3856 might be invalidated by the creation of the this file handle.
3858 hv_clear(PL_stashcache);
3864 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3866 SV * const sref = SvRV(sstr);
3868 const int intro = GvINTRO(dstr);
3871 const U32 stype = SvTYPE(sref);
3873 PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3876 GvINTRO_off(dstr); /* one-shot flag */
3877 GvLINE(dstr) = CopLINE(PL_curcop);
3878 GvEGV(dstr) = MUTABLE_GV(dstr);
3883 location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
3884 import_flag = GVf_IMPORTED_CV;
3887 location = (SV **) &GvHV(dstr);
3888 import_flag = GVf_IMPORTED_HV;
3891 location = (SV **) &GvAV(dstr);
3892 import_flag = GVf_IMPORTED_AV;
3895 location = (SV **) &GvIOp(dstr);
3898 location = (SV **) &GvFORM(dstr);
3901 location = &GvSV(dstr);
3902 import_flag = GVf_IMPORTED_SV;
3905 if (stype == SVt_PVCV) {
3906 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3907 if (GvCVGEN(dstr)) {
3908 SvREFCNT_dec(GvCV(dstr));
3909 GvCV_set(dstr, NULL);
3910 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3913 /* SAVEt_GVSLOT takes more room on the savestack and has more
3914 overhead in leave_scope than SAVEt_GENERIC_SV. But for CVs
3915 leave_scope needs access to the GV so it can reset method
3916 caches. We must use SAVEt_GVSLOT whenever the type is
3917 SVt_PVCV, even if the stash is anonymous, as the stash may
3918 gain a name somehow before leave_scope. */
3919 if (stype == SVt_PVCV) {
3920 /* There is no save_pushptrptrptr. Creating it for this
3921 one call site would be overkill. So inline the ss add
3925 SS_ADD_PTR(location);
3926 SS_ADD_PTR(SvREFCNT_inc(*location));
3927 SS_ADD_UV(SAVEt_GVSLOT);
3930 else SAVEGENERICSV(*location);
3933 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3934 CV* const cv = MUTABLE_CV(*location);
3936 if (!GvCVGEN((const GV *)dstr) &&
3937 (CvROOT(cv) || CvXSUB(cv)) &&
3938 /* redundant check that avoids creating the extra SV
3939 most of the time: */
3940 (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
3942 SV * const new_const_sv =
3943 CvCONST((const CV *)sref)
3944 ? cv_const_sv((const CV *)sref)
3946 report_redefined_cv(
3947 sv_2mortal(Perl_newSVpvf(aTHX_
3950 HvNAME_HEK(GvSTASH((const GV *)dstr))
3952 HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
3955 CvCONST((const CV *)sref) ? &new_const_sv : NULL
3959 cv_ckproto_len_flags(cv, (const GV *)dstr,
3960 SvPOK(sref) ? CvPROTO(sref) : NULL,
3961 SvPOK(sref) ? CvPROTOLEN(sref) : 0,
3962 SvPOK(sref) ? SvUTF8(sref) : 0);
3964 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3965 GvASSUMECV_on(dstr);
3966 if(GvSTASH(dstr)) gv_method_changed(dstr); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3968 *location = SvREFCNT_inc_simple_NN(sref);
3969 if (import_flag && !(GvFLAGS(dstr) & import_flag)
3970 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3971 GvFLAGS(dstr) |= import_flag;
3973 if (stype == SVt_PVHV) {
3974 const char * const name = GvNAME((GV*)dstr);
3975 const STRLEN len = GvNAMELEN(dstr);
3978 (len > 1 && name[len-2] == ':' && name[len-1] == ':')
3979 || (len == 1 && name[0] == ':')
3981 && (!dref || HvENAME_get(dref))
3984 (HV *)sref, (HV *)dref,
3990 stype == SVt_PVAV && sref != dref
3991 && strEQ(GvNAME((GV*)dstr), "ISA")
3992 /* The stash may have been detached from the symbol table, so
3993 check its name before doing anything. */
3994 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3997 MAGIC * const omg = dref && SvSMAGICAL(dref)
3998 ? mg_find(dref, PERL_MAGIC_isa)
4000 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
4001 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
4002 AV * const ary = newAV();
4003 av_push(ary, mg->mg_obj); /* takes the refcount */
4004 mg->mg_obj = (SV *)ary;
4007 if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
4008 SV **svp = AvARRAY((AV *)omg->mg_obj);
4009 I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
4013 SvREFCNT_inc_simple_NN(*svp++)
4019 SvREFCNT_inc_simple_NN(omg->mg_obj)
4023 av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
4028 sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
4030 mg = mg_find(sref, PERL_MAGIC_isa);
4032 /* Since the *ISA assignment could have affected more than
4033 one stash, don't call mro_isa_changed_in directly, but let
4034 magic_clearisa do it for us, as it already has the logic for
4035 dealing with globs vs arrays of globs. */
4037 Perl_magic_clearisa(aTHX_ NULL, mg);
4039 else if (stype == SVt_PVIO) {
4040 DEBUG_o(Perl_deb(aTHX_ "glob_assign_ref clearing PL_stashcache\n"));
4041 /* It's a cache. It will rebuild itself quite happily.
4042 It's a lot of effort to work out exactly which key (or keys)
4043 might be invalidated by the creation of the this file handle.
4045 hv_clear(PL_stashcache);
4049 if (!intro) SvREFCNT_dec(dref);
4050 if (SvTAINTED(sstr))
4058 #ifdef PERL_DEBUG_READONLY_COW
4059 # include <sys/mman.h>
4061 # ifndef PERL_MEMORY_DEBUG_HEADER_SIZE
4062 # define PERL_MEMORY_DEBUG_HEADER_SIZE 0
4066 Perl_sv_buf_to_ro(pTHX_ SV *sv)
4068 struct perl_memory_debug_header * const header =
4069 (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4070 const MEM_SIZE len = header->size;
4071 PERL_ARGS_ASSERT_SV_BUF_TO_RO;
4072 # ifdef PERL_TRACK_MEMPOOL
4073 if (!header->readonly) header->readonly = 1;
4075 if (mprotect(header, len, PROT_READ))
4076 Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
4077 header, len, errno);
4081 S_sv_buf_to_rw(pTHX_ SV *sv)
4083 struct perl_memory_debug_header * const header =
4084 (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4085 const MEM_SIZE len = header->size;
4086 PERL_ARGS_ASSERT_SV_BUF_TO_RW;
4087 if (mprotect(header, len, PROT_READ|PROT_WRITE))
4088 Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
4089 header, len, errno);
4090 # ifdef PERL_TRACK_MEMPOOL
4091 header->readonly = 0;
4096 # define sv_buf_to_ro(sv) NOOP
4097 # define sv_buf_to_rw(sv) NOOP
4101 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
4107 PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
4112 if (SvIS_FREED(dstr)) {
4113 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
4114 " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
4116 SV_CHECK_THINKFIRST_COW_DROP(dstr);
4118 sstr = &PL_sv_undef;
4119 if (SvIS_FREED(sstr)) {
4120 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
4121 (void*)sstr, (void*)dstr);
4123 stype = SvTYPE(sstr);
4124 dtype = SvTYPE(dstr);
4126 /* There's a lot of redundancy below but we're going for speed here */
4131 if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
4132 (void)SvOK_off(dstr);
4140 sv_upgrade(dstr, SVt_IV);
4144 sv_upgrade(dstr, SVt_PVIV);
4148 goto end_of_first_switch;
4150 (void)SvIOK_only(dstr);
4151 SvIV_set(dstr, SvIVX(sstr));
4154 /* SvTAINTED can only be true if the SV has taint magic, which in
4155 turn means that the SV type is PVMG (or greater). This is the
4156 case statement for SVt_IV, so this cannot be true (whatever gcov
4158 assert(!SvTAINTED(sstr));
4163 if (dtype < SVt_PV && dtype != SVt_IV)
4164 sv_upgrade(dstr, SVt_IV);
4172 sv_upgrade(dstr, SVt_NV);
4176 sv_upgrade(dstr, SVt_PVNV);
4180 goto end_of_first_switch;
4182 SvNV_set(dstr, SvNVX(sstr));
4183 (void)SvNOK_only(dstr);
4184 /* SvTAINTED can only be true if the SV has taint magic, which in
4185 turn means that the SV type is PVMG (or greater). This is the
4186 case statement for SVt_NV, so this cannot be true (whatever gcov
4188 assert(!SvTAINTED(sstr));
4195 sv_upgrade(dstr, SVt_PV);
4198 if (dtype < SVt_PVIV)
4199 sv_upgrade(dstr, SVt_PVIV);
4202 if (dtype < SVt_PVNV)
4203 sv_upgrade(dstr, SVt_PVNV);
4207 const char * const type = sv_reftype(sstr,0);
4209 /* diag_listed_as: Bizarre copy of %s */
4210 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4212 Perl_croak(aTHX_ "Bizarre copy of %s", type);
4214 NOT_REACHED; /* NOTREACHED */
4218 if (dtype < SVt_REGEXP)
4220 if (dtype >= SVt_PV) {
4226 sv_upgrade(dstr, SVt_REGEXP);
4234 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4236 if (SvTYPE(sstr) != stype)
4237 stype = SvTYPE(sstr);
4239 if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4240 glob_assign_glob(dstr, sstr, dtype);
4243 if (stype == SVt_PVLV)
4245 if (isREGEXP(sstr)) goto upgregexp;
4246 SvUPGRADE(dstr, SVt_PVNV);
4249 SvUPGRADE(dstr, (svtype)stype);
4251 end_of_first_switch:
4253 /* dstr may have been upgraded. */
4254 dtype = SvTYPE(dstr);
4255 sflags = SvFLAGS(sstr);
4257 if (dtype == SVt_PVCV) {
4258 /* Assigning to a subroutine sets the prototype. */
4261 const char *const ptr = SvPV_const(sstr, len);
4263 SvGROW(dstr, len + 1);
4264 Copy(ptr, SvPVX(dstr), len + 1, char);
4265 SvCUR_set(dstr, len);
4267 SvFLAGS(dstr) |= sflags & SVf_UTF8;
4268 CvAUTOLOAD_off(dstr);
4273 else if (dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM) {
4274 const char * const type = sv_reftype(dstr,0);
4276 /* diag_listed_as: Cannot copy to %s */
4277 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4279 Perl_croak(aTHX_ "Cannot copy to %s", type);
4280 } else if (sflags & SVf_ROK) {
4281 if (isGV_with_GP(dstr)
4282 && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4285 if (GvIMPORTED(dstr) != GVf_IMPORTED
4286 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4288 GvIMPORTED_on(dstr);
4293 glob_assign_glob(dstr, sstr, dtype);
4297 if (dtype >= SVt_PV) {
4298 if (isGV_with_GP(dstr)) {
4299 glob_assign_ref(dstr, sstr);
4302 if (SvPVX_const(dstr)) {
4308 (void)SvOK_off(dstr);
4309 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4310 SvFLAGS(dstr) |= sflags & SVf_ROK;
4311 assert(!(sflags & SVp_NOK));
4312 assert(!(sflags & SVp_IOK));
4313 assert(!(sflags & SVf_NOK));
4314 assert(!(sflags & SVf_IOK));
4316 else if (isGV_with_GP(dstr)) {
4317 if (!(sflags & SVf_OK)) {
4318 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4319 "Undefined value assigned to typeglob");
4322 GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
4323 if (dstr != (const SV *)gv) {
4324 const char * const name = GvNAME((const GV *)dstr);
4325 const STRLEN len = GvNAMELEN(dstr);
4326 HV *old_stash = NULL;
4327 bool reset_isa = FALSE;
4328 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4329 || (len == 1 && name[0] == ':')) {
4330 /* Set aside the old stash, so we can reset isa caches
4331 on its subclasses. */
4332 if((old_stash = GvHV(dstr))) {
4333 /* Make sure we do not lose it early. */
4334 SvREFCNT_inc_simple_void_NN(
4335 sv_2mortal((SV *)old_stash)
4342 SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
4343 gp_free(MUTABLE_GV(dstr));
4345 GvGP_set(dstr, gp_ref(GvGP(gv)));
4348 HV * const stash = GvHV(dstr);
4350 old_stash ? (HV *)HvENAME_get(old_stash) : stash
4360 else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4361 && (stype == SVt_REGEXP || isREGEXP(sstr))) {
4362 reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4364 else if (sflags & SVp_POK) {
4365 const STRLEN cur = SvCUR(sstr);
4366 const STRLEN len = SvLEN(sstr);
4369 * We have three basic ways to copy the string:
4375 * Which we choose is based on various factors. The following
4376 * things are listed in order of speed, fastest to slowest:
4378 * - Copying a short string
4379 * - Copy-on-write bookkeeping
4381 * - Copying a long string
4383 * We swipe the string (steal the string buffer) if the SV on the
4384 * rhs is about to be freed anyway (TEMP and refcnt==1). This is a
4385 * big win on long strings. It should be a win on short strings if
4386 * SvPVX_const(dstr) has to be allocated. If not, it should not
4387 * slow things down, as SvPVX_const(sstr) would have been freed
4390 * We also steal the buffer from a PADTMP (operator target) if it
4391 * is ‘long enough’. For short strings, a swipe does not help
4392 * here, as it causes more malloc calls the next time the target
4393 * is used. Benchmarks show that even if SvPVX_const(dstr) has to
4394 * be allocated it is still not worth swiping PADTMPs for short
4395 * strings, as the savings here are small.
4397 * If the rhs is already flagged as a copy-on-write string and COW
4398 * is possible here, we use copy-on-write and make both SVs share
4399 * the string buffer.
4401 * If the rhs is not flagged as copy-on-write, then we see whether
4402 * it is worth upgrading it to such. If the lhs already has a buf-
4403 * fer big enough and the string is short, we skip it and fall back
4404 * to method 3, since memcpy is faster for short strings than the
4405 * later bookkeeping overhead that copy-on-write entails.
4407 * If there is no buffer on the left, or the buffer is too small,
4408 * then we use copy-on-write.
4411 /* Whichever path we take through the next code, we want this true,
4412 and doing it now facilitates the COW check. */
4413 (void)SvPOK_only(dstr);
4417 /* slated for free anyway (and not COW)? */
4418 (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
4419 /* or a swipable TARG */
4420 || ((sflags & (SVs_PADTMP|SVf_READONLY|SVf_IsCOW))
4422 /* whose buffer is worth stealing */
4423 && CHECK_COWBUF_THRESHOLD(cur,len)
4426 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4427 (!(flags & SV_NOSTEAL)) &&
4428 /* and we're allowed to steal temps */
4429 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4430 len) /* and really is a string */
4431 { /* Passes the swipe test. */
4432 if (SvPVX_const(dstr)) /* we know that dtype >= SVt_PV */
4434 SvPV_set(dstr, SvPVX_mutable(sstr));
4435 SvLEN_set(dstr, SvLEN(sstr));
4436 SvCUR_set(dstr, SvCUR(sstr));
4439 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4440 SvPV_set(sstr, NULL);
4445 else if (flags & SV_COW_SHARED_HASH_KEYS
4447 #ifdef PERL_OLD_COPY_ON_WRITE
4448 ( sflags & SVf_IsCOW
4449 || ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4450 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4451 && SvTYPE(sstr) >= SVt_PVIV && len
4454 #elif defined(PERL_NEW_COPY_ON_WRITE)
4457 ( (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
4458 /* If this is a regular (non-hek) COW, only so
4459 many COW "copies" are possible. */
4460 && CowREFCNT(sstr) != SV_COW_REFCNT_MAX ))
4461 : ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4462 && !(SvFLAGS(dstr) & SVf_BREAK)
4463 && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len
4464 && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
4468 && !(SvFLAGS(dstr) & SVf_BREAK)
4471 /* Either it's a shared hash key, or it's suitable for
4474 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4479 if (!(sflags & SVf_IsCOW)) {
4481 # ifdef PERL_OLD_COPY_ON_WRITE
4482 /* Make the source SV into a loop of 1.
4483 (about to become 2) */
4484 SV_COW_NEXT_SV_SET(sstr, sstr);
4486 CowREFCNT(sstr) = 0;
4490 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4496 # ifdef PERL_OLD_COPY_ON_WRITE
4497 assert (SvTYPE(dstr) >= SVt_PVIV);
4498 /* SvIsCOW_normal */
4499 /* splice us in between source and next-after-source. */
4500 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4501 SV_COW_NEXT_SV_SET(sstr, dstr);
4503 if (sflags & SVf_IsCOW) {
4508 SvPV_set(dstr, SvPVX_mutable(sstr));
4513 /* SvIsCOW_shared_hash */
4514 DEBUG_C(PerlIO_printf(Perl_debug_log,
4515 "Copy on write: Sharing hash\n"));
4517 assert (SvTYPE(dstr) >= SVt_PV);
4519 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4521 SvLEN_set(dstr, len);
4522 SvCUR_set(dstr, cur);
4525 /* Failed the swipe test, and we cannot do copy-on-write either.
4526 Have to copy the string. */
4527 SvGROW(dstr, cur + 1); /* inlined from sv_setpvn */
4528 Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
4529 SvCUR_set(dstr, cur);
4530 *SvEND(dstr) = '\0';
4532 if (sflags & SVp_NOK) {
4533 SvNV_set(dstr, SvNVX(sstr));
4535 if (sflags & SVp_IOK) {
4536 SvIV_set(dstr, SvIVX(sstr));
4537 /* Must do this otherwise some other overloaded use of 0x80000000
4538 gets confused. I guess SVpbm_VALID */
4539 if (sflags & SVf_IVisUV)
4542 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4544 const MAGIC * const smg = SvVSTRING_mg(sstr);
4546 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4547 smg->mg_ptr, smg->mg_len);
4548 SvRMAGICAL_on(dstr);
4552 else if (sflags & (SVp_IOK|SVp_NOK)) {
4553 (void)SvOK_off(dstr);
4554 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4555 if (sflags & SVp_IOK) {
4556 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4557 SvIV_set(dstr, SvIVX(sstr));
4559 if (sflags & SVp_NOK) {
4560 SvNV_set(dstr, SvNVX(sstr));
4564 if (isGV_with_GP(sstr)) {
4565 gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4568 (void)SvOK_off(dstr);
4570 if (SvTAINTED(sstr))
4575 =for apidoc sv_setsv_mg
4577 Like C<sv_setsv>, but also handles 'set' magic.
4583 Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr)
4585 PERL_ARGS_ASSERT_SV_SETSV_MG;
4587 sv_setsv(dstr,sstr);
4592 # ifdef PERL_OLD_COPY_ON_WRITE
4593 # define SVt_COW SVt_PVIV
4595 # define SVt_COW SVt_PV
4598 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4600 STRLEN cur = SvCUR(sstr);
4601 STRLEN len = SvLEN(sstr);
4603 #if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_NEW_COPY_ON_WRITE)
4604 const bool already = cBOOL(SvIsCOW(sstr));
4607 PERL_ARGS_ASSERT_SV_SETSV_COW;
4610 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4611 (void*)sstr, (void*)dstr);
4618 if (SvTHINKFIRST(dstr))
4619 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4620 else if (SvPVX_const(dstr))
4621 Safefree(SvPVX_mutable(dstr));
4625 SvUPGRADE(dstr, SVt_COW);
4627 assert (SvPOK(sstr));
4628 assert (SvPOKp(sstr));
4629 # ifdef PERL_OLD_COPY_ON_WRITE
4630 assert (!SvIOK(sstr));
4631 assert (!SvIOKp(sstr));
4632 assert (!SvNOK(sstr));
4633 assert (!SvNOKp(sstr));
4636 if (SvIsCOW(sstr)) {
4638 if (SvLEN(sstr) == 0) {
4639 /* source is a COW shared hash key. */
4640 DEBUG_C(PerlIO_printf(Perl_debug_log,
4641 "Fast copy on write: Sharing hash\n"));
4642 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4645 # ifdef PERL_OLD_COPY_ON_WRITE
4646 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4648 assert(SvCUR(sstr)+1 < SvLEN(sstr));
4649 assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX);
4652 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4653 SvUPGRADE(sstr, SVt_COW);
4655 DEBUG_C(PerlIO_printf(Perl_debug_log,
4656 "Fast copy on write: Converting sstr to COW\n"));
4657 # ifdef PERL_OLD_COPY_ON_WRITE
4658 SV_COW_NEXT_SV_SET(dstr, sstr);
4660 CowREFCNT(sstr) = 0;
4663 # ifdef PERL_OLD_COPY_ON_WRITE
4664 SV_COW_NEXT_SV_SET(sstr, dstr);
4666 # ifdef PERL_DEBUG_READONLY_COW
4667 if (already) sv_buf_to_rw(sstr);
4671 new_pv = SvPVX_mutable(sstr);
4675 SvPV_set(dstr, new_pv);
4676 SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
4679 SvLEN_set(dstr, len);
4680 SvCUR_set(dstr, cur);
4689 =for apidoc sv_setpvn
4691 Copies a string (possibly containing embedded C<NUL> characters) into an SV.
4692 The C<len> parameter indicates the number of
4693 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4694 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4700 Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4704 PERL_ARGS_ASSERT_SV_SETPVN;
4706 SV_CHECK_THINKFIRST_COW_DROP(sv);
4712 /* len is STRLEN which is unsigned, need to copy to signed */
4715 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
4718 SvUPGRADE(sv, SVt_PV);
4720 dptr = SvGROW(sv, len + 1);
4721 Move(ptr,dptr,len,char);
4724 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4726 if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4730 =for apidoc sv_setpvn_mg
4732 Like C<sv_setpvn>, but also handles 'set' magic.
4738 Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4740 PERL_ARGS_ASSERT_SV_SETPVN_MG;
4742 sv_setpvn(sv,ptr,len);
4747 =for apidoc sv_setpv
4749 Copies a string into an SV. The string must be terminated with a C<NUL>
4751 Does not handle 'set' magic. See C<sv_setpv_mg>.
4757 Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
4761 PERL_ARGS_ASSERT_SV_SETPV;
4763 SV_CHECK_THINKFIRST_COW_DROP(sv);
4769 SvUPGRADE(sv, SVt_PV);
4771 SvGROW(sv, len + 1);
4772 Move(ptr,SvPVX(sv),len+1,char);
4774 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4776 if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4780 =for apidoc sv_setpv_mg
4782 Like C<sv_setpv>, but also handles 'set' magic.
4788 Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
4790 PERL_ARGS_ASSERT_SV_SETPV_MG;
4797 Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
4799 PERL_ARGS_ASSERT_SV_SETHEK;
4805 if (HEK_LEN(hek) == HEf_SVKEY) {
4806 sv_setsv(sv, *(SV**)HEK_KEY(hek));
4809 const int flags = HEK_FLAGS(hek);
4810 if (flags & HVhek_WASUTF8) {
4811 STRLEN utf8_len = HEK_LEN(hek);
4812 char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
4813 sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
4816 } else if (flags & HVhek_UNSHARED) {
4817 sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
4820 else SvUTF8_off(sv);
4824 SV_CHECK_THINKFIRST_COW_DROP(sv);
4825 SvUPGRADE(sv, SVt_PV);
4827 SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
4828 SvCUR_set(sv, HEK_LEN(hek));
4834 else SvUTF8_off(sv);
4842 =for apidoc sv_usepvn_flags
4844 Tells an SV to use C<ptr> to find its string value. Normally the
4845 string is stored inside the SV, but sv_usepvn allows the SV to use an
4846 outside string. The C<ptr> should point to memory that was allocated
4847 by L<Newx|perlclib/Memory Management and String Handling>. It must be
4848 the start of a Newx-ed block of memory, and not a pointer to the
4849 middle of it (beware of L<OOK|perlguts/Offsets> and copy-on-write),
4850 and not be from a non-Newx memory allocator like C<malloc>. The
4851 string length, C<len>, must be supplied. By default this function
4852 will C<Renew> (i.e. realloc, move) the memory pointed to by C<ptr>,
4853 so that pointer should not be freed or used by the programmer after
4854 giving it to sv_usepvn, and neither should any pointers from "behind"
4855 that pointer (e.g. ptr + 1) be used.
4857 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4858 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be C<NUL>, and the realloc
4859 will be skipped (i.e. the buffer is actually at least 1 byte longer than
4860 C<len>, and already meets the requirements for storing in C<SvPVX>).
4866 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4870 PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4872 SV_CHECK_THINKFIRST_COW_DROP(sv);
4873 SvUPGRADE(sv, SVt_PV);
4876 if (flags & SV_SMAGIC)
4880 if (SvPVX_const(sv))
4884 if (flags & SV_HAS_TRAILING_NUL)
4885 assert(ptr[len] == '\0');
4888 allocate = (flags & SV_HAS_TRAILING_NUL)
4890 #ifdef Perl_safesysmalloc_size
4893 PERL_STRLEN_ROUNDUP(len + 1);
4895 if (flags & SV_HAS_TRAILING_NUL) {
4896 /* It's long enough - do nothing.
4897 Specifically Perl_newCONSTSUB is relying on this. */
4900 /* Force a move to shake out bugs in callers. */
4901 char *new_ptr = (char*)safemalloc(allocate);
4902 Copy(ptr, new_ptr, len, char);
4903 PoisonFree(ptr,len,char);
4907 ptr = (char*) saferealloc (ptr, allocate);
4910 #ifdef Perl_safesysmalloc_size
4911 SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4913 SvLEN_set(sv, allocate);
4917 if (!(flags & SV_HAS_TRAILING_NUL)) {
4920 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4922 if (flags & SV_SMAGIC)
4926 #ifdef PERL_OLD_COPY_ON_WRITE
4927 /* Need to do this *after* making the SV normal, as we need the buffer
4928 pointer to remain valid until after we've copied it. If we let go too early,
4929 another thread could invalidate it by unsharing last of the same hash key
4930 (which it can do by means other than releasing copy-on-write Svs)
4931 or by changing the other copy-on-write SVs in the loop. */
4933 S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after)
4935 PERL_ARGS_ASSERT_SV_RELEASE_COW;
4937 { /* this SV was SvIsCOW_normal(sv) */
4938 /* we need to find the SV pointing to us. */
4939 SV *current = SV_COW_NEXT_SV(after);
4941 if (current == sv) {
4942 /* The SV we point to points back to us (there were only two of us
4944 Hence other SV is no longer copy on write either. */
4946 sv_buf_to_rw(after);
4948 /* We need to follow the pointers around the loop. */
4950 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4953 /* don't loop forever if the structure is bust, and we have
4954 a pointer into a closed loop. */
4955 assert (current != after);
4956 assert (SvPVX_const(current) == pvx);
4958 /* Make the SV before us point to the SV after us. */
4959 SV_COW_NEXT_SV_SET(current, after);
4965 =for apidoc sv_force_normal_flags
4967 Undo various types of fakery on an SV, where fakery means
4968 "more than" a string: if the PV is a shared string, make
4969 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4970 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4971 we do the copy, and is also used locally; if this is a
4972 vstring, drop the vstring magic. If C<SV_COW_DROP_PV> is set
4973 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4974 SvPOK_off rather than making a copy. (Used where this
4975 scalar is about to be set to some other value.) In addition,
4976 the C<flags> parameter gets passed to C<sv_unref_flags()>
4977 when unreffing. C<sv_force_normal> calls this function
4978 with flags set to 0.
4980 This function is expected to be used to signal to perl that this SV is
4981 about to be written to, and any extra book-keeping needs to be taken care
4982 of. Hence, it croaks on read-only values.
4988 S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
4990 assert(SvIsCOW(sv));
4993 const char * const pvx = SvPVX_const(sv);
4994 const STRLEN len = SvLEN(sv);
4995 const STRLEN cur = SvCUR(sv);
4996 # ifdef PERL_OLD_COPY_ON_WRITE
4997 /* next COW sv in the loop. If len is 0 then this is a shared-hash
4998 key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4999 we'll fail an assertion. */
5000 SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
5004 PerlIO_printf(Perl_debug_log,
5005 "Copy on write: Force normal %ld\n",
5010 # ifdef PERL_NEW_COPY_ON_WRITE
5011 if (len && CowREFCNT(sv) == 0)
5012 /* We own the buffer ourselves. */
5018 /* This SV doesn't own the buffer, so need to Newx() a new one: */
5019 # ifdef PERL_NEW_COPY_ON_WRITE
5020 /* Must do this first, since the macro uses SvPVX. */
5030 if (flags & SV_COW_DROP_PV) {
5031 /* OK, so we don't need to copy our buffer. */
5034 SvGROW(sv, cur + 1);
5035 Move(pvx,SvPVX(sv),cur,char);
5040 # ifdef PERL_OLD_COPY_ON_WRITE
5041 sv_release_COW(sv, pvx, next);
5044 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5051 const char * const pvx = SvPVX_const(sv);
5052 const STRLEN len = SvCUR(sv);
5056 if (flags & SV_COW_DROP_PV) {
5057 /* OK, so we don't need to copy our buffer. */
5060 SvGROW(sv, len + 1);
5061 Move(pvx,SvPVX(sv),len,char);
5064 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5070 Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
5072 PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
5075 Perl_croak_no_modify();
5076 else if (SvIsCOW(sv))
5077 S_sv_uncow(aTHX_ sv, flags);
5079 sv_unref_flags(sv, flags);
5080 else if (SvFAKE(sv) && isGV_with_GP(sv))
5081 sv_unglob(sv, flags);
5082 else if (SvFAKE(sv) && isREGEXP(sv)) {
5083 /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
5084 to sv_unglob. We only need it here, so inline it. */
5085 const bool islv = SvTYPE(sv) == SVt_PVLV;
5086 const svtype new_type =
5087 islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
5088 SV *const temp = newSV_type(new_type);
5089 regexp *const temp_p = ReANY((REGEXP *)sv);
5091 if (new_type == SVt_PVMG) {
5092 SvMAGIC_set(temp, SvMAGIC(sv));
5093 SvMAGIC_set(sv, NULL);
5094 SvSTASH_set(temp, SvSTASH(sv));
5095 SvSTASH_set(sv, NULL);
5097 if (!islv) SvCUR_set(temp, SvCUR(sv));
5098 /* Remember that SvPVX is in the head, not the body. But
5099 RX_WRAPPED is in the body. */
5100 assert(ReANY((REGEXP *)sv)->mother_re);
5101 /* Their buffer is already owned by someone else. */
5102 if (flags & SV_COW_DROP_PV) {
5103 /* SvLEN is already 0. For SVt_REGEXP, we have a brand new
5104 zeroed body. For SVt_PVLV, it should have been set to 0
5105 before turning into a regexp. */
5106 assert(!SvLEN(islv ? sv : temp));
5107 sv->sv_u.svu_pv = 0;
5110 sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
5111 SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
5115 /* Now swap the rest of the bodies. */
5119 SvFLAGS(sv) &= ~SVTYPEMASK;
5120 SvFLAGS(sv) |= new_type;
5121 SvANY(sv) = SvANY(temp);
5124 SvFLAGS(temp) &= ~(SVTYPEMASK);
5125 SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
5126 SvANY(temp) = temp_p;
5127 temp->sv_u.svu_rx = (regexp *)temp_p;
5129 SvREFCNT_dec_NN(temp);
5131 else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
5137 Efficient removal of characters from the beginning of the string buffer.
5138 SvPOK(sv), or at least SvPOKp(sv), must be true and the C<ptr> must be a
5139 pointer to somewhere inside the string buffer. The C<ptr> becomes the first
5140 character of the adjusted string. Uses the "OOK hack". On return, only
5141 SvPOK(sv) and SvPOKp(sv) among the OK flags will be true.
5143 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
5144 refer to the same chunk of data.
5146 The unfortunate similarity of this function's name to that of Perl's C<chop>
5147 operator is strictly coincidental. This function works from the left;
5148 C<chop> works from the right.
5154 Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
5165 PERL_ARGS_ASSERT_SV_CHOP;
5167 if (!ptr || !SvPOKp(sv))
5169 delta = ptr - SvPVX_const(sv);
5171 /* Nothing to do. */
5174 max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
5175 if (delta > max_delta)
5176 Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
5177 ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
5178 /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
5179 SV_CHECK_THINKFIRST(sv);
5180 SvPOK_only_UTF8(sv);
5183 if (!SvLEN(sv)) { /* make copy of shared string */
5184 const char *pvx = SvPVX_const(sv);
5185 const STRLEN len = SvCUR(sv);
5186 SvGROW(sv, len + 1);
5187 Move(pvx,SvPVX(sv),len,char);
5193 SvOOK_offset(sv, old_delta);
5195 SvLEN_set(sv, SvLEN(sv) - delta);
5196 SvCUR_set(sv, SvCUR(sv) - delta);
5197 SvPV_set(sv, SvPVX(sv) + delta);
5199 p = (U8 *)SvPVX_const(sv);
5202 /* how many bytes were evacuated? we will fill them with sentinel
5203 bytes, except for the part holding the new offset of course. */
5206 evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
5208 assert(evacn <= delta + old_delta);
5212 /* This sets 'delta' to the accumulated value of all deltas so far */
5216 /* If 'delta' fits in a byte, store it just prior to the new beginning of
5217 * the string; otherwise store a 0 byte there and store 'delta' just prior
5218 * to that, using as many bytes as a STRLEN occupies. Thus it overwrites a
5219 * portion of the chopped part of the string */
5220 if (delta < 0x100) {
5224 p -= sizeof(STRLEN);
5225 Copy((U8*)&delta, p, sizeof(STRLEN), U8);
5229 /* Fill the preceding buffer with sentinals to verify that no-one is
5239 =for apidoc sv_catpvn
5241 Concatenates the string onto the end of the string which is in the SV. The
5242 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5243 status set, then the bytes appended should be valid UTF-8.
5244 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
5246 =for apidoc sv_catpvn_flags
5248 Concatenates the string onto the end of the string which is in the SV. The
5249 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5250 status set, then the bytes appended should be valid UTF-8.
5251 If C<flags> has the C<SV_SMAGIC> bit set, will
5252 C<mg_set> on C<dsv> afterwards if appropriate.
5253 C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5254 in terms of this function.
5260 Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
5263 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5265 PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5266 assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5268 if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
5269 if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
5270 sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5273 else SvGROW(dsv, dlen + slen + 1);
5275 sstr = SvPVX_const(dsv);
5276 Move(sstr, SvPVX(dsv) + dlen, slen, char);
5277 SvCUR_set(dsv, SvCUR(dsv) + slen);
5280 /* We inline bytes_to_utf8, to avoid an extra malloc. */
5281 const char * const send = sstr + slen;
5284 /* Something this code does not account for, which I think is
5285 impossible; it would require the same pv to be treated as
5286 bytes *and* utf8, which would indicate a bug elsewhere. */
5287 assert(sstr != dstr);
5289 SvGROW(dsv, dlen + slen * 2 + 1);
5290 d = (U8 *)SvPVX(dsv) + dlen;
5292 while (sstr < send) {
5293 append_utf8_from_native_byte(*sstr, &d);
5296 SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5299 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
5301 if (flags & SV_SMAGIC)
5306 =for apidoc sv_catsv
5308 Concatenates the string from SV C<ssv> onto the end of the string in SV
5309 C<dsv>. If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5310 Handles 'get' magic on both SVs, but no 'set' magic. See C<sv_catsv_mg> and
5313 =for apidoc sv_catsv_flags
5315 Concatenates the string from SV C<ssv> onto the end of the string in SV
5316 C<dsv>. If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5317 If C<flags> include C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if
5318 appropriate. If C<flags> include C<SV_SMAGIC>, C<mg_set> will be called on
5319 the modified SV afterward, if appropriate. C<sv_catsv>, C<sv_catsv_nomg>,
5320 and C<sv_catsv_mg> are implemented in terms of this function.
5325 Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
5327 PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5331 const char *spv = SvPV_flags_const(ssv, slen, flags);
5333 if (flags & SV_GMAGIC)
5335 sv_catpvn_flags(dsv, spv, slen,
5336 DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
5337 if (flags & SV_SMAGIC)
5344 =for apidoc sv_catpv
5346 Concatenates the C<NUL>-terminated string onto the end of the string which is
5348 If the SV has the UTF-8 status set, then the bytes appended should be
5349 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
5354 Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
5360 PERL_ARGS_ASSERT_SV_CATPV;
5364 junk = SvPV_force(sv, tlen);
5366 SvGROW(sv, tlen + len + 1);
5368 ptr = SvPVX_const(sv);
5369 Move(ptr,SvPVX(sv)+tlen,len+1,char);
5370 SvCUR_set(sv, SvCUR(sv) + len);
5371 (void)SvPOK_only_UTF8(sv); /* validate pointer */
5376 =for apidoc sv_catpv_flags
5378 Concatenates the C<NUL>-terminated string onto the end of the string which is
5380 If the SV has the UTF-8 status set, then the bytes appended should
5381 be valid UTF-8. If C<flags> has the C<SV_SMAGIC> bit set, will C<mg_set>
5382 on the modified SV if appropriate.
5388 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
5390 PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5391 sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
5395 =for apidoc sv_catpv_mg
5397 Like C<sv_catpv>, but also handles 'set' magic.
5403 Perl_sv_catpv_mg(pTHX_ SV *const sv, const char *const ptr)
5405 PERL_ARGS_ASSERT_SV_CATPV_MG;
5414 Creates a new SV. A non-zero C<len> parameter indicates the number of
5415 bytes of preallocated string space the SV should have. An extra byte for a
5416 trailing C<NUL> is also reserved. (SvPOK is not set for the SV even if string
5417 space is allocated.) The reference count for the new SV is set to 1.
5419 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
5420 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5421 This aid has been superseded by a new build option, PERL_MEM_LOG (see
5422 L<perlhacktips/PERL_MEM_LOG>). The older API is still there for use in XS
5423 modules supporting older perls.
5429 Perl_newSV(pTHX_ const STRLEN len)
5435 sv_upgrade(sv, SVt_PV);
5436 SvGROW(sv, len + 1);
5441 =for apidoc sv_magicext
5443 Adds magic to an SV, upgrading it if necessary. Applies the
5444 supplied vtable and returns a pointer to the magic added.
5446 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5447 In particular, you can add magic to SvREADONLY SVs, and add more than
5448 one instance of the same 'how'.
5450 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5451 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5452 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5453 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5455 (This is now used as a subroutine by C<sv_magic>.)
5460 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
5461 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5465 PERL_ARGS_ASSERT_SV_MAGICEXT;
5467 if (SvTYPE(sv)==SVt_PVAV) { assert (!AvPAD_NAMELIST(sv)); }
5469 SvUPGRADE(sv, SVt_PVMG);
5470 Newxz(mg, 1, MAGIC);
5471 mg->mg_moremagic = SvMAGIC(sv);
5472 SvMAGIC_set(sv, mg);
5474 /* Sometimes a magic contains a reference loop, where the sv and
5475 object refer to each other. To prevent a reference loop that
5476 would prevent such objects being freed, we look for such loops
5477 and if we find one we avoid incrementing the object refcount.
5479 Note we cannot do this to avoid self-tie loops as intervening RV must
5480 have its REFCNT incremented to keep it in existence.
5483 if (!obj || obj == sv ||
5484 how == PERL_MAGIC_arylen ||
5485 how == PERL_MAGIC_symtab ||
5486 (SvTYPE(obj) == SVt_PVGV &&
5487 (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5488 || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5489 || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5494 mg->mg_obj = SvREFCNT_inc_simple(obj);
5495 mg->mg_flags |= MGf_REFCOUNTED;
5498 /* Normal self-ties simply pass a null object, and instead of
5499 using mg_obj directly, use the SvTIED_obj macro to produce a
5500 new RV as needed. For glob "self-ties", we are tieing the PVIO
5501 with an RV obj pointing to the glob containing the PVIO. In
5502 this case, to avoid a reference loop, we need to weaken the
5506 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5507 obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5513 mg->mg_len = namlen;
5516 mg->mg_ptr = savepvn(name, namlen);
5517 else if (namlen == HEf_SVKEY) {
5518 /* Yes, this is casting away const. This is only for the case of
5519 HEf_SVKEY. I think we need to document this aberation of the
5520 constness of the API, rather than making name non-const, as
5521 that change propagating outwards a long way. */
5522 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5524 mg->mg_ptr = (char *) name;
5526 mg->mg_virtual = (MGVTBL *) vtable;
5533 Perl_sv_magicext_mglob(pTHX_ SV *sv)
5535 PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB;
5536 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
5537 /* This sv is only a delegate. //g magic must be attached to
5542 #ifdef PERL_OLD_COPY_ON_WRITE
5544 sv_force_normal_flags(sv, 0);
5546 return sv_magicext(sv, NULL, PERL_MAGIC_regex_global,
5547 &PL_vtbl_mglob, 0, 0);
5551 =for apidoc sv_magic
5553 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if
5554 necessary, then adds a new magic item of type C<how> to the head of the
5557 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5558 handling of the C<name> and C<namlen> arguments.
5560 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5561 to add more than one instance of the same 'how'.
5567 Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
5568 const char *const name, const I32 namlen)
5570 const MGVTBL *vtable;
5573 unsigned int vtable_index;
5575 PERL_ARGS_ASSERT_SV_MAGIC;
5577 if (how < 0 || (unsigned)how >= C_ARRAY_LENGTH(PL_magic_data)
5578 || ((flags = PL_magic_data[how]),
5579 (vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
5580 > magic_vtable_max))
5581 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5583 /* PERL_MAGIC_ext is reserved for use by extensions not perl internals.
5584 Useful for attaching extension internal data to perl vars.
5585 Note that multiple extensions may clash if magical scalars
5586 etc holding private data from one are passed to another. */
5588 vtable = (vtable_index == magic_vtable_max)
5589 ? NULL : PL_magic_vtables + vtable_index;
5591 #ifdef PERL_OLD_COPY_ON_WRITE
5593 sv_force_normal_flags(sv, 0);
5595 if (SvREADONLY(sv)) {
5597 !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
5600 Perl_croak_no_modify();
5603 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5604 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5605 /* sv_magic() refuses to add a magic of the same 'how' as an
5608 if (how == PERL_MAGIC_taint)
5614 /* Force pos to be stored as characters, not bytes. */
5615 if (SvMAGICAL(sv) && DO_UTF8(sv)
5616 && (mg = mg_find(sv, PERL_MAGIC_regex_global))
5618 && mg->mg_flags & MGf_BYTES) {
5619 mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len,
5621 mg->mg_flags &= ~MGf_BYTES;
5624 /* Rest of work is done else where */
5625 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5628 case PERL_MAGIC_taint:
5631 case PERL_MAGIC_ext:
5632 case PERL_MAGIC_dbfile:
5639 S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
5646 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5648 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5649 for (mg = *mgp; mg; mg = *mgp) {
5650 const MGVTBL* const virt = mg->mg_virtual;
5651 if (mg->mg_type == type && (!flags || virt == vtbl)) {
5652 *mgp = mg->mg_moremagic;
5653 if (virt && virt->svt_free)
5654 virt->svt_free(aTHX_ sv, mg);
5655 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5657 Safefree(mg->mg_ptr);
5658 else if (mg->mg_len == HEf_SVKEY)
5659 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5660 else if (mg->mg_type == PERL_MAGIC_utf8)
5661 Safefree(mg->mg_ptr);
5663 if (mg->mg_flags & MGf_REFCOUNTED)
5664 SvREFCNT_dec(mg->mg_obj);
5668 mgp = &mg->mg_moremagic;
5671 if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */
5672 mg_magical(sv); /* else fix the flags now */
5676 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5682 =for apidoc sv_unmagic
5684 Removes all magic of type C<type> from an SV.
5690 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5692 PERL_ARGS_ASSERT_SV_UNMAGIC;
5693 return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
5697 =for apidoc sv_unmagicext
5699 Removes all magic of type C<type> with the specified C<vtbl> from an SV.
5705 Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
5707 PERL_ARGS_ASSERT_SV_UNMAGICEXT;
5708 return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
5712 =for apidoc sv_rvweaken
5714 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5715 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5716 push a back-reference to this RV onto the array of backreferences
5717 associated with that magic. If the RV is magical, set magic will be
5718 called after the RV is cleared.
5724 Perl_sv_rvweaken(pTHX_ SV *const sv)
5728 PERL_ARGS_ASSERT_SV_RVWEAKEN;
5730 if (!SvOK(sv)) /* let undefs pass */
5733 Perl_croak(aTHX_ "Can't weaken a nonreference");
5734 else if (SvWEAKREF(sv)) {
5735 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5738 else if (SvREADONLY(sv)) croak_no_modify();
5740 Perl_sv_add_backref(aTHX_ tsv, sv);
5742 SvREFCNT_dec_NN(tsv);
5746 /* Give tsv backref magic if it hasn't already got it, then push a
5747 * back-reference to sv onto the array associated with the backref magic.
5749 * As an optimisation, if there's only one backref and it's not an AV,
5750 * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5751 * allocate an AV. (Whether the slot holds an AV tells us whether this is
5755 /* A discussion about the backreferences array and its refcount:
5757 * The AV holding the backreferences is pointed to either as the mg_obj of
5758 * PERL_MAGIC_backref, or in the specific case of a HV, from the
5759 * xhv_backreferences field. The array is created with a refcount
5760 * of 2. This means that if during global destruction the array gets
5761 * picked on before its parent to have its refcount decremented by the
5762 * random zapper, it won't actually be freed, meaning it's still there for
5763 * when its parent gets freed.
5765 * When the parent SV is freed, the extra ref is killed by
5766 * Perl_sv_kill_backrefs. The other ref is killed, in the case of magic,
5767 * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5769 * When a single backref SV is stored directly, it is not reference
5774 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5780 PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5782 /* find slot to store array or singleton backref */
5784 if (SvTYPE(tsv) == SVt_PVHV) {
5785 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5788 mg = mg_find(tsv, PERL_MAGIC_backref);
5790 mg = sv_magicext(tsv, NULL, PERL_MAGIC_backref, &PL_vtbl_backref, NULL, 0);
5791 svp = &(mg->mg_obj);
5794 /* create or retrieve the array */
5796 if ( (!*svp && SvTYPE(sv) == SVt_PVAV)
5797 || (*svp && SvTYPE(*svp) != SVt_PVAV)
5801 mg->mg_flags |= MGf_REFCOUNTED;
5804 SvREFCNT_inc_simple_void_NN(av);
5805 /* av now has a refcnt of 2; see discussion above */
5806 av_extend(av, *svp ? 2 : 1);
5808 /* move single existing backref to the array */
5809 AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5814 av = MUTABLE_AV(*svp);
5816 /* optimisation: store single backref directly in HvAUX or mg_obj */
5820 assert(SvTYPE(av) == SVt_PVAV);
5821 if (AvFILLp(av) >= AvMAX(av)) {
5822 av_extend(av, AvFILLp(av)+1);
5825 /* push new backref */
5826 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5829 /* delete a back-reference to ourselves from the backref magic associated
5830 * with the SV we point to.
5834 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5838 PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5840 if (SvTYPE(tsv) == SVt_PVHV) {
5842 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5844 else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) {
5845 /* It's possible for the the last (strong) reference to tsv to have
5846 become freed *before* the last thing holding a weak reference.
5847 If both survive longer than the backreferences array, then when
5848 the referent's reference count drops to 0 and it is freed, it's
5849 not able to chase the backreferences, so they aren't NULLed.
5851 For example, a CV holds a weak reference to its stash. If both the
5852 CV and the stash survive longer than the backreferences array,
5853 and the CV gets picked for the SvBREAK() treatment first,
5854 *and* it turns out that the stash is only being kept alive because
5855 of an our variable in the pad of the CV, then midway during CV
5856 destruction the stash gets freed, but CvSTASH() isn't set to NULL.
5857 It ends up pointing to the freed HV. Hence it's chased in here, and
5858 if this block wasn't here, it would hit the !svp panic just below.
5860 I don't believe that "better" destruction ordering is going to help
5861 here - during global destruction there's always going to be the
5862 chance that something goes out of order. We've tried to make it
5863 foolproof before, and it only resulted in evolutionary pressure on
5864 fools. Which made us look foolish for our hubris. :-(
5870 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5871 svp = mg ? &(mg->mg_obj) : NULL;
5875 Perl_croak(aTHX_ "panic: del_backref, svp=0");
5877 /* It's possible that sv is being freed recursively part way through the
5878 freeing of tsv. If this happens, the backreferences array of tsv has
5879 already been freed, and so svp will be NULL. If this is the case,
5880 we should not panic. Instead, nothing needs doing, so return. */
5881 if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
5883 Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
5884 (void*)*svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
5887 if (SvTYPE(*svp) == SVt_PVAV) {
5891 AV * const av = (AV*)*svp;
5893 assert(!SvIS_FREED(av));
5897 /* for an SV with N weak references to it, if all those
5898 * weak refs are deleted, then sv_del_backref will be called
5899 * N times and O(N^2) compares will be done within the backref
5900 * array. To ameliorate this potential slowness, we:
5901 * 1) make sure this code is as tight as possible;
5902 * 2) when looking for SV, look for it at both the head and tail of the
5903 * array first before searching the rest, since some create/destroy
5904 * patterns will cause the backrefs to be freed in order.
5911 SV **p = &svp[fill];
5912 SV *const topsv = *p;
5919 /* We weren't the last entry.
5920 An unordered list has this property that you
5921 can take the last element off the end to fill
5922 the hole, and it's still an unordered list :-)
5928 break; /* should only be one */
5935 AvFILLp(av) = fill-1;
5937 else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) {
5938 /* freed AV; skip */
5941 /* optimisation: only a single backref, stored directly */
5943 Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p",
5944 (void*)*svp, (void*)sv);
5951 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5957 PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5962 /* after multiple passes through Perl_sv_clean_all() for a thingy
5963 * that has badly leaked, the backref array may have gotten freed,
5964 * since we only protect it against 1 round of cleanup */
5965 if (SvIS_FREED(av)) {
5966 if (PL_in_clean_all) /* All is fair */
5969 "panic: magic_killbackrefs (freed backref AV/SV)");
5973 is_array = (SvTYPE(av) == SVt_PVAV);
5975 assert(!SvIS_FREED(av));
5978 last = svp + AvFILLp(av);
5981 /* optimisation: only a single backref, stored directly */
5987 while (svp <= last) {
5989 SV *const referrer = *svp;
5990 if (SvWEAKREF(referrer)) {
5991 /* XXX Should we check that it hasn't changed? */
5992 assert(SvROK(referrer));
5993 SvRV_set(referrer, 0);
5995 SvWEAKREF_off(referrer);
5996 SvSETMAGIC(referrer);
5997 } else if (SvTYPE(referrer) == SVt_PVGV ||
5998 SvTYPE(referrer) == SVt_PVLV) {
5999 assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
6000 /* You lookin' at me? */
6001 assert(GvSTASH(referrer));
6002 assert(GvSTASH(referrer) == (const HV *)sv);
6003 GvSTASH(referrer) = 0;
6004 } else if (SvTYPE(referrer) == SVt_PVCV ||
6005 SvTYPE(referrer) == SVt_PVFM) {
6006 if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
6007 /* You lookin' at me? */
6008 assert(CvSTASH(referrer));
6009 assert(CvSTASH(referrer) == (const HV *)sv);
6010 SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
6013 assert(SvTYPE(sv) == SVt_PVGV);
6014 /* You lookin' at me? */
6015 assert(CvGV(referrer));
6016 assert(CvGV(referrer) == (const GV *)sv);
6017 anonymise_cv_maybe(MUTABLE_GV(sv),
6018 MUTABLE_CV(referrer));
6023 "panic: magic_killbackrefs (flags=%"UVxf")",
6024 (UV)SvFLAGS(referrer));
6035 SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */
6041 =for apidoc sv_insert
6043 Inserts a string at the specified offset/length within the SV. Similar to
6044 the Perl substr() function. Handles get magic.
6046 =for apidoc sv_insert_flags
6048 Same as C<sv_insert>, but the extra C<flags> are passed to the
6049 C<SvPV_force_flags> that applies to C<bigstr>.
6055 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
6061 SSize_t i; /* better be sizeof(STRLEN) or bad things happen */
6064 PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
6067 Perl_croak(aTHX_ "Can't modify nonexistent substring");
6068 SvPV_force_flags(bigstr, curlen, flags);
6069 (void)SvPOK_only_UTF8(bigstr);
6070 if (offset + len > curlen) {
6071 SvGROW(bigstr, offset+len+1);
6072 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
6073 SvCUR_set(bigstr, offset+len);
6077 i = littlelen - len;
6078 if (i > 0) { /* string might grow */
6079 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
6080 mid = big + offset + len;
6081 midend = bigend = big + SvCUR(bigstr);
6084 while (midend > mid) /* shove everything down */
6085 *--bigend = *--midend;
6086 Move(little,big+offset,littlelen,char);
6087 SvCUR_set(bigstr, SvCUR(bigstr) + i);
6092 Move(little,SvPVX(bigstr)+offset,len,char);
6097 big = SvPVX(bigstr);
6100 bigend = big + SvCUR(bigstr);
6102 if (midend > bigend)
6103 Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p",
6106 if (mid - big > bigend - midend) { /* faster to shorten from end */
6108 Move(little, mid, littlelen,char);
6111 i = bigend - midend;
6113 Move(midend, mid, i,char);
6117 SvCUR_set(bigstr, mid - big);
6119 else if ((i = mid - big)) { /* faster from front */
6120 midend -= littlelen;
6122 Move(big, midend - i, i, char);
6123 sv_chop(bigstr,midend-i);
6125 Move(little, mid, littlelen,char);
6127 else if (littlelen) {
6128 midend -= littlelen;
6129 sv_chop(bigstr,midend);
6130 Move(little,midend,littlelen,char);
6133 sv_chop(bigstr,midend);
6139 =for apidoc sv_replace
6141 Make the first argument a copy of the second, then delete the original.
6142 The target SV physically takes over ownership of the body of the source SV
6143 and inherits its flags; however, the target keeps any magic it owns,
6144 and any magic in the source is discarded.
6145 Note that this is a rather specialist SV copying operation; most of the
6146 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
6152 Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv)
6154 const U32 refcnt = SvREFCNT(sv);
6156 PERL_ARGS_ASSERT_SV_REPLACE;
6158 SV_CHECK_THINKFIRST_COW_DROP(sv);
6159 if (SvREFCNT(nsv) != 1) {
6160 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
6161 " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
6163 if (SvMAGICAL(sv)) {
6167 sv_upgrade(nsv, SVt_PVMG);
6168 SvMAGIC_set(nsv, SvMAGIC(sv));
6169 SvFLAGS(nsv) |= SvMAGICAL(sv);
6171 SvMAGIC_set(sv, NULL);
6175 assert(!SvREFCNT(sv));
6176 #ifdef DEBUG_LEAKING_SCALARS
6177 sv->sv_flags = nsv->sv_flags;
6178 sv->sv_any = nsv->sv_any;
6179 sv->sv_refcnt = nsv->sv_refcnt;
6180 sv->sv_u = nsv->sv_u;
6182 StructCopy(nsv,sv,SV);
6184 if(SvTYPE(sv) == SVt_IV) {
6186 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
6190 #ifdef PERL_OLD_COPY_ON_WRITE
6191 if (SvIsCOW_normal(nsv)) {
6192 /* We need to follow the pointers around the loop to make the
6193 previous SV point to sv, rather than nsv. */
6196 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
6199 assert(SvPVX_const(current) == SvPVX_const(nsv));
6201 /* Make the SV before us point to the SV after us. */
6203 PerlIO_printf(Perl_debug_log, "previous is\n");
6205 PerlIO_printf(Perl_debug_log,
6206 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
6207 (UV) SV_COW_NEXT_SV(current), (UV) sv);
6209 SV_COW_NEXT_SV_SET(current, sv);
6212 SvREFCNT(sv) = refcnt;
6213 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
6218 /* We're about to free a GV which has a CV that refers back to us.
6219 * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
6223 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
6228 PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
6231 assert(SvREFCNT(gv) == 0);
6232 assert(isGV(gv) && isGV_with_GP(gv));
6234 assert(!CvANON(cv));
6235 assert(CvGV(cv) == gv);
6236 assert(!CvNAMED(cv));
6238 /* will the CV shortly be freed by gp_free() ? */
6239 if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
6240 SvANY(cv)->xcv_gv_u.xcv_gv = NULL;
6244 /* if not, anonymise: */
6245 gvname = (GvSTASH(gv) && HvNAME(GvSTASH(gv)) && HvENAME(GvSTASH(gv)))
6246 ? newSVhek(HvENAME_HEK(GvSTASH(gv)))
6247 : newSVpvn_flags( "__ANON__", 8, 0 );
6248 sv_catpvs(gvname, "::__ANON__");
6249 anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
6250 SvREFCNT_dec_NN(gvname);
6254 SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
6259 =for apidoc sv_clear
6261 Clear an SV: call any destructors, free up any memory used by the body,
6262 and free the body itself. The SV's head is I<not> freed, although
6263 its type is set to all 1's so that it won't inadvertently be assumed
6264 to be live during global destruction etc.
6265 This function should only be called when REFCNT is zero. Most of the time
6266 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
6273 Perl_sv_clear(pTHX_ SV *const orig_sv)
6278 const struct body_details *sv_type_details;
6284 PERL_ARGS_ASSERT_SV_CLEAR;
6286 /* within this loop, sv is the SV currently being freed, and
6287 * iter_sv is the most recent AV or whatever that's being iterated
6288 * over to provide more SVs */
6294 assert(SvREFCNT(sv) == 0);
6295 assert(SvTYPE(sv) != (svtype)SVTYPEMASK);
6297 if (type <= SVt_IV) {
6298 /* See the comment in sv.h about the collusion between this
6299 * early return and the overloading of the NULL slots in the
6303 SvFLAGS(sv) &= SVf_BREAK;
6304 SvFLAGS(sv) |= SVTYPEMASK;
6308 assert(!SvOBJECT(sv) || type >= SVt_PVMG); /* objs are always >= MG */
6310 if (type >= SVt_PVMG) {
6312 if (!curse(sv, 1)) goto get_next_sv;
6313 type = SvTYPE(sv); /* destructor may have changed it */
6315 /* Free back-references before magic, in case the magic calls
6316 * Perl code that has weak references to sv. */
6317 if (type == SVt_PVHV) {
6318 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
6322 else if (type == SVt_PVMG && SvPAD_OUR(sv)) {
6323 SvREFCNT_dec(SvOURSTASH(sv));
6325 else if (type == SVt_PVAV && AvPAD_NAMELIST(sv)) {
6326 assert(!SvMAGICAL(sv));
6327 } else if (SvMAGIC(sv)) {
6328 /* Free back-references before other types of magic. */
6329 sv_unmagic(sv, PERL_MAGIC_backref);
6333 if (type == SVt_PVMG && SvPAD_TYPED(sv))
6334 SvREFCNT_dec(SvSTASH(sv));
6337 /* case SVt_INVLIST: */
6340 IoIFP(sv) != PerlIO_stdin() &&
6341 IoIFP(sv) != PerlIO_stdout() &&
6342 IoIFP(sv) != PerlIO_stderr() &&
6343 !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6345 io_close(MUTABLE_IO(sv), FALSE);
6347 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6348 PerlDir_close(IoDIRP(sv));
6349 IoDIRP(sv) = (DIR*)NULL;
6350 Safefree(IoTOP_NAME(sv));
6351 Safefree(IoFMT_NAME(sv));
6352 Safefree(IoBOTTOM_NAME(sv));
6353 if ((const GV *)sv == PL_statgv)
6357 /* FIXME for plugins */
6359 pregfree2((REGEXP*) sv);
6363 cv_undef(MUTABLE_CV(sv));
6364 /* If we're in a stash, we don't own a reference to it.
6365 * However it does have a back reference to us, which needs to
6367 if ((stash = CvSTASH(sv)))
6368 sv_del_backref(MUTABLE_SV(stash), sv);
6371 if (PL_last_swash_hv == (const HV *)sv) {
6372 PL_last_swash_hv = NULL;
6374 if (HvTOTALKEYS((HV*)sv) > 0) {
6376 /* this statement should match the one at the beginning of
6377 * hv_undef_flags() */
6378 if ( PL_phase != PERL_PHASE_DESTRUCT
6379 && (name = HvNAME((HV*)sv)))
6381 if (PL_stashcache) {
6382 DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n",
6384 (void)hv_deletehek(PL_stashcache,
6385 HvNAME_HEK((HV*)sv), G_DISCARD);
6387 hv_name_set((HV*)sv, NULL, 0, 0);
6390 /* save old iter_sv in unused SvSTASH field */
6391 assert(!SvOBJECT(sv));
6392 SvSTASH(sv) = (HV*)iter_sv;
6395 /* save old hash_index in unused SvMAGIC field */
6396 assert(!SvMAGICAL(sv));
6397 assert(!SvMAGIC(sv));
6398 ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index = hash_index;
6401 next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index);
6402 goto get_next_sv; /* process this new sv */
6404 /* free empty hash */
6405 Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6406 assert(!HvARRAY((HV*)sv));
6410 AV* av = MUTABLE_AV(sv);
6411 if (PL_comppad == av) {
6415 if (AvREAL(av) && AvFILLp(av) > -1) {
6416 next_sv = AvARRAY(av)[AvFILLp(av)--];
6417 /* save old iter_sv in top-most slot of AV,
6418 * and pray that it doesn't get wiped in the meantime */
6419 AvARRAY(av)[AvMAX(av)] = iter_sv;
6421 goto get_next_sv; /* process this new sv */
6423 Safefree(AvALLOC(av));
6428 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
6429 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
6430 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
6431 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
6433 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
6434 SvREFCNT_dec(LvTARG(sv));
6435 if (isREGEXP(sv)) goto freeregexp;
6437 if (isGV_with_GP(sv)) {
6438 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
6439 && HvENAME_get(stash))
6440 mro_method_changed_in(stash);
6441 gp_free(MUTABLE_GV(sv));
6443 unshare_hek(GvNAME_HEK(sv));
6444 /* If we're in a stash, we don't own a reference to it.
6445 * However it does have a back reference to us, which
6446 * needs to be cleared. */
6447 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
6448 sv_del_backref(MUTABLE_SV(stash), sv);
6450 /* FIXME. There are probably more unreferenced pointers to SVs
6451 * in the interpreter struct that we should check and tidy in
6452 * a similar fashion to this: */
6453 /* See also S_sv_unglob, which does the same thing. */
6454 if ((const GV *)sv == PL_last_in_gv)
6455 PL_last_in_gv = NULL;
6456 else if ((const GV *)sv == PL_statgv)
6458 else if ((const GV *)sv == PL_stderrgv)
6466 /* Don't bother with SvOOK_off(sv); as we're only going to
6470 SvOOK_offset(sv, offset);
6471 SvPV_set(sv, SvPVX_mutable(sv) - offset);
6472 /* Don't even bother with turning off the OOK flag. */
6477 SV * const target = SvRV(sv);
6479 sv_del_backref(target, sv);
6485 else if (SvPVX_const(sv)
6486 && !(SvTYPE(sv) == SVt_PVIO
6487 && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6491 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6495 # ifdef PERL_OLD_COPY_ON_WRITE
6496 sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
6498 if (CowREFCNT(sv)) {
6506 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6510 # ifdef PERL_OLD_COPY_ON_WRITE
6514 Safefree(SvPVX_mutable(sv));
6518 else if (SvPVX_const(sv) && SvLEN(sv)
6519 && !(SvTYPE(sv) == SVt_PVIO
6520 && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6521 Safefree(SvPVX_mutable(sv));
6522 else if (SvPVX_const(sv) && SvIsCOW(sv)) {
6523 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6533 SvFLAGS(sv) &= SVf_BREAK;
6534 SvFLAGS(sv) |= SVTYPEMASK;
6536 sv_type_details = bodies_by_type + type;
6537 if (sv_type_details->arena) {
6538 del_body(((char *)SvANY(sv) + sv_type_details->offset),
6539 &PL_body_roots[type]);
6541 else if (sv_type_details->body_size) {
6542 safefree(SvANY(sv));
6546 /* caller is responsible for freeing the head of the original sv */
6547 if (sv != orig_sv && !SvREFCNT(sv))
6550 /* grab and free next sv, if any */
6558 else if (!iter_sv) {
6560 } else if (SvTYPE(iter_sv) == SVt_PVAV) {
6561 AV *const av = (AV*)iter_sv;
6562 if (AvFILLp(av) > -1) {
6563 sv = AvARRAY(av)[AvFILLp(av)--];
6565 else { /* no more elements of current AV to free */
6568 /* restore previous value, squirrelled away */
6569 iter_sv = AvARRAY(av)[AvMAX(av)];
6570 Safefree(AvALLOC(av));
6573 } else if (SvTYPE(iter_sv) == SVt_PVHV) {
6574 sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index);
6575 if (!sv && !HvTOTALKEYS((HV *)iter_sv)) {
6576 /* no more elements of current HV to free */
6579 /* Restore previous values of iter_sv and hash_index,
6580 * squirrelled away */
6581 assert(!SvOBJECT(sv));
6582 iter_sv = (SV*)SvSTASH(sv);
6583 assert(!SvMAGICAL(sv));
6584 hash_index = ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index;
6586 /* perl -DA does not like rubbish in SvMAGIC. */
6590 /* free any remaining detritus from the hash struct */
6591 Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6592 assert(!HvARRAY((HV*)sv));
6597 /* unrolled SvREFCNT_dec and sv_free2 follows: */
6601 if (!SvREFCNT(sv)) {
6605 if (--(SvREFCNT(sv)))
6609 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6610 "Attempt to free temp prematurely: SV 0x%"UVxf
6611 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6615 if (SvIMMORTAL(sv)) {
6616 /* make sure SvREFCNT(sv)==0 happens very seldom */
6617 SvREFCNT(sv) = SvREFCNT_IMMORTAL;
6626 /* This routine curses the sv itself, not the object referenced by sv. So
6627 sv does not have to be ROK. */
6630 S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
6631 PERL_ARGS_ASSERT_CURSE;
6632 assert(SvOBJECT(sv));
6634 if (PL_defstash && /* Still have a symbol table? */
6640 stash = SvSTASH(sv);
6641 assert(SvTYPE(stash) == SVt_PVHV);
6642 if (HvNAME(stash)) {
6643 CV* destructor = NULL;
6644 assert (SvOOK(stash));
6645 if (!SvOBJECT(stash)) destructor = (CV *)SvSTASH(stash);
6646 if (!destructor || HvMROMETA(stash)->destroy_gen
6647 != PL_sub_generation)
6650 gv_fetchmeth_autoload(stash, "DESTROY", 7, 0);
6651 if (gv) destructor = GvCV(gv);
6652 if (!SvOBJECT(stash))
6655 destructor ? (HV *)destructor : ((HV *)0)+1;
6656 HvAUX(stash)->xhv_mro_meta->destroy_gen =
6660 assert(!destructor || destructor == ((CV *)0)+1
6661 || SvTYPE(destructor) == SVt_PVCV);
6662 if (destructor && destructor != ((CV *)0)+1
6663 /* A constant subroutine can have no side effects, so
6664 don't bother calling it. */
6665 && !CvCONST(destructor)
6666 /* Don't bother calling an empty destructor or one that
6667 returns immediately. */
6668 && (CvISXSUB(destructor)
6669 || (CvSTART(destructor)
6670 && (CvSTART(destructor)->op_next->op_type
6672 && (CvSTART(destructor)->op_next->op_type
6674 || CvSTART(destructor)->op_next->op_next->op_type
6680 SV* const tmpref = newRV(sv);
6681 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
6683 PUSHSTACKi(PERLSI_DESTROY);
6688 call_sv(MUTABLE_SV(destructor),
6689 G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
6693 if(SvREFCNT(tmpref) < 2) {
6694 /* tmpref is not kept alive! */
6696 SvRV_set(tmpref, NULL);
6699 SvREFCNT_dec_NN(tmpref);
6702 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
6705 if (check_refcnt && SvREFCNT(sv)) {
6706 if (PL_in_clean_objs)
6708 "DESTROY created new reference to dead object '%"HEKf"'",
6709 HEKfARG(HvNAME_HEK(stash)));
6710 /* DESTROY gave object new lease on life */
6716 HV * const stash = SvSTASH(sv);
6717 /* Curse before freeing the stash, as freeing the stash could cause
6718 a recursive call into S_curse. */
6719 SvOBJECT_off(sv); /* Curse the object. */
6720 SvSTASH_set(sv,0); /* SvREFCNT_dec may try to read this */
6721 SvREFCNT_dec(stash); /* possibly of changed persuasion */
6727 =for apidoc sv_newref
6729 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
6736 Perl_sv_newref(pTHX_ SV *const sv)
6738 PERL_UNUSED_CONTEXT;
6747 Decrement an SV's reference count, and if it drops to zero, call
6748 C<sv_clear> to invoke destructors and free up any memory used by
6749 the body; finally, deallocate the SV's head itself.
6750 Normally called via a wrapper macro C<SvREFCNT_dec>.
6756 Perl_sv_free(pTHX_ SV *const sv)
6762 /* Private helper function for SvREFCNT_dec().
6763 * Called with rc set to original SvREFCNT(sv), where rc == 0 or 1 */
6766 Perl_sv_free2(pTHX_ SV *const sv, const U32 rc)
6770 PERL_ARGS_ASSERT_SV_FREE2;
6772 if (LIKELY( rc == 1 )) {
6778 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6779 "Attempt to free temp prematurely: SV 0x%"UVxf
6780 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6784 if (SvIMMORTAL(sv)) {
6785 /* make sure SvREFCNT(sv)==0 happens very seldom */
6786 SvREFCNT(sv) = SvREFCNT_IMMORTAL;
6790 if (! SvREFCNT(sv)) /* may have have been resurrected */
6795 /* handle exceptional cases */
6799 if (SvFLAGS(sv) & SVf_BREAK)
6800 /* this SV's refcnt has been artificially decremented to
6801 * trigger cleanup */
6803 if (PL_in_clean_all) /* All is fair */
6805 if (SvIMMORTAL(sv)) {
6806 /* make sure SvREFCNT(sv)==0 happens very seldom */
6807 SvREFCNT(sv) = SvREFCNT_IMMORTAL;
6810 if (ckWARN_d(WARN_INTERNAL)) {
6811 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
6812 Perl_dump_sv_child(aTHX_ sv);
6814 #ifdef DEBUG_LEAKING_SCALARS
6817 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6818 if (PL_warnhook == PERL_WARNHOOK_FATAL
6819 || ckDEAD(packWARN(WARN_INTERNAL))) {
6820 /* Don't let Perl_warner cause us to escape our fate: */
6824 /* This may not return: */
6825 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6826 "Attempt to free unreferenced scalar: SV 0x%"UVxf
6827 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6830 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6840 Returns the length of the string in the SV. Handles magic and type
6841 coercion and sets the UTF8 flag appropriately. See also C<SvCUR>, which
6842 gives raw access to the xpv_cur slot.
6848 Perl_sv_len(pTHX_ SV *const sv)
6855 (void)SvPV_const(sv, len);
6860 =for apidoc sv_len_utf8
6862 Returns the number of characters in the string in an SV, counting wide
6863 UTF-8 bytes as a single character. Handles magic and type coercion.
6869 * The length is cached in PERL_MAGIC_utf8, in the mg_len field. Also the
6870 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
6871 * (Note that the mg_len is not the length of the mg_ptr field.
6872 * This allows the cache to store the character length of the string without
6873 * needing to malloc() extra storage to attach to the mg_ptr.)
6878 Perl_sv_len_utf8(pTHX_ SV *const sv)
6884 return sv_len_utf8_nomg(sv);
6888 Perl_sv_len_utf8_nomg(pTHX_ SV * const sv)
6891 const U8 *s = (U8*)SvPV_nomg_const(sv, len);
6893 PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG;
6895 if (PL_utf8cache && SvUTF8(sv)) {
6897 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
6899 if (mg && (mg->mg_len != -1 || mg->mg_ptr)) {
6900 if (mg->mg_len != -1)
6903 /* We can use the offset cache for a headstart.
6904 The longer value is stored in the first pair. */
6905 STRLEN *cache = (STRLEN *) mg->mg_ptr;
6907 ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1],
6911 if (PL_utf8cache < 0) {
6912 const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
6913 assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv);
6917 ulen = Perl_utf8_length(aTHX_ s, s + len);
6918 utf8_mg_len_cache_update(sv, &mg, ulen);
6922 return SvUTF8(sv) ? Perl_utf8_length(aTHX_ s, s + len) : len;
6925 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6928 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6929 STRLEN *const uoffset_p, bool *const at_end)
6931 const U8 *s = start;
6932 STRLEN uoffset = *uoffset_p;
6934 PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6936 while (s < send && uoffset) {
6943 else if (s > send) {
6945 /* This is the existing behaviour. Possibly it should be a croak, as
6946 it's actually a bounds error */
6949 *uoffset_p -= uoffset;
6953 /* Given the length of the string in both bytes and UTF-8 characters, decide
6954 whether to walk forwards or backwards to find the byte corresponding to
6955 the passed in UTF-8 offset. */
6957 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6958 STRLEN uoffset, const STRLEN uend)
6960 STRLEN backw = uend - uoffset;
6962 PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6964 if (uoffset < 2 * backw) {
6965 /* The assumption is that going forwards is twice the speed of going
6966 forward (that's where the 2 * backw comes from).
6967 (The real figure of course depends on the UTF-8 data.) */
6968 const U8 *s = start;
6970 while (s < send && uoffset--)
6980 while (UTF8_IS_CONTINUATION(*send))
6983 return send - start;
6986 /* For the string representation of the given scalar, find the byte
6987 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0
6988 give another position in the string, *before* the sought offset, which
6989 (which is always true, as 0, 0 is a valid pair of positions), which should
6990 help reduce the amount of linear searching.
6991 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6992 will be used to reduce the amount of linear searching. The cache will be
6993 created if necessary, and the found value offered to it for update. */
6995 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6996 const U8 *const send, STRLEN uoffset,
6997 STRLEN uoffset0, STRLEN boffset0)
6999 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
7001 bool at_end = FALSE;
7003 PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
7005 assert (uoffset >= uoffset0);
7010 if (!SvREADONLY(sv) && !SvGMAGICAL(sv) && SvPOK(sv)
7012 && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
7013 (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
7014 if ((*mgp)->mg_ptr) {
7015 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
7016 if (cache[0] == uoffset) {
7017 /* An exact match. */
7020 if (cache[2] == uoffset) {
7021 /* An exact match. */
7025 if (cache[0] < uoffset) {
7026 /* The cache already knows part of the way. */
7027 if (cache[0] > uoffset0) {
7028 /* The cache knows more than the passed in pair */
7029 uoffset0 = cache[0];
7030 boffset0 = cache[1];
7032 if ((*mgp)->mg_len != -1) {
7033 /* And we know the end too. */
7035 + sv_pos_u2b_midway(start + boffset0, send,
7037 (*mgp)->mg_len - uoffset0);
7039 uoffset -= uoffset0;
7041 + sv_pos_u2b_forwards(start + boffset0,
7042 send, &uoffset, &at_end);
7043 uoffset += uoffset0;
7046 else if (cache[2] < uoffset) {
7047 /* We're between the two cache entries. */
7048 if (cache[2] > uoffset0) {
7049 /* and the cache knows more than the passed in pair */
7050 uoffset0 = cache[2];
7051 boffset0 = cache[3];
7055 + sv_pos_u2b_midway(start + boffset0,
7058 cache[0] - uoffset0);
7061 + sv_pos_u2b_midway(start + boffset0,
7064 cache[2] - uoffset0);
7068 else if ((*mgp)->mg_len != -1) {
7069 /* If we can take advantage of a passed in offset, do so. */
7070 /* In fact, offset0 is either 0, or less than offset, so don't
7071 need to worry about the other possibility. */
7073 + sv_pos_u2b_midway(start + boffset0, send,
7075 (*mgp)->mg_len - uoffset0);
7080 if (!found || PL_utf8cache < 0) {
7081 STRLEN real_boffset;
7082 uoffset -= uoffset0;
7083 real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0,
7084 send, &uoffset, &at_end);
7085 uoffset += uoffset0;
7087 if (found && PL_utf8cache < 0)
7088 assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset,
7090 boffset = real_boffset;
7093 if (PL_utf8cache && !SvGMAGICAL(sv) && SvPOK(sv)) {
7095 utf8_mg_len_cache_update(sv, mgp, uoffset);
7097 utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
7104 =for apidoc sv_pos_u2b_flags
7106 Converts the offset from a count of UTF-8 chars from
7107 the start of the string, to a count of the equivalent number of bytes; if
7108 lenp is non-zero, it does the same to lenp, but this time starting from
7109 the offset, rather than from the start
7110 of the string. Handles type coercion.
7111 I<flags> is passed to C<SvPV_flags>, and usually should be
7112 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
7118 * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
7119 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
7120 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
7125 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
7132 PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
7134 start = (U8*)SvPV_flags(sv, len, flags);
7136 const U8 * const send = start + len;
7138 boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
7141 && *lenp /* don't bother doing work for 0, as its bytes equivalent
7142 is 0, and *lenp is already set to that. */) {
7143 /* Convert the relative offset to absolute. */
7144 const STRLEN uoffset2 = uoffset + *lenp;
7145 const STRLEN boffset2
7146 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
7147 uoffset, boffset) - boffset;
7161 =for apidoc sv_pos_u2b
7163 Converts the value pointed to by offsetp from a count of UTF-8 chars from
7164 the start of the string, to a count of the equivalent number of bytes; if
7165 lenp is non-zero, it does the same to lenp, but this time starting from
7166 the offset, rather than from the start of the string. Handles magic and
7169 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
7176 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
7177 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
7178 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
7182 /* This function is subject to size and sign problems */
7185 Perl_sv_pos_u2b(pTHX_ SV *const sv, I32 *const offsetp, I32 *const lenp)
7187 PERL_ARGS_ASSERT_SV_POS_U2B;
7190 STRLEN ulen = (STRLEN)*lenp;
7191 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
7192 SV_GMAGIC|SV_CONST_RETURN);
7195 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
7196 SV_GMAGIC|SV_CONST_RETURN);
7201 S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp,
7204 PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
7205 if (SvREADONLY(sv) || SvGMAGICAL(sv) || !SvPOK(sv))
7208 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
7209 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
7210 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
7214 (*mgp)->mg_len = ulen;
7217 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
7218 byte length pairing. The (byte) length of the total SV is passed in too,
7219 as blen, because for some (more esoteric) SVs, the call to SvPV_const()
7220 may not have updated SvCUR, so we can't rely on reading it directly.
7222 The proffered utf8/byte length pairing isn't used if the cache already has
7223 two pairs, and swapping either for the proffered pair would increase the
7224 RMS of the intervals between known byte offsets.
7226 The cache itself consists of 4 STRLEN values
7227 0: larger UTF-8 offset
7228 1: corresponding byte offset
7229 2: smaller UTF-8 offset
7230 3: corresponding byte offset
7232 Unused cache pairs have the value 0, 0.
7233 Keeping the cache "backwards" means that the invariant of
7234 cache[0] >= cache[2] is maintained even with empty slots, which means that
7235 the code that uses it doesn't need to worry if only 1 entry has actually
7236 been set to non-zero. It also makes the "position beyond the end of the
7237 cache" logic much simpler, as the first slot is always the one to start
7241 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
7242 const STRLEN utf8, const STRLEN blen)
7246 PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
7251 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
7252 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
7253 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
7255 (*mgp)->mg_len = -1;
7259 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
7260 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
7261 (*mgp)->mg_ptr = (char *) cache;
7265 if (PL_utf8cache < 0 && SvPOKp(sv)) {
7266 /* SvPOKp() because it's possible that sv has string overloading, and
7267 therefore is a reference, hence SvPVX() is actually a pointer.
7268 This cures the (very real) symptoms of RT 69422, but I'm not actually
7269 sure whether we should even be caching the results of UTF-8
7270 operations on overloading, given that nothing stops overloading
7271 returning a different value every time it's called. */
7272 const U8 *start = (const U8 *) SvPVX_const(sv);
7273 const STRLEN realutf8 = utf8_length(start, start + byte);
7275 assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8,
7279 /* Cache is held with the later position first, to simplify the code
7280 that deals with unbounded ends. */
7282 ASSERT_UTF8_CACHE(cache);
7283 if (cache[1] == 0) {
7284 /* Cache is totally empty */
7287 } else if (cache[3] == 0) {
7288 if (byte > cache[1]) {
7289 /* New one is larger, so goes first. */
7290 cache[2] = cache[0];
7291 cache[3] = cache[1];
7299 #define THREEWAY_SQUARE(a,b,c,d) \
7300 ((float)((d) - (c))) * ((float)((d) - (c))) \
7301 + ((float)((c) - (b))) * ((float)((c) - (b))) \
7302 + ((float)((b) - (a))) * ((float)((b) - (a)))
7304 /* Cache has 2 slots in use, and we know three potential pairs.
7305 Keep the two that give the lowest RMS distance. Do the
7306 calculation in bytes simply because we always know the byte
7307 length. squareroot has the same ordering as the positive value,
7308 so don't bother with the actual square root. */
7309 if (byte > cache[1]) {
7310 /* New position is after the existing pair of pairs. */
7311 const float keep_earlier
7312 = THREEWAY_SQUARE(0, cache[3], byte, blen);
7313 const float keep_later
7314 = THREEWAY_SQUARE(0, cache[1], byte, blen);
7316 if (keep_later < keep_earlier) {
7317 cache[2] = cache[0];
7318 cache[3] = cache[1];
7327 else if (byte > cache[3]) {
7328 /* New position is between the existing pair of pairs. */
7329 const float keep_earlier
7330 = THREEWAY_SQUARE(0, cache[3], byte, blen);
7331 const float keep_later
7332 = THREEWAY_SQUARE(0, byte, cache[1], blen);
7334 if (keep_later < keep_earlier) {
7344 /* New position is before the existing pair of pairs. */
7345 const float keep_earlier
7346 = THREEWAY_SQUARE(0, byte, cache[3], blen);
7347 const float keep_later
7348 = THREEWAY_SQUARE(0, byte, cache[1], blen);
7350 if (keep_later < keep_earlier) {
7355 cache[0] = cache[2];
7356 cache[1] = cache[3];
7362 ASSERT_UTF8_CACHE(cache);
7365 /* We already know all of the way, now we may be able to walk back. The same
7366 assumption is made as in S_sv_pos_u2b_midway(), namely that walking
7367 backward is half the speed of walking forward. */
7369 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
7370 const U8 *end, STRLEN endu)
7372 const STRLEN forw = target - s;
7373 STRLEN backw = end - target;
7375 PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
7377 if (forw < 2 * backw) {
7378 return utf8_length(s, target);
7381 while (end > target) {
7383 while (UTF8_IS_CONTINUATION(*end)) {
7392 =for apidoc sv_pos_b2u_flags
7394 Converts the offset from a count of bytes from the start of the string, to
7395 a count of the equivalent number of UTF-8 chars. Handles type coercion.
7396 I<flags> is passed to C<SvPV_flags>, and usually should be
7397 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
7403 * sv_pos_b2u_flags() uses, like sv_pos_u2b_flags(), the mg_ptr of the
7404 * potential PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8
7409 Perl_sv_pos_b2u_flags(pTHX_ SV *const sv, STRLEN const offset, U32 flags)
7412 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
7418 PERL_ARGS_ASSERT_SV_POS_B2U_FLAGS;
7420 s = (const U8*)SvPV_flags(sv, blen, flags);
7423 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%"UVuf
7424 ", byte=%"UVuf, (UV)blen, (UV)offset);
7430 && SvTYPE(sv) >= SVt_PVMG
7431 && (mg = mg_find(sv, PERL_MAGIC_utf8)))
7434 STRLEN * const cache = (STRLEN *) mg->mg_ptr;
7435 if (cache[1] == offset) {
7436 /* An exact match. */
7439 if (cache[3] == offset) {
7440 /* An exact match. */
7444 if (cache[1] < offset) {
7445 /* We already know part of the way. */
7446 if (mg->mg_len != -1) {
7447 /* Actually, we know the end too. */
7449 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
7450 s + blen, mg->mg_len - cache[0]);
7452 len = cache[0] + utf8_length(s + cache[1], send);
7455 else if (cache[3] < offset) {
7456 /* We're between the two cached pairs, so we do the calculation
7457 offset by the byte/utf-8 positions for the earlier pair,
7458 then add the utf-8 characters from the string start to
7460 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
7461 s + cache[1], cache[0] - cache[2])
7465 else { /* cache[3] > offset */
7466 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
7470 ASSERT_UTF8_CACHE(cache);
7472 } else if (mg->mg_len != -1) {
7473 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
7477 if (!found || PL_utf8cache < 0) {
7478 const STRLEN real_len = utf8_length(s, send);
7480 if (found && PL_utf8cache < 0)
7481 assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv);
7487 utf8_mg_len_cache_update(sv, &mg, len);
7489 utf8_mg_pos_cache_update(sv, &mg, offset, len, blen);
7496 =for apidoc sv_pos_b2u
7498 Converts the value pointed to by offsetp from a count of bytes from the
7499 start of the string, to a count of the equivalent number of UTF-8 chars.
7500 Handles magic and type coercion.
7502 Use C<sv_pos_b2u_flags> in preference, which correctly handles strings
7509 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
7510 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
7515 Perl_sv_pos_b2u(pTHX_ SV *const sv, I32 *const offsetp)
7517 PERL_ARGS_ASSERT_SV_POS_B2U;
7522 *offsetp = (I32)sv_pos_b2u_flags(sv, (STRLEN)*offsetp,
7523 SV_GMAGIC|SV_CONST_RETURN);
7527 S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache,
7528 STRLEN real, SV *const sv)
7530 PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT;
7532 /* As this is debugging only code, save space by keeping this test here,
7533 rather than inlining it in all the callers. */
7534 if (from_cache == real)
7537 /* Need to turn the assertions off otherwise we may recurse infinitely
7538 while printing error messages. */
7539 SAVEI8(PL_utf8cache);
7541 Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf,
7542 func, (UV) from_cache, (UV) real, SVfARG(sv));
7548 Returns a boolean indicating whether the strings in the two SVs are
7549 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
7550 coerce its args to strings if necessary.
7552 =for apidoc sv_eq_flags
7554 Returns a boolean indicating whether the strings in the two SVs are
7555 identical. Is UTF-8 and 'use bytes' aware and coerces its args to strings
7556 if necessary. If the flags include SV_GMAGIC, it handles get-magic, too.
7562 Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
7569 SV* svrecode = NULL;
7576 /* if pv1 and pv2 are the same, second SvPV_const call may
7577 * invalidate pv1 (if we are handling magic), so we may need to
7579 if (sv1 == sv2 && flags & SV_GMAGIC
7580 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
7581 pv1 = SvPV_const(sv1, cur1);
7582 sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
7584 pv1 = SvPV_flags_const(sv1, cur1, flags);
7592 pv2 = SvPV_flags_const(sv2, cur2, flags);
7594 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7595 /* Differing utf8ness.
7596 * Do not UTF8size the comparands as a side-effect. */
7599 svrecode = newSVpvn(pv2, cur2);
7600 sv_recode_to_utf8(svrecode, PL_encoding);
7601 pv2 = SvPV_const(svrecode, cur2);
7604 svrecode = newSVpvn(pv1, cur1);
7605 sv_recode_to_utf8(svrecode, PL_encoding);
7606 pv1 = SvPV_const(svrecode, cur1);
7608 /* Now both are in UTF-8. */
7610 SvREFCNT_dec_NN(svrecode);
7616 /* sv1 is the UTF-8 one */
7617 return bytes_cmp_utf8((const U8*)pv2, cur2,
7618 (const U8*)pv1, cur1) == 0;
7621 /* sv2 is the UTF-8 one */
7622 return bytes_cmp_utf8((const U8*)pv1, cur1,
7623 (const U8*)pv2, cur2) == 0;
7629 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
7631 SvREFCNT_dec(svrecode);
7639 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7640 string in C<sv1> is less than, equal to, or greater than the string in
7641 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
7642 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
7644 =for apidoc sv_cmp_flags
7646 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7647 string in C<sv1> is less than, equal to, or greater than the string in
7648 C<sv2>. Is UTF-8 and 'use bytes' aware and will coerce its args to strings
7649 if necessary. If the flags include SV_GMAGIC, it handles get magic. See
7650 also C<sv_cmp_locale_flags>.
7656 Perl_sv_cmp(pTHX_ SV *const sv1, SV *const sv2)
7658 return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
7662 Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2,
7666 const char *pv1, *pv2;
7668 SV *svrecode = NULL;
7675 pv1 = SvPV_flags_const(sv1, cur1, flags);
7682 pv2 = SvPV_flags_const(sv2, cur2, flags);
7684 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7685 /* Differing utf8ness.
7686 * Do not UTF8size the comparands as a side-effect. */
7689 svrecode = newSVpvn(pv2, cur2);
7690 sv_recode_to_utf8(svrecode, PL_encoding);
7691 pv2 = SvPV_const(svrecode, cur2);
7694 const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2,
7695 (const U8*)pv1, cur1);
7696 return retval ? retval < 0 ? -1 : +1 : 0;
7701 svrecode = newSVpvn(pv1, cur1);
7702 sv_recode_to_utf8(svrecode, PL_encoding);
7703 pv1 = SvPV_const(svrecode, cur1);
7706 const int retval = bytes_cmp_utf8((const U8*)pv1, cur1,
7707 (const U8*)pv2, cur2);
7708 return retval ? retval < 0 ? -1 : +1 : 0;
7714 cmp = cur2 ? -1 : 0;
7718 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
7721 cmp = retval < 0 ? -1 : 1;
7722 } else if (cur1 == cur2) {
7725 cmp = cur1 < cur2 ? -1 : 1;
7729 SvREFCNT_dec(svrecode);
7735 =for apidoc sv_cmp_locale
7737 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7738 'use bytes' aware, handles get magic, and will coerce its args to strings
7739 if necessary. See also C<sv_cmp>.
7741 =for apidoc sv_cmp_locale_flags
7743 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7744 'use bytes' aware and will coerce its args to strings if necessary. If the
7745 flags contain SV_GMAGIC, it handles get magic. See also C<sv_cmp_flags>.
7751 Perl_sv_cmp_locale(pTHX_ SV *const sv1, SV *const sv2)
7753 return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
7757 Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2,
7760 #ifdef USE_LOCALE_COLLATE
7766 if (PL_collation_standard)
7770 pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
7772 pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
7774 if (!pv1 || !len1) {
7785 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
7788 return retval < 0 ? -1 : 1;
7791 * When the result of collation is equality, that doesn't mean
7792 * that there are no differences -- some locales exclude some
7793 * characters from consideration. So to avoid false equalities,
7794 * we use the raw string as a tiebreaker.
7801 PERL_UNUSED_ARG(flags);
7802 #endif /* USE_LOCALE_COLLATE */
7804 return sv_cmp(sv1, sv2);
7808 #ifdef USE_LOCALE_COLLATE
7811 =for apidoc sv_collxfrm
7813 This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag. See
7814 C<sv_collxfrm_flags>.
7816 =for apidoc sv_collxfrm_flags
7818 Add Collate Transform magic to an SV if it doesn't already have it. If the
7819 flags contain SV_GMAGIC, it handles get-magic.
7821 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
7822 scalar data of the variable, but transformed to such a format that a normal
7823 memory comparison can be used to compare the data according to the locale
7830 Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
7834 PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
7836 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
7837 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
7843 Safefree(mg->mg_ptr);
7844 s = SvPV_flags_const(sv, len, flags);
7845 if ((xf = mem_collxfrm(s, len, &xlen))) {
7847 #ifdef PERL_OLD_COPY_ON_WRITE
7849 sv_force_normal_flags(sv, 0);
7851 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
7865 if (mg && mg->mg_ptr) {
7867 return mg->mg_ptr + sizeof(PL_collation_ix);
7875 #endif /* USE_LOCALE_COLLATE */
7878 S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7880 SV * const tsv = newSV(0);
7883 sv_gets(tsv, fp, 0);
7884 sv_utf8_upgrade_nomg(tsv);
7885 SvCUR_set(sv,append);
7888 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7892 S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7895 const STRLEN recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
7896 /* Grab the size of the record we're getting */
7897 char *buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7904 /* With a true, record-oriented file on VMS, we need to use read directly
7905 * to ensure that we respect RMS record boundaries. The user is responsible
7906 * for providing a PL_rs value that corresponds to the FAB$W_MRS (maximum
7907 * record size) field. N.B. This is likely to produce invalid results on
7908 * varying-width character data when a record ends mid-character.
7910 fd = PerlIO_fileno(fp);
7912 && PerlLIO_fstat(fd, &st) == 0
7913 && (st.st_fab_rfm == FAB$C_VAR
7914 || st.st_fab_rfm == FAB$C_VFC
7915 || st.st_fab_rfm == FAB$C_FIX)) {
7917 bytesread = PerlLIO_read(fd, buffer, recsize);
7919 else /* in-memory file from PerlIO::Scalar
7920 * or not a record-oriented file
7924 bytesread = PerlIO_read(fp, buffer, recsize);
7926 /* At this point, the logic in sv_get() means that sv will
7927 be treated as utf-8 if the handle is utf8.
7929 if (PerlIO_isutf8(fp) && bytesread > 0) {
7930 char *bend = buffer + bytesread;
7931 char *bufp = buffer;
7932 size_t charcount = 0;
7933 bool charstart = TRUE;
7936 while (charcount < recsize) {
7937 /* count accumulated characters */
7938 while (bufp < bend) {
7940 skip = UTF8SKIP(bufp);
7942 if (bufp + skip > bend) {
7943 /* partial at the end */
7954 if (charcount < recsize) {
7956 STRLEN bufp_offset = bufp - buffer;
7957 SSize_t morebytesread;
7959 /* originally I read enough to fill any incomplete
7960 character and the first byte of the next
7961 character if needed, but if there's many
7962 multi-byte encoded characters we're going to be
7963 making a read call for every character beyond
7964 the original read size.
7966 So instead, read the rest of the character if
7967 any, and enough bytes to match at least the
7968 start bytes for each character we're going to
7972 readsize = recsize - charcount;
7974 readsize = skip - (bend - bufp) + recsize - charcount - 1;
7975 buffer = SvGROW(sv, append + bytesread + readsize + 1) + append;
7976 bend = buffer + bytesread;
7977 morebytesread = PerlIO_read(fp, bend, readsize);
7978 if (morebytesread <= 0) {
7979 /* we're done, if we still have incomplete
7980 characters the check code in sv_gets() will
7983 I'd originally considered doing
7984 PerlIO_ungetc() on all but the lead
7985 character of the incomplete character, but
7986 read() doesn't do that, so I don't.
7991 /* prepare to scan some more */
7992 bytesread += morebytesread;
7993 bend = buffer + bytesread;
7994 bufp = buffer + bufp_offset;
8002 SvCUR_set(sv, bytesread + append);
8003 buffer[bytesread] = '\0';
8004 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
8010 Get a line from the filehandle and store it into the SV, optionally
8011 appending to the currently-stored string. If C<append> is not 0, the
8012 line is appended to the SV instead of overwriting it. C<append> should
8013 be set to the byte offset that the appended string should start at
8014 in the SV (typically, C<SvCUR(sv)> is a suitable choice).
8020 Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
8030 PERL_ARGS_ASSERT_SV_GETS;
8032 if (SvTHINKFIRST(sv))
8033 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
8034 /* XXX. If you make this PVIV, then copy on write can copy scalars read
8036 However, perlbench says it's slower, because the existing swipe code
8037 is faster than copy on write.
8038 Swings and roundabouts. */
8039 SvUPGRADE(sv, SVt_PV);
8042 /* line is going to be appended to the existing buffer in the sv */
8043 if (PerlIO_isutf8(fp)) {
8045 sv_utf8_upgrade_nomg(sv);
8046 sv_pos_u2b(sv,&append,0);
8048 } else if (SvUTF8(sv)) {
8049 return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append);
8055 /* not appending - "clear" the string by setting SvCUR to 0,
8056 * the pv is still avaiable. */
8059 if (PerlIO_isutf8(fp))
8062 if (IN_PERL_COMPILETIME) {
8063 /* we always read code in line mode */
8067 else if (RsSNARF(PL_rs)) {
8068 /* If it is a regular disk file use size from stat() as estimate
8069 of amount we are going to read -- may result in mallocing
8070 more memory than we really need if the layers below reduce
8071 the size we read (e.g. CRLF or a gzip layer).
8074 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
8075 const Off_t offset = PerlIO_tell(fp);
8076 if (offset != (Off_t) -1 && st.st_size + append > offset) {
8077 #ifdef PERL_NEW_COPY_ON_WRITE
8078 /* Add an extra byte for the sake of copy-on-write's
8079 * buffer reference count. */
8080 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 2));
8082 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
8089 else if (RsRECORD(PL_rs)) {
8090 return S_sv_gets_read_record(aTHX_ sv, fp, append);
8092 else if (RsPARA(PL_rs)) {
8098 /* Get $/ i.e. PL_rs into same encoding as stream wants */
8099 if (PerlIO_isutf8(fp)) {
8100 rsptr = SvPVutf8(PL_rs, rslen);
8103 if (SvUTF8(PL_rs)) {
8104 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
8105 Perl_croak(aTHX_ "Wide character in $/");
8108 /* extract the raw pointer to the record separator */
8109 rsptr = SvPV_const(PL_rs, rslen);
8113 /* rslast is the last character in the record separator
8114 * note we don't use rslast except when rslen is true, so the
8115 * null assign is a placeholder. */
8116 rslast = rslen ? rsptr[rslen - 1] : '\0';
8118 if (rspara) { /* have to do this both before and after */
8119 do { /* to make sure file boundaries work right */
8122 i = PerlIO_getc(fp);
8126 PerlIO_ungetc(fp,i);
8132 /* See if we know enough about I/O mechanism to cheat it ! */
8134 /* This used to be #ifdef test - it is made run-time test for ease
8135 of abstracting out stdio interface. One call should be cheap
8136 enough here - and may even be a macro allowing compile
8140 if (PerlIO_fast_gets(fp)) {
8142 * We can do buffer based IO operations on this filehandle.
8144 * This means we can bypass a lot of subcalls and process
8145 * the buffer directly, it also means we know the upper bound
8146 * on the amount of data we might read of the current buffer
8147 * into our sv. Knowing this allows us to preallocate the pv
8148 * to be able to hold that maximum, which allows us to simplify
8149 * a lot of logic. */
8152 * We're going to steal some values from the stdio struct
8153 * and put EVERYTHING in the innermost loop into registers.
8155 STDCHAR *ptr; /* pointer into fp's read-ahead buffer */
8156 STRLEN bpx; /* length of the data in the target sv
8157 used to fix pointers after a SvGROW */
8158 I32 shortbuffered; /* If the pv buffer is shorter than the amount
8159 of data left in the read-ahead buffer.
8160 If 0 then the pv buffer can hold the full
8161 amount left, otherwise this is the amount it
8164 #if defined(__VMS) && defined(PERLIO_IS_STDIO)
8165 /* An ungetc()d char is handled separately from the regular
8166 * buffer, so we getc() it back out and stuff it in the buffer.
8168 i = PerlIO_getc(fp);
8169 if (i == EOF) return 0;
8170 *(--((*fp)->_ptr)) = (unsigned char) i;
8174 /* Here is some breathtakingly efficient cheating */
8176 /* When you read the following logic resist the urge to think
8177 * of record separators that are 1 byte long. They are an
8178 * uninteresting special (simple) case.
8180 * Instead think of record separators which are at least 2 bytes
8181 * long, and keep in mind that we need to deal with such
8182 * separators when they cross a read-ahead buffer boundary.
8184 * Also consider that we need to gracefully deal with separators
8185 * that may be longer than a single read ahead buffer.
8187 * Lastly do not forget we want to copy the delimiter as well. We
8188 * are copying all data in the file _up_to_and_including_ the separator
8191 * Now that you have all that in mind here is what is happening below:
8193 * 1. When we first enter the loop we do some memory book keeping to see
8194 * how much free space there is in the target SV. (This sub assumes that
8195 * it is operating on the same SV most of the time via $_ and that it is
8196 * going to be able to reuse the same pv buffer each call.) If there is
8197 * "enough" room then we set "shortbuffered" to how much space there is
8198 * and start reading forward.
8200 * 2. When we scan forward we copy from the read-ahead buffer to the target
8201 * SV's pv buffer. While we go we watch for the end of the read-ahead buffer,
8202 * and the end of the of pv, as well as for the "rslast", which is the last
8203 * char of the separator.
8205 * 3. When scanning forward if we see rslast then we jump backwards in *pv*
8206 * (which has a "complete" record up to the point we saw rslast) and check
8207 * it to see if it matches the separator. If it does we are done. If it doesn't
8208 * we continue on with the scan/copy.
8210 * 4. If we run out of read-ahead buffer (cnt goes to 0) then we have to get
8211 * the IO system to read the next buffer. We do this by doing a getc(), which
8212 * returns a single char read (or EOF), and prefills the buffer, and also
8213 * allows us to find out how full the buffer is. We use this information to
8214 * SvGROW() the sv to the size remaining in the buffer, after which we copy
8215 * the returned single char into the target sv, and then go back into scan
8218 * 5. If we run out of write-buffer then we SvGROW() it by the size of the
8219 * remaining space in the read-buffer.
8221 * Note that this code despite its twisty-turny nature is pretty darn slick.
8222 * It manages single byte separators, multi-byte cross boundary separators,
8223 * and cross-read-buffer separators cleanly and efficiently at the cost
8224 * of potentially greatly overallocating the target SV.
8230 /* get the number of bytes remaining in the read-ahead buffer
8231 * on first call on a given fp this will return 0.*/
8232 cnt = PerlIO_get_cnt(fp);
8234 /* make sure we have the room */
8235 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
8236 /* Not room for all of it
8237 if we are looking for a separator and room for some
8239 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
8240 /* just process what we have room for */
8241 shortbuffered = cnt - SvLEN(sv) + append + 1;
8242 cnt -= shortbuffered;
8245 /* ensure that the target sv has enough room to hold
8246 * the rest of the read-ahead buffer */
8248 /* remember that cnt can be negative */
8249 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
8253 /* we have enough room to hold the full buffer, lets scream */
8257 /* extract the pointer to sv's string buffer, offset by append as necessary */
8258 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
8259 /* extract the point to the read-ahead buffer */
8260 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
8262 /* some trace debug output */
8263 DEBUG_P(PerlIO_printf(Perl_debug_log,
8264 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
8265 DEBUG_P(PerlIO_printf(Perl_debug_log,
8266 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%"IVdf", base=%"
8268 PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
8269 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
8273 /* if there is stuff left in the read-ahead buffer */
8275 /* if there is a separator */
8277 /* loop until we hit the end of the read-ahead buffer */
8278 while (cnt > 0) { /* this | eat */
8279 /* scan forward copying and searching for rslast as we go */
8281 if ((*bp++ = *ptr++) == rslast) /* really | dust */
8282 goto thats_all_folks; /* screams | sed :-) */
8286 /* no separator, slurp the full buffer */
8287 Copy(ptr, bp, cnt, char); /* this | eat */
8288 bp += cnt; /* screams | dust */
8289 ptr += cnt; /* louder | sed :-) */
8291 assert (!shortbuffered);
8292 goto cannot_be_shortbuffered;
8296 if (shortbuffered) { /* oh well, must extend */
8297 /* we didnt have enough room to fit the line into the target buffer
8298 * so we must extend the target buffer and keep going */
8299 cnt = shortbuffered;
8301 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
8303 /* extned the target sv's buffer so it can hold the full read-ahead buffer */
8304 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
8305 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
8309 cannot_be_shortbuffered:
8310 /* we need to refill the read-ahead buffer if possible */
8312 DEBUG_P(PerlIO_printf(Perl_debug_log,
8313 "Screamer: going to getc, ptr=%"UVuf", cnt=%"IVdf"\n",
8314 PTR2UV(ptr),(IV)cnt));
8315 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
8317 DEBUG_Pv(PerlIO_printf(Perl_debug_log,
8318 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%"IVdf", base=%"UVuf"\n",
8319 PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
8320 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
8323 call PerlIO_getc() to let it prefill the lookahead buffer
8325 This used to call 'filbuf' in stdio form, but as that behaves like
8326 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
8327 another abstraction.
8329 Note we have to deal with the char in 'i' if we are not at EOF
8331 i = PerlIO_getc(fp); /* get more characters */
8333 DEBUG_Pv(PerlIO_printf(Perl_debug_log,
8334 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%"IVdf", base=%"UVuf"\n",
8335 PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
8336 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
8338 /* find out how much is left in the read-ahead buffer, and rextract its pointer */
8339 cnt = PerlIO_get_cnt(fp);
8340 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
8341 DEBUG_P(PerlIO_printf(Perl_debug_log,
8342 "Screamer: after getc, ptr=%"UVuf", cnt=%"IVdf"\n",
8343 PTR2UV(ptr),(IV)cnt));
8345 if (i == EOF) /* all done for ever? */
8346 goto thats_really_all_folks;
8348 /* make sure we have enough space in the target sv */
8349 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
8351 SvGROW(sv, bpx + cnt + 2);
8352 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
8354 /* copy of the char we got from getc() */
8355 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
8357 /* make sure we deal with the i being the last character of a separator */
8358 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
8359 goto thats_all_folks;
8363 /* check if we have actually found the separator - only really applies
8365 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
8366 memNE((char*)bp - rslen, rsptr, rslen))
8367 goto screamer; /* go back to the fray */
8368 thats_really_all_folks:
8370 cnt += shortbuffered;
8371 DEBUG_P(PerlIO_printf(Perl_debug_log,
8372 "Screamer: quitting, ptr=%"UVuf", cnt=%"IVdf"\n",PTR2UV(ptr),(IV)cnt));
8373 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
8374 DEBUG_P(PerlIO_printf(Perl_debug_log,
8375 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%"IVdf", base=%"UVuf
8377 PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
8378 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
8380 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
8381 DEBUG_P(PerlIO_printf(Perl_debug_log,
8382 "Screamer: done, len=%ld, string=|%.*s|\n",
8383 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
8387 /*The big, slow, and stupid way. */
8388 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
8389 STDCHAR *buf = NULL;
8390 Newx(buf, 8192, STDCHAR);
8398 const STDCHAR * const bpe = buf + sizeof(buf);
8400 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
8401 ; /* keep reading */
8405 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
8406 /* Accommodate broken VAXC compiler, which applies U8 cast to
8407 * both args of ?: operator, causing EOF to change into 255
8410 i = (U8)buf[cnt - 1];
8416 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
8418 sv_catpvn_nomg(sv, (char *) buf, cnt);
8420 sv_setpvn(sv, (char *) buf, cnt); /* "nomg" is implied */
8422 if (i != EOF && /* joy */
8424 SvCUR(sv) < rslen ||
8425 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
8429 * If we're reading from a TTY and we get a short read,
8430 * indicating that the user hit his EOF character, we need
8431 * to notice it now, because if we try to read from the TTY
8432 * again, the EOF condition will disappear.
8434 * The comparison of cnt to sizeof(buf) is an optimization
8435 * that prevents unnecessary calls to feof().
8439 if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
8443 #ifdef USE_HEAP_INSTEAD_OF_STACK
8448 if (rspara) { /* have to do this both before and after */
8449 while (i != EOF) { /* to make sure file boundaries work right */
8450 i = PerlIO_getc(fp);
8452 PerlIO_ungetc(fp,i);
8458 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
8464 Auto-increment of the value in the SV, doing string to numeric conversion
8465 if necessary. Handles 'get' magic and operator overloading.
8471 Perl_sv_inc(pTHX_ SV *const sv)
8480 =for apidoc sv_inc_nomg
8482 Auto-increment of the value in the SV, doing string to numeric conversion
8483 if necessary. Handles operator overloading. Skips handling 'get' magic.
8489 Perl_sv_inc_nomg(pTHX_ SV *const sv)
8496 if (SvTHINKFIRST(sv)) {
8497 if (SvREADONLY(sv)) {
8498 Perl_croak_no_modify();
8502 if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg))
8504 i = PTR2IV(SvRV(sv));
8508 else sv_force_normal_flags(sv, 0);
8510 flags = SvFLAGS(sv);
8511 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
8512 /* It's (privately or publicly) a float, but not tested as an
8513 integer, so test it to see. */
8515 flags = SvFLAGS(sv);
8517 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
8518 /* It's publicly an integer, or privately an integer-not-float */
8519 #ifdef PERL_PRESERVE_IVUV
8523 if (SvUVX(sv) == UV_MAX)
8524 sv_setnv(sv, UV_MAX_P1);
8526 (void)SvIOK_only_UV(sv);
8527 SvUV_set(sv, SvUVX(sv) + 1);
8529 if (SvIVX(sv) == IV_MAX)
8530 sv_setuv(sv, (UV)IV_MAX + 1);
8532 (void)SvIOK_only(sv);
8533 SvIV_set(sv, SvIVX(sv) + 1);
8538 if (flags & SVp_NOK) {
8539 const NV was = SvNVX(sv);
8540 if (NV_OVERFLOWS_INTEGERS_AT &&
8541 was >= NV_OVERFLOWS_INTEGERS_AT) {
8542 /* diag_listed_as: Lost precision when %s %f by 1 */
8543 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
8544 "Lost precision when incrementing %" NVff " by 1",
8547 (void)SvNOK_only(sv);
8548 SvNV_set(sv, was + 1.0);
8552 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
8553 if ((flags & SVTYPEMASK) < SVt_PVIV)
8554 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
8555 (void)SvIOK_only(sv);
8560 while (isALPHA(*d)) d++;
8561 while (isDIGIT(*d)) d++;
8562 if (d < SvEND(sv)) {
8563 const int numtype = grok_number_flags(SvPVX_const(sv), SvCUR(sv), NULL, PERL_SCAN_TRAILING);
8564 #ifdef PERL_PRESERVE_IVUV
8565 /* Got to punt this as an integer if needs be, but we don't issue
8566 warnings. Probably ought to make the sv_iv_please() that does
8567 the conversion if possible, and silently. */
8568 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
8569 /* Need to try really hard to see if it's an integer.
8570 9.22337203685478e+18 is an integer.
8571 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
8572 so $a="9.22337203685478e+18"; $a+0; $a++
8573 needs to be the same as $a="9.22337203685478e+18"; $a++
8580 /* sv_2iv *should* have made this an NV */
8581 if (flags & SVp_NOK) {
8582 (void)SvNOK_only(sv);
8583 SvNV_set(sv, SvNVX(sv) + 1.0);
8586 /* I don't think we can get here. Maybe I should assert this
8587 And if we do get here I suspect that sv_setnv will croak. NWC
8589 #if defined(USE_LONG_DOUBLE)
8590 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",
8591 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8593 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
8594 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8597 #endif /* PERL_PRESERVE_IVUV */
8598 if (!numtype && ckWARN(WARN_NUMERIC))
8599 not_incrementable(sv);
8600 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
8604 while (d >= SvPVX_const(sv)) {
8612 /* MKS: The original code here died if letters weren't consecutive.
8613 * at least it didn't have to worry about non-C locales. The
8614 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
8615 * arranged in order (although not consecutively) and that only
8616 * [A-Za-z] are accepted by isALPHA in the C locale.
8618 if (*d != 'z' && *d != 'Z') {
8619 do { ++*d; } while (!isALPHA(*d));
8622 *(d--) -= 'z' - 'a';
8627 *(d--) -= 'z' - 'a' + 1;
8631 /* oh,oh, the number grew */
8632 SvGROW(sv, SvCUR(sv) + 2);
8633 SvCUR_set(sv, SvCUR(sv) + 1);
8634 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
8645 Auto-decrement of the value in the SV, doing string to numeric conversion
8646 if necessary. Handles 'get' magic and operator overloading.
8652 Perl_sv_dec(pTHX_ SV *const sv)
8661 =for apidoc sv_dec_nomg
8663 Auto-decrement of the value in the SV, doing string to numeric conversion
8664 if necessary. Handles operator overloading. Skips handling 'get' magic.
8670 Perl_sv_dec_nomg(pTHX_ SV *const sv)
8676 if (SvTHINKFIRST(sv)) {
8677 if (SvREADONLY(sv)) {
8678 Perl_croak_no_modify();
8682 if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg))
8684 i = PTR2IV(SvRV(sv));
8688 else sv_force_normal_flags(sv, 0);
8690 /* Unlike sv_inc we don't have to worry about string-never-numbers
8691 and keeping them magic. But we mustn't warn on punting */
8692 flags = SvFLAGS(sv);
8693 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
8694 /* It's publicly an integer, or privately an integer-not-float */
8695 #ifdef PERL_PRESERVE_IVUV
8699 if (SvUVX(sv) == 0) {
8700 (void)SvIOK_only(sv);
8704 (void)SvIOK_only_UV(sv);
8705 SvUV_set(sv, SvUVX(sv) - 1);
8708 if (SvIVX(sv) == IV_MIN) {
8709 sv_setnv(sv, (NV)IV_MIN);
8713 (void)SvIOK_only(sv);
8714 SvIV_set(sv, SvIVX(sv) - 1);
8719 if (flags & SVp_NOK) {
8722 const NV was = SvNVX(sv);
8723 if (NV_OVERFLOWS_INTEGERS_AT &&
8724 was <= -NV_OVERFLOWS_INTEGERS_AT) {
8725 /* diag_listed_as: Lost precision when %s %f by 1 */
8726 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
8727 "Lost precision when decrementing %" NVff " by 1",
8730 (void)SvNOK_only(sv);
8731 SvNV_set(sv, was - 1.0);
8735 if (!(flags & SVp_POK)) {
8736 if ((flags & SVTYPEMASK) < SVt_PVIV)
8737 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
8739 (void)SvIOK_only(sv);
8742 #ifdef PERL_PRESERVE_IVUV
8744 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
8745 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
8746 /* Need to try really hard to see if it's an integer.
8747 9.22337203685478e+18 is an integer.
8748 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
8749 so $a="9.22337203685478e+18"; $a+0; $a--
8750 needs to be the same as $a="9.22337203685478e+18"; $a--
8757 /* sv_2iv *should* have made this an NV */
8758 if (flags & SVp_NOK) {
8759 (void)SvNOK_only(sv);
8760 SvNV_set(sv, SvNVX(sv) - 1.0);
8763 /* I don't think we can get here. Maybe I should assert this
8764 And if we do get here I suspect that sv_setnv will croak. NWC
8766 #if defined(USE_LONG_DOUBLE)
8767 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",
8768 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8770 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
8771 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8775 #endif /* PERL_PRESERVE_IVUV */
8776 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
8779 /* this define is used to eliminate a chunk of duplicated but shared logic
8780 * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
8781 * used anywhere but here - yves
8783 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
8786 PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
8790 =for apidoc sv_mortalcopy
8792 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
8793 The new SV is marked as mortal. It will be destroyed "soon", either by an
8794 explicit call to FREETMPS, or by an implicit call at places such as
8795 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
8800 /* Make a string that will exist for the duration of the expression
8801 * evaluation. Actually, it may have to last longer than that, but
8802 * hopefully we won't free it until it has been assigned to a
8803 * permanent location. */
8806 Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags)
8810 if (flags & SV_GMAGIC)
8811 SvGETMAGIC(oldstr); /* before new_SV, in case it dies */
8813 sv_setsv_flags(sv,oldstr,flags & ~SV_GMAGIC);
8814 PUSH_EXTEND_MORTAL__SV_C(sv);
8820 =for apidoc sv_newmortal
8822 Creates a new null SV which is mortal. The reference count of the SV is
8823 set to 1. It will be destroyed "soon", either by an explicit call to
8824 FREETMPS, or by an implicit call at places such as statement boundaries.
8825 See also C<sv_mortalcopy> and C<sv_2mortal>.
8831 Perl_sv_newmortal(pTHX)
8836 SvFLAGS(sv) = SVs_TEMP;
8837 PUSH_EXTEND_MORTAL__SV_C(sv);
8843 =for apidoc newSVpvn_flags
8845 Creates a new SV and copies a string (which may contain C<NUL> (C<\0>)
8846 characters) into it. The reference count for the
8847 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
8848 string. You are responsible for ensuring that the source string is at least
8849 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
8850 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
8851 If C<SVs_TEMP> is set, then C<sv_2mortal()> is called on the result before
8852 returning. If C<SVf_UTF8> is set, C<s>
8853 is considered to be in UTF-8 and the
8854 C<SVf_UTF8> flag will be set on the new SV.
8855 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
8857 #define newSVpvn_utf8(s, len, u) \
8858 newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
8864 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
8868 /* All the flags we don't support must be zero.
8869 And we're new code so I'm going to assert this from the start. */
8870 assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
8872 sv_setpvn(sv,s,len);
8874 /* This code used to do a sv_2mortal(), however we now unroll the call to
8875 * sv_2mortal() and do what it does ourselves here. Since we have asserted
8876 * that flags can only have the SVf_UTF8 and/or SVs_TEMP flags set above we
8877 * can use it to enable the sv flags directly (bypassing SvTEMP_on), which
8878 * in turn means we dont need to mask out the SVf_UTF8 flag below, which
8879 * means that we eliminate quite a few steps than it looks - Yves
8880 * (explaining patch by gfx) */
8882 SvFLAGS(sv) |= flags;
8884 if(flags & SVs_TEMP){
8885 PUSH_EXTEND_MORTAL__SV_C(sv);
8892 =for apidoc sv_2mortal
8894 Marks an existing SV as mortal. The SV will be destroyed "soon", either
8895 by an explicit call to FREETMPS, or by an implicit call at places such as
8896 statement boundaries. SvTEMP() is turned on which means that the SV's
8897 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
8898 and C<sv_mortalcopy>.
8904 Perl_sv_2mortal(pTHX_ SV *const sv)
8911 PUSH_EXTEND_MORTAL__SV_C(sv);
8919 Creates a new SV and copies a string (which may contain C<NUL> (C<\0>)
8920 characters) into it. The reference count for the
8921 SV is set to 1. If C<len> is zero, Perl will compute the length using
8922 strlen(), (which means if you use this option, that C<s> can't have embedded
8923 C<NUL> characters and has to have a terminating C<NUL> byte).
8925 For efficiency, consider using C<newSVpvn> instead.
8931 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
8936 sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
8941 =for apidoc newSVpvn
8943 Creates a new SV and copies a string into it, which may contain C<NUL> characters
8944 (C<\0>) and other binary data. The reference count for the SV is set to 1.
8945 Note that if C<len> is zero, Perl will create a zero length (Perl) string. You
8946 are responsible for ensuring that the source buffer is at least
8947 C<len> bytes long. If the C<buffer> argument is NULL the new SV will be
8954 Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len)
8958 sv_setpvn(sv,buffer,len);
8963 =for apidoc newSVhek
8965 Creates a new SV from the hash key structure. It will generate scalars that
8966 point to the shared string table where possible. Returns a new (undefined)
8967 SV if the hek is NULL.
8973 Perl_newSVhek(pTHX_ const HEK *const hek)
8982 if (HEK_LEN(hek) == HEf_SVKEY) {
8983 return newSVsv(*(SV**)HEK_KEY(hek));
8985 const int flags = HEK_FLAGS(hek);
8986 if (flags & HVhek_WASUTF8) {
8988 Andreas would like keys he put in as utf8 to come back as utf8
8990 STRLEN utf8_len = HEK_LEN(hek);
8991 SV * const sv = newSV_type(SVt_PV);
8992 char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
8993 /* bytes_to_utf8() allocates a new string, which we can repurpose: */
8994 sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
8997 } else if (flags & HVhek_UNSHARED) {
8998 /* A hash that isn't using shared hash keys has to have
8999 the flag in every key so that we know not to try to call
9000 share_hek_hek on it. */
9002 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
9007 /* This will be overwhelminly the most common case. */
9009 /* Inline most of newSVpvn_share(), because share_hek_hek() is far
9010 more efficient than sharepvn(). */
9014 sv_upgrade(sv, SVt_PV);
9015 SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
9016 SvCUR_set(sv, HEK_LEN(hek));
9028 =for apidoc newSVpvn_share
9030 Creates a new SV with its SvPVX_const pointing to a shared string in the string
9031 table. If the string does not already exist in the table, it is
9032 created first. Turns on the SvIsCOW flag (or READONLY
9033 and FAKE in 5.16 and earlier). If the C<hash> parameter
9034 is non-zero, that value is used; otherwise the hash is computed.
9035 The string's hash can later be retrieved from the SV
9036 with the C<SvSHARED_HASH()> macro. The idea here is
9037 that as the string table is used for shared hash keys these strings will have
9038 SvPVX_const == HeKEY and hash lookup will avoid string compare.
9044 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
9048 bool is_utf8 = FALSE;
9049 const char *const orig_src = src;
9052 STRLEN tmplen = -len;
9054 /* See the note in hv.c:hv_fetch() --jhi */
9055 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
9059 PERL_HASH(hash, src, len);
9061 /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
9062 changes here, update it there too. */
9063 sv_upgrade(sv, SVt_PV);
9064 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
9071 if (src != orig_src)
9077 =for apidoc newSVpv_share
9079 Like C<newSVpvn_share>, but takes a C<NUL>-terminated string instead of a
9086 Perl_newSVpv_share(pTHX_ const char *src, U32 hash)
9088 return newSVpvn_share(src, strlen(src), hash);
9091 #if defined(PERL_IMPLICIT_CONTEXT)
9093 /* pTHX_ magic can't cope with varargs, so this is a no-context
9094 * version of the main function, (which may itself be aliased to us).
9095 * Don't access this version directly.
9099 Perl_newSVpvf_nocontext(const char *const pat, ...)
9105 PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
9107 va_start(args, pat);
9108 sv = vnewSVpvf(pat, &args);
9115 =for apidoc newSVpvf
9117 Creates a new SV and initializes it with the string formatted like
9124 Perl_newSVpvf(pTHX_ const char *const pat, ...)
9129 PERL_ARGS_ASSERT_NEWSVPVF;
9131 va_start(args, pat);
9132 sv = vnewSVpvf(pat, &args);
9137 /* backend for newSVpvf() and newSVpvf_nocontext() */
9140 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
9144 PERL_ARGS_ASSERT_VNEWSVPVF;
9147 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9154 Creates a new SV and copies a floating point value into it.
9155 The reference count for the SV is set to 1.
9161 Perl_newSVnv(pTHX_ const NV n)
9173 Creates a new SV and copies an integer into it. The reference count for the
9180 Perl_newSViv(pTHX_ const IV i)
9192 Creates a new SV and copies an unsigned integer into it.
9193 The reference count for the SV is set to 1.
9199 Perl_newSVuv(pTHX_ const UV u)
9209 =for apidoc newSV_type
9211 Creates a new SV, of the type specified. The reference count for the new SV
9218 Perl_newSV_type(pTHX_ const svtype type)
9223 sv_upgrade(sv, type);
9228 =for apidoc newRV_noinc
9230 Creates an RV wrapper for an SV. The reference count for the original
9231 SV is B<not> incremented.
9237 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
9239 SV *sv = newSV_type(SVt_IV);
9241 PERL_ARGS_ASSERT_NEWRV_NOINC;
9244 SvRV_set(sv, tmpRef);
9249 /* newRV_inc is the official function name to use now.
9250 * newRV_inc is in fact #defined to newRV in sv.h
9254 Perl_newRV(pTHX_ SV *const sv)
9256 PERL_ARGS_ASSERT_NEWRV;
9258 return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
9264 Creates a new SV which is an exact duplicate of the original SV.
9271 Perl_newSVsv(pTHX_ SV *const old)
9277 if (SvTYPE(old) == (svtype)SVTYPEMASK) {
9278 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
9281 /* Do this here, otherwise we leak the new SV if this croaks. */
9284 /* SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
9285 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
9286 sv_setsv_flags(sv, old, SV_NOSTEAL);
9291 =for apidoc sv_reset
9293 Underlying implementation for the C<reset> Perl function.
9294 Note that the perl-level function is vaguely deprecated.
9300 Perl_sv_reset(pTHX_ const char *s, HV *const stash)
9302 PERL_ARGS_ASSERT_SV_RESET;
9304 sv_resetpvn(*s ? s : NULL, strlen(s), stash);
9308 Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash)
9310 char todo[PERL_UCHAR_MAX+1];
9313 if (!stash || SvTYPE(stash) != SVt_PVHV)
9316 if (!s) { /* reset ?? searches */
9317 MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
9319 const U32 count = mg->mg_len / sizeof(PMOP**);
9320 PMOP **pmp = (PMOP**) mg->mg_ptr;
9321 PMOP *const *const end = pmp + count;
9325 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
9327 (*pmp)->op_pmflags &= ~PMf_USED;
9335 /* reset variables */
9337 if (!HvARRAY(stash))
9340 Zero(todo, 256, char);
9344 I32 i = (unsigned char)*s;
9348 max = (unsigned char)*s++;
9349 for ( ; i <= max; i++) {
9352 for (i = 0; i <= (I32) HvMAX(stash); i++) {
9354 for (entry = HvARRAY(stash)[i];
9356 entry = HeNEXT(entry))
9361 if (!todo[(U8)*HeKEY(entry)])
9363 gv = MUTABLE_GV(HeVAL(entry));
9365 if (sv && !SvREADONLY(sv)) {
9366 SV_CHECK_THINKFIRST_COW_DROP(sv);
9367 if (!isGV(sv)) SvOK_off(sv);
9372 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
9383 Using various gambits, try to get an IO from an SV: the IO slot if its a
9384 GV; or the recursive result if we're an RV; or the IO slot of the symbol
9385 named after the PV if we're a string.
9387 'Get' magic is ignored on the sv passed in, but will be called on
9388 C<SvRV(sv)> if sv is an RV.
9394 Perl_sv_2io(pTHX_ SV *const sv)
9399 PERL_ARGS_ASSERT_SV_2IO;
9401 switch (SvTYPE(sv)) {
9403 io = MUTABLE_IO(sv);
9407 if (isGV_with_GP(sv)) {
9408 gv = MUTABLE_GV(sv);
9411 Perl_croak(aTHX_ "Bad filehandle: %"HEKf,
9412 HEKfARG(GvNAME_HEK(gv)));
9418 Perl_croak(aTHX_ PL_no_usym, "filehandle");
9420 SvGETMAGIC(SvRV(sv));
9421 return sv_2io(SvRV(sv));
9423 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
9430 if (SvGMAGICAL(sv)) {
9431 newsv = sv_newmortal();
9432 sv_setsv_nomg(newsv, sv);
9434 Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(newsv));
9444 Using various gambits, try to get a CV from an SV; in addition, try if
9445 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
9446 The flags in C<lref> are passed to gv_fetchsv.
9452 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
9457 PERL_ARGS_ASSERT_SV_2CV;
9464 switch (SvTYPE(sv)) {
9468 return MUTABLE_CV(sv);
9478 sv = amagic_deref_call(sv, to_cv_amg);
9481 if (SvTYPE(sv) == SVt_PVCV) {
9482 cv = MUTABLE_CV(sv);
9487 else if(SvGETMAGIC(sv), isGV_with_GP(sv))
9488 gv = MUTABLE_GV(sv);
9490 Perl_croak(aTHX_ "Not a subroutine reference");
9492 else if (isGV_with_GP(sv)) {
9493 gv = MUTABLE_GV(sv);
9496 gv = gv_fetchsv_nomg(sv, lref, SVt_PVCV);
9503 /* Some flags to gv_fetchsv mean don't really create the GV */
9504 if (!isGV_with_GP(gv)) {
9509 if (lref & ~GV_ADDMG && !GvCVu(gv)) {
9510 /* XXX this is probably not what they think they're getting.
9511 * It has the same effect as "sub name;", i.e. just a forward
9522 Returns true if the SV has a true value by Perl's rules.
9523 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
9524 instead use an in-line version.
9530 Perl_sv_true(pTHX_ SV *const sv)
9535 const XPV* const tXpv = (XPV*)SvANY(sv);
9537 (tXpv->xpv_cur > 1 ||
9538 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
9545 return SvIVX(sv) != 0;
9548 return SvNVX(sv) != 0.0;
9550 return sv_2bool(sv);
9556 =for apidoc sv_pvn_force
9558 Get a sensible string out of the SV somehow.
9559 A private implementation of the C<SvPV_force> macro for compilers which
9560 can't cope with complex macro expressions. Always use the macro instead.
9562 =for apidoc sv_pvn_force_flags
9564 Get a sensible string out of the SV somehow.
9565 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
9566 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
9567 implemented in terms of this function.
9568 You normally want to use the various wrapper macros instead: see
9569 C<SvPV_force> and C<SvPV_force_nomg>
9575 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
9577 PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
9579 if (flags & SV_GMAGIC) SvGETMAGIC(sv);
9580 if (SvTHINKFIRST(sv) && (!SvROK(sv) || SvREADONLY(sv)))
9581 sv_force_normal_flags(sv, 0);
9591 if (SvTYPE(sv) > SVt_PVLV
9592 || isGV_with_GP(sv))
9593 /* diag_listed_as: Can't coerce %s to %s in %s */
9594 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
9596 s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC);
9603 if (SvTYPE(sv) < SVt_PV ||
9604 s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
9607 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
9608 SvGROW(sv, len + 1);
9609 Move(s,SvPVX(sv),len,char);
9611 SvPVX(sv)[len] = '\0';
9614 SvPOK_on(sv); /* validate pointer */
9616 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
9617 PTR2UV(sv),SvPVX_const(sv)));
9620 (void)SvPOK_only_UTF8(sv);
9621 return SvPVX_mutable(sv);
9625 =for apidoc sv_pvbyten_force
9627 The backend for the C<SvPVbytex_force> macro. Always use the macro
9634 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
9636 PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
9638 sv_pvn_force(sv,lp);
9639 sv_utf8_downgrade(sv,0);
9645 =for apidoc sv_pvutf8n_force
9647 The backend for the C<SvPVutf8x_force> macro. Always use the macro
9654 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
9656 PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
9659 sv_utf8_upgrade_nomg(sv);
9665 =for apidoc sv_reftype
9667 Returns a string describing what the SV is a reference to.
9673 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
9675 PERL_ARGS_ASSERT_SV_REFTYPE;
9676 if (ob && SvOBJECT(sv)) {
9677 return SvPV_nolen_const(sv_ref(NULL, sv, ob));
9680 /* WARNING - There is code, for instance in mg.c, that assumes that
9681 * the only reason that sv_reftype(sv,0) would return a string starting
9682 * with 'L' or 'S' is that it is a LVALUE or a SCALAR.
9683 * Yes this a dodgy way to do type checking, but it saves practically reimplementing
9684 * this routine inside other subs, and it saves time.
9685 * Do not change this assumption without searching for "dodgy type check" in
9688 switch (SvTYPE(sv)) {
9703 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
9704 /* tied lvalues should appear to be
9705 * scalars for backwards compatibility */
9706 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
9707 ? "SCALAR" : "LVALUE");
9708 case SVt_PVAV: return "ARRAY";
9709 case SVt_PVHV: return "HASH";
9710 case SVt_PVCV: return "CODE";
9711 case SVt_PVGV: return (char *) (isGV_with_GP(sv)
9712 ? "GLOB" : "SCALAR");
9713 case SVt_PVFM: return "FORMAT";
9714 case SVt_PVIO: return "IO";
9715 case SVt_INVLIST: return "INVLIST";
9716 case SVt_REGEXP: return "REGEXP";
9717 default: return "UNKNOWN";
9725 Returns a SV describing what the SV passed in is a reference to.
9731 Perl_sv_ref(pTHX_ SV *dst, const SV *const sv, const int ob)
9733 PERL_ARGS_ASSERT_SV_REF;
9736 dst = sv_newmortal();
9738 if (ob && SvOBJECT(sv)) {
9739 HvNAME_get(SvSTASH(sv))
9740 ? sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)))
9741 : sv_setpvn(dst, "__ANON__", 8);
9744 const char * reftype = sv_reftype(sv, 0);
9745 sv_setpv(dst, reftype);
9751 =for apidoc sv_isobject
9753 Returns a boolean indicating whether the SV is an RV pointing to a blessed
9754 object. If the SV is not an RV, or if the object is not blessed, then this
9761 Perl_sv_isobject(pTHX_ SV *sv)
9777 Returns a boolean indicating whether the SV is blessed into the specified
9778 class. This does not check for subtypes; use C<sv_derived_from> to verify
9779 an inheritance relationship.
9785 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
9789 PERL_ARGS_ASSERT_SV_ISA;
9799 hvname = HvNAME_get(SvSTASH(sv));
9803 return strEQ(hvname, name);
9809 Creates a new SV for the existing RV, C<rv>, to point to. If C<rv> is not an
9810 RV then it will be upgraded to one. If C<classname> is non-null then the new
9811 SV will be blessed in the specified package. The new SV is returned and its
9812 reference count is 1. The reference count 1 is owned by C<rv>.
9818 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
9822 PERL_ARGS_ASSERT_NEWSVRV;
9826 SV_CHECK_THINKFIRST_COW_DROP(rv);
9828 if (SvTYPE(rv) >= SVt_PVMG) {
9829 const U32 refcnt = SvREFCNT(rv);
9833 SvREFCNT(rv) = refcnt;
9835 sv_upgrade(rv, SVt_IV);
9836 } else if (SvROK(rv)) {
9837 SvREFCNT_dec(SvRV(rv));
9839 prepare_SV_for_RV(rv);
9847 HV* const stash = gv_stashpv(classname, GV_ADD);
9848 (void)sv_bless(rv, stash);
9854 Perl_newSVavdefelem(pTHX_ AV *av, SSize_t ix, bool extendible)
9856 SV * const lv = newSV_type(SVt_PVLV);
9857 PERL_ARGS_ASSERT_NEWSVAVDEFELEM;
9859 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
9860 LvTARG(lv) = SvREFCNT_inc_simple_NN(av);
9861 LvSTARGOFF(lv) = ix;
9862 LvTARGLEN(lv) = extendible ? 1 : (STRLEN)UV_MAX;
9867 =for apidoc sv_setref_pv
9869 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
9870 argument will be upgraded to an RV. That RV will be modified to point to
9871 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
9872 into the SV. The C<classname> argument indicates the package for the
9873 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9874 will have a reference count of 1, and the RV will be returned.
9876 Do not use with other Perl types such as HV, AV, SV, CV, because those
9877 objects will become corrupted by the pointer copy process.
9879 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
9885 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
9887 PERL_ARGS_ASSERT_SV_SETREF_PV;
9890 sv_setsv(rv, &PL_sv_undef);
9894 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
9899 =for apidoc sv_setref_iv
9901 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
9902 argument will be upgraded to an RV. That RV will be modified to point to
9903 the new SV. The C<classname> argument indicates the package for the
9904 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9905 will have a reference count of 1, and the RV will be returned.
9911 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
9913 PERL_ARGS_ASSERT_SV_SETREF_IV;
9915 sv_setiv(newSVrv(rv,classname), iv);
9920 =for apidoc sv_setref_uv
9922 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
9923 argument will be upgraded to an RV. That RV will be modified to point to
9924 the new SV. The C<classname> argument indicates the package for the
9925 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9926 will have a reference count of 1, and the RV will be returned.
9932 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
9934 PERL_ARGS_ASSERT_SV_SETREF_UV;
9936 sv_setuv(newSVrv(rv,classname), uv);
9941 =for apidoc sv_setref_nv
9943 Copies a double into a new SV, optionally blessing the SV. The C<rv>
9944 argument will be upgraded to an RV. That RV will be modified to point to
9945 the new SV. The C<classname> argument indicates the package for the
9946 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9947 will have a reference count of 1, and the RV will be returned.
9953 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
9955 PERL_ARGS_ASSERT_SV_SETREF_NV;
9957 sv_setnv(newSVrv(rv,classname), nv);
9962 =for apidoc sv_setref_pvn
9964 Copies a string into a new SV, optionally blessing the SV. The length of the
9965 string must be specified with C<n>. The C<rv> argument will be upgraded to
9966 an RV. That RV will be modified to point to the new SV. The C<classname>
9967 argument indicates the package for the blessing. Set C<classname> to
9968 C<NULL> to avoid the blessing. The new SV will have a reference count
9969 of 1, and the RV will be returned.
9971 Note that C<sv_setref_pv> copies the pointer while this copies the string.
9977 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
9978 const char *const pv, const STRLEN n)
9980 PERL_ARGS_ASSERT_SV_SETREF_PVN;
9982 sv_setpvn(newSVrv(rv,classname), pv, n);
9987 =for apidoc sv_bless
9989 Blesses an SV into a specified package. The SV must be an RV. The package
9990 must be designated by its stash (see C<gv_stashpv()>). The reference count
9991 of the SV is unaffected.
9997 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
10000 HV *oldstash = NULL;
10002 PERL_ARGS_ASSERT_SV_BLESS;
10006 Perl_croak(aTHX_ "Can't bless non-reference value");
10008 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
10009 if (SvREADONLY(tmpRef))
10010 Perl_croak_no_modify();
10011 if (SvOBJECT(tmpRef)) {
10012 oldstash = SvSTASH(tmpRef);
10015 SvOBJECT_on(tmpRef);
10016 SvUPGRADE(tmpRef, SVt_PVMG);
10017 SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
10018 SvREFCNT_dec(oldstash);
10020 if(SvSMAGICAL(tmpRef))
10021 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
10029 /* Downgrades a PVGV to a PVMG. If it's actually a PVLV, we leave the type
10030 * as it is after unglobbing it.
10033 PERL_STATIC_INLINE void
10034 S_sv_unglob(pTHX_ SV *const sv, U32 flags)
10038 SV * const temp = flags & SV_COW_DROP_PV ? NULL : sv_newmortal();
10040 PERL_ARGS_ASSERT_SV_UNGLOB;
10042 assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
10044 if (!(flags & SV_COW_DROP_PV))
10045 gv_efullname3(temp, MUTABLE_GV(sv), "*");
10047 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
10049 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
10050 && HvNAME_get(stash))
10051 mro_method_changed_in(stash);
10052 gp_free(MUTABLE_GV(sv));
10055 sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
10056 GvSTASH(sv) = NULL;
10059 if (GvNAME_HEK(sv)) {
10060 unshare_hek(GvNAME_HEK(sv));
10062 isGV_with_GP_off(sv);
10064 if(SvTYPE(sv) == SVt_PVGV) {
10065 /* need to keep SvANY(sv) in the right arena */
10066 xpvmg = new_XPVMG();
10067 StructCopy(SvANY(sv), xpvmg, XPVMG);
10068 del_XPVGV(SvANY(sv));
10071 SvFLAGS(sv) &= ~SVTYPEMASK;
10072 SvFLAGS(sv) |= SVt_PVMG;
10075 /* Intentionally not calling any local SET magic, as this isn't so much a
10076 set operation as merely an internal storage change. */
10077 if (flags & SV_COW_DROP_PV) SvOK_off(sv);
10078 else sv_setsv_flags(sv, temp, 0);
10080 if ((const GV *)sv == PL_last_in_gv)
10081 PL_last_in_gv = NULL;
10082 else if ((const GV *)sv == PL_statgv)
10087 =for apidoc sv_unref_flags
10089 Unsets the RV status of the SV, and decrements the reference count of
10090 whatever was being referenced by the RV. This can almost be thought of
10091 as a reversal of C<newSVrv>. The C<cflags> argument can contain
10092 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
10093 (otherwise the decrementing is conditional on the reference count being
10094 different from one or the reference being a readonly SV).
10101 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
10103 SV* const target = SvRV(ref);
10105 PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
10107 if (SvWEAKREF(ref)) {
10108 sv_del_backref(target, ref);
10109 SvWEAKREF_off(ref);
10110 SvRV_set(ref, NULL);
10113 SvRV_set(ref, NULL);
10115 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
10116 assigned to as BEGIN {$a = \"Foo"} will fail. */
10117 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
10118 SvREFCNT_dec_NN(target);
10119 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
10120 sv_2mortal(target); /* Schedule for freeing later */
10124 =for apidoc sv_untaint
10126 Untaint an SV. Use C<SvTAINTED_off> instead.
10132 Perl_sv_untaint(pTHX_ SV *const sv)
10134 PERL_ARGS_ASSERT_SV_UNTAINT;
10135 PERL_UNUSED_CONTEXT;
10137 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
10138 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
10145 =for apidoc sv_tainted
10147 Test an SV for taintedness. Use C<SvTAINTED> instead.
10153 Perl_sv_tainted(pTHX_ SV *const sv)
10155 PERL_ARGS_ASSERT_SV_TAINTED;
10156 PERL_UNUSED_CONTEXT;
10158 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
10159 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
10160 if (mg && (mg->mg_len & 1) )
10167 =for apidoc sv_setpviv
10169 Copies an integer into the given SV, also updating its string value.
10170 Does not handle 'set' magic. See C<sv_setpviv_mg>.
10176 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
10178 char buf[TYPE_CHARS(UV)];
10180 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
10182 PERL_ARGS_ASSERT_SV_SETPVIV;
10184 sv_setpvn(sv, ptr, ebuf - ptr);
10188 =for apidoc sv_setpviv_mg
10190 Like C<sv_setpviv>, but also handles 'set' magic.
10196 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
10198 PERL_ARGS_ASSERT_SV_SETPVIV_MG;
10200 sv_setpviv(sv, iv);
10204 #if defined(PERL_IMPLICIT_CONTEXT)
10206 /* pTHX_ magic can't cope with varargs, so this is a no-context
10207 * version of the main function, (which may itself be aliased to us).
10208 * Don't access this version directly.
10212 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
10217 PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
10219 va_start(args, pat);
10220 sv_vsetpvf(sv, pat, &args);
10224 /* pTHX_ magic can't cope with varargs, so this is a no-context
10225 * version of the main function, (which may itself be aliased to us).
10226 * Don't access this version directly.
10230 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
10235 PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
10237 va_start(args, pat);
10238 sv_vsetpvf_mg(sv, pat, &args);
10244 =for apidoc sv_setpvf
10246 Works like C<sv_catpvf> but copies the text into the SV instead of
10247 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
10253 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
10257 PERL_ARGS_ASSERT_SV_SETPVF;
10259 va_start(args, pat);
10260 sv_vsetpvf(sv, pat, &args);
10265 =for apidoc sv_vsetpvf
10267 Works like C<sv_vcatpvf> but copies the text into the SV instead of
10268 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
10270 Usually used via its frontend C<sv_setpvf>.
10276 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
10278 PERL_ARGS_ASSERT_SV_VSETPVF;
10280 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
10284 =for apidoc sv_setpvf_mg
10286 Like C<sv_setpvf>, but also handles 'set' magic.
10292 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
10296 PERL_ARGS_ASSERT_SV_SETPVF_MG;
10298 va_start(args, pat);
10299 sv_vsetpvf_mg(sv, pat, &args);
10304 =for apidoc sv_vsetpvf_mg
10306 Like C<sv_vsetpvf>, but also handles 'set' magic.
10308 Usually used via its frontend C<sv_setpvf_mg>.
10314 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
10316 PERL_ARGS_ASSERT_SV_VSETPVF_MG;
10318 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
10322 #if defined(PERL_IMPLICIT_CONTEXT)
10324 /* pTHX_ magic can't cope with varargs, so this is a no-context
10325 * version of the main function, (which may itself be aliased to us).
10326 * Don't access this version directly.
10330 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
10335 PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
10337 va_start(args, pat);
10338 sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
10342 /* pTHX_ magic can't cope with varargs, so this is a no-context
10343 * version of the main function, (which may itself be aliased to us).
10344 * Don't access this version directly.
10348 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
10353 PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
10355 va_start(args, pat);
10356 sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
10363 =for apidoc sv_catpvf
10365 Processes its arguments like C<sprintf> and appends the formatted
10366 output to an SV. If the appended data contains "wide" characters
10367 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
10368 and characters >255 formatted with %c), the original SV might get
10369 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
10370 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
10371 valid UTF-8; if the original SV was bytes, the pattern should be too.
10376 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
10380 PERL_ARGS_ASSERT_SV_CATPVF;
10382 va_start(args, pat);
10383 sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
10388 =for apidoc sv_vcatpvf
10390 Processes its arguments like C<vsprintf> and appends the formatted output
10391 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
10393 Usually used via its frontend C<sv_catpvf>.
10399 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
10401 PERL_ARGS_ASSERT_SV_VCATPVF;
10403 sv_vcatpvfn_flags(sv, pat, strlen(pat), args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
10407 =for apidoc sv_catpvf_mg
10409 Like C<sv_catpvf>, but also handles 'set' magic.
10415 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
10419 PERL_ARGS_ASSERT_SV_CATPVF_MG;
10421 va_start(args, pat);
10422 sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
10428 =for apidoc sv_vcatpvf_mg
10430 Like C<sv_vcatpvf>, but also handles 'set' magic.
10432 Usually used via its frontend C<sv_catpvf_mg>.
10438 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
10440 PERL_ARGS_ASSERT_SV_VCATPVF_MG;
10442 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
10447 =for apidoc sv_vsetpvfn
10449 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
10452 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
10458 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
10459 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
10461 PERL_ARGS_ASSERT_SV_VSETPVFN;
10464 sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, 0);
10469 * Warn of missing argument to sprintf, and then return a defined value
10470 * to avoid inappropriate "use of uninit" warnings [perl #71000].
10473 S_vcatpvfn_missing_argument(pTHX) {
10474 if (ckWARN(WARN_MISSING)) {
10475 Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
10476 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
10483 S_expect_number(pTHX_ char **const pattern)
10487 PERL_ARGS_ASSERT_EXPECT_NUMBER;
10489 switch (**pattern) {
10490 case '1': case '2': case '3':
10491 case '4': case '5': case '6':
10492 case '7': case '8': case '9':
10493 var = *(*pattern)++ - '0';
10494 while (isDIGIT(**pattern)) {
10495 const I32 tmp = var * 10 + (*(*pattern)++ - '0');
10497 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
10505 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
10507 const int neg = nv < 0;
10510 PERL_ARGS_ASSERT_F0CONVERT;
10518 if (uv & 1 && uv == nv)
10519 uv--; /* Round to even */
10521 const unsigned dig = uv % 10;
10523 } while (uv /= 10);
10534 =for apidoc sv_vcatpvfn
10536 =for apidoc sv_vcatpvfn_flags
10538 Processes its arguments like C<vsprintf> and appends the formatted output
10539 to an SV. Uses an array of SVs if the C style variable argument list is
10540 missing (NULL). When running with taint checks enabled, indicates via
10541 C<maybe_tainted> if results are untrustworthy (often due to the use of
10544 If called as C<sv_vcatpvfn> or flags include C<SV_GMAGIC>, calls get magic.
10546 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
10551 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
10552 vecstr = (U8*)SvPV_const(vecsv,veclen);\
10553 vec_utf8 = DO_UTF8(vecsv);
10555 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
10558 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
10559 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
10561 PERL_ARGS_ASSERT_SV_VCATPVFN;
10563 sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC);
10567 Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
10568 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted,
10573 const char *patend;
10576 static const char nullstr[] = "(null)";
10578 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
10579 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
10581 /* Times 4: a decimal digit takes more than 3 binary digits.
10582 * NV_DIG: mantissa takes than many decimal digits.
10583 * Plus 32: Playing safe. */
10584 char ebuf[IV_DIG * 4 + NV_DIG + 32];
10585 /* large enough for "%#.#f" --chip */
10586 /* what about long double NVs? --jhi */
10587 bool no_redundant_warning = FALSE; /* did we use any explicit format parameter index? */
10589 DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED;
10591 PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
10592 PERL_UNUSED_ARG(maybe_tainted);
10594 if (flags & SV_GMAGIC)
10597 /* no matter what, this is a string now */
10598 (void)SvPV_force_nomg(sv, origlen);
10600 /* special-case "", "%s", and "%-p" (SVf - see below) */
10602 if (svmax && ckWARN(WARN_REDUNDANT))
10603 Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
10604 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
10607 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
10608 if (svmax > 1 && ckWARN(WARN_REDUNDANT))
10609 Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
10610 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
10613 const char * const s = va_arg(*args, char*);
10614 sv_catpv_nomg(sv, s ? s : nullstr);
10616 else if (svix < svmax) {
10617 /* we want get magic on the source but not the target. sv_catsv can't do that, though */
10618 SvGETMAGIC(*svargs);
10619 sv_catsv_nomg(sv, *svargs);
10622 S_vcatpvfn_missing_argument(aTHX);
10625 if (args && patlen == 3 && pat[0] == '%' &&
10626 pat[1] == '-' && pat[2] == 'p') {
10627 if (svmax > 1 && ckWARN(WARN_REDUNDANT))
10628 Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
10629 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
10630 argsv = MUTABLE_SV(va_arg(*args, void*));
10631 sv_catsv_nomg(sv, argsv);
10635 #ifndef USE_LONG_DOUBLE
10636 /* special-case "%.<number>[gf]" */
10637 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
10638 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
10639 unsigned digits = 0;
10643 while (*pp >= '0' && *pp <= '9')
10644 digits = 10 * digits + (*pp++ - '0');
10646 /* XXX: Why do this `svix < svmax` test? Couldn't we just
10647 format the first argument and WARN_REDUNDANT if svmax > 1?
10648 Munged by Nicholas Clark in v5.13.0-209-g95ea86d */
10649 if (pp - pat == (int)patlen - 1 && svix < svmax) {
10650 const NV nv = SvNV(*svargs);
10652 /* Add check for digits != 0 because it seems that some
10653 gconverts are buggy in this case, and we don't yet have
10654 a Configure test for this. */
10655 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
10656 /* 0, point, slack */
10657 STORE_LC_NUMERIC_SET_TO_NEEDED();
10658 PERL_UNUSED_RESULT(Gconvert(nv, (int)digits, 0, ebuf));
10659 sv_catpv_nomg(sv, ebuf);
10660 if (*ebuf) /* May return an empty string for digits==0 */
10663 } else if (!digits) {
10666 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
10667 sv_catpvn_nomg(sv, p, l);
10673 #endif /* !USE_LONG_DOUBLE */
10675 if (!args && svix < svmax && DO_UTF8(*svargs))
10678 patend = (char*)pat + patlen;
10679 for (p = (char*)pat; p < patend; p = q) {
10682 bool vectorize = FALSE;
10683 bool vectorarg = FALSE;
10684 bool vec_utf8 = FALSE;
10690 bool has_precis = FALSE;
10692 const I32 osvix = svix;
10693 bool is_utf8 = FALSE; /* is this item utf8? */
10694 #ifdef HAS_LDBL_SPRINTF_BUG
10695 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10696 with sfio - Allen <allens@cpan.org> */
10697 bool fix_ldbl_sprintf_bug = FALSE;
10701 U8 utf8buf[UTF8_MAXBYTES+1];
10702 STRLEN esignlen = 0;
10704 const char *eptr = NULL;
10705 const char *fmtstart;
10708 const U8 *vecstr = NULL;
10715 /* we need a long double target in case HAS_LONG_DOUBLE but
10716 not USE_LONG_DOUBLE
10718 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
10726 const char *dotstr = ".";
10727 STRLEN dotstrlen = 1;
10728 I32 efix = 0; /* explicit format parameter index */
10729 I32 ewix = 0; /* explicit width index */
10730 I32 epix = 0; /* explicit precision index */
10731 I32 evix = 0; /* explicit vector index */
10732 bool asterisk = FALSE;
10734 /* echo everything up to the next format specification */
10735 for (q = p; q < patend && *q != '%'; ++q) ;
10737 if (has_utf8 && !pat_utf8)
10738 sv_catpvn_nomg_utf8_upgrade(sv, p, q - p, nsv);
10740 sv_catpvn_nomg(sv, p, q - p);
10749 We allow format specification elements in this order:
10750 \d+\$ explicit format parameter index
10752 v|\*(\d+\$)?v vector with optional (optionally specified) arg
10753 0 flag (as above): repeated to allow "v02"
10754 \d+|\*(\d+\$)? width using optional (optionally specified) arg
10755 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
10757 [%bcdefginopsuxDFOUX] format (mandatory)
10762 As of perl5.9.3, printf format checking is on by default.
10763 Internally, perl uses %p formats to provide an escape to
10764 some extended formatting. This block deals with those
10765 extensions: if it does not match, (char*)q is reset and
10766 the normal format processing code is used.
10768 Currently defined extensions are:
10769 %p include pointer address (standard)
10770 %-p (SVf) include an SV (previously %_)
10771 %-<num>p include an SV with precision <num>
10773 %3p include a HEK with precision of 256
10774 %4p char* preceded by utf8 flag and length
10775 %<num>p (where num is 1 or > 4) reserved for future
10778 Robin Barker 2005-07-14 (but modified since)
10780 %1p (VDf) removed. RMB 2007-10-19
10787 else if (strnEQ(q, UTF8f, sizeof(UTF8f)-1)) { /* UTF8f */
10788 /* The argument has already gone through cBOOL, so the cast
10790 is_utf8 = (bool)va_arg(*args, int);
10791 elen = va_arg(*args, UV);
10792 eptr = va_arg(*args, char *);
10793 q += sizeof(UTF8f)-1;
10796 n = expect_number(&q);
10798 if (sv) { /* SVf */
10803 argsv = MUTABLE_SV(va_arg(*args, void*));
10804 eptr = SvPV_const(argsv, elen);
10805 if (DO_UTF8(argsv))
10809 else if (n==2 || n==3) { /* HEKf */
10810 HEK * const hek = va_arg(*args, HEK *);
10811 eptr = HEK_KEY(hek);
10812 elen = HEK_LEN(hek);
10813 if (HEK_UTF8(hek)) is_utf8 = TRUE;
10814 if (n==3) precis = 256, has_precis = TRUE;
10818 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
10819 "internal %%<num>p might conflict with future printf extensions");
10825 if ( (width = expect_number(&q)) ) {
10829 if (!no_redundant_warning)
10830 /* I've forgotten if it's a better
10831 micro-optimization to always set this or to
10832 only set it if it's unset */
10833 no_redundant_warning = TRUE;
10845 if (plus == '+' && *q == ' ') /* '+' over ' ' */
10874 if ( (ewix = expect_number(&q)) )
10883 if ((vectorarg = asterisk)) {
10896 width = expect_number(&q);
10899 if (vectorize && vectorarg) {
10900 /* vectorizing, but not with the default "." */
10902 vecsv = va_arg(*args, SV*);
10904 vecsv = (evix > 0 && evix <= svmax)
10905 ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
10907 vecsv = svix < svmax
10908 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10910 dotstr = SvPV_const(vecsv, dotstrlen);
10911 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
10912 bad with tied or overloaded values that return UTF8. */
10913 if (DO_UTF8(vecsv))
10915 else if (has_utf8) {
10916 vecsv = sv_mortalcopy(vecsv);
10917 sv_utf8_upgrade(vecsv);
10918 dotstr = SvPV_const(vecsv, dotstrlen);
10925 i = va_arg(*args, int);
10927 i = (ewix ? ewix <= svmax : svix < svmax) ?
10928 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10930 width = (i < 0) ? -i : i;
10940 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
10942 /* XXX: todo, support specified precision parameter */
10946 i = va_arg(*args, int);
10948 i = (ewix ? ewix <= svmax : svix < svmax)
10949 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10951 has_precis = !(i < 0);
10955 while (isDIGIT(*q))
10956 precis = precis * 10 + (*q++ - '0');
10965 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
10966 vecsv = svargs[efix ? efix-1 : svix++];
10967 vecstr = (U8*)SvPV_const(vecsv,veclen);
10968 vec_utf8 = DO_UTF8(vecsv);
10970 /* if this is a version object, we need to convert
10971 * back into v-string notation and then let the
10972 * vectorize happen normally
10974 if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) {
10975 if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
10976 Perl_ck_warner_d(aTHX_ packWARN(WARN_PRINTF),
10977 "vector argument not supported with alpha versions");
10980 vecsv = sv_newmortal();
10981 scan_vstring((char *)vecstr, (char *)vecstr + veclen,
10983 vecstr = (U8*)SvPV_const(vecsv, veclen);
10984 vec_utf8 = DO_UTF8(vecsv);
10998 case 'I': /* Ix, I32x, and I64x */
10999 # ifdef USE_64_BIT_INT
11000 if (q[1] == '6' && q[2] == '4') {
11006 if (q[1] == '3' && q[2] == '2') {
11010 # ifdef USE_64_BIT_INT
11016 #if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)
11028 #if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)
11029 if (*q == 'l') { /* lld, llf */
11038 if (*++q == 'h') { /* hhd, hhu */
11067 if (!vectorize && !args) {
11069 const I32 i = efix-1;
11070 argsv = (i >= 0 && i < svmax)
11071 ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
11073 argsv = (svix >= 0 && svix < svmax)
11074 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
11078 switch (c = *q++) {
11085 uv = (args) ? va_arg(*args, int) : SvIV(argsv);
11087 (!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv)))
11089 eptr = (char*)utf8buf;
11090 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
11104 eptr = va_arg(*args, char*);
11106 elen = strlen(eptr);
11108 eptr = (char *)nullstr;
11109 elen = sizeof nullstr - 1;
11113 eptr = SvPV_const(argsv, elen);
11114 if (DO_UTF8(argsv)) {
11115 STRLEN old_precis = precis;
11116 if (has_precis && precis < elen) {
11117 STRLEN ulen = sv_or_pv_len_utf8(argsv, eptr, elen);
11118 STRLEN p = precis > ulen ? ulen : precis;
11119 precis = sv_or_pv_pos_u2b(argsv, eptr, p, 0);
11120 /* sticks at end */
11122 if (width) { /* fudge width (can't fudge elen) */
11123 if (has_precis && precis < elen)
11124 width += precis - old_precis;
11127 elen - sv_or_pv_len_utf8(argsv,eptr,elen);
11134 if (has_precis && precis < elen)
11141 if (alt || vectorize)
11143 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
11161 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
11170 esignbuf[esignlen++] = plus;
11174 case 'c': iv = (char)va_arg(*args, int); break;
11175 case 'h': iv = (short)va_arg(*args, int); break;
11176 case 'l': iv = va_arg(*args, long); break;
11177 case 'V': iv = va_arg(*args, IV); break;
11178 case 'z': iv = va_arg(*args, SSize_t); break;
11179 #ifdef HAS_PTRDIFF_T
11180 case 't': iv = va_arg(*args, ptrdiff_t); break;
11182 default: iv = va_arg(*args, int); break;
11184 case 'j': iv = va_arg(*args, intmax_t); break;
11188 iv = va_arg(*args, Quad_t); break;
11195 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
11197 case 'c': iv = (char)tiv; break;
11198 case 'h': iv = (short)tiv; break;
11199 case 'l': iv = (long)tiv; break;
11201 default: iv = tiv; break;
11204 iv = (Quad_t)tiv; break;
11210 if ( !vectorize ) /* we already set uv above */
11215 esignbuf[esignlen++] = plus;
11219 esignbuf[esignlen++] = '-';
11263 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
11274 case 'c': uv = (unsigned char)va_arg(*args, unsigned); break;
11275 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
11276 case 'l': uv = va_arg(*args, unsigned long); break;
11277 case 'V': uv = va_arg(*args, UV); break;
11278 case 'z': uv = va_arg(*args, Size_t); break;
11279 #ifdef HAS_PTRDIFF_T
11280 case 't': uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */
11283 case 'j': uv = va_arg(*args, uintmax_t); break;
11285 default: uv = va_arg(*args, unsigned); break;
11288 uv = va_arg(*args, Uquad_t); break;
11295 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
11297 case 'c': uv = (unsigned char)tuv; break;
11298 case 'h': uv = (unsigned short)tuv; break;
11299 case 'l': uv = (unsigned long)tuv; break;
11301 default: uv = tuv; break;
11304 uv = (Uquad_t)tuv; break;
11313 char *ptr = ebuf + sizeof ebuf;
11314 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
11320 p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
11324 } while (uv >>= 4);
11326 esignbuf[esignlen++] = '0';
11327 esignbuf[esignlen++] = c; /* 'x' or 'X' */
11333 *--ptr = '0' + dig;
11334 } while (uv >>= 3);
11335 if (alt && *ptr != '0')
11341 *--ptr = '0' + dig;
11342 } while (uv >>= 1);
11344 esignbuf[esignlen++] = '0';
11345 esignbuf[esignlen++] = c;
11348 default: /* it had better be ten or less */
11351 *--ptr = '0' + dig;
11352 } while (uv /= base);
11355 elen = (ebuf + sizeof ebuf) - ptr;
11359 zeros = precis - elen;
11360 else if (precis == 0 && elen == 1 && *eptr == '0'
11361 && !(base == 8 && alt)) /* "%#.0o" prints "0" */
11364 /* a precision nullifies the 0 flag. */
11371 /* FLOATING POINT */
11374 c = 'f'; /* maybe %F isn't supported here */
11376 case 'e': case 'E':
11378 case 'g': case 'G':
11382 /* This is evil, but floating point is even more evil */
11384 /* for SV-style calling, we can only get NV
11385 for C-style calling, we assume %f is double;
11386 for simplicity we allow any of %Lf, %llf, %qf for long double
11390 #if defined(USE_LONG_DOUBLE)
11394 /* [perl #20339] - we should accept and ignore %lf rather than die */
11398 #if defined(USE_LONG_DOUBLE)
11399 intsize = args ? 0 : 'q';
11403 #if defined(HAS_LONG_DOUBLE)
11416 /* now we need (long double) if intsize == 'q', else (double) */
11418 #if LONG_DOUBLESIZE > DOUBLESIZE
11420 va_arg(*args, long double) :
11421 va_arg(*args, double)
11423 va_arg(*args, double)
11428 /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
11429 else. frexp() has some unspecified behaviour for those three */
11430 if (c != 'e' && c != 'E' && (nv * 0) == 0) {
11432 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
11433 will cast our (long double) to (double) */
11434 (void)Perl_frexp(nv, &i);
11435 if (i == PERL_INT_MIN)
11436 Perl_die(aTHX_ "panic: frexp");
11438 need = BIT_DIGITS(i);
11440 need += has_precis ? precis : 6; /* known default */
11445 #ifdef HAS_LDBL_SPRINTF_BUG
11446 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
11447 with sfio - Allen <allens@cpan.org> */
11450 # define MY_DBL_MAX DBL_MAX
11451 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
11452 # if DOUBLESIZE >= 8
11453 # define MY_DBL_MAX 1.7976931348623157E+308L
11455 # define MY_DBL_MAX 3.40282347E+38L
11459 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
11460 # define MY_DBL_MAX_BUG 1L
11462 # define MY_DBL_MAX_BUG MY_DBL_MAX
11466 # define MY_DBL_MIN DBL_MIN
11467 # else /* XXX guessing! -Allen */
11468 # if DOUBLESIZE >= 8
11469 # define MY_DBL_MIN 2.2250738585072014E-308L
11471 # define MY_DBL_MIN 1.17549435E-38L
11475 if ((intsize == 'q') && (c == 'f') &&
11476 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
11477 (need < DBL_DIG)) {
11478 /* it's going to be short enough that
11479 * long double precision is not needed */
11481 if ((nv <= 0L) && (nv >= -0L))
11482 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
11484 /* would use Perl_fp_class as a double-check but not
11485 * functional on IRIX - see perl.h comments */
11487 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
11488 /* It's within the range that a double can represent */
11489 #if defined(DBL_MAX) && !defined(DBL_MIN)
11490 if ((nv >= ((long double)1/DBL_MAX)) ||
11491 (nv <= (-(long double)1/DBL_MAX)))
11493 fix_ldbl_sprintf_bug = TRUE;
11496 if (fix_ldbl_sprintf_bug == TRUE) {
11506 # undef MY_DBL_MAX_BUG
11509 #endif /* HAS_LDBL_SPRINTF_BUG */
11511 need += 20; /* fudge factor */
11512 if (PL_efloatsize < need) {
11513 Safefree(PL_efloatbuf);
11514 PL_efloatsize = need + 20; /* more fudge */
11515 Newx(PL_efloatbuf, PL_efloatsize, char);
11516 PL_efloatbuf[0] = '\0';
11519 if ( !(width || left || plus || alt) && fill != '0'
11520 && has_precis && intsize != 'q' ) { /* Shortcuts */
11521 /* See earlier comment about buggy Gconvert when digits,
11523 if ( c == 'g' && precis) {
11524 STORE_LC_NUMERIC_SET_TO_NEEDED();
11525 PERL_UNUSED_RESULT(Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf));
11526 /* May return an empty string for digits==0 */
11527 if (*PL_efloatbuf) {
11528 elen = strlen(PL_efloatbuf);
11529 goto float_converted;
11531 } else if ( c == 'f' && !precis) {
11532 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
11537 char *ptr = ebuf + sizeof ebuf;
11540 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
11541 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
11542 if (intsize == 'q') {
11543 /* Copy the one or more characters in a long double
11544 * format before the 'base' ([efgEFG]) character to
11545 * the format string. */
11546 static char const prifldbl[] = PERL_PRIfldbl;
11547 char const *p = prifldbl + sizeof(prifldbl) - 3;
11548 while (p >= prifldbl) { *--ptr = *p--; }
11553 do { *--ptr = '0' + (base % 10); } while (base /= 10);
11558 do { *--ptr = '0' + (base % 10); } while (base /= 10);
11570 /* No taint. Otherwise we are in the strange situation
11571 * where printf() taints but print($float) doesn't.
11574 STORE_LC_NUMERIC_SET_TO_NEEDED();
11576 /* hopefully the above makes ptr a very constrained format
11577 * that is safe to use, even though it's not literal */
11578 GCC_DIAG_IGNORE(-Wformat-nonliteral);
11579 #if defined(HAS_LONG_DOUBLE)
11580 elen = ((intsize == 'q')
11581 ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
11582 : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
11584 elen = my_sprintf(PL_efloatbuf, ptr, nv);
11589 eptr = PL_efloatbuf;
11591 #ifdef USE_LOCALE_NUMERIC
11592 /* If the decimal point character in the string is UTF-8, make the
11594 if (PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
11595 && instr(eptr, SvPVX_const(PL_numeric_radix_sv)))
11608 i = SvCUR(sv) - origlen;
11611 case 'c': *(va_arg(*args, char*)) = i; break;
11612 case 'h': *(va_arg(*args, short*)) = i; break;
11613 default: *(va_arg(*args, int*)) = i; break;
11614 case 'l': *(va_arg(*args, long*)) = i; break;
11615 case 'V': *(va_arg(*args, IV*)) = i; break;
11616 case 'z': *(va_arg(*args, SSize_t*)) = i; break;
11617 #ifdef HAS_PTRDIFF_T
11618 case 't': *(va_arg(*args, ptrdiff_t*)) = i; break;
11621 case 'j': *(va_arg(*args, intmax_t*)) = i; break;
11625 *(va_arg(*args, Quad_t*)) = i; break;
11632 sv_setuv_mg(argsv, has_utf8 ? (UV)sv_len_utf8(sv) : (UV)i);
11633 continue; /* not "break" */
11640 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
11641 && ckWARN(WARN_PRINTF))
11643 SV * const msg = sv_newmortal();
11644 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
11645 (PL_op->op_type == OP_PRTF) ? "" : "s");
11646 if (fmtstart < patend) {
11647 const char * const fmtend = q < patend ? q : patend;
11649 sv_catpvs(msg, "\"%");
11650 for (f = fmtstart; f < fmtend; f++) {
11652 sv_catpvn_nomg(msg, f, 1);
11654 Perl_sv_catpvf(aTHX_ msg,
11655 "\\%03"UVof, (UV)*f & 0xFF);
11658 sv_catpvs(msg, "\"");
11660 sv_catpvs(msg, "end of string");
11662 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
11665 /* output mangled stuff ... */
11671 /* ... right here, because formatting flags should not apply */
11672 SvGROW(sv, SvCUR(sv) + elen + 1);
11674 Copy(eptr, p, elen, char);
11677 SvCUR_set(sv, p - SvPVX_const(sv));
11679 continue; /* not "break" */
11682 if (is_utf8 != has_utf8) {
11685 sv_utf8_upgrade(sv);
11688 const STRLEN old_elen = elen;
11689 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
11690 sv_utf8_upgrade(nsv);
11691 eptr = SvPVX_const(nsv);
11694 if (width) { /* fudge width (can't fudge elen) */
11695 width += elen - old_elen;
11701 have = esignlen + zeros + elen;
11703 croak_memory_wrap();
11705 need = (have > width ? have : width);
11708 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
11709 croak_memory_wrap();
11710 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
11712 if (esignlen && fill == '0') {
11714 for (i = 0; i < (int)esignlen; i++)
11715 *p++ = esignbuf[i];
11717 if (gap && !left) {
11718 memset(p, fill, gap);
11721 if (esignlen && fill != '0') {
11723 for (i = 0; i < (int)esignlen; i++)
11724 *p++ = esignbuf[i];
11728 for (i = zeros; i; i--)
11732 Copy(eptr, p, elen, char);
11736 memset(p, ' ', gap);
11741 Copy(dotstr, p, dotstrlen, char);
11745 vectorize = FALSE; /* done iterating over vecstr */
11752 SvCUR_set(sv, p - SvPVX_const(sv));
11759 /* Now that we've consumed all our printf format arguments (svix)
11760 * do we have things left on the stack that we didn't use?
11762 if (!no_redundant_warning && svmax >= svix + 1 && ckWARN(WARN_REDUNDANT)) {
11763 Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
11764 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
11769 RESTORE_LC_NUMERIC(); /* Done outside loop, so don't have to save/restore
11773 /* =========================================================================
11775 =head1 Cloning an interpreter
11779 All the macros and functions in this section are for the private use of
11780 the main function, perl_clone().
11782 The foo_dup() functions make an exact copy of an existing foo thingy.
11783 During the course of a cloning, a hash table is used to map old addresses
11784 to new addresses. The table is created and manipulated with the
11785 ptr_table_* functions.
11787 * =========================================================================*/
11790 #if defined(USE_ITHREADS)
11792 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
11793 #ifndef GpREFCNT_inc
11794 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
11798 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
11799 that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
11800 If this changes, please unmerge ss_dup.
11801 Likewise, sv_dup_inc_multiple() relies on this fact. */
11802 #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup_inc(s,t))
11803 #define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t))
11804 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
11805 #define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t))
11806 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
11807 #define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t))
11808 #define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t))
11809 #define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t))
11810 #define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t))
11811 #define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t))
11812 #define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t))
11813 #define SAVEPV(p) ((p) ? savepv(p) : NULL)
11814 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
11816 /* clone a parser */
11819 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
11823 PERL_ARGS_ASSERT_PARSER_DUP;
11828 /* look for it in the table first */
11829 parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
11833 /* create anew and remember what it is */
11834 Newxz(parser, 1, yy_parser);
11835 ptr_table_store(PL_ptr_table, proto, parser);
11837 /* XXX these not yet duped */
11838 parser->old_parser = NULL;
11839 parser->stack = NULL;
11841 parser->stack_size = 0;
11842 /* XXX parser->stack->state = 0; */
11844 /* XXX eventually, just Copy() most of the parser struct ? */
11846 parser->lex_brackets = proto->lex_brackets;
11847 parser->lex_casemods = proto->lex_casemods;
11848 parser->lex_brackstack = savepvn(proto->lex_brackstack,
11849 (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
11850 parser->lex_casestack = savepvn(proto->lex_casestack,
11851 (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
11852 parser->lex_defer = proto->lex_defer;
11853 parser->lex_dojoin = proto->lex_dojoin;
11854 parser->lex_expect = proto->lex_expect;
11855 parser->lex_formbrack = proto->lex_formbrack;
11856 parser->lex_inpat = proto->lex_inpat;
11857 parser->lex_inwhat = proto->lex_inwhat;
11858 parser->lex_op = proto->lex_op;
11859 parser->lex_repl = sv_dup_inc(proto->lex_repl, param);
11860 parser->lex_starts = proto->lex_starts;
11861 parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param);
11862 parser->multi_close = proto->multi_close;
11863 parser->multi_open = proto->multi_open;
11864 parser->multi_start = proto->multi_start;
11865 parser->multi_end = proto->multi_end;
11866 parser->preambled = proto->preambled;
11867 parser->sublex_info = proto->sublex_info; /* XXX not quite right */
11868 parser->linestr = sv_dup_inc(proto->linestr, param);
11869 parser->expect = proto->expect;
11870 parser->copline = proto->copline;
11871 parser->last_lop_op = proto->last_lop_op;
11872 parser->lex_state = proto->lex_state;
11873 parser->rsfp = fp_dup(proto->rsfp, '<', param);
11874 /* rsfp_filters entries have fake IoDIRP() */
11875 parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
11876 parser->in_my = proto->in_my;
11877 parser->in_my_stash = hv_dup(proto->in_my_stash, param);
11878 parser->error_count = proto->error_count;
11881 parser->linestr = sv_dup_inc(proto->linestr, param);
11884 char * const ols = SvPVX(proto->linestr);
11885 char * const ls = SvPVX(parser->linestr);
11887 parser->bufptr = ls + (proto->bufptr >= ols ?
11888 proto->bufptr - ols : 0);
11889 parser->oldbufptr = ls + (proto->oldbufptr >= ols ?
11890 proto->oldbufptr - ols : 0);
11891 parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
11892 proto->oldoldbufptr - ols : 0);
11893 parser->linestart = ls + (proto->linestart >= ols ?
11894 proto->linestart - ols : 0);
11895 parser->last_uni = ls + (proto->last_uni >= ols ?
11896 proto->last_uni - ols : 0);
11897 parser->last_lop = ls + (proto->last_lop >= ols ?
11898 proto->last_lop - ols : 0);
11900 parser->bufend = ls + SvCUR(parser->linestr);
11903 Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
11906 Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
11907 Copy(proto->nexttype, parser->nexttype, 5, I32);
11908 parser->nexttoke = proto->nexttoke;
11910 /* XXX should clone saved_curcop here, but we aren't passed
11911 * proto_perl; so do it in perl_clone_using instead */
11917 /* duplicate a file handle */
11920 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
11924 PERL_ARGS_ASSERT_FP_DUP;
11925 PERL_UNUSED_ARG(type);
11928 return (PerlIO*)NULL;
11930 /* look for it in the table first */
11931 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
11935 /* create anew and remember what it is */
11936 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
11937 ptr_table_store(PL_ptr_table, fp, ret);
11941 /* duplicate a directory handle */
11944 Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
11948 #if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR)
11950 const Direntry_t *dirent;
11951 char smallbuf[256];
11957 PERL_UNUSED_CONTEXT;
11958 PERL_ARGS_ASSERT_DIRP_DUP;
11963 /* look for it in the table first */
11964 ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
11968 #if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR)
11970 PERL_UNUSED_ARG(param);
11974 /* open the current directory (so we can switch back) */
11975 if (!(pwd = PerlDir_open("."))) return (DIR *)NULL;
11977 /* chdir to our dir handle and open the present working directory */
11978 if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) {
11979 PerlDir_close(pwd);
11980 return (DIR *)NULL;
11982 /* Now we should have two dir handles pointing to the same dir. */
11984 /* Be nice to the calling code and chdir back to where we were. */
11985 /* XXX If this fails, then what? */
11986 PERL_UNUSED_RESULT(fchdir(my_dirfd(pwd)));
11988 /* We have no need of the pwd handle any more. */
11989 PerlDir_close(pwd);
11992 # define d_namlen(d) (d)->d_namlen
11994 # define d_namlen(d) strlen((d)->d_name)
11996 /* Iterate once through dp, to get the file name at the current posi-
11997 tion. Then step back. */
11998 pos = PerlDir_tell(dp);
11999 if ((dirent = PerlDir_read(dp))) {
12000 len = d_namlen(dirent);
12001 if (len <= sizeof smallbuf) name = smallbuf;
12002 else Newx(name, len, char);
12003 Move(dirent->d_name, name, len, char);
12005 PerlDir_seek(dp, pos);
12007 /* Iterate through the new dir handle, till we find a file with the
12009 if (!dirent) /* just before the end */
12011 pos = PerlDir_tell(ret);
12012 if (PerlDir_read(ret)) continue; /* not there yet */
12013 PerlDir_seek(ret, pos); /* step back */
12017 const long pos0 = PerlDir_tell(ret);
12019 pos = PerlDir_tell(ret);
12020 if ((dirent = PerlDir_read(ret))) {
12021 if (len == (STRLEN)d_namlen(dirent)
12022 && memEQ(name, dirent->d_name, len)) {
12024 PerlDir_seek(ret, pos); /* step back */
12027 /* else we are not there yet; keep iterating */
12029 else { /* This is not meant to happen. The best we can do is
12030 reset the iterator to the beginning. */
12031 PerlDir_seek(ret, pos0);
12038 if (name && name != smallbuf)
12043 ret = win32_dirp_dup(dp, param);
12046 /* pop it in the pointer table */
12048 ptr_table_store(PL_ptr_table, dp, ret);
12053 /* duplicate a typeglob */
12056 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
12060 PERL_ARGS_ASSERT_GP_DUP;
12064 /* look for it in the table first */
12065 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
12069 /* create anew and remember what it is */
12071 ptr_table_store(PL_ptr_table, gp, ret);
12074 /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
12075 on Newxz() to do this for us. */
12076 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
12077 ret->gp_io = io_dup_inc(gp->gp_io, param);
12078 ret->gp_form = cv_dup_inc(gp->gp_form, param);
12079 ret->gp_av = av_dup_inc(gp->gp_av, param);
12080 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
12081 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
12082 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
12083 ret->gp_cvgen = gp->gp_cvgen;
12084 ret->gp_line = gp->gp_line;
12085 ret->gp_file_hek = hek_dup(gp->gp_file_hek, param);
12089 /* duplicate a chain of magic */
12092 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
12094 MAGIC *mgret = NULL;
12095 MAGIC **mgprev_p = &mgret;
12097 PERL_ARGS_ASSERT_MG_DUP;
12099 for (; mg; mg = mg->mg_moremagic) {
12102 if ((param->flags & CLONEf_JOIN_IN)
12103 && mg->mg_type == PERL_MAGIC_backref)
12104 /* when joining, we let the individual SVs add themselves to
12105 * backref as needed. */
12108 Newx(nmg, 1, MAGIC);
12110 mgprev_p = &(nmg->mg_moremagic);
12112 /* There was a comment "XXX copy dynamic vtable?" but as we don't have
12113 dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
12114 from the original commit adding Perl_mg_dup() - revision 4538.
12115 Similarly there is the annotation "XXX random ptr?" next to the
12116 assignment to nmg->mg_ptr. */
12119 /* FIXME for plugins
12120 if (nmg->mg_type == PERL_MAGIC_qr) {
12121 nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
12125 nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
12126 ? nmg->mg_type == PERL_MAGIC_backref
12127 /* The backref AV has its reference
12128 * count deliberately bumped by 1 */
12129 ? SvREFCNT_inc(av_dup_inc((const AV *)
12130 nmg->mg_obj, param))
12131 : sv_dup_inc(nmg->mg_obj, param)
12132 : sv_dup(nmg->mg_obj, param);
12134 if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
12135 if (nmg->mg_len > 0) {
12136 nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
12137 if (nmg->mg_type == PERL_MAGIC_overload_table &&
12138 AMT_AMAGIC((AMT*)nmg->mg_ptr))
12140 AMT * const namtp = (AMT*)nmg->mg_ptr;
12141 sv_dup_inc_multiple((SV**)(namtp->table),
12142 (SV**)(namtp->table), NofAMmeth, param);
12145 else if (nmg->mg_len == HEf_SVKEY)
12146 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
12148 if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
12149 nmg->mg_virtual->svt_dup(aTHX_ nmg, param);
12155 #endif /* USE_ITHREADS */
12157 struct ptr_tbl_arena {
12158 struct ptr_tbl_arena *next;
12159 struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers. */
12162 /* create a new pointer-mapping table */
12165 Perl_ptr_table_new(pTHX)
12168 PERL_UNUSED_CONTEXT;
12170 Newx(tbl, 1, PTR_TBL_t);
12171 tbl->tbl_max = 511;
12172 tbl->tbl_items = 0;
12173 tbl->tbl_arena = NULL;
12174 tbl->tbl_arena_next = NULL;
12175 tbl->tbl_arena_end = NULL;
12176 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
12180 #define PTR_TABLE_HASH(ptr) \
12181 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
12183 /* map an existing pointer using a table */
12185 STATIC PTR_TBL_ENT_t *
12186 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
12188 PTR_TBL_ENT_t *tblent;
12189 const UV hash = PTR_TABLE_HASH(sv);
12191 PERL_ARGS_ASSERT_PTR_TABLE_FIND;
12193 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
12194 for (; tblent; tblent = tblent->next) {
12195 if (tblent->oldval == sv)
12202 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
12204 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
12206 PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
12207 PERL_UNUSED_CONTEXT;
12209 return tblent ? tblent->newval : NULL;
12212 /* add a new entry to a pointer-mapping table 'tbl'. In hash terms, 'oldsv' is
12213 * the key; 'newsv' is the value. The names "old" and "new" are specific to
12214 * the core's typical use of ptr_tables in thread cloning. */
12217 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
12219 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
12221 PERL_ARGS_ASSERT_PTR_TABLE_STORE;
12222 PERL_UNUSED_CONTEXT;
12225 tblent->newval = newsv;
12227 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
12229 if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
12230 struct ptr_tbl_arena *new_arena;
12232 Newx(new_arena, 1, struct ptr_tbl_arena);
12233 new_arena->next = tbl->tbl_arena;
12234 tbl->tbl_arena = new_arena;
12235 tbl->tbl_arena_next = new_arena->array;
12236 tbl->tbl_arena_end = C_ARRAY_END(new_arena->array);
12239 tblent = tbl->tbl_arena_next++;
12241 tblent->oldval = oldsv;
12242 tblent->newval = newsv;
12243 tblent->next = tbl->tbl_ary[entry];
12244 tbl->tbl_ary[entry] = tblent;
12246 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
12247 ptr_table_split(tbl);
12251 /* double the hash bucket size of an existing ptr table */
12254 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
12256 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
12257 const UV oldsize = tbl->tbl_max + 1;
12258 UV newsize = oldsize * 2;
12261 PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
12262 PERL_UNUSED_CONTEXT;
12264 Renew(ary, newsize, PTR_TBL_ENT_t*);
12265 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
12266 tbl->tbl_max = --newsize;
12267 tbl->tbl_ary = ary;
12268 for (i=0; i < oldsize; i++, ary++) {
12269 PTR_TBL_ENT_t **entp = ary;
12270 PTR_TBL_ENT_t *ent = *ary;
12271 PTR_TBL_ENT_t **curentp;
12274 curentp = ary + oldsize;
12276 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
12278 ent->next = *curentp;
12288 /* remove all the entries from a ptr table */
12289 /* Deprecated - will be removed post 5.14 */
12292 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
12294 PERL_UNUSED_CONTEXT;
12295 if (tbl && tbl->tbl_items) {
12296 struct ptr_tbl_arena *arena = tbl->tbl_arena;
12298 Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
12301 struct ptr_tbl_arena *next = arena->next;
12307 tbl->tbl_items = 0;
12308 tbl->tbl_arena = NULL;
12309 tbl->tbl_arena_next = NULL;
12310 tbl->tbl_arena_end = NULL;
12314 /* clear and free a ptr table */
12317 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
12319 struct ptr_tbl_arena *arena;
12321 PERL_UNUSED_CONTEXT;
12327 arena = tbl->tbl_arena;
12330 struct ptr_tbl_arena *next = arena->next;
12336 Safefree(tbl->tbl_ary);
12340 #if defined(USE_ITHREADS)
12343 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
12345 PERL_ARGS_ASSERT_RVPV_DUP;
12347 assert(!isREGEXP(sstr));
12349 if (SvWEAKREF(sstr)) {
12350 SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
12351 if (param->flags & CLONEf_JOIN_IN) {
12352 /* if joining, we add any back references individually rather
12353 * than copying the whole backref array */
12354 Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
12358 SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
12360 else if (SvPVX_const(sstr)) {
12361 /* Has something there */
12363 /* Normal PV - clone whole allocated space */
12364 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
12365 /* sstr may not be that normal, but actually copy on write.
12366 But we are a true, independent SV, so: */
12370 /* Special case - not normally malloced for some reason */
12371 if (isGV_with_GP(sstr)) {
12372 /* Don't need to do anything here. */
12374 else if ((SvIsCOW(sstr))) {
12375 /* A "shared" PV - clone it as "shared" PV */
12377 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
12381 /* Some other special case - random pointer */
12382 SvPV_set(dstr, (char *) SvPVX_const(sstr));
12387 /* Copy the NULL */
12388 SvPV_set(dstr, NULL);
12392 /* duplicate a list of SVs. source and dest may point to the same memory. */
12394 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
12395 SSize_t items, CLONE_PARAMS *const param)
12397 PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
12399 while (items-- > 0) {
12400 *dest++ = sv_dup_inc(*source++, param);
12406 /* duplicate an SV of any type (including AV, HV etc) */
12409 S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12414 PERL_ARGS_ASSERT_SV_DUP_COMMON;
12416 if (SvTYPE(sstr) == (svtype)SVTYPEMASK) {
12417 #ifdef DEBUG_LEAKING_SCALARS_ABORT
12422 /* look for it in the table first */
12423 dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
12427 if(param->flags & CLONEf_JOIN_IN) {
12428 /** We are joining here so we don't want do clone
12429 something that is bad **/
12430 if (SvTYPE(sstr) == SVt_PVHV) {
12431 const HEK * const hvname = HvNAME_HEK(sstr);
12433 /** don't clone stashes if they already exist **/
12434 dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
12435 HEK_UTF8(hvname) ? SVf_UTF8 : 0));
12436 ptr_table_store(PL_ptr_table, sstr, dstr);
12440 else if (SvTYPE(sstr) == SVt_PVGV && !SvFAKE(sstr)) {
12441 HV *stash = GvSTASH(sstr);
12442 const HEK * hvname;
12443 if (stash && (hvname = HvNAME_HEK(stash))) {
12444 /** don't clone GVs if they already exist **/
12446 stash = gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
12447 HEK_UTF8(hvname) ? SVf_UTF8 : 0);
12449 stash, GvNAME(sstr),
12455 if (svp && *svp && SvTYPE(*svp) == SVt_PVGV) {
12456 ptr_table_store(PL_ptr_table, sstr, *svp);
12463 /* create anew and remember what it is */
12466 #ifdef DEBUG_LEAKING_SCALARS
12467 dstr->sv_debug_optype = sstr->sv_debug_optype;
12468 dstr->sv_debug_line = sstr->sv_debug_line;
12469 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
12470 dstr->sv_debug_parent = (SV*)sstr;
12471 FREE_SV_DEBUG_FILE(dstr);
12472 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
12475 ptr_table_store(PL_ptr_table, sstr, dstr);
12478 SvFLAGS(dstr) = SvFLAGS(sstr);
12479 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
12480 SvREFCNT(dstr) = 0; /* must be before any other dups! */
12483 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
12484 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
12485 (void*)PL_watch_pvx, SvPVX_const(sstr));
12488 /* don't clone objects whose class has asked us not to */
12489 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
12494 switch (SvTYPE(sstr)) {
12496 SvANY(dstr) = NULL;
12499 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
12501 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
12503 SvIV_set(dstr, SvIVX(sstr));
12507 SvANY(dstr) = new_XNV();
12508 SvNV_set(dstr, SvNVX(sstr));
12512 /* These are all the types that need complex bodies allocating. */
12514 const svtype sv_type = SvTYPE(sstr);
12515 const struct body_details *const sv_type_details
12516 = bodies_by_type + sv_type;
12520 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
12536 assert(sv_type_details->body_size);
12537 if (sv_type_details->arena) {
12538 new_body_inline(new_body, sv_type);
12540 = (void*)((char*)new_body - sv_type_details->offset);
12542 new_body = new_NOARENA(sv_type_details);
12546 SvANY(dstr) = new_body;
12549 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
12550 ((char*)SvANY(dstr)) + sv_type_details->offset,
12551 sv_type_details->copy, char);
12553 Copy(((char*)SvANY(sstr)),
12554 ((char*)SvANY(dstr)),
12555 sv_type_details->body_size + sv_type_details->offset, char);
12558 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
12559 && !isGV_with_GP(dstr)
12561 && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
12562 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
12564 /* The Copy above means that all the source (unduplicated) pointers
12565 are now in the destination. We can check the flags and the
12566 pointers in either, but it's possible that there's less cache
12567 missing by always going for the destination.
12568 FIXME - instrument and check that assumption */
12569 if (sv_type >= SVt_PVMG) {
12570 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
12571 SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
12572 } else if (sv_type == SVt_PVAV && AvPAD_NAMELIST(dstr)) {
12574 } else if (SvMAGIC(dstr))
12575 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
12576 if (SvOBJECT(dstr) && SvSTASH(dstr))
12577 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
12578 else SvSTASH_set(dstr, 0); /* don't copy DESTROY cache */
12581 /* The cast silences a GCC warning about unhandled types. */
12582 switch ((int)sv_type) {
12593 /* FIXME for plugins */
12594 dstr->sv_u.svu_rx = ((REGEXP *)dstr)->sv_any;
12595 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
12598 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
12599 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
12600 LvTARG(dstr) = dstr;
12601 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
12602 LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
12604 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
12605 if (isREGEXP(sstr)) goto duprex;
12607 /* non-GP case already handled above */
12608 if(isGV_with_GP(sstr)) {
12609 GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
12610 /* Don't call sv_add_backref here as it's going to be
12611 created as part of the magic cloning of the symbol
12612 table--unless this is during a join and the stash
12613 is not actually being cloned. */
12614 /* Danger Will Robinson - GvGP(dstr) isn't initialised
12615 at the point of this comment. */
12616 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
12617 if (param->flags & CLONEf_JOIN_IN)
12618 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
12619 GvGP_set(dstr, gp_dup(GvGP(sstr), param));
12620 (void)GpREFCNT_inc(GvGP(dstr));
12624 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
12625 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
12626 /* I have no idea why fake dirp (rsfps)
12627 should be treated differently but otherwise
12628 we end up with leaks -- sky*/
12629 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
12630 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
12631 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
12633 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
12634 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
12635 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
12636 if (IoDIRP(dstr)) {
12637 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr), param);
12640 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
12642 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(dstr), param);
12644 if (IoOFP(dstr) == IoIFP(sstr))
12645 IoOFP(dstr) = IoIFP(dstr);
12647 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
12648 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
12649 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
12650 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
12653 /* avoid cloning an empty array */
12654 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
12655 SV **dst_ary, **src_ary;
12656 SSize_t items = AvFILLp((const AV *)sstr) + 1;
12658 src_ary = AvARRAY((const AV *)sstr);
12659 Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
12660 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
12661 AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
12662 AvALLOC((const AV *)dstr) = dst_ary;
12663 if (AvREAL((const AV *)sstr)) {
12664 dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
12668 while (items-- > 0)
12669 *dst_ary++ = sv_dup(*src_ary++, param);
12671 items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
12672 while (items-- > 0) {
12673 *dst_ary++ = &PL_sv_undef;
12677 AvARRAY(MUTABLE_AV(dstr)) = NULL;
12678 AvALLOC((const AV *)dstr) = (SV**)NULL;
12679 AvMAX( (const AV *)dstr) = -1;
12680 AvFILLp((const AV *)dstr) = -1;
12684 if (HvARRAY((const HV *)sstr)) {
12686 const bool sharekeys = !!HvSHAREKEYS(sstr);
12687 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
12688 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
12690 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
12691 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
12693 HvARRAY(dstr) = (HE**)darray;
12694 while (i <= sxhv->xhv_max) {
12695 const HE * const source = HvARRAY(sstr)[i];
12696 HvARRAY(dstr)[i] = source
12697 ? he_dup(source, sharekeys, param) : 0;
12701 const struct xpvhv_aux * const saux = HvAUX(sstr);
12702 struct xpvhv_aux * const daux = HvAUX(dstr);
12703 /* This flag isn't copied. */
12706 if (saux->xhv_name_count) {
12707 HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
12709 = saux->xhv_name_count < 0
12710 ? -saux->xhv_name_count
12711 : saux->xhv_name_count;
12712 HEK **shekp = sname + count;
12714 Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *);
12715 dhekp = daux->xhv_name_u.xhvnameu_names + count;
12716 while (shekp-- > sname) {
12718 *dhekp = hek_dup(*shekp, param);
12722 daux->xhv_name_u.xhvnameu_name
12723 = hek_dup(saux->xhv_name_u.xhvnameu_name,
12726 daux->xhv_name_count = saux->xhv_name_count;
12728 daux->xhv_fill_lazy = saux->xhv_fill_lazy;
12729 daux->xhv_aux_flags = saux->xhv_aux_flags;
12730 #ifdef PERL_HASH_RANDOMIZE_KEYS
12731 daux->xhv_rand = saux->xhv_rand;
12732 daux->xhv_last_rand = saux->xhv_last_rand;
12734 daux->xhv_riter = saux->xhv_riter;
12735 daux->xhv_eiter = saux->xhv_eiter
12736 ? he_dup(saux->xhv_eiter,
12737 cBOOL(HvSHAREKEYS(sstr)), param) : 0;
12738 /* backref array needs refcnt=2; see sv_add_backref */
12739 daux->xhv_backreferences =
12740 (param->flags & CLONEf_JOIN_IN)
12741 /* when joining, we let the individual GVs and
12742 * CVs add themselves to backref as
12743 * needed. This avoids pulling in stuff
12744 * that isn't required, and simplifies the
12745 * case where stashes aren't cloned back
12746 * if they already exist in the parent
12749 : saux->xhv_backreferences
12750 ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
12751 ? MUTABLE_AV(SvREFCNT_inc(
12752 sv_dup_inc((const SV *)
12753 saux->xhv_backreferences, param)))
12754 : MUTABLE_AV(sv_dup((const SV *)
12755 saux->xhv_backreferences, param))
12758 daux->xhv_mro_meta = saux->xhv_mro_meta
12759 ? mro_meta_dup(saux->xhv_mro_meta, param)
12762 /* Record stashes for possible cloning in Perl_clone(). */
12764 av_push(param->stashes, dstr);
12768 HvARRAY(MUTABLE_HV(dstr)) = NULL;
12771 if (!(param->flags & CLONEf_COPY_STACKS)) {
12776 /* NOTE: not refcounted */
12777 SvANY(MUTABLE_CV(dstr))->xcv_stash =
12778 hv_dup(CvSTASH(dstr), param);
12779 if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
12780 Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
12781 if (!CvISXSUB(dstr)) {
12783 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
12785 CvSLABBED_off(dstr);
12786 } else if (CvCONST(dstr)) {
12787 CvXSUBANY(dstr).any_ptr =
12788 sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
12790 assert(!CvSLABBED(dstr));
12791 if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr));
12793 SvANY((CV *)dstr)->xcv_gv_u.xcv_hek =
12794 share_hek_hek(CvNAME_HEK((CV *)sstr));
12795 /* don't dup if copying back - CvGV isn't refcounted, so the
12796 * duped GV may never be freed. A bit of a hack! DAPM */
12798 SvANY(MUTABLE_CV(dstr))->xcv_gv_u.xcv_gv =
12800 ? gv_dup_inc(CvGV(sstr), param)
12801 : (param->flags & CLONEf_JOIN_IN)
12803 : gv_dup(CvGV(sstr), param);
12805 CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
12807 CvWEAKOUTSIDE(sstr)
12808 ? cv_dup( CvOUTSIDE(dstr), param)
12809 : cv_dup_inc(CvOUTSIDE(dstr), param);
12819 Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12821 PERL_ARGS_ASSERT_SV_DUP_INC;
12822 return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL;
12826 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12828 SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
12829 PERL_ARGS_ASSERT_SV_DUP;
12831 /* Track every SV that (at least initially) had a reference count of 0.
12832 We need to do this by holding an actual reference to it in this array.
12833 If we attempt to cheat, turn AvREAL_off(), and store only pointers
12834 (akin to the stashes hash, and the perl stack), we come unstuck if
12835 a weak reference (or other SV legitimately SvREFCNT() == 0 for this
12836 thread) is manipulated in a CLONE method, because CLONE runs before the
12837 unreferenced array is walked to find SVs still with SvREFCNT() == 0
12838 (and fix things up by giving each a reference via the temps stack).
12839 Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
12840 then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
12841 before the walk of unreferenced happens and a reference to that is SV
12842 added to the temps stack. At which point we have the same SV considered
12843 to be in use, and free to be re-used. Not good.
12845 if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
12846 assert(param->unreferenced);
12847 av_push(param->unreferenced, SvREFCNT_inc(dstr));
12853 /* duplicate a context */
12856 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
12858 PERL_CONTEXT *ncxs;
12860 PERL_ARGS_ASSERT_CX_DUP;
12863 return (PERL_CONTEXT*)NULL;
12865 /* look for it in the table first */
12866 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
12870 /* create anew and remember what it is */
12871 Newx(ncxs, max + 1, PERL_CONTEXT);
12872 ptr_table_store(PL_ptr_table, cxs, ncxs);
12873 Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
12876 PERL_CONTEXT * const ncx = &ncxs[ix];
12877 if (CxTYPE(ncx) == CXt_SUBST) {
12878 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
12881 ncx->blk_oldcop = (COP*)any_dup(ncx->blk_oldcop, param->proto_perl);
12882 switch (CxTYPE(ncx)) {
12884 ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
12885 ? cv_dup_inc(ncx->blk_sub.cv, param)
12886 : cv_dup(ncx->blk_sub.cv,param));
12887 if(CxHASARGS(ncx)){
12888 ncx->blk_sub.argarray = av_dup_inc(ncx->blk_sub.argarray,param);
12889 ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,param);
12891 ncx->blk_sub.argarray = NULL;
12892 ncx->blk_sub.savearray = NULL;
12894 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
12895 ncx->blk_sub.oldcomppad);
12898 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
12900 ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
12901 ncx->blk_eval.cv = cv_dup(ncx->blk_eval.cv, param);
12903 case CXt_LOOP_LAZYSV:
12904 ncx->blk_loop.state_u.lazysv.end
12905 = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
12906 /* We are taking advantage of av_dup_inc and sv_dup_inc
12907 actually being the same function, and order equivalence of
12909 We can assert the later [but only at run time :-(] */
12910 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
12911 (void *) &ncx->blk_loop.state_u.lazysv.cur);
12913 ncx->blk_loop.state_u.ary.ary
12914 = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
12915 case CXt_LOOP_LAZYIV:
12916 case CXt_LOOP_PLAIN:
12917 if (CxPADLOOP(ncx)) {
12918 ncx->blk_loop.itervar_u.oldcomppad
12919 = (PAD*)ptr_table_fetch(PL_ptr_table,
12920 ncx->blk_loop.itervar_u.oldcomppad);
12922 ncx->blk_loop.itervar_u.gv
12923 = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
12928 ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param);
12929 ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param);
12930 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
12945 /* duplicate a stack info structure */
12948 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
12952 PERL_ARGS_ASSERT_SI_DUP;
12955 return (PERL_SI*)NULL;
12957 /* look for it in the table first */
12958 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
12962 /* create anew and remember what it is */
12963 Newxz(nsi, 1, PERL_SI);
12964 ptr_table_store(PL_ptr_table, si, nsi);
12966 nsi->si_stack = av_dup_inc(si->si_stack, param);
12967 nsi->si_cxix = si->si_cxix;
12968 nsi->si_cxmax = si->si_cxmax;
12969 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
12970 nsi->si_type = si->si_type;
12971 nsi->si_prev = si_dup(si->si_prev, param);
12972 nsi->si_next = si_dup(si->si_next, param);
12973 nsi->si_markoff = si->si_markoff;
12978 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
12979 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
12980 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
12981 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
12982 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
12983 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
12984 #define POPUV(ss,ix) ((ss)[--(ix)].any_uv)
12985 #define TOPUV(ss,ix) ((ss)[ix].any_uv)
12986 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
12987 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
12988 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
12989 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
12990 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
12991 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
12992 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
12993 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
12996 #define pv_dup_inc(p) SAVEPV(p)
12997 #define pv_dup(p) SAVEPV(p)
12998 #define svp_dup_inc(p,pp) any_dup(p,pp)
13000 /* map any object to the new equivent - either something in the
13001 * ptr table, or something in the interpreter structure
13005 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
13009 PERL_ARGS_ASSERT_ANY_DUP;
13012 return (void*)NULL;
13014 /* look for it in the table first */
13015 ret = ptr_table_fetch(PL_ptr_table, v);
13019 /* see if it is part of the interpreter structure */
13020 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
13021 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
13029 /* duplicate the save stack */
13032 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
13035 ANY * const ss = proto_perl->Isavestack;
13036 const I32 max = proto_perl->Isavestack_max;
13037 I32 ix = proto_perl->Isavestack_ix;
13050 void (*dptr) (void*);
13051 void (*dxptr) (pTHX_ void*);
13053 PERL_ARGS_ASSERT_SS_DUP;
13055 Newxz(nss, max, ANY);
13058 const UV uv = POPUV(ss,ix);
13059 const U8 type = (U8)uv & SAVE_MASK;
13061 TOPUV(nss,ix) = uv;
13063 case SAVEt_CLEARSV:
13064 case SAVEt_CLEARPADRANGE:
13066 case SAVEt_HELEM: /* hash element */
13067 sv = (const SV *)POPPTR(ss,ix);
13068 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
13070 case SAVEt_ITEM: /* normal string */
13071 case SAVEt_GVSV: /* scalar slot in GV */
13072 case SAVEt_SV: /* scalar reference */
13073 sv = (const SV *)POPPTR(ss,ix);
13074 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
13077 case SAVEt_MORTALIZESV:
13078 case SAVEt_READONLY_OFF:
13079 sv = (const SV *)POPPTR(ss,ix);
13080 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
13082 case SAVEt_SHARED_PVREF: /* char* in shared space */
13083 c = (char*)POPPTR(ss,ix);
13084 TOPPTR(nss,ix) = savesharedpv(c);
13085 ptr = POPPTR(ss,ix);
13086 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
13088 case SAVEt_GENERIC_SVREF: /* generic sv */
13089 case SAVEt_SVREF: /* scalar reference */
13090 sv = (const SV *)POPPTR(ss,ix);
13091 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
13092 ptr = POPPTR(ss,ix);
13093 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
13095 case SAVEt_GVSLOT: /* any slot in GV */
13096 sv = (const SV *)POPPTR(ss,ix);
13097 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
13098 ptr = POPPTR(ss,ix);
13099 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
13100 sv = (const SV *)POPPTR(ss,ix);
13101 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
13103 case SAVEt_HV: /* hash reference */
13104 case SAVEt_AV: /* array reference */
13105 sv = (const SV *) POPPTR(ss,ix);
13106 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
13108 case SAVEt_COMPPAD:
13110 sv = (const SV *) POPPTR(ss,ix);
13111 TOPPTR(nss,ix) = sv_dup(sv, param);
13113 case SAVEt_INT: /* int reference */
13114 ptr = POPPTR(ss,ix);
13115 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
13116 intval = (int)POPINT(ss,ix);
13117 TOPINT(nss,ix) = intval;
13119 case SAVEt_LONG: /* long reference */
13120 ptr = POPPTR(ss,ix);
13121 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
13122 longval = (long)POPLONG(ss,ix);
13123 TOPLONG(nss,ix) = longval;
13125 case SAVEt_I32: /* I32 reference */
13126 ptr = POPPTR(ss,ix);
13127 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
13129 TOPINT(nss,ix) = i;
13131 case SAVEt_IV: /* IV reference */
13132 case SAVEt_STRLEN: /* STRLEN/size_t ref */
13133 ptr = POPPTR(ss,ix);
13134 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
13136 TOPIV(nss,ix) = iv;
13138 case SAVEt_HPTR: /* HV* reference */
13139 case SAVEt_APTR: /* AV* reference */
13140 case SAVEt_SPTR: /* SV* reference */
13141 ptr = POPPTR(ss,ix);
13142 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
13143 sv = (const SV *)POPPTR(ss,ix);
13144 TOPPTR(nss,ix) = sv_dup(sv, param);
13146 case SAVEt_VPTR: /* random* reference */
13147 ptr = POPPTR(ss,ix);
13148 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
13150 case SAVEt_INT_SMALL:
13151 case SAVEt_I32_SMALL:
13152 case SAVEt_I16: /* I16 reference */
13153 case SAVEt_I8: /* I8 reference */
13155 ptr = POPPTR(ss,ix);
13156 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
13158 case SAVEt_GENERIC_PVREF: /* generic char* */
13159 case SAVEt_PPTR: /* char* reference */
13160 ptr = POPPTR(ss,ix);
13161 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
13162 c = (char*)POPPTR(ss,ix);
13163 TOPPTR(nss,ix) = pv_dup(c);
13165 case SAVEt_GP: /* scalar reference */
13166 gp = (GP*)POPPTR(ss,ix);
13167 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
13168 (void)GpREFCNT_inc(gp);
13169 gv = (const GV *)POPPTR(ss,ix);
13170 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
13173 ptr = POPPTR(ss,ix);
13174 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
13175 /* these are assumed to be refcounted properly */
13177 switch (((OP*)ptr)->op_type) {
13179 case OP_LEAVESUBLV:
13183 case OP_LEAVEWRITE:
13184 TOPPTR(nss,ix) = ptr;
13187 (void) OpREFCNT_inc(o);
13191 TOPPTR(nss,ix) = NULL;
13196 TOPPTR(nss,ix) = NULL;
13198 case SAVEt_FREECOPHH:
13199 ptr = POPPTR(ss,ix);
13200 TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr);
13202 case SAVEt_ADELETE:
13203 av = (const AV *)POPPTR(ss,ix);
13204 TOPPTR(nss,ix) = av_dup_inc(av, param);
13206 TOPINT(nss,ix) = i;
13209 hv = (const HV *)POPPTR(ss,ix);
13210 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
13212 TOPINT(nss,ix) = i;
13215 c = (char*)POPPTR(ss,ix);
13216 TOPPTR(nss,ix) = pv_dup_inc(c);
13218 case SAVEt_STACK_POS: /* Position on Perl stack */
13220 TOPINT(nss,ix) = i;
13222 case SAVEt_DESTRUCTOR:
13223 ptr = POPPTR(ss,ix);
13224 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
13225 dptr = POPDPTR(ss,ix);
13226 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
13227 any_dup(FPTR2DPTR(void *, dptr),
13230 case SAVEt_DESTRUCTOR_X:
13231 ptr = POPPTR(ss,ix);
13232 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
13233 dxptr = POPDXPTR(ss,ix);
13234 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
13235 any_dup(FPTR2DPTR(void *, dxptr),
13238 case SAVEt_REGCONTEXT:
13240 ix -= uv >> SAVE_TIGHT_SHIFT;
13242 case SAVEt_AELEM: /* array element */
13243 sv = (const SV *)POPPTR(ss,ix);
13244 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
13246 TOPINT(nss,ix) = i;
13247 av = (const AV *)POPPTR(ss,ix);
13248 TOPPTR(nss,ix) = av_dup_inc(av, param);
13251 ptr = POPPTR(ss,ix);
13252 TOPPTR(nss,ix) = ptr;
13255 ptr = POPPTR(ss,ix);
13256 ptr = cophh_copy((COPHH*)ptr);
13257 TOPPTR(nss,ix) = ptr;
13259 TOPINT(nss,ix) = i;
13260 if (i & HINT_LOCALIZE_HH) {
13261 hv = (const HV *)POPPTR(ss,ix);
13262 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
13265 case SAVEt_PADSV_AND_MORTALIZE:
13266 longval = (long)POPLONG(ss,ix);
13267 TOPLONG(nss,ix) = longval;
13268 ptr = POPPTR(ss,ix);
13269 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
13270 sv = (const SV *)POPPTR(ss,ix);
13271 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
13273 case SAVEt_SET_SVFLAGS:
13275 TOPINT(nss,ix) = i;
13277 TOPINT(nss,ix) = i;
13278 sv = (const SV *)POPPTR(ss,ix);
13279 TOPPTR(nss,ix) = sv_dup(sv, param);
13281 case SAVEt_COMPILE_WARNINGS:
13282 ptr = POPPTR(ss,ix);
13283 TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
13286 ptr = POPPTR(ss,ix);
13287 TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
13291 "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
13299 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
13300 * flag to the result. This is done for each stash before cloning starts,
13301 * so we know which stashes want their objects cloned */
13304 do_mark_cloneable_stash(pTHX_ SV *const sv)
13306 const HEK * const hvname = HvNAME_HEK((const HV *)sv);
13308 GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
13309 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
13310 if (cloner && GvCV(cloner)) {
13317 mXPUSHs(newSVhek(hvname));
13319 call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
13326 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
13334 =for apidoc perl_clone
13336 Create and return a new interpreter by cloning the current one.
13338 perl_clone takes these flags as parameters:
13340 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
13341 without it we only clone the data and zero the stacks,
13342 with it we copy the stacks and the new perl interpreter is
13343 ready to run at the exact same point as the previous one.
13344 The pseudo-fork code uses COPY_STACKS while the
13345 threads->create doesn't.
13347 CLONEf_KEEP_PTR_TABLE -
13348 perl_clone keeps a ptr_table with the pointer of the old
13349 variable as a key and the new variable as a value,
13350 this allows it to check if something has been cloned and not
13351 clone it again but rather just use the value and increase the
13352 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
13353 the ptr_table using the function
13354 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
13355 reason to keep it around is if you want to dup some of your own
13356 variable who are outside the graph perl scans, example of this
13357 code is in threads.xs create.
13359 CLONEf_CLONE_HOST -
13360 This is a win32 thing, it is ignored on unix, it tells perls
13361 win32host code (which is c++) to clone itself, this is needed on
13362 win32 if you want to run two threads at the same time,
13363 if you just want to do some stuff in a separate perl interpreter
13364 and then throw it away and return to the original one,
13365 you don't need to do anything.
13370 /* XXX the above needs expanding by someone who actually understands it ! */
13371 EXTERN_C PerlInterpreter *
13372 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
13375 perl_clone(PerlInterpreter *proto_perl, UV flags)
13378 #ifdef PERL_IMPLICIT_SYS
13380 PERL_ARGS_ASSERT_PERL_CLONE;
13382 /* perlhost.h so we need to call into it
13383 to clone the host, CPerlHost should have a c interface, sky */
13385 if (flags & CLONEf_CLONE_HOST) {
13386 return perl_clone_host(proto_perl,flags);
13388 return perl_clone_using(proto_perl, flags,
13390 proto_perl->IMemShared,
13391 proto_perl->IMemParse,
13393 proto_perl->IStdIO,
13397 proto_perl->IProc);
13401 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
13402 struct IPerlMem* ipM, struct IPerlMem* ipMS,
13403 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
13404 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
13405 struct IPerlDir* ipD, struct IPerlSock* ipS,
13406 struct IPerlProc* ipP)
13408 /* XXX many of the string copies here can be optimized if they're
13409 * constants; they need to be allocated as common memory and just
13410 * their pointers copied. */
13413 CLONE_PARAMS clone_params;
13414 CLONE_PARAMS* const param = &clone_params;
13416 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
13418 PERL_ARGS_ASSERT_PERL_CLONE_USING;
13419 #else /* !PERL_IMPLICIT_SYS */
13421 CLONE_PARAMS clone_params;
13422 CLONE_PARAMS* param = &clone_params;
13423 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
13425 PERL_ARGS_ASSERT_PERL_CLONE;
13426 #endif /* PERL_IMPLICIT_SYS */
13428 /* for each stash, determine whether its objects should be cloned */
13429 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
13430 PERL_SET_THX(my_perl);
13433 PoisonNew(my_perl, 1, PerlInterpreter);
13436 PL_defstash = NULL; /* may be used by perl malloc() */
13439 PL_scopestack_name = 0;
13441 PL_savestack_ix = 0;
13442 PL_savestack_max = -1;
13443 PL_sig_pending = 0;
13445 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
13446 # ifdef DEBUG_LEAKING_SCALARS
13447 PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
13449 #else /* !DEBUGGING */
13450 Zero(my_perl, 1, PerlInterpreter);
13451 #endif /* DEBUGGING */
13453 #ifdef PERL_IMPLICIT_SYS
13454 /* host pointers */
13456 PL_MemShared = ipMS;
13457 PL_MemParse = ipMP;
13464 #endif /* PERL_IMPLICIT_SYS */
13467 param->flags = flags;
13468 /* Nothing in the core code uses this, but we make it available to
13469 extensions (using mg_dup). */
13470 param->proto_perl = proto_perl;
13471 /* Likely nothing will use this, but it is initialised to be consistent
13472 with Perl_clone_params_new(). */
13473 param->new_perl = my_perl;
13474 param->unreferenced = NULL;
13477 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
13479 PL_body_arenas = NULL;
13480 Zero(&PL_body_roots, 1, PL_body_roots);
13484 PL_sv_arenaroot = NULL;
13486 PL_debug = proto_perl->Idebug;
13488 /* dbargs array probably holds garbage */
13491 PL_compiling = proto_perl->Icompiling;
13493 /* pseudo environmental stuff */
13494 PL_origargc = proto_perl->Iorigargc;
13495 PL_origargv = proto_perl->Iorigargv;
13497 #ifndef NO_TAINT_SUPPORT
13498 /* Set tainting stuff before PerlIO_debug can possibly get called */
13499 PL_tainting = proto_perl->Itainting;
13500 PL_taint_warn = proto_perl->Itaint_warn;
13502 PL_tainting = FALSE;
13503 PL_taint_warn = FALSE;
13506 PL_minus_c = proto_perl->Iminus_c;
13508 PL_localpatches = proto_perl->Ilocalpatches;
13509 PL_splitstr = proto_perl->Isplitstr;
13510 PL_minus_n = proto_perl->Iminus_n;
13511 PL_minus_p = proto_perl->Iminus_p;
13512 PL_minus_l = proto_perl->Iminus_l;
13513 PL_minus_a = proto_perl->Iminus_a;
13514 PL_minus_E = proto_perl->Iminus_E;
13515 PL_minus_F = proto_perl->Iminus_F;
13516 PL_doswitches = proto_perl->Idoswitches;
13517 PL_dowarn = proto_perl->Idowarn;
13518 #ifdef PERL_SAWAMPERSAND
13519 PL_sawampersand = proto_perl->Isawampersand;
13521 PL_unsafe = proto_perl->Iunsafe;
13522 PL_perldb = proto_perl->Iperldb;
13523 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
13524 PL_exit_flags = proto_perl->Iexit_flags;
13526 /* XXX time(&PL_basetime) when asked for? */
13527 PL_basetime = proto_perl->Ibasetime;
13529 PL_maxsysfd = proto_perl->Imaxsysfd;
13530 PL_statusvalue = proto_perl->Istatusvalue;
13532 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
13534 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
13537 /* RE engine related */
13538 PL_regmatch_slab = NULL;
13539 PL_reg_curpm = NULL;
13541 PL_sub_generation = proto_perl->Isub_generation;
13543 /* funky return mechanisms */
13544 PL_forkprocess = proto_perl->Iforkprocess;
13546 /* internal state */
13547 PL_maxo = proto_perl->Imaxo;
13549 PL_main_start = proto_perl->Imain_start;
13550 PL_eval_root = proto_perl->Ieval_root;
13551 PL_eval_start = proto_perl->Ieval_start;
13553 PL_filemode = proto_perl->Ifilemode;
13554 PL_lastfd = proto_perl->Ilastfd;
13555 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
13558 PL_gensym = proto_perl->Igensym;
13560 PL_laststatval = proto_perl->Ilaststatval;
13561 PL_laststype = proto_perl->Ilaststype;
13564 PL_profiledata = NULL;
13566 PL_generation = proto_perl->Igeneration;
13568 PL_in_clean_objs = proto_perl->Iin_clean_objs;
13569 PL_in_clean_all = proto_perl->Iin_clean_all;
13571 PL_delaymagic_uid = proto_perl->Idelaymagic_uid;
13572 PL_delaymagic_euid = proto_perl->Idelaymagic_euid;
13573 PL_delaymagic_gid = proto_perl->Idelaymagic_gid;
13574 PL_delaymagic_egid = proto_perl->Idelaymagic_egid;
13575 PL_nomemok = proto_perl->Inomemok;
13576 PL_an = proto_perl->Ian;
13577 PL_evalseq = proto_perl->Ievalseq;
13578 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
13579 PL_origalen = proto_perl->Iorigalen;
13581 PL_sighandlerp = proto_perl->Isighandlerp;
13583 PL_runops = proto_perl->Irunops;
13585 PL_subline = proto_perl->Isubline;
13588 PL_cryptseen = proto_perl->Icryptseen;
13591 #ifdef USE_LOCALE_COLLATE
13592 PL_collation_ix = proto_perl->Icollation_ix;
13593 PL_collation_standard = proto_perl->Icollation_standard;
13594 PL_collxfrm_base = proto_perl->Icollxfrm_base;
13595 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
13596 #endif /* USE_LOCALE_COLLATE */
13598 #ifdef USE_LOCALE_NUMERIC
13599 PL_numeric_standard = proto_perl->Inumeric_standard;
13600 PL_numeric_local = proto_perl->Inumeric_local;
13601 #endif /* !USE_LOCALE_NUMERIC */
13603 /* Did the locale setup indicate UTF-8? */
13604 PL_utf8locale = proto_perl->Iutf8locale;
13605 PL_in_utf8_CTYPE_locale = proto_perl->Iin_utf8_CTYPE_locale;
13606 /* Unicode features (see perlrun/-C) */
13607 PL_unicode = proto_perl->Iunicode;
13609 /* Pre-5.8 signals control */
13610 PL_signals = proto_perl->Isignals;
13612 /* times() ticks per second */
13613 PL_clocktick = proto_perl->Iclocktick;
13615 /* Recursion stopper for PerlIO_find_layer */
13616 PL_in_load_module = proto_perl->Iin_load_module;
13618 /* sort() routine */
13619 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
13621 /* Not really needed/useful since the reenrant_retint is "volatile",
13622 * but do it for consistency's sake. */
13623 PL_reentrant_retint = proto_perl->Ireentrant_retint;
13625 /* Hooks to shared SVs and locks. */
13626 PL_sharehook = proto_perl->Isharehook;
13627 PL_lockhook = proto_perl->Ilockhook;
13628 PL_unlockhook = proto_perl->Iunlockhook;
13629 PL_threadhook = proto_perl->Ithreadhook;
13630 PL_destroyhook = proto_perl->Idestroyhook;
13631 PL_signalhook = proto_perl->Isignalhook;
13633 PL_globhook = proto_perl->Iglobhook;
13636 PL_last_swash_hv = NULL; /* reinits on demand */
13637 PL_last_swash_klen = 0;
13638 PL_last_swash_key[0]= '\0';
13639 PL_last_swash_tmps = (U8*)NULL;
13640 PL_last_swash_slen = 0;
13642 PL_srand_called = proto_perl->Isrand_called;
13643 Copy(&(proto_perl->Irandom_state), &PL_random_state, 1, PL_RANDOM_STATE_TYPE);
13645 if (flags & CLONEf_COPY_STACKS) {
13646 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
13647 PL_tmps_ix = proto_perl->Itmps_ix;
13648 PL_tmps_max = proto_perl->Itmps_max;
13649 PL_tmps_floor = proto_perl->Itmps_floor;
13651 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
13652 * NOTE: unlike the others! */
13653 PL_scopestack_ix = proto_perl->Iscopestack_ix;
13654 PL_scopestack_max = proto_perl->Iscopestack_max;
13656 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
13657 * NOTE: unlike the others! */
13658 PL_savestack_ix = proto_perl->Isavestack_ix;
13659 PL_savestack_max = proto_perl->Isavestack_max;
13662 PL_start_env = proto_perl->Istart_env; /* XXXXXX */
13663 PL_top_env = &PL_start_env;
13665 PL_op = proto_perl->Iop;
13668 PL_Xpv = (XPV*)NULL;
13669 my_perl->Ina = proto_perl->Ina;
13671 PL_statbuf = proto_perl->Istatbuf;
13672 PL_statcache = proto_perl->Istatcache;
13674 #ifndef NO_TAINT_SUPPORT
13675 PL_tainted = proto_perl->Itainted;
13677 PL_tainted = FALSE;
13679 PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
13681 PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
13683 PL_restartjmpenv = proto_perl->Irestartjmpenv;
13684 PL_restartop = proto_perl->Irestartop;
13685 PL_in_eval = proto_perl->Iin_eval;
13686 PL_delaymagic = proto_perl->Idelaymagic;
13687 PL_phase = proto_perl->Iphase;
13688 PL_localizing = proto_perl->Ilocalizing;
13690 PL_hv_fetch_ent_mh = NULL;
13691 PL_modcount = proto_perl->Imodcount;
13692 PL_lastgotoprobe = NULL;
13693 PL_dumpindent = proto_perl->Idumpindent;
13695 PL_efloatbuf = NULL; /* reinits on demand */
13696 PL_efloatsize = 0; /* reinits on demand */
13700 PL_colorset = 0; /* reinits PL_colors[] */
13701 /*PL_colors[6] = {0,0,0,0,0,0};*/
13703 /* Pluggable optimizer */
13704 PL_peepp = proto_perl->Ipeepp;
13705 PL_rpeepp = proto_perl->Irpeepp;
13706 /* op_free() hook */
13707 PL_opfreehook = proto_perl->Iopfreehook;
13709 #ifdef USE_REENTRANT_API
13710 /* XXX: things like -Dm will segfault here in perlio, but doing
13711 * PERL_SET_CONTEXT(proto_perl);
13712 * breaks too many other things
13714 Perl_reentrant_init(aTHX);
13717 /* create SV map for pointer relocation */
13718 PL_ptr_table = ptr_table_new();
13720 /* initialize these special pointers as early as possible */
13722 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
13723 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
13724 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
13726 /* create (a non-shared!) shared string table */
13727 PL_strtab = newHV();
13728 HvSHAREKEYS_off(PL_strtab);
13729 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
13730 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
13732 Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
13734 /* This PV will be free'd special way so must set it same way op.c does */
13735 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
13736 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
13738 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
13739 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
13740 CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling)));
13741 PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
13743 param->stashes = newAV(); /* Setup array of objects to call clone on */
13744 /* This makes no difference to the implementation, as it always pushes
13745 and shifts pointers to other SVs without changing their reference
13746 count, with the array becoming empty before it is freed. However, it
13747 makes it conceptually clear what is going on, and will avoid some
13748 work inside av.c, filling slots between AvFILL() and AvMAX() with
13749 &PL_sv_undef, and SvREFCNT_dec()ing those. */
13750 AvREAL_off(param->stashes);
13752 if (!(flags & CLONEf_COPY_STACKS)) {
13753 param->unreferenced = newAV();
13756 #ifdef PERLIO_LAYERS
13757 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
13758 PerlIO_clone(aTHX_ proto_perl, param);
13761 PL_envgv = gv_dup_inc(proto_perl->Ienvgv, param);
13762 PL_incgv = gv_dup_inc(proto_perl->Iincgv, param);
13763 PL_hintgv = gv_dup_inc(proto_perl->Ihintgv, param);
13764 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
13765 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
13766 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
13769 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
13770 PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param);
13771 PL_inplace = SAVEPV(proto_perl->Iinplace);
13772 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
13774 /* magical thingies */
13776 PL_encoding = sv_dup(proto_perl->Iencoding, param);
13778 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
13779 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
13780 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
13783 /* Clone the regex array */
13784 /* ORANGE FIXME for plugins, probably in the SV dup code.
13785 newSViv(PTR2IV(CALLREGDUPE(
13786 INT2PTR(REGEXP *, SvIVX(regex)), param))))
13788 PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
13789 PL_regex_pad = AvARRAY(PL_regex_padav);
13791 PL_stashpadmax = proto_perl->Istashpadmax;
13792 PL_stashpadix = proto_perl->Istashpadix ;
13793 Newx(PL_stashpad, PL_stashpadmax, HV *);
13796 for (; o < PL_stashpadmax; ++o)
13797 PL_stashpad[o] = hv_dup(proto_perl->Istashpad[o], param);
13800 /* shortcuts to various I/O objects */
13801 PL_ofsgv = gv_dup_inc(proto_perl->Iofsgv, param);
13802 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
13803 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
13804 PL_defgv = gv_dup(proto_perl->Idefgv, param);
13805 PL_argvgv = gv_dup_inc(proto_perl->Iargvgv, param);
13806 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
13807 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
13809 /* shortcuts to regexp stuff */
13810 PL_replgv = gv_dup_inc(proto_perl->Ireplgv, param);
13812 /* shortcuts to misc objects */
13813 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
13815 /* shortcuts to debugging objects */
13816 PL_DBgv = gv_dup_inc(proto_perl->IDBgv, param);
13817 PL_DBline = gv_dup_inc(proto_perl->IDBline, param);
13818 PL_DBsub = gv_dup_inc(proto_perl->IDBsub, param);
13819 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
13820 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
13821 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
13823 /* symbol tables */
13824 PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
13825 PL_curstash = hv_dup_inc(proto_perl->Icurstash, param);
13826 PL_debstash = hv_dup(proto_perl->Idebstash, param);
13827 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
13828 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
13830 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
13831 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
13832 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
13833 PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
13834 PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
13835 PL_endav = av_dup_inc(proto_perl->Iendav, param);
13836 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
13837 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
13839 PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
13841 /* subprocess state */
13842 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
13844 if (proto_perl->Iop_mask)
13845 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
13848 /* PL_asserting = proto_perl->Iasserting; */
13850 /* current interpreter roots */
13851 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
13853 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
13856 /* runtime control stuff */
13857 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
13859 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
13861 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
13863 /* interpreter atexit processing */
13864 PL_exitlistlen = proto_perl->Iexitlistlen;
13865 if (PL_exitlistlen) {
13866 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
13867 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
13870 PL_exitlist = (PerlExitListEntry*)NULL;
13872 PL_my_cxt_size = proto_perl->Imy_cxt_size;
13873 if (PL_my_cxt_size) {
13874 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
13875 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
13876 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
13877 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
13878 Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
13882 PL_my_cxt_list = (void**)NULL;
13883 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
13884 PL_my_cxt_keys = (const char**)NULL;
13887 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
13888 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
13889 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
13890 PL_custom_ops = hv_dup_inc(proto_perl->Icustom_ops, param);
13892 PL_compcv = cv_dup(proto_perl->Icompcv, param);
13894 PAD_CLONE_VARS(proto_perl, param);
13896 #ifdef HAVE_INTERP_INTERN
13897 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
13900 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
13902 #ifdef PERL_USES_PL_PIDSTATUS
13903 PL_pidstatus = newHV(); /* XXX flag for cloning? */
13905 PL_osname = SAVEPV(proto_perl->Iosname);
13906 PL_parser = parser_dup(proto_perl->Iparser, param);
13908 /* XXX this only works if the saved cop has already been cloned */
13909 if (proto_perl->Iparser) {
13910 PL_parser->saved_curcop = (COP*)any_dup(
13911 proto_perl->Iparser->saved_curcop,
13915 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
13917 #ifdef USE_LOCALE_COLLATE
13918 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
13919 #endif /* USE_LOCALE_COLLATE */
13921 #ifdef USE_LOCALE_NUMERIC
13922 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
13923 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
13924 #endif /* !USE_LOCALE_NUMERIC */
13926 /* Unicode inversion lists */
13927 PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
13928 PL_UpperLatin1 = sv_dup_inc(proto_perl->IUpperLatin1, param);
13929 PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param);
13931 PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param);
13932 PL_HasMultiCharFold = sv_dup_inc(proto_perl->IHasMultiCharFold, param);
13934 /* utf8 character class swashes */
13935 for (i = 0; i < POSIX_SWASH_COUNT; i++) {
13936 PL_utf8_swash_ptrs[i] = sv_dup_inc(proto_perl->Iutf8_swash_ptrs[i], param);
13938 for (i = 0; i < POSIX_CC_COUNT; i++) {
13939 PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param);
13941 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
13942 PL_utf8_X_regular_begin = sv_dup_inc(proto_perl->Iutf8_X_regular_begin, param);
13943 PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
13944 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
13945 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
13946 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
13947 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
13948 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
13949 PL_utf8_xidstart = sv_dup_inc(proto_perl->Iutf8_xidstart, param);
13950 PL_utf8_perl_idstart = sv_dup_inc(proto_perl->Iutf8_perl_idstart, param);
13951 PL_utf8_perl_idcont = sv_dup_inc(proto_perl->Iutf8_perl_idcont, param);
13952 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
13953 PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param);
13954 PL_utf8_foldable = sv_dup_inc(proto_perl->Iutf8_foldable, param);
13955 PL_utf8_charname_begin = sv_dup_inc(proto_perl->Iutf8_charname_begin, param);
13956 PL_utf8_charname_continue = sv_dup_inc(proto_perl->Iutf8_charname_continue, param);
13958 if (proto_perl->Ipsig_pend) {
13959 Newxz(PL_psig_pend, SIG_SIZE, int);
13962 PL_psig_pend = (int*)NULL;
13965 if (proto_perl->Ipsig_name) {
13966 Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
13967 sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
13969 PL_psig_ptr = PL_psig_name + SIG_SIZE;
13972 PL_psig_ptr = (SV**)NULL;
13973 PL_psig_name = (SV**)NULL;
13976 if (flags & CLONEf_COPY_STACKS) {
13977 Newx(PL_tmps_stack, PL_tmps_max, SV*);
13978 sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
13979 PL_tmps_ix+1, param);
13981 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
13982 i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
13983 Newxz(PL_markstack, i, I32);
13984 PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
13985 - proto_perl->Imarkstack);
13986 PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
13987 - proto_perl->Imarkstack);
13988 Copy(proto_perl->Imarkstack, PL_markstack,
13989 PL_markstack_ptr - PL_markstack + 1, I32);
13991 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
13992 * NOTE: unlike the others! */
13993 Newxz(PL_scopestack, PL_scopestack_max, I32);
13994 Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
13997 Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
13998 Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
14000 /* reset stack AV to correct length before its duped via
14001 * PL_curstackinfo */
14002 AvFILLp(proto_perl->Icurstack) =
14003 proto_perl->Istack_sp - proto_perl->Istack_base;
14005 /* NOTE: si_dup() looks at PL_markstack */
14006 PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
14008 /* PL_curstack = PL_curstackinfo->si_stack; */
14009 PL_curstack = av_dup(proto_perl->Icurstack, param);
14010 PL_mainstack = av_dup(proto_perl->Imainstack, param);
14012 /* next PUSHs() etc. set *(PL_stack_sp+1) */
14013 PL_stack_base = AvARRAY(PL_curstack);
14014 PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp
14015 - proto_perl->Istack_base);
14016 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
14018 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
14019 PL_savestack = ss_dup(proto_perl, param);
14023 ENTER; /* perl_destruct() wants to LEAVE; */
14026 PL_statgv = gv_dup(proto_perl->Istatgv, param);
14027 PL_statname = sv_dup_inc(proto_perl->Istatname, param);
14029 PL_rs = sv_dup_inc(proto_perl->Irs, param);
14030 PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
14031 PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
14032 PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
14033 PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
14034 PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
14036 PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
14038 PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
14039 PL_firstgv = gv_dup_inc(proto_perl->Ifirstgv, param);
14040 PL_secondgv = gv_dup_inc(proto_perl->Isecondgv, param);
14042 PL_stashcache = newHV();
14044 PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
14045 proto_perl->Iwatchaddr);
14046 PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
14047 if (PL_debug && PL_watchaddr) {
14048 PerlIO_printf(Perl_debug_log,
14049 "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
14050 PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
14051 PTR2UV(PL_watchok));
14054 PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
14055 PL_blockhooks = av_dup_inc(proto_perl->Iblockhooks, param);
14056 PL_utf8_foldclosures = hv_dup_inc(proto_perl->Iutf8_foldclosures, param);
14058 /* Call the ->CLONE method, if it exists, for each of the stashes
14059 identified by sv_dup() above.
14061 while(av_tindex(param->stashes) != -1) {
14062 HV* const stash = MUTABLE_HV(av_shift(param->stashes));
14063 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
14064 if (cloner && GvCV(cloner)) {
14069 mXPUSHs(newSVhek(HvNAME_HEK(stash)));
14071 call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
14077 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
14078 ptr_table_free(PL_ptr_table);
14079 PL_ptr_table = NULL;
14082 if (!(flags & CLONEf_COPY_STACKS)) {
14083 unreferenced_to_tmp_stack(param->unreferenced);
14086 SvREFCNT_dec(param->stashes);
14088 /* orphaned? eg threads->new inside BEGIN or use */
14089 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
14090 SvREFCNT_inc_simple_void(PL_compcv);
14091 SAVEFREESV(PL_compcv);
14098 S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
14100 PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK;
14102 if (AvFILLp(unreferenced) > -1) {
14103 SV **svp = AvARRAY(unreferenced);
14104 SV **const last = svp + AvFILLp(unreferenced);
14108 if (SvREFCNT(*svp) == 1)
14110 } while (++svp <= last);
14112 EXTEND_MORTAL(count);
14113 svp = AvARRAY(unreferenced);
14116 if (SvREFCNT(*svp) == 1) {
14117 /* Our reference is the only one to this SV. This means that
14118 in this thread, the scalar effectively has a 0 reference.
14119 That doesn't work (cleanup never happens), so donate our
14120 reference to it onto the save stack. */
14121 PL_tmps_stack[++PL_tmps_ix] = *svp;
14123 /* As an optimisation, because we are already walking the
14124 entire array, instead of above doing either
14125 SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
14126 release our reference to the scalar, so that at the end of
14127 the array owns zero references to the scalars it happens to
14128 point to. We are effectively converting the array from
14129 AvREAL() on to AvREAL() off. This saves the av_clear()
14130 (triggered by the SvREFCNT_dec(unreferenced) below) from
14131 walking the array a second time. */
14132 SvREFCNT_dec(*svp);
14135 } while (++svp <= last);
14136 AvREAL_off(unreferenced);
14138 SvREFCNT_dec_NN(unreferenced);
14142 Perl_clone_params_del(CLONE_PARAMS *param)
14144 /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT
14146 PerlInterpreter *const to = param->new_perl;
14148 PerlInterpreter *const was = PERL_GET_THX;
14150 PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
14156 SvREFCNT_dec(param->stashes);
14157 if (param->unreferenced)
14158 unreferenced_to_tmp_stack(param->unreferenced);
14168 Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
14171 /* Need to play this game, as newAV() can call safesysmalloc(), and that
14172 does a dTHX; to get the context from thread local storage.
14173 FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
14174 a version that passes in my_perl. */
14175 PerlInterpreter *const was = PERL_GET_THX;
14176 CLONE_PARAMS *param;
14178 PERL_ARGS_ASSERT_CLONE_PARAMS_NEW;
14184 /* Given that we've set the context, we can do this unshared. */
14185 Newx(param, 1, CLONE_PARAMS);
14188 param->proto_perl = from;
14189 param->new_perl = to;
14190 param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
14191 AvREAL_off(param->stashes);
14192 param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
14200 #endif /* USE_ITHREADS */
14203 Perl_init_constants(pTHX)
14205 SvREFCNT(&PL_sv_undef) = SvREFCNT_IMMORTAL;
14206 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
14207 SvANY(&PL_sv_undef) = NULL;
14209 SvANY(&PL_sv_no) = new_XPVNV();
14210 SvREFCNT(&PL_sv_no) = SvREFCNT_IMMORTAL;
14211 SvFLAGS(&PL_sv_no) = SVt_PVNV|SVf_READONLY
14212 |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
14215 SvANY(&PL_sv_yes) = new_XPVNV();
14216 SvREFCNT(&PL_sv_yes) = SvREFCNT_IMMORTAL;
14217 SvFLAGS(&PL_sv_yes) = SVt_PVNV|SVf_READONLY
14218 |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
14221 SvPV_set(&PL_sv_no, (char*)PL_No);
14222 SvCUR_set(&PL_sv_no, 0);
14223 SvLEN_set(&PL_sv_no, 0);
14224 SvIV_set(&PL_sv_no, 0);
14225 SvNV_set(&PL_sv_no, 0);
14227 SvPV_set(&PL_sv_yes, (char*)PL_Yes);
14228 SvCUR_set(&PL_sv_yes, 1);
14229 SvLEN_set(&PL_sv_yes, 0);
14230 SvIV_set(&PL_sv_yes, 1);
14231 SvNV_set(&PL_sv_yes, 1);
14235 =head1 Unicode Support
14237 =for apidoc sv_recode_to_utf8
14239 The encoding is assumed to be an Encode object, on entry the PV
14240 of the sv is assumed to be octets in that encoding, and the sv
14241 will be converted into Unicode (and UTF-8).
14243 If the sv already is UTF-8 (or if it is not POK), or if the encoding
14244 is not a reference, nothing is done to the sv. If the encoding is not
14245 an C<Encode::XS> Encoding object, bad things will happen.
14246 (See F<lib/encoding.pm> and L<Encode>.)
14248 The PV of the sv is returned.
14253 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
14255 PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
14257 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
14266 if (SvPADTMP(nsv)) {
14267 nsv = sv_newmortal();
14268 SvSetSV_nosteal(nsv, sv);
14277 Passing sv_yes is wrong - it needs to be or'ed set of constants
14278 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
14279 remove converted chars from source.
14281 Both will default the value - let them.
14283 XPUSHs(&PL_sv_yes);
14286 call_method("decode", G_SCALAR);
14290 s = SvPV_const(uni, len);
14291 if (s != SvPVX_const(sv)) {
14292 SvGROW(sv, len + 1);
14293 Move(s, SvPVX(sv), len + 1, char);
14294 SvCUR_set(sv, len);
14299 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
14300 /* clear pos and any utf8 cache */
14301 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
14304 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
14305 magic_setutf8(sv,mg); /* clear UTF8 cache */
14310 return SvPOKp(sv) ? SvPVX(sv) : NULL;
14314 =for apidoc sv_cat_decode
14316 The encoding is assumed to be an Encode object, the PV of the ssv is
14317 assumed to be octets in that encoding and decoding the input starts
14318 from the position which (PV + *offset) pointed to. The dsv will be
14319 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
14320 when the string tstr appears in decoding output or the input ends on
14321 the PV of the ssv. The value which the offset points will be modified
14322 to the last input position on the ssv.
14324 Returns TRUE if the terminator was found, else returns FALSE.
14329 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
14330 SV *ssv, int *offset, char *tstr, int tlen)
14334 PERL_ARGS_ASSERT_SV_CAT_DECODE;
14336 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
14347 offsv = newSViv(*offset);
14349 mPUSHp(tstr, tlen);
14351 call_method("cat_decode", G_SCALAR);
14353 ret = SvTRUE(TOPs);
14354 *offset = SvIV(offsv);
14360 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
14365 /* ---------------------------------------------------------------------
14367 * support functions for report_uninit()
14370 /* the maxiumum size of array or hash where we will scan looking
14371 * for the undefined element that triggered the warning */
14373 #define FUV_MAX_SEARCH_SIZE 1000
14375 /* Look for an entry in the hash whose value has the same SV as val;
14376 * If so, return a mortal copy of the key. */
14379 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
14385 PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
14387 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
14388 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
14391 array = HvARRAY(hv);
14393 for (i=HvMAX(hv); i>=0; i--) {
14395 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
14396 if (HeVAL(entry) != val)
14398 if ( HeVAL(entry) == &PL_sv_undef ||
14399 HeVAL(entry) == &PL_sv_placeholder)
14403 if (HeKLEN(entry) == HEf_SVKEY)
14404 return sv_mortalcopy(HeKEY_sv(entry));
14405 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
14411 /* Look for an entry in the array whose value has the same SV as val;
14412 * If so, return the index, otherwise return -1. */
14415 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
14417 PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
14419 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
14420 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
14423 if (val != &PL_sv_undef) {
14424 SV ** const svp = AvARRAY(av);
14427 for (i=AvFILLp(av); i>=0; i--)
14434 /* varname(): return the name of a variable, optionally with a subscript.
14435 * If gv is non-zero, use the name of that global, along with gvtype (one
14436 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
14437 * targ. Depending on the value of the subscript_type flag, return:
14440 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
14441 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
14442 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
14443 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
14446 Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
14447 const SV *const keyname, I32 aindex, int subscript_type)
14450 SV * const name = sv_newmortal();
14451 if (gv && isGV(gv)) {
14453 buffer[0] = gvtype;
14456 /* as gv_fullname4(), but add literal '^' for $^FOO names */
14458 gv_fullname4(name, gv, buffer, 0);
14460 if ((unsigned int)SvPVX(name)[1] <= 26) {
14462 buffer[1] = SvPVX(name)[1] + 'A' - 1;
14464 /* Swap the 1 unprintable control character for the 2 byte pretty
14465 version - ie substr($name, 1, 1) = $buffer; */
14466 sv_insert(name, 1, 1, buffer, 2);
14470 CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL);
14474 assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
14476 if (!cv || !CvPADLIST(cv))
14478 av = *PadlistARRAY(CvPADLIST(cv));
14479 sv = *av_fetch(av, targ, FALSE);
14480 sv_setsv_flags(name, sv, 0);
14483 if (subscript_type == FUV_SUBSCRIPT_HASH) {
14484 SV * const sv = newSV(0);
14485 *SvPVX(name) = '$';
14486 Perl_sv_catpvf(aTHX_ name, "{%s}",
14487 pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL,
14488 PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT ));
14489 SvREFCNT_dec_NN(sv);
14491 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
14492 *SvPVX(name) = '$';
14493 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
14495 else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
14496 /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
14497 Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
14505 =for apidoc find_uninit_var
14507 Find the name of the undefined variable (if any) that caused the operator
14508 to issue a "Use of uninitialized value" warning.
14509 If match is true, only return a name if its value matches uninit_sv.
14510 So roughly speaking, if a unary operator (such as OP_COS) generates a
14511 warning, then following the direct child of the op may yield an
14512 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
14513 other hand, with OP_ADD there are two branches to follow, so we only print
14514 the variable name if we get an exact match.
14516 The name is returned as a mortal SV.
14518 Assumes that PL_op is the op that originally triggered the error, and that
14519 PL_comppad/PL_curpad points to the currently executing pad.
14525 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
14531 const OP *o, *o2, *kid;
14533 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
14534 uninit_sv == &PL_sv_placeholder)))
14537 switch (obase->op_type) {
14544 const bool pad = ( obase->op_type == OP_PADAV
14545 || obase->op_type == OP_PADHV
14546 || obase->op_type == OP_PADRANGE
14549 const bool hash = ( obase->op_type == OP_PADHV
14550 || obase->op_type == OP_RV2HV
14551 || (obase->op_type == OP_PADRANGE
14552 && SvTYPE(PAD_SVl(obase->op_targ)) == SVt_PVHV)
14556 int subscript_type = FUV_SUBSCRIPT_WITHIN;
14558 if (pad) { /* @lex, %lex */
14559 sv = PAD_SVl(obase->op_targ);
14563 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
14564 /* @global, %global */
14565 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
14568 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
14570 else if (obase == PL_op) /* @{expr}, %{expr} */
14571 return find_uninit_var(cUNOPx(obase)->op_first,
14573 else /* @{expr}, %{expr} as a sub-expression */
14577 /* attempt to find a match within the aggregate */
14579 keysv = find_hash_subscript((const HV*)sv, uninit_sv);
14581 subscript_type = FUV_SUBSCRIPT_HASH;
14584 index = find_array_subscript((const AV *)sv, uninit_sv);
14586 subscript_type = FUV_SUBSCRIPT_ARRAY;
14589 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
14592 return varname(gv, hash ? '%' : '@', obase->op_targ,
14593 keysv, index, subscript_type);
14597 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
14599 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
14600 if (!gv || !GvSTASH(gv))
14602 if (match && (GvSV(gv) != uninit_sv))
14604 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
14607 return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1);
14610 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
14612 return varname(NULL, '$', obase->op_targ,
14613 NULL, 0, FUV_SUBSCRIPT_NONE);
14616 gv = cGVOPx_gv(obase);
14617 if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv))
14619 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
14621 case OP_AELEMFAST_LEX:
14624 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
14625 if (!av || SvRMAGICAL(av))
14627 svp = av_fetch(av, (I8)obase->op_private, FALSE);
14628 if (!svp || *svp != uninit_sv)
14631 return varname(NULL, '$', obase->op_targ,
14632 NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY);
14635 gv = cGVOPx_gv(obase);
14640 AV *const av = GvAV(gv);
14641 if (!av || SvRMAGICAL(av))
14643 svp = av_fetch(av, (I8)obase->op_private, FALSE);
14644 if (!svp || *svp != uninit_sv)
14647 return varname(gv, '$', 0,
14648 NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY);
14650 NOT_REACHED; /* NOTREACHED */
14653 o = cUNOPx(obase)->op_first;
14654 if (!o || o->op_type != OP_NULL ||
14655 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
14657 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
14662 bool negate = FALSE;
14664 if (PL_op == obase)
14665 /* $a[uninit_expr] or $h{uninit_expr} */
14666 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
14669 o = cBINOPx(obase)->op_first;
14670 kid = cBINOPx(obase)->op_last;
14672 /* get the av or hv, and optionally the gv */
14674 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
14675 sv = PAD_SV(o->op_targ);
14677 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
14678 && cUNOPo->op_first->op_type == OP_GV)
14680 gv = cGVOPx_gv(cUNOPo->op_first);
14684 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
14689 if (kid && kid->op_type == OP_NEGATE) {
14691 kid = cUNOPx(kid)->op_first;
14694 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
14695 /* index is constant */
14698 kidsv = sv_2mortal(newSVpvs("-"));
14699 sv_catsv(kidsv, cSVOPx_sv(kid));
14702 kidsv = cSVOPx_sv(kid);
14706 if (obase->op_type == OP_HELEM) {
14707 HE* he = hv_fetch_ent(MUTABLE_HV(sv), kidsv, 0, 0);
14708 if (!he || HeVAL(he) != uninit_sv)
14712 SV * const opsv = cSVOPx_sv(kid);
14713 const IV opsviv = SvIV(opsv);
14714 SV * const * const svp = av_fetch(MUTABLE_AV(sv),
14715 negate ? - opsviv : opsviv,
14717 if (!svp || *svp != uninit_sv)
14721 if (obase->op_type == OP_HELEM)
14722 return varname(gv, '%', o->op_targ,
14723 kidsv, 0, FUV_SUBSCRIPT_HASH);
14725 return varname(gv, '@', o->op_targ, NULL,
14726 negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)),
14727 FUV_SUBSCRIPT_ARRAY);
14730 /* index is an expression;
14731 * attempt to find a match within the aggregate */
14732 if (obase->op_type == OP_HELEM) {
14733 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
14735 return varname(gv, '%', o->op_targ,
14736 keysv, 0, FUV_SUBSCRIPT_HASH);
14740 = find_array_subscript((const AV *)sv, uninit_sv);
14742 return varname(gv, '@', o->op_targ,
14743 NULL, index, FUV_SUBSCRIPT_ARRAY);
14748 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
14750 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
14752 NOT_REACHED; /* NOTREACHED */
14756 /* only examine RHS */
14757 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
14760 o = cUNOPx(obase)->op_first;
14761 if ( o->op_type == OP_PUSHMARK
14762 || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)
14766 if (!OP_HAS_SIBLING(o)) {
14767 /* one-arg version of open is highly magical */
14769 if (o->op_type == OP_GV) { /* open FOO; */
14771 if (match && GvSV(gv) != uninit_sv)
14773 return varname(gv, '$', 0,
14774 NULL, 0, FUV_SUBSCRIPT_NONE);
14776 /* other possibilities not handled are:
14777 * open $x; or open my $x; should return '${*$x}'
14778 * open expr; should return '$'.expr ideally
14784 /* ops where $_ may be an implicit arg */
14789 if ( !(obase->op_flags & OPf_STACKED)) {
14790 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
14791 ? PAD_SVl(obase->op_targ)
14794 sv = sv_newmortal();
14795 sv_setpvs(sv, "$_");
14804 match = 1; /* print etc can return undef on defined args */
14805 /* skip filehandle as it can't produce 'undef' warning */
14806 o = cUNOPx(obase)->op_first;
14807 if ((obase->op_flags & OPf_STACKED)
14809 ( o->op_type == OP_PUSHMARK
14810 || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)))
14811 o = OP_SIBLING(OP_SIBLING(o));
14815 case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
14816 case OP_CUSTOM: /* XS or custom code could trigger random warnings */
14818 /* the following ops are capable of returning PL_sv_undef even for
14819 * defined arg(s) */
14838 case OP_GETPEERNAME:
14886 case OP_SMARTMATCH:
14895 /* XXX tmp hack: these two may call an XS sub, and currently
14896 XS subs don't have a SUB entry on the context stack, so CV and
14897 pad determination goes wrong, and BAD things happen. So, just
14898 don't try to determine the value under those circumstances.
14899 Need a better fix at dome point. DAPM 11/2007 */
14905 GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
14906 if (gv && GvSV(gv) == uninit_sv)
14907 return newSVpvs_flags("$.", SVs_TEMP);
14912 /* def-ness of rval pos() is independent of the def-ness of its arg */
14913 if ( !(obase->op_flags & OPf_MOD))
14918 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
14919 return newSVpvs_flags("${$/}", SVs_TEMP);
14924 if (!(obase->op_flags & OPf_KIDS))
14926 o = cUNOPx(obase)->op_first;
14932 /* This loop checks all the kid ops, skipping any that cannot pos-
14933 * sibly be responsible for the uninitialized value; i.e., defined
14934 * constants and ops that return nothing. If there is only one op
14935 * left that is not skipped, then we *know* it is responsible for
14936 * the uninitialized value. If there is more than one op left, we
14937 * have to look for an exact match in the while() loop below.
14938 * Note that we skip padrange, because the individual pad ops that
14939 * it replaced are still in the tree, so we work on them instead.
14942 for (kid=o; kid; kid = OP_SIBLING(kid)) {
14943 const OPCODE type = kid->op_type;
14944 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
14945 || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
14946 || (type == OP_PUSHMARK)
14947 || (type == OP_PADRANGE)
14951 if (o2) { /* more than one found */
14958 return find_uninit_var(o2, uninit_sv, match);
14960 /* scan all args */
14962 sv = find_uninit_var(o, uninit_sv, 1);
14974 =for apidoc report_uninit
14976 Print appropriate "Use of uninitialized variable" warning.
14982 Perl_report_uninit(pTHX_ const SV *uninit_sv)
14985 SV* varname = NULL;
14986 if (uninit_sv && PL_curpad) {
14987 varname = find_uninit_var(PL_op, uninit_sv,0);
14989 sv_insert(varname, 0, 0, " ", 1);
14991 /* PL_warn_uninit_sv is constant */
14992 GCC_DIAG_IGNORE(-Wformat-nonliteral);
14993 /* diag_listed_as: Use of uninitialized value%s */
14994 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
14995 SVfARG(varname ? varname : &PL_sv_no),
14996 " in ", OP_DESC(PL_op));
15000 /* PL_warn_uninit is constant */
15001 GCC_DIAG_IGNORE(-Wformat-nonliteral);
15002 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
15010 * c-indentation-style: bsd
15011 * c-basic-offset: 4
15012 * indent-tabs-mode: nil
15015 * ex: set ts=8 sts=4 sw=4 et: