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 /* Missing proto on LynxOS */
40 char *gconvert(double, int, int, char *);
44 # define SNPRINTF_G(nv, buffer, size, ndig) \
45 quadmath_snprintf(buffer, size, "%.*Qg", (int)ndig, (NV)(nv))
47 # define SNPRINTF_G(nv, buffer, size, ndig) \
48 PERL_UNUSED_RESULT(Gconvert((NV)(nv), (int)ndig, 0, buffer))
51 #ifndef SV_COW_THRESHOLD
52 # define SV_COW_THRESHOLD 0 /* COW iff len > K */
54 #ifndef SV_COWBUF_THRESHOLD
55 # define SV_COWBUF_THRESHOLD 1250 /* COW iff len > K */
57 #ifndef SV_COW_MAX_WASTE_THRESHOLD
58 # define SV_COW_MAX_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */
60 #ifndef SV_COWBUF_WASTE_THRESHOLD
61 # define SV_COWBUF_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */
63 #ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD
64 # define SV_COW_MAX_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */
66 #ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD
67 # define SV_COWBUF_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */
69 /* Work around compiler warnings about unsigned >= THRESHOLD when thres-
72 # define GE_COW_THRESHOLD(cur) ((cur) >= SV_COW_THRESHOLD)
74 # define GE_COW_THRESHOLD(cur) 1
76 #if SV_COWBUF_THRESHOLD
77 # define GE_COWBUF_THRESHOLD(cur) ((cur) >= SV_COWBUF_THRESHOLD)
79 # define GE_COWBUF_THRESHOLD(cur) 1
81 #if SV_COW_MAX_WASTE_THRESHOLD
82 # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COW_MAX_WASTE_THRESHOLD)
84 # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) 1
86 #if SV_COWBUF_WASTE_THRESHOLD
87 # define GE_COWBUF_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COWBUF_WASTE_THRESHOLD)
89 # define GE_COWBUF_WASTE_THRESHOLD(cur,len) 1
91 #if SV_COW_MAX_WASTE_FACTOR_THRESHOLD
92 # define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COW_MAX_WASTE_FACTOR_THRESHOLD * (cur))
94 # define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) 1
96 #if SV_COWBUF_WASTE_FACTOR_THRESHOLD
97 # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COWBUF_WASTE_FACTOR_THRESHOLD * (cur))
99 # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) 1
102 #define CHECK_COW_THRESHOLD(cur,len) (\
103 GE_COW_THRESHOLD((cur)) && \
104 GE_COW_MAX_WASTE_THRESHOLD((cur),(len)) && \
105 GE_COW_MAX_WASTE_FACTOR_THRESHOLD((cur),(len)) \
107 #define CHECK_COWBUF_THRESHOLD(cur,len) (\
108 GE_COWBUF_THRESHOLD((cur)) && \
109 GE_COWBUF_WASTE_THRESHOLD((cur),(len)) && \
110 GE_COWBUF_WASTE_FACTOR_THRESHOLD((cur),(len)) \
113 #ifdef PERL_UTF8_CACHE_ASSERT
114 /* if adding more checks watch out for the following tests:
115 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
116 * lib/utf8.t lib/Unicode/Collate/t/index.t
119 # define ASSERT_UTF8_CACHE(cache) \
120 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
121 assert((cache)[2] <= (cache)[3]); \
122 assert((cache)[3] <= (cache)[1]);} \
125 # define ASSERT_UTF8_CACHE(cache) NOOP
128 static const char S_destroy[] = "DESTROY";
129 #define S_destroy_len (sizeof(S_destroy)-1)
131 /* ============================================================================
133 =head1 Allocation and deallocation of SVs.
134 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
135 sv, av, hv...) contains type and reference count information, and for
136 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
137 contains fields specific to each type. Some types store all they need
138 in the head, so don't have a body.
140 In all but the most memory-paranoid configurations (ex: PURIFY), heads
141 and bodies are allocated out of arenas, which by default are
142 approximately 4K chunks of memory parcelled up into N heads or bodies.
143 Sv-bodies are allocated by their sv-type, guaranteeing size
144 consistency needed to allocate safely from arrays.
146 For SV-heads, the first slot in each arena is reserved, and holds a
147 link to the next arena, some flags, and a note of the number of slots.
148 Snaked through each arena chain is a linked list of free items; when
149 this becomes empty, an extra arena is allocated and divided up into N
150 items which are threaded into the free list.
152 SV-bodies are similar, but they use arena-sets by default, which
153 separate the link and info from the arena itself, and reclaim the 1st
154 slot in the arena. SV-bodies are further described later.
156 The following global variables are associated with arenas:
158 PL_sv_arenaroot pointer to list of SV arenas
159 PL_sv_root pointer to list of free SV structures
161 PL_body_arenas head of linked-list of body arenas
162 PL_body_roots[] array of pointers to list of free bodies of svtype
163 arrays are indexed by the svtype needed
165 A few special SV heads are not allocated from an arena, but are
166 instead directly created in the interpreter structure, eg PL_sv_undef.
167 The size of arenas can be changed from the default by setting
168 PERL_ARENA_SIZE appropriately at compile time.
170 The SV arena serves the secondary purpose of allowing still-live SVs
171 to be located and destroyed during final cleanup.
173 At the lowest level, the macros new_SV() and del_SV() grab and free
174 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
175 to return the SV to the free list with error checking.) new_SV() calls
176 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
177 SVs in the free list have their SvTYPE field set to all ones.
179 At the time of very final cleanup, sv_free_arenas() is called from
180 perl_destruct() to physically free all the arenas allocated since the
181 start of the interpreter.
183 The function visit() scans the SV arenas list, and calls a specified
184 function for each SV it finds which is still live - ie which has an SvTYPE
185 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
186 following functions (specified as [function that calls visit()] / [function
187 called by visit() for each SV]):
189 sv_report_used() / do_report_used()
190 dump all remaining SVs (debugging aid)
192 sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
193 do_clean_named_io_objs(),do_curse()
194 Attempt to free all objects pointed to by RVs,
195 try to do the same for all objects indir-
196 ectly referenced by typeglobs too, and
197 then do a final sweep, cursing any
198 objects that remain. Called once from
199 perl_destruct(), prior to calling sv_clean_all()
202 sv_clean_all() / do_clean_all()
203 SvREFCNT_dec(sv) each remaining SV, possibly
204 triggering an sv_free(). It also sets the
205 SVf_BREAK flag on the SV to indicate that the
206 refcnt has been artificially lowered, and thus
207 stopping sv_free() from giving spurious warnings
208 about SVs which unexpectedly have a refcnt
209 of zero. called repeatedly from perl_destruct()
210 until there are no SVs left.
212 =head2 Arena allocator API Summary
214 Private API to rest of sv.c
218 new_XPVNV(), del_XPVGV(),
223 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
227 * ========================================================================= */
230 * "A time to plant, and a time to uproot what was planted..."
234 # define MEM_LOG_NEW_SV(sv, file, line, func) \
235 Perl_mem_log_new_sv(sv, file, line, func)
236 # define MEM_LOG_DEL_SV(sv, file, line, func) \
237 Perl_mem_log_del_sv(sv, file, line, func)
239 # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP
240 # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP
243 #ifdef DEBUG_LEAKING_SCALARS
244 # define FREE_SV_DEBUG_FILE(sv) STMT_START { \
245 if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \
247 # define DEBUG_SV_SERIAL(sv) \
248 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
249 PTR2UV(sv), (long)(sv)->sv_debug_serial))
251 # define FREE_SV_DEBUG_FILE(sv)
252 # define DEBUG_SV_SERIAL(sv) NOOP
256 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
257 # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val))
258 /* Whilst I'd love to do this, it seems that things like to check on
260 # define POISON_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
262 # define POISON_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
263 PoisonNew(&SvREFCNT(sv), 1, U32)
265 # define SvARENA_CHAIN(sv) SvANY(sv)
266 # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val)
267 # define POISON_SV_HEAD(sv)
270 /* Mark an SV head as unused, and add to free list.
272 * If SVf_BREAK is set, skip adding it to the free list, as this SV had
273 * its refcount artificially decremented during global destruction, so
274 * there may be dangling pointers to it. The last thing we want in that
275 * case is for it to be reused. */
277 #define plant_SV(p) \
279 const U32 old_flags = SvFLAGS(p); \
280 MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
281 DEBUG_SV_SERIAL(p); \
282 FREE_SV_DEBUG_FILE(p); \
284 SvFLAGS(p) = SVTYPEMASK; \
285 if (!(old_flags & SVf_BREAK)) { \
286 SvARENA_CHAIN_SET(p, PL_sv_root); \
292 #define uproot_SV(p) \
295 PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \
300 /* make some more SVs by adding another arena */
306 char *chunk; /* must use New here to match call to */
307 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
308 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
313 /* new_SV(): return a new, empty SV head */
315 #ifdef DEBUG_LEAKING_SCALARS
316 /* provide a real function for a debugger to play with */
318 S_new_SV(pTHX_ const char *file, int line, const char *func)
325 sv = S_more_sv(aTHX);
329 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
330 sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
336 sv->sv_debug_inpad = 0;
337 sv->sv_debug_parent = NULL;
338 sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
340 sv->sv_debug_serial = PL_sv_serial++;
342 MEM_LOG_NEW_SV(sv, file, line, func);
343 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
344 PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
348 # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
356 (p) = S_more_sv(aTHX); \
360 MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \
365 /* del_SV(): return an empty SV head to the free list */
378 S_del_sv(pTHX_ SV *p)
380 PERL_ARGS_ASSERT_DEL_SV;
385 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
386 const SV * const sv = sva + 1;
387 const SV * const svend = &sva[SvREFCNT(sva)];
388 if (p >= sv && p < svend) {
394 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
395 "Attempt to free non-arena SV: 0x%"UVxf
396 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
403 #else /* ! DEBUGGING */
405 #define del_SV(p) plant_SV(p)
407 #endif /* DEBUGGING */
411 =head1 SV Manipulation Functions
413 =for apidoc sv_add_arena
415 Given a chunk of memory, link it to the head of the list of arenas,
416 and split it into a list of free SVs.
422 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
424 SV *const sva = MUTABLE_SV(ptr);
428 PERL_ARGS_ASSERT_SV_ADD_ARENA;
430 /* The first SV in an arena isn't an SV. */
431 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
432 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
433 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
435 PL_sv_arenaroot = sva;
436 PL_sv_root = sva + 1;
438 svend = &sva[SvREFCNT(sva) - 1];
441 SvARENA_CHAIN_SET(sv, (sv + 1));
445 /* Must always set typemask because it's always checked in on cleanup
446 when the arenas are walked looking for objects. */
447 SvFLAGS(sv) = SVTYPEMASK;
450 SvARENA_CHAIN_SET(sv, 0);
454 SvFLAGS(sv) = SVTYPEMASK;
457 /* visit(): call the named function for each non-free SV in the arenas
458 * whose flags field matches the flags/mask args. */
461 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
466 PERL_ARGS_ASSERT_VISIT;
468 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
469 const SV * const svend = &sva[SvREFCNT(sva)];
471 for (sv = sva + 1; sv < svend; ++sv) {
472 if (SvTYPE(sv) != (svtype)SVTYPEMASK
473 && (sv->sv_flags & mask) == flags
486 /* called by sv_report_used() for each live SV */
489 do_report_used(pTHX_ SV *const sv)
491 if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
492 PerlIO_printf(Perl_debug_log, "****\n");
499 =for apidoc sv_report_used
501 Dump the contents of all SVs not yet freed (debugging aid).
507 Perl_sv_report_used(pTHX)
510 visit(do_report_used, 0, 0);
516 /* called by sv_clean_objs() for each live SV */
519 do_clean_objs(pTHX_ SV *const ref)
523 SV * const target = SvRV(ref);
524 if (SvOBJECT(target)) {
525 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
526 if (SvWEAKREF(ref)) {
527 sv_del_backref(target, ref);
533 SvREFCNT_dec_NN(target);
540 /* clear any slots in a GV which hold objects - except IO;
541 * called by sv_clean_objs() for each live GV */
544 do_clean_named_objs(pTHX_ SV *const sv)
547 assert(SvTYPE(sv) == SVt_PVGV);
548 assert(isGV_with_GP(sv));
552 /* freeing GP entries may indirectly free the current GV;
553 * hold onto it while we mess with the GP slots */
556 if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
557 DEBUG_D((PerlIO_printf(Perl_debug_log,
558 "Cleaning named glob SV object:\n "), sv_dump(obj)));
560 SvREFCNT_dec_NN(obj);
562 if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
563 DEBUG_D((PerlIO_printf(Perl_debug_log,
564 "Cleaning named glob AV object:\n "), sv_dump(obj)));
566 SvREFCNT_dec_NN(obj);
568 if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
569 DEBUG_D((PerlIO_printf(Perl_debug_log,
570 "Cleaning named glob HV object:\n "), sv_dump(obj)));
572 SvREFCNT_dec_NN(obj);
574 if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
575 DEBUG_D((PerlIO_printf(Perl_debug_log,
576 "Cleaning named glob CV object:\n "), sv_dump(obj)));
578 SvREFCNT_dec_NN(obj);
580 SvREFCNT_dec_NN(sv); /* undo the inc above */
583 /* clear any IO slots in a GV which hold objects (except stderr, defout);
584 * called by sv_clean_objs() for each live GV */
587 do_clean_named_io_objs(pTHX_ SV *const sv)
590 assert(SvTYPE(sv) == SVt_PVGV);
591 assert(isGV_with_GP(sv));
592 if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
596 if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
597 DEBUG_D((PerlIO_printf(Perl_debug_log,
598 "Cleaning named glob IO object:\n "), sv_dump(obj)));
600 SvREFCNT_dec_NN(obj);
602 SvREFCNT_dec_NN(sv); /* undo the inc above */
605 /* Void wrapper to pass to visit() */
607 do_curse(pTHX_ SV * const sv) {
608 if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
609 || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
615 =for apidoc sv_clean_objs
617 Attempt to destroy all objects not yet freed.
623 Perl_sv_clean_objs(pTHX)
626 PL_in_clean_objs = TRUE;
627 visit(do_clean_objs, SVf_ROK, SVf_ROK);
628 /* Some barnacles may yet remain, clinging to typeglobs.
629 * Run the non-IO destructors first: they may want to output
630 * error messages, close files etc */
631 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
632 visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
633 /* And if there are some very tenacious barnacles clinging to arrays,
634 closures, or what have you.... */
635 visit(do_curse, SVs_OBJECT, SVs_OBJECT);
636 olddef = PL_defoutgv;
637 PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
638 if (olddef && isGV_with_GP(olddef))
639 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
640 olderr = PL_stderrgv;
641 PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
642 if (olderr && isGV_with_GP(olderr))
643 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
644 SvREFCNT_dec(olddef);
645 PL_in_clean_objs = FALSE;
648 /* called by sv_clean_all() for each live SV */
651 do_clean_all(pTHX_ SV *const sv)
653 if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
654 /* don't clean pid table and strtab */
657 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
658 SvFLAGS(sv) |= SVf_BREAK;
663 =for apidoc sv_clean_all
665 Decrement the refcnt of each remaining SV, possibly triggering a
666 cleanup. This function may have to be called multiple times to free
667 SVs which are in complex self-referential hierarchies.
673 Perl_sv_clean_all(pTHX)
676 PL_in_clean_all = TRUE;
677 cleaned = visit(do_clean_all, 0,0);
682 ARENASETS: a meta-arena implementation which separates arena-info
683 into struct arena_set, which contains an array of struct
684 arena_descs, each holding info for a single arena. By separating
685 the meta-info from the arena, we recover the 1st slot, formerly
686 borrowed for list management. The arena_set is about the size of an
687 arena, avoiding the needless malloc overhead of a naive linked-list.
689 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
690 memory in the last arena-set (1/2 on average). In trade, we get
691 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
692 smaller types). The recovery of the wasted space allows use of
693 small arenas for large, rare body types, by changing array* fields
694 in body_details_by_type[] below.
697 char *arena; /* the raw storage, allocated aligned */
698 size_t size; /* its size ~4k typ */
699 svtype utype; /* bodytype stored in arena */
704 /* Get the maximum number of elements in set[] such that struct arena_set
705 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
706 therefore likely to be 1 aligned memory page. */
708 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
709 - 2 * sizeof(int)) / sizeof (struct arena_desc))
712 struct arena_set* next;
713 unsigned int set_size; /* ie ARENAS_PER_SET */
714 unsigned int curr; /* index of next available arena-desc */
715 struct arena_desc set[ARENAS_PER_SET];
719 =for apidoc sv_free_arenas
721 Deallocate the memory used by all arenas. Note that all the individual SV
722 heads and bodies within the arenas must already have been freed.
728 Perl_sv_free_arenas(pTHX)
734 /* Free arenas here, but be careful about fake ones. (We assume
735 contiguity of the fake ones with the corresponding real ones.) */
737 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
738 svanext = MUTABLE_SV(SvANY(sva));
739 while (svanext && SvFAKE(svanext))
740 svanext = MUTABLE_SV(SvANY(svanext));
747 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
750 struct arena_set *current = aroot;
753 assert(aroot->set[i].arena);
754 Safefree(aroot->set[i].arena);
762 i = PERL_ARENA_ROOTS_SIZE;
764 PL_body_roots[i] = 0;
771 Here are mid-level routines that manage the allocation of bodies out
772 of the various arenas. There are 5 kinds of arenas:
774 1. SV-head arenas, which are discussed and handled above
775 2. regular body arenas
776 3. arenas for reduced-size bodies
779 Arena types 2 & 3 are chained by body-type off an array of
780 arena-root pointers, which is indexed by svtype. Some of the
781 larger/less used body types are malloced singly, since a large
782 unused block of them is wasteful. Also, several svtypes dont have
783 bodies; the data fits into the sv-head itself. The arena-root
784 pointer thus has a few unused root-pointers (which may be hijacked
785 later for arena types 4,5)
787 3 differs from 2 as an optimization; some body types have several
788 unused fields in the front of the structure (which are kept in-place
789 for consistency). These bodies can be allocated in smaller chunks,
790 because the leading fields arent accessed. Pointers to such bodies
791 are decremented to point at the unused 'ghost' memory, knowing that
792 the pointers are used with offsets to the real memory.
795 =head1 SV-Body Allocation
799 Allocation of SV-bodies is similar to SV-heads, differing as follows;
800 the allocation mechanism is used for many body types, so is somewhat
801 more complicated, it uses arena-sets, and has no need for still-live
804 At the outermost level, (new|del)_X*V macros return bodies of the
805 appropriate type. These macros call either (new|del)_body_type or
806 (new|del)_body_allocated macro pairs, depending on specifics of the
807 type. Most body types use the former pair, the latter pair is used to
808 allocate body types with "ghost fields".
810 "ghost fields" are fields that are unused in certain types, and
811 consequently don't need to actually exist. They are declared because
812 they're part of a "base type", which allows use of functions as
813 methods. The simplest examples are AVs and HVs, 2 aggregate types
814 which don't use the fields which support SCALAR semantics.
816 For these types, the arenas are carved up into appropriately sized
817 chunks, we thus avoid wasted memory for those unaccessed members.
818 When bodies are allocated, we adjust the pointer back in memory by the
819 size of the part not allocated, so it's as if we allocated the full
820 structure. (But things will all go boom if you write to the part that
821 is "not there", because you'll be overwriting the last members of the
822 preceding structure in memory.)
824 We calculate the correction using the STRUCT_OFFSET macro on the first
825 member present. If the allocated structure is smaller (no initial NV
826 actually allocated) then the net effect is to subtract the size of the NV
827 from the pointer, to return a new pointer as if an initial NV were actually
828 allocated. (We were using structures named *_allocated for this, but
829 this turned out to be a subtle bug, because a structure without an NV
830 could have a lower alignment constraint, but the compiler is allowed to
831 optimised accesses based on the alignment constraint of the actual pointer
832 to the full structure, for example, using a single 64 bit load instruction
833 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
835 This is the same trick as was used for NV and IV bodies. Ironically it
836 doesn't need to be used for NV bodies any more, because NV is now at
837 the start of the structure. IV bodies, and also in some builds NV bodies,
838 don't need it either, because they are no longer allocated.
840 In turn, the new_body_* allocators call S_new_body(), which invokes
841 new_body_inline macro, which takes a lock, and takes a body off the
842 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
843 necessary to refresh an empty list. Then the lock is released, and
844 the body is returned.
846 Perl_more_bodies allocates a new arena, and carves it up into an array of N
847 bodies, which it strings into a linked list. It looks up arena-size
848 and body-size from the body_details table described below, thus
849 supporting the multiple body-types.
851 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
852 the (new|del)_X*V macros are mapped directly to malloc/free.
854 For each sv-type, struct body_details bodies_by_type[] carries
855 parameters which control these aspects of SV handling:
857 Arena_size determines whether arenas are used for this body type, and if
858 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
859 zero, forcing individual mallocs and frees.
861 Body_size determines how big a body is, and therefore how many fit into
862 each arena. Offset carries the body-pointer adjustment needed for
863 "ghost fields", and is used in *_allocated macros.
865 But its main purpose is to parameterize info needed in
866 Perl_sv_upgrade(). The info here dramatically simplifies the function
867 vs the implementation in 5.8.8, making it table-driven. All fields
868 are used for this, except for arena_size.
870 For the sv-types that have no bodies, arenas are not used, so those
871 PL_body_roots[sv_type] are unused, and can be overloaded. In
872 something of a special case, SVt_NULL is borrowed for HE arenas;
873 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
874 bodies_by_type[SVt_NULL] slot is not used, as the table is not
879 struct body_details {
880 U8 body_size; /* Size to allocate */
881 U8 copy; /* Size of structure to copy (may be shorter) */
882 U8 offset; /* Size of unalloced ghost fields to first alloced field*/
883 PERL_BITFIELD8 type : 4; /* We have space for a sanity check. */
884 PERL_BITFIELD8 cant_upgrade : 1;/* Cannot upgrade this type */
885 PERL_BITFIELD8 zero_nv : 1; /* zero the NV when upgrading from this */
886 PERL_BITFIELD8 arena : 1; /* Allocated from an arena */
887 U32 arena_size; /* Size of arena to allocate */
895 /* With -DPURFIY we allocate everything directly, and don't use arenas.
896 This seems a rather elegant way to simplify some of the code below. */
897 #define HASARENA FALSE
899 #define HASARENA TRUE
901 #define NOARENA FALSE
903 /* Size the arenas to exactly fit a given number of bodies. A count
904 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
905 simplifying the default. If count > 0, the arena is sized to fit
906 only that many bodies, allowing arenas to be used for large, rare
907 bodies (XPVFM, XPVIO) without undue waste. The arena size is
908 limited by PERL_ARENA_SIZE, so we can safely oversize the
911 #define FIT_ARENA0(body_size) \
912 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
913 #define FIT_ARENAn(count,body_size) \
914 ( count * body_size <= PERL_ARENA_SIZE) \
915 ? count * body_size \
916 : FIT_ARENA0 (body_size)
917 #define FIT_ARENA(count,body_size) \
919 ? FIT_ARENAn (count, body_size) \
920 : FIT_ARENA0 (body_size))
922 /* Calculate the length to copy. Specifically work out the length less any
923 final padding the compiler needed to add. See the comment in sv_upgrade
924 for why copying the padding proved to be a bug. */
926 #define copy_length(type, last_member) \
927 STRUCT_OFFSET(type, last_member) \
928 + sizeof (((type*)SvANY((const SV *)0))->last_member)
930 static const struct body_details bodies_by_type[] = {
931 /* HEs use this offset for their arena. */
932 { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
934 /* IVs are in the head, so the allocation size is 0. */
936 sizeof(IV), /* This is used to copy out the IV body. */
937 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
938 NOARENA /* IVS don't need an arena */, 0
943 STRUCT_OFFSET(XPVNV, xnv_u),
944 SVt_NV, FALSE, HADNV, NOARENA, 0 },
946 { sizeof(NV), sizeof(NV),
947 STRUCT_OFFSET(XPVNV, xnv_u),
948 SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
951 { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
952 copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
953 + STRUCT_OFFSET(XPV, xpv_cur),
954 SVt_PV, FALSE, NONV, HASARENA,
955 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
957 { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur),
958 copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur),
959 + STRUCT_OFFSET(XPV, xpv_cur),
960 SVt_INVLIST, TRUE, NONV, HASARENA,
961 FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) },
963 { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
964 copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
965 + STRUCT_OFFSET(XPV, xpv_cur),
966 SVt_PVIV, FALSE, NONV, HASARENA,
967 FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
969 { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
970 copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
971 + STRUCT_OFFSET(XPV, xpv_cur),
972 SVt_PVNV, FALSE, HADNV, HASARENA,
973 FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
975 { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
976 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
981 SVt_REGEXP, TRUE, NONV, HASARENA,
982 FIT_ARENA(0, sizeof(regexp))
985 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
986 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
988 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
989 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
992 copy_length(XPVAV, xav_alloc),
994 SVt_PVAV, TRUE, NONV, HASARENA,
995 FIT_ARENA(0, sizeof(XPVAV)) },
998 copy_length(XPVHV, xhv_max),
1000 SVt_PVHV, TRUE, NONV, HASARENA,
1001 FIT_ARENA(0, sizeof(XPVHV)) },
1006 SVt_PVCV, TRUE, NONV, HASARENA,
1007 FIT_ARENA(0, sizeof(XPVCV)) },
1012 SVt_PVFM, TRUE, NONV, NOARENA,
1013 FIT_ARENA(20, sizeof(XPVFM)) },
1018 SVt_PVIO, TRUE, NONV, HASARENA,
1019 FIT_ARENA(24, sizeof(XPVIO)) },
1022 #define new_body_allocated(sv_type) \
1023 (void *)((char *)S_new_body(aTHX_ sv_type) \
1024 - bodies_by_type[sv_type].offset)
1026 /* return a thing to the free list */
1028 #define del_body(thing, root) \
1030 void ** const thing_copy = (void **)thing; \
1031 *thing_copy = *root; \
1032 *root = (void*)thing_copy; \
1036 #if !(NVSIZE <= IVSIZE)
1037 # define new_XNV() safemalloc(sizeof(XPVNV))
1039 #define new_XPVNV() safemalloc(sizeof(XPVNV))
1040 #define new_XPVMG() safemalloc(sizeof(XPVMG))
1042 #define del_XPVGV(p) safefree(p)
1046 #if !(NVSIZE <= IVSIZE)
1047 # define new_XNV() new_body_allocated(SVt_NV)
1049 #define new_XPVNV() new_body_allocated(SVt_PVNV)
1050 #define new_XPVMG() new_body_allocated(SVt_PVMG)
1052 #define del_XPVGV(p) del_body(p + bodies_by_type[SVt_PVGV].offset, \
1053 &PL_body_roots[SVt_PVGV])
1057 /* no arena for you! */
1059 #define new_NOARENA(details) \
1060 safemalloc((details)->body_size + (details)->offset)
1061 #define new_NOARENAZ(details) \
1062 safecalloc((details)->body_size + (details)->offset, 1)
1065 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
1066 const size_t arena_size)
1068 void ** const root = &PL_body_roots[sv_type];
1069 struct arena_desc *adesc;
1070 struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1074 const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1075 #if defined(DEBUGGING) && defined(PERL_GLOBAL_STRUCT)
1078 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1079 static bool done_sanity_check;
1081 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1082 * variables like done_sanity_check. */
1083 if (!done_sanity_check) {
1084 unsigned int i = SVt_LAST;
1086 done_sanity_check = TRUE;
1089 assert (bodies_by_type[i].type == i);
1095 /* may need new arena-set to hold new arena */
1096 if (!aroot || aroot->curr >= aroot->set_size) {
1097 struct arena_set *newroot;
1098 Newxz(newroot, 1, struct arena_set);
1099 newroot->set_size = ARENAS_PER_SET;
1100 newroot->next = aroot;
1102 PL_body_arenas = (void *) newroot;
1103 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1106 /* ok, now have arena-set with at least 1 empty/available arena-desc */
1107 curr = aroot->curr++;
1108 adesc = &(aroot->set[curr]);
1109 assert(!adesc->arena);
1111 Newx(adesc->arena, good_arena_size, char);
1112 adesc->size = good_arena_size;
1113 adesc->utype = sv_type;
1114 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
1115 curr, (void*)adesc->arena, (UV)good_arena_size));
1117 start = (char *) adesc->arena;
1119 /* Get the address of the byte after the end of the last body we can fit.
1120 Remember, this is integer division: */
1121 end = start + good_arena_size / body_size * body_size;
1123 /* computed count doesn't reflect the 1st slot reservation */
1124 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1125 DEBUG_m(PerlIO_printf(Perl_debug_log,
1126 "arena %p end %p arena-size %d (from %d) type %d "
1128 (void*)start, (void*)end, (int)good_arena_size,
1129 (int)arena_size, sv_type, (int)body_size,
1130 (int)good_arena_size / (int)body_size));
1132 DEBUG_m(PerlIO_printf(Perl_debug_log,
1133 "arena %p end %p arena-size %d type %d size %d ct %d\n",
1134 (void*)start, (void*)end,
1135 (int)arena_size, sv_type, (int)body_size,
1136 (int)good_arena_size / (int)body_size));
1138 *root = (void *)start;
1141 /* Where the next body would start: */
1142 char * const next = start + body_size;
1145 /* This is the last body: */
1146 assert(next == end);
1148 *(void **)start = 0;
1152 *(void**) start = (void *)next;
1157 /* grab a new thing from the free list, allocating more if necessary.
1158 The inline version is used for speed in hot routines, and the
1159 function using it serves the rest (unless PURIFY).
1161 #define new_body_inline(xpv, sv_type) \
1163 void ** const r3wt = &PL_body_roots[sv_type]; \
1164 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
1165 ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1166 bodies_by_type[sv_type].body_size,\
1167 bodies_by_type[sv_type].arena_size)); \
1168 *(r3wt) = *(void**)(xpv); \
1174 S_new_body(pTHX_ const svtype sv_type)
1177 new_body_inline(xpv, sv_type);
1183 static const struct body_details fake_rv =
1184 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1187 =for apidoc sv_upgrade
1189 Upgrade an SV to a more complex form. Generally adds a new body type to the
1190 SV, then copies across as much information as possible from the old body.
1191 It croaks if the SV is already in a more complex form than requested. You
1192 generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
1193 before calling C<sv_upgrade>, and hence does not croak. See also
1200 Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
1204 const svtype old_type = SvTYPE(sv);
1205 const struct body_details *new_type_details;
1206 const struct body_details *old_type_details
1207 = bodies_by_type + old_type;
1208 SV *referant = NULL;
1210 PERL_ARGS_ASSERT_SV_UPGRADE;
1212 if (old_type == new_type)
1215 /* This clause was purposefully added ahead of the early return above to
1216 the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1217 inference by Nick I-S that it would fix other troublesome cases. See
1218 changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1220 Given that shared hash key scalars are no longer PVIV, but PV, there is
1221 no longer need to unshare so as to free up the IVX slot for its proper
1222 purpose. So it's safe to move the early return earlier. */
1224 if (new_type > SVt_PVMG && SvIsCOW(sv)) {
1225 sv_force_normal_flags(sv, 0);
1228 old_body = SvANY(sv);
1230 /* Copying structures onto other structures that have been neatly zeroed
1231 has a subtle gotcha. Consider XPVMG
1233 +------+------+------+------+------+-------+-------+
1234 | NV | CUR | LEN | IV | MAGIC | STASH |
1235 +------+------+------+------+------+-------+-------+
1236 0 4 8 12 16 20 24 28
1238 where NVs are aligned to 8 bytes, so that sizeof that structure is
1239 actually 32 bytes long, with 4 bytes of padding at the end:
1241 +------+------+------+------+------+-------+-------+------+
1242 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1243 +------+------+------+------+------+-------+-------+------+
1244 0 4 8 12 16 20 24 28 32
1246 so what happens if you allocate memory for this structure:
1248 +------+------+------+------+------+-------+-------+------+------+...
1249 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1250 +------+------+------+------+------+-------+-------+------+------+...
1251 0 4 8 12 16 20 24 28 32 36
1253 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1254 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1255 started out as zero once, but it's quite possible that it isn't. So now,
1256 rather than a nicely zeroed GP, you have it pointing somewhere random.
1259 (In fact, GP ends up pointing at a previous GP structure, because the
1260 principle cause of the padding in XPVMG getting garbage is a copy of
1261 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1262 this happens to be moot because XPVGV has been re-ordered, with GP
1263 no longer after STASH)
1265 So we are careful and work out the size of used parts of all the
1273 referant = SvRV(sv);
1274 old_type_details = &fake_rv;
1275 if (new_type == SVt_NV)
1276 new_type = SVt_PVNV;
1278 if (new_type < SVt_PVIV) {
1279 new_type = (new_type == SVt_NV)
1280 ? SVt_PVNV : SVt_PVIV;
1285 if (new_type < SVt_PVNV) {
1286 new_type = SVt_PVNV;
1290 assert(new_type > SVt_PV);
1291 STATIC_ASSERT_STMT(SVt_IV < SVt_PV);
1292 STATIC_ASSERT_STMT(SVt_NV < SVt_PV);
1299 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1300 there's no way that it can be safely upgraded, because perl.c
1301 expects to Safefree(SvANY(PL_mess_sv)) */
1302 assert(sv != PL_mess_sv);
1305 if (UNLIKELY(old_type_details->cant_upgrade))
1306 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1307 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1310 if (UNLIKELY(old_type > new_type))
1311 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1312 (int)old_type, (int)new_type);
1314 new_type_details = bodies_by_type + new_type;
1316 SvFLAGS(sv) &= ~SVTYPEMASK;
1317 SvFLAGS(sv) |= new_type;
1319 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1320 the return statements above will have triggered. */
1321 assert (new_type != SVt_NULL);
1324 assert(old_type == SVt_NULL);
1325 SET_SVANY_FOR_BODYLESS_IV(sv);
1329 assert(old_type == SVt_NULL);
1330 #if NVSIZE <= IVSIZE
1331 SET_SVANY_FOR_BODYLESS_NV(sv);
1333 SvANY(sv) = new_XNV();
1339 assert(new_type_details->body_size);
1342 assert(new_type_details->arena);
1343 assert(new_type_details->arena_size);
1344 /* This points to the start of the allocated area. */
1345 new_body_inline(new_body, new_type);
1346 Zero(new_body, new_type_details->body_size, char);
1347 new_body = ((char *)new_body) - new_type_details->offset;
1349 /* We always allocated the full length item with PURIFY. To do this
1350 we fake things so that arena is false for all 16 types.. */
1351 new_body = new_NOARENAZ(new_type_details);
1353 SvANY(sv) = new_body;
1354 if (new_type == SVt_PVAV) {
1358 if (old_type_details->body_size) {
1361 /* It will have been zeroed when the new body was allocated.
1362 Lets not write to it, in case it confuses a write-back
1368 #ifndef NODEFAULT_SHAREKEYS
1369 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1371 /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
1372 HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
1375 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1376 The target created by newSVrv also is, and it can have magic.
1377 However, it never has SvPVX set.
1379 if (old_type == SVt_IV) {
1381 } else if (old_type >= SVt_PV) {
1382 assert(SvPVX_const(sv) == 0);
1385 if (old_type >= SVt_PVMG) {
1386 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1387 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1389 sv->sv_u.svu_array = NULL; /* or svu_hash */
1394 /* XXX Is this still needed? Was it ever needed? Surely as there is
1395 no route from NV to PVIV, NOK can never be true */
1396 assert(!SvNOKp(sv));
1410 assert(new_type_details->body_size);
1411 /* We always allocated the full length item with PURIFY. To do this
1412 we fake things so that arena is false for all 16 types.. */
1413 if(new_type_details->arena) {
1414 /* This points to the start of the allocated area. */
1415 new_body_inline(new_body, new_type);
1416 Zero(new_body, new_type_details->body_size, char);
1417 new_body = ((char *)new_body) - new_type_details->offset;
1419 new_body = new_NOARENAZ(new_type_details);
1421 SvANY(sv) = new_body;
1423 if (old_type_details->copy) {
1424 /* There is now the potential for an upgrade from something without
1425 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1426 int offset = old_type_details->offset;
1427 int length = old_type_details->copy;
1429 if (new_type_details->offset > old_type_details->offset) {
1430 const int difference
1431 = new_type_details->offset - old_type_details->offset;
1432 offset += difference;
1433 length -= difference;
1435 assert (length >= 0);
1437 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1441 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1442 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1443 * correct 0.0 for us. Otherwise, if the old body didn't have an
1444 * NV slot, but the new one does, then we need to initialise the
1445 * freshly created NV slot with whatever the correct bit pattern is
1447 if (old_type_details->zero_nv && !new_type_details->zero_nv
1448 && !isGV_with_GP(sv))
1452 if (UNLIKELY(new_type == SVt_PVIO)) {
1453 IO * const io = MUTABLE_IO(sv);
1454 GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1457 /* Clear the stashcache because a new IO could overrule a package
1459 DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
1460 hv_clear(PL_stashcache);
1462 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1463 IoPAGE_LEN(sv) = 60;
1465 if (UNLIKELY(new_type == SVt_REGEXP))
1466 sv->sv_u.svu_rx = (regexp *)new_body;
1467 else if (old_type < SVt_PV) {
1468 /* referant will be NULL unless the old type was SVt_IV emulating
1470 sv->sv_u.svu_rv = referant;
1474 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1475 (unsigned long)new_type);
1478 /* if this is zero, this is a body-less SVt_NULL, SVt_IV/SVt_RV,
1479 and sometimes SVt_NV */
1480 if (old_type_details->body_size) {
1484 /* Note that there is an assumption that all bodies of types that
1485 can be upgraded came from arenas. Only the more complex non-
1486 upgradable types are allowed to be directly malloc()ed. */
1487 assert(old_type_details->arena);
1488 del_body((void*)((char*)old_body + old_type_details->offset),
1489 &PL_body_roots[old_type]);
1495 =for apidoc sv_backoff
1497 Remove any string offset. You should normally use the C<SvOOK_off> macro
1503 /* prior to 5.000 stable, this function returned the new OOK-less SvFLAGS
1504 prior to 5.23.4 this function always returned 0
1508 Perl_sv_backoff(SV *const sv)
1511 const char * const s = SvPVX_const(sv);
1513 PERL_ARGS_ASSERT_SV_BACKOFF;
1516 assert(SvTYPE(sv) != SVt_PVHV);
1517 assert(SvTYPE(sv) != SVt_PVAV);
1519 SvOOK_offset(sv, delta);
1521 SvLEN_set(sv, SvLEN(sv) + delta);
1522 SvPV_set(sv, SvPVX(sv) - delta);
1523 SvFLAGS(sv) &= ~SVf_OOK;
1524 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1531 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1532 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1533 Use the C<SvGROW> wrapper instead.
1538 static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
1541 Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
1545 PERL_ARGS_ASSERT_SV_GROW;
1549 if (SvTYPE(sv) < SVt_PV) {
1550 sv_upgrade(sv, SVt_PV);
1551 s = SvPVX_mutable(sv);
1553 else if (SvOOK(sv)) { /* pv is offset? */
1555 s = SvPVX_mutable(sv);
1556 if (newlen > SvLEN(sv))
1557 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1561 if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0);
1562 s = SvPVX_mutable(sv);
1565 #ifdef PERL_COPY_ON_WRITE
1566 /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1567 * to store the COW count. So in general, allocate one more byte than
1568 * asked for, to make it likely this byte is always spare: and thus
1569 * make more strings COW-able.
1570 * If the new size is a big power of two, don't bother: we assume the
1571 * caller wanted a nice 2^N sized block and will be annoyed at getting
1573 * Only increment if the allocation isn't MEM_SIZE_MAX,
1574 * otherwise it will wrap to 0.
1576 if ( (newlen < 0x1000 || (newlen & (newlen - 1)))
1577 && newlen != MEM_SIZE_MAX
1582 #if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size)
1583 #define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1586 if (newlen > SvLEN(sv)) { /* need more room? */
1587 STRLEN minlen = SvCUR(sv);
1588 minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1589 if (newlen < minlen)
1591 #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1593 /* Don't round up on the first allocation, as odds are pretty good that
1594 * the initial request is accurate as to what is really needed */
1596 STRLEN rounded = PERL_STRLEN_ROUNDUP(newlen);
1597 if (rounded > newlen)
1601 if (SvLEN(sv) && s) {
1602 s = (char*)saferealloc(s, newlen);
1605 s = (char*)safemalloc(newlen);
1606 if (SvPVX_const(sv) && SvCUR(sv)) {
1607 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1611 #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1612 /* Do this here, do it once, do it right, and then we will never get
1613 called back into sv_grow() unless there really is some growing
1615 SvLEN_set(sv, Perl_safesysmalloc_size(s));
1617 SvLEN_set(sv, newlen);
1624 =for apidoc sv_setiv
1626 Copies an integer into the given SV, upgrading first if necessary.
1627 Does not handle 'set' magic. See also C<L</sv_setiv_mg>>.
1633 Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
1635 PERL_ARGS_ASSERT_SV_SETIV;
1637 SV_CHECK_THINKFIRST_COW_DROP(sv);
1638 switch (SvTYPE(sv)) {
1641 sv_upgrade(sv, SVt_IV);
1644 sv_upgrade(sv, SVt_PVIV);
1648 if (!isGV_with_GP(sv))
1655 /* diag_listed_as: Can't coerce %s to %s in %s */
1656 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1661 (void)SvIOK_only(sv); /* validate number */
1667 =for apidoc sv_setiv_mg
1669 Like C<sv_setiv>, but also handles 'set' magic.
1675 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1677 PERL_ARGS_ASSERT_SV_SETIV_MG;
1684 =for apidoc sv_setuv
1686 Copies an unsigned integer into the given SV, upgrading first if necessary.
1687 Does not handle 'set' magic. See also C<L</sv_setuv_mg>>.
1693 Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1695 PERL_ARGS_ASSERT_SV_SETUV;
1697 /* With the if statement to ensure that integers are stored as IVs whenever
1699 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1702 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1704 If you wish to remove the following if statement, so that this routine
1705 (and its callers) always return UVs, please benchmark to see what the
1706 effect is. Modern CPUs may be different. Or may not :-)
1708 if (u <= (UV)IV_MAX) {
1709 sv_setiv(sv, (IV)u);
1718 =for apidoc sv_setuv_mg
1720 Like C<sv_setuv>, but also handles 'set' magic.
1726 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1728 PERL_ARGS_ASSERT_SV_SETUV_MG;
1735 =for apidoc sv_setnv
1737 Copies a double into the given SV, upgrading first if necessary.
1738 Does not handle 'set' magic. See also C<L</sv_setnv_mg>>.
1744 Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1746 PERL_ARGS_ASSERT_SV_SETNV;
1748 SV_CHECK_THINKFIRST_COW_DROP(sv);
1749 switch (SvTYPE(sv)) {
1752 sv_upgrade(sv, SVt_NV);
1756 sv_upgrade(sv, SVt_PVNV);
1760 if (!isGV_with_GP(sv))
1767 /* diag_listed_as: Can't coerce %s to %s in %s */
1768 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1774 (void)SvNOK_only(sv); /* validate number */
1779 =for apidoc sv_setnv_mg
1781 Like C<sv_setnv>, but also handles 'set' magic.
1787 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1789 PERL_ARGS_ASSERT_SV_SETNV_MG;
1795 /* Return a cleaned-up, printable version of sv, for non-numeric, or
1796 * not incrementable warning display.
1797 * Originally part of S_not_a_number().
1798 * The return value may be != tmpbuf.
1802 S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1805 PERL_ARGS_ASSERT_SV_DISPLAY;
1808 SV *dsv = newSVpvs_flags("", SVs_TEMP);
1809 pv = sv_uni_display(dsv, sv, 32, UNI_DISPLAY_ISPRINT);
1812 const char * const limit = tmpbuf + tmpbuf_size - 8;
1813 /* each *s can expand to 4 chars + "...\0",
1814 i.e. need room for 8 chars */
1816 const char *s = SvPVX_const(sv);
1817 const char * const end = s + SvCUR(sv);
1818 for ( ; s < end && d < limit; s++ ) {
1820 if (! isASCII(ch) && !isPRINT_LC(ch)) {
1824 /* Map to ASCII "equivalent" of Latin1 */
1825 ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1831 else if (ch == '\r') {
1835 else if (ch == '\f') {
1839 else if (ch == '\\') {
1843 else if (ch == '\0') {
1847 else if (isPRINT_LC(ch))
1866 /* Print an "isn't numeric" warning, using a cleaned-up,
1867 * printable version of the offending string
1871 S_not_a_number(pTHX_ SV *const sv)
1876 PERL_ARGS_ASSERT_NOT_A_NUMBER;
1878 pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1881 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1882 /* diag_listed_as: Argument "%s" isn't numeric%s */
1883 "Argument \"%s\" isn't numeric in %s", pv,
1886 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1887 /* diag_listed_as: Argument "%s" isn't numeric%s */
1888 "Argument \"%s\" isn't numeric", pv);
1892 S_not_incrementable(pTHX_ SV *const sv) {
1896 PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1898 pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1900 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1901 "Argument \"%s\" treated as 0 in increment (++)", pv);
1905 =for apidoc looks_like_number
1907 Test if the content of an SV looks like a number (or is a number).
1908 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1909 non-numeric warning), even if your C<atof()> doesn't grok them. Get-magic is
1916 Perl_looks_like_number(pTHX_ SV *const sv)
1922 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1924 if (SvPOK(sv) || SvPOKp(sv)) {
1925 sbegin = SvPV_nomg_const(sv, len);
1928 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1929 numtype = grok_number(sbegin, len, NULL);
1930 return ((numtype & IS_NUMBER_TRAILING)) ? 0 : numtype;
1934 S_glob_2number(pTHX_ GV * const gv)
1936 PERL_ARGS_ASSERT_GLOB_2NUMBER;
1938 /* We know that all GVs stringify to something that is not-a-number,
1939 so no need to test that. */
1940 if (ckWARN(WARN_NUMERIC))
1942 SV *const buffer = sv_newmortal();
1943 gv_efullname3(buffer, gv, "*");
1944 not_a_number(buffer);
1946 /* We just want something true to return, so that S_sv_2iuv_common
1947 can tail call us and return true. */
1951 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1952 until proven guilty, assume that things are not that bad... */
1957 As 64 bit platforms often have an NV that doesn't preserve all bits of
1958 an IV (an assumption perl has been based on to date) it becomes necessary
1959 to remove the assumption that the NV always carries enough precision to
1960 recreate the IV whenever needed, and that the NV is the canonical form.
1961 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1962 precision as a side effect of conversion (which would lead to insanity
1963 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1964 1) to distinguish between IV/UV/NV slots that have a valid conversion cached
1965 where precision was lost, and IV/UV/NV slots that have a valid conversion
1966 which has lost no precision
1967 2) to ensure that if a numeric conversion to one form is requested that
1968 would lose precision, the precise conversion (or differently
1969 imprecise conversion) is also performed and cached, to prevent
1970 requests for different numeric formats on the same SV causing
1971 lossy conversion chains. (lossless conversion chains are perfectly
1976 SvIOKp is true if the IV slot contains a valid value
1977 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1978 SvNOKp is true if the NV slot contains a valid value
1979 SvNOK is true only if the NV value is accurate
1982 while converting from PV to NV, check to see if converting that NV to an
1983 IV(or UV) would lose accuracy over a direct conversion from PV to
1984 IV(or UV). If it would, cache both conversions, return NV, but mark
1985 SV as IOK NOKp (ie not NOK).
1987 While converting from PV to IV, check to see if converting that IV to an
1988 NV would lose accuracy over a direct conversion from PV to NV. If it
1989 would, cache both conversions, flag similarly.
1991 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1992 correctly because if IV & NV were set NV *always* overruled.
1993 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1994 changes - now IV and NV together means that the two are interchangeable:
1995 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1997 The benefit of this is that operations such as pp_add know that if
1998 SvIOK is true for both left and right operands, then integer addition
1999 can be used instead of floating point (for cases where the result won't
2000 overflow). Before, floating point was always used, which could lead to
2001 loss of precision compared with integer addition.
2003 * making IV and NV equal status should make maths accurate on 64 bit
2005 * may speed up maths somewhat if pp_add and friends start to use
2006 integers when possible instead of fp. (Hopefully the overhead in
2007 looking for SvIOK and checking for overflow will not outweigh the
2008 fp to integer speedup)
2009 * will slow down integer operations (callers of SvIV) on "inaccurate"
2010 values, as the change from SvIOK to SvIOKp will cause a call into
2011 sv_2iv each time rather than a macro access direct to the IV slot
2012 * should speed up number->string conversion on integers as IV is
2013 favoured when IV and NV are equally accurate
2015 ####################################################################
2016 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2017 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2018 On the other hand, SvUOK is true iff UV.
2019 ####################################################################
2021 Your mileage will vary depending your CPU's relative fp to integer
2025 #ifndef NV_PRESERVES_UV
2026 # define IS_NUMBER_UNDERFLOW_IV 1
2027 # define IS_NUMBER_UNDERFLOW_UV 2
2028 # define IS_NUMBER_IV_AND_UV 2
2029 # define IS_NUMBER_OVERFLOW_IV 4
2030 # define IS_NUMBER_OVERFLOW_UV 5
2032 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2034 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2036 S_sv_2iuv_non_preserve(pTHX_ SV *const sv
2042 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
2043 PERL_UNUSED_CONTEXT;
2045 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));
2046 if (SvNVX(sv) < (NV)IV_MIN) {
2047 (void)SvIOKp_on(sv);
2049 SvIV_set(sv, IV_MIN);
2050 return IS_NUMBER_UNDERFLOW_IV;
2052 if (SvNVX(sv) > (NV)UV_MAX) {
2053 (void)SvIOKp_on(sv);
2056 SvUV_set(sv, UV_MAX);
2057 return IS_NUMBER_OVERFLOW_UV;
2059 (void)SvIOKp_on(sv);
2061 /* Can't use strtol etc to convert this string. (See truth table in
2063 if (SvNVX(sv) <= (UV)IV_MAX) {
2064 SvIV_set(sv, I_V(SvNVX(sv)));
2065 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2066 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2068 /* Integer is imprecise. NOK, IOKp */
2070 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2073 SvUV_set(sv, U_V(SvNVX(sv)));
2074 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2075 if (SvUVX(sv) == UV_MAX) {
2076 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2077 possibly be preserved by NV. Hence, it must be overflow.
2079 return IS_NUMBER_OVERFLOW_UV;
2081 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2083 /* Integer is imprecise. NOK, IOKp */
2085 return IS_NUMBER_OVERFLOW_IV;
2087 #endif /* !NV_PRESERVES_UV*/
2089 /* If numtype is infnan, set the NV of the sv accordingly.
2090 * If numtype is anything else, try setting the NV using Atof(PV). */
2092 # pragma warning(push)
2093 # pragma warning(disable:4756;disable:4056)
2096 S_sv_setnv(pTHX_ SV* sv, int numtype)
2098 bool pok = cBOOL(SvPOK(sv));
2100 if ((numtype & IS_NUMBER_INFINITY)) {
2101 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
2104 else if ((numtype & IS_NUMBER_NAN)) {
2105 SvNV_set(sv, NV_NAN);
2109 SvNV_set(sv, Atof(SvPVX_const(sv)));
2110 /* Purposefully no true nok here, since we don't want to blow
2111 * away the possible IOK/UV of an existing sv. */
2114 SvNOK_only(sv); /* No IV or UV please, this is pure infnan. */
2116 SvPOK_on(sv); /* PV is okay, though. */
2120 # pragma warning(pop)
2124 S_sv_2iuv_common(pTHX_ SV *const sv)
2126 PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2129 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2130 * without also getting a cached IV/UV from it at the same time
2131 * (ie PV->NV conversion should detect loss of accuracy and cache
2132 * IV or UV at same time to avoid this. */
2133 /* IV-over-UV optimisation - choose to cache IV if possible */
2135 if (SvTYPE(sv) == SVt_NV)
2136 sv_upgrade(sv, SVt_PVNV);
2138 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2139 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2140 certainly cast into the IV range at IV_MAX, whereas the correct
2141 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2143 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2144 if (Perl_isnan(SvNVX(sv))) {
2150 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2151 SvIV_set(sv, I_V(SvNVX(sv)));
2152 if (SvNVX(sv) == (NV) SvIVX(sv)
2153 #ifndef NV_PRESERVES_UV
2154 && SvIVX(sv) != IV_MIN /* avoid negating IV_MIN below */
2155 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2156 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2157 /* Don't flag it as "accurately an integer" if the number
2158 came from a (by definition imprecise) NV operation, and
2159 we're outside the range of NV integer precision */
2163 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2165 /* scalar has trailing garbage, eg "42a" */
2167 DEBUG_c(PerlIO_printf(Perl_debug_log,
2168 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2174 /* IV not precise. No need to convert from PV, as NV
2175 conversion would already have cached IV if it detected
2176 that PV->IV would be better than PV->NV->IV
2177 flags already correct - don't set public IOK. */
2178 DEBUG_c(PerlIO_printf(Perl_debug_log,
2179 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2184 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2185 but the cast (NV)IV_MIN rounds to a the value less (more
2186 negative) than IV_MIN which happens to be equal to SvNVX ??
2187 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2188 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2189 (NV)UVX == NVX are both true, but the values differ. :-(
2190 Hopefully for 2s complement IV_MIN is something like
2191 0x8000000000000000 which will be exact. NWC */
2194 SvUV_set(sv, U_V(SvNVX(sv)));
2196 (SvNVX(sv) == (NV) SvUVX(sv))
2197 #ifndef NV_PRESERVES_UV
2198 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2199 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2200 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2201 /* Don't flag it as "accurately an integer" if the number
2202 came from a (by definition imprecise) NV operation, and
2203 we're outside the range of NV integer precision */
2209 DEBUG_c(PerlIO_printf(Perl_debug_log,
2210 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2216 else if (SvPOKp(sv)) {
2218 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2219 /* We want to avoid a possible problem when we cache an IV/ a UV which
2220 may be later translated to an NV, and the resulting NV is not
2221 the same as the direct translation of the initial string
2222 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2223 be careful to ensure that the value with the .456 is around if the
2224 NV value is requested in the future).
2226 This means that if we cache such an IV/a UV, we need to cache the
2227 NV as well. Moreover, we trade speed for space, and do not
2228 cache the NV if we are sure it's not needed.
2231 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2232 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2233 == IS_NUMBER_IN_UV) {
2234 /* It's definitely an integer, only upgrade to PVIV */
2235 if (SvTYPE(sv) < SVt_PVIV)
2236 sv_upgrade(sv, SVt_PVIV);
2238 } else if (SvTYPE(sv) < SVt_PVNV)
2239 sv_upgrade(sv, SVt_PVNV);
2241 if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
2242 if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING)))
2244 S_sv_setnv(aTHX_ sv, numtype);
2248 /* If NVs preserve UVs then we only use the UV value if we know that
2249 we aren't going to call atof() below. If NVs don't preserve UVs
2250 then the value returned may have more precision than atof() will
2251 return, even though value isn't perfectly accurate. */
2252 if ((numtype & (IS_NUMBER_IN_UV
2253 #ifdef NV_PRESERVES_UV
2256 )) == IS_NUMBER_IN_UV) {
2257 /* This won't turn off the public IOK flag if it was set above */
2258 (void)SvIOKp_on(sv);
2260 if (!(numtype & IS_NUMBER_NEG)) {
2262 if (value <= (UV)IV_MAX) {
2263 SvIV_set(sv, (IV)value);
2265 /* it didn't overflow, and it was positive. */
2266 SvUV_set(sv, value);
2270 /* 2s complement assumption */
2271 if (value <= (UV)IV_MIN) {
2272 SvIV_set(sv, value == (UV)IV_MIN
2273 ? IV_MIN : -(IV)value);
2275 /* Too negative for an IV. This is a double upgrade, but
2276 I'm assuming it will be rare. */
2277 if (SvTYPE(sv) < SVt_PVNV)
2278 sv_upgrade(sv, SVt_PVNV);
2282 SvNV_set(sv, -(NV)value);
2283 SvIV_set(sv, IV_MIN);
2287 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2288 will be in the previous block to set the IV slot, and the next
2289 block to set the NV slot. So no else here. */
2291 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2292 != IS_NUMBER_IN_UV) {
2293 /* It wasn't an (integer that doesn't overflow the UV). */
2294 S_sv_setnv(aTHX_ sv, numtype);
2296 if (! numtype && ckWARN(WARN_NUMERIC))
2299 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" NVgf ")\n",
2300 PTR2UV(sv), SvNVX(sv)));
2302 #ifdef NV_PRESERVES_UV
2303 (void)SvIOKp_on(sv);
2305 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2306 if (Perl_isnan(SvNVX(sv))) {
2312 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2313 SvIV_set(sv, I_V(SvNVX(sv)));
2314 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2317 NOOP; /* Integer is imprecise. NOK, IOKp */
2319 /* UV will not work better than IV */
2321 if (SvNVX(sv) > (NV)UV_MAX) {
2323 /* Integer is inaccurate. NOK, IOKp, is UV */
2324 SvUV_set(sv, UV_MAX);
2326 SvUV_set(sv, U_V(SvNVX(sv)));
2327 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2328 NV preservse UV so can do correct comparison. */
2329 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2332 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
2337 #else /* NV_PRESERVES_UV */
2338 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2339 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2340 /* The IV/UV slot will have been set from value returned by
2341 grok_number above. The NV slot has just been set using
2344 assert (SvIOKp(sv));
2346 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2347 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2348 /* Small enough to preserve all bits. */
2349 (void)SvIOKp_on(sv);
2351 SvIV_set(sv, I_V(SvNVX(sv)));
2352 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2354 /* Assumption: first non-preserved integer is < IV_MAX,
2355 this NV is in the preserved range, therefore: */
2356 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2358 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);
2362 0 0 already failed to read UV.
2363 0 1 already failed to read UV.
2364 1 0 you won't get here in this case. IV/UV
2365 slot set, public IOK, Atof() unneeded.
2366 1 1 already read UV.
2367 so there's no point in sv_2iuv_non_preserve() attempting
2368 to use atol, strtol, strtoul etc. */
2370 sv_2iuv_non_preserve (sv, numtype);
2372 sv_2iuv_non_preserve (sv);
2376 #endif /* NV_PRESERVES_UV */
2377 /* It might be more code efficient to go through the entire logic above
2378 and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2379 gets complex and potentially buggy, so more programmer efficient
2380 to do it this way, by turning off the public flags: */
2382 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2386 if (isGV_with_GP(sv))
2387 return glob_2number(MUTABLE_GV(sv));
2389 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2391 if (SvTYPE(sv) < SVt_IV)
2392 /* Typically the caller expects that sv_any is not NULL now. */
2393 sv_upgrade(sv, SVt_IV);
2394 /* Return 0 from the caller. */
2401 =for apidoc sv_2iv_flags
2403 Return the integer value of an SV, doing any necessary string
2404 conversion. If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2405 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2411 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2413 PERL_ARGS_ASSERT_SV_2IV_FLAGS;
2415 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2416 && SvTYPE(sv) != SVt_PVFM);
2418 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2424 if (flags & SV_SKIP_OVERLOAD)
2426 tmpstr = AMG_CALLunary(sv, numer_amg);
2427 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2428 return SvIV(tmpstr);
2431 return PTR2IV(SvRV(sv));
2434 if (SvVALID(sv) || isREGEXP(sv)) {
2435 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2436 the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2437 In practice they are extremely unlikely to actually get anywhere
2438 accessible by user Perl code - the only way that I'm aware of is when
2439 a constant subroutine which is used as the second argument to index.
2441 Regexps have no SvIVX and SvNVX fields.
2443 assert(isREGEXP(sv) || SvPOKp(sv));
2446 const char * const ptr =
2447 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2449 = grok_number(ptr, SvCUR(sv), &value);
2451 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2452 == IS_NUMBER_IN_UV) {
2453 /* It's definitely an integer */
2454 if (numtype & IS_NUMBER_NEG) {
2455 if (value < (UV)IV_MIN)
2458 if (value < (UV)IV_MAX)
2463 /* Quite wrong but no good choices. */
2464 if ((numtype & IS_NUMBER_INFINITY)) {
2465 return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX;
2466 } else if ((numtype & IS_NUMBER_NAN)) {
2467 return 0; /* So wrong. */
2471 if (ckWARN(WARN_NUMERIC))
2474 return I_V(Atof(ptr));
2478 if (SvTHINKFIRST(sv)) {
2479 if (SvREADONLY(sv) && !SvOK(sv)) {
2480 if (ckWARN(WARN_UNINITIALIZED))
2487 if (S_sv_2iuv_common(aTHX_ sv))
2491 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2492 PTR2UV(sv),SvIVX(sv)));
2493 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2497 =for apidoc sv_2uv_flags
2499 Return the unsigned integer value of an SV, doing any necessary string
2500 conversion. If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2501 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2507 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2509 PERL_ARGS_ASSERT_SV_2UV_FLAGS;
2511 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2517 if (flags & SV_SKIP_OVERLOAD)
2519 tmpstr = AMG_CALLunary(sv, numer_amg);
2520 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2521 return SvUV(tmpstr);
2524 return PTR2UV(SvRV(sv));
2527 if (SvVALID(sv) || isREGEXP(sv)) {
2528 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2529 the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2530 Regexps have no SvIVX and SvNVX fields. */
2531 assert(isREGEXP(sv) || SvPOKp(sv));
2534 const char * const ptr =
2535 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2537 = grok_number(ptr, SvCUR(sv), &value);
2539 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2540 == IS_NUMBER_IN_UV) {
2541 /* It's definitely an integer */
2542 if (!(numtype & IS_NUMBER_NEG))
2546 /* Quite wrong but no good choices. */
2547 if ((numtype & IS_NUMBER_INFINITY)) {
2548 return UV_MAX; /* So wrong. */
2549 } else if ((numtype & IS_NUMBER_NAN)) {
2550 return 0; /* So wrong. */
2554 if (ckWARN(WARN_NUMERIC))
2557 return U_V(Atof(ptr));
2561 if (SvTHINKFIRST(sv)) {
2562 if (SvREADONLY(sv) && !SvOK(sv)) {
2563 if (ckWARN(WARN_UNINITIALIZED))
2570 if (S_sv_2iuv_common(aTHX_ sv))
2574 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2575 PTR2UV(sv),SvUVX(sv)));
2576 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2580 =for apidoc sv_2nv_flags
2582 Return the num value of an SV, doing any necessary string or integer
2583 conversion. If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2584 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2590 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2592 PERL_ARGS_ASSERT_SV_2NV_FLAGS;
2594 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2595 && SvTYPE(sv) != SVt_PVFM);
2596 if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
2597 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2598 the same flag bit as SVf_IVisUV, so must not let them cache NVs.
2599 Regexps have no SvIVX and SvNVX fields. */
2601 if (flags & SV_GMAGIC)
2605 if (SvPOKp(sv) && !SvIOKp(sv)) {
2606 ptr = SvPVX_const(sv);
2608 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2609 !grok_number(ptr, SvCUR(sv), NULL))
2615 return (NV)SvUVX(sv);
2617 return (NV)SvIVX(sv);
2623 ptr = RX_WRAPPED((REGEXP *)sv);
2626 assert(SvTYPE(sv) >= SVt_PVMG);
2627 /* This falls through to the report_uninit near the end of the
2629 } else if (SvTHINKFIRST(sv)) {
2634 if (flags & SV_SKIP_OVERLOAD)
2636 tmpstr = AMG_CALLunary(sv, numer_amg);
2637 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2638 return SvNV(tmpstr);
2641 return PTR2NV(SvRV(sv));
2643 if (SvREADONLY(sv) && !SvOK(sv)) {
2644 if (ckWARN(WARN_UNINITIALIZED))
2649 if (SvTYPE(sv) < SVt_NV) {
2650 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2651 sv_upgrade(sv, SVt_NV);
2653 STORE_NUMERIC_LOCAL_SET_STANDARD();
2654 PerlIO_printf(Perl_debug_log,
2655 "0x%"UVxf" num(%" NVgf ")\n",
2656 PTR2UV(sv), SvNVX(sv));
2657 RESTORE_NUMERIC_LOCAL();
2660 else if (SvTYPE(sv) < SVt_PVNV)
2661 sv_upgrade(sv, SVt_PVNV);
2666 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2667 #ifdef NV_PRESERVES_UV
2673 /* Only set the public NV OK flag if this NV preserves the IV */
2674 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2676 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2677 : (SvIVX(sv) == I_V(SvNVX(sv))))
2683 else if (SvPOKp(sv)) {
2685 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2686 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2688 #ifdef NV_PRESERVES_UV
2689 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2690 == IS_NUMBER_IN_UV) {
2691 /* It's definitely an integer */
2692 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2694 S_sv_setnv(aTHX_ sv, numtype);
2701 SvNV_set(sv, Atof(SvPVX_const(sv)));
2702 /* Only set the public NV OK flag if this NV preserves the value in
2703 the PV at least as well as an IV/UV would.
2704 Not sure how to do this 100% reliably. */
2705 /* if that shift count is out of range then Configure's test is
2706 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2708 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2709 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2710 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2711 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2712 /* Can't use strtol etc to convert this string, so don't try.
2713 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2716 /* value has been set. It may not be precise. */
2717 if ((numtype & IS_NUMBER_NEG) && (value >= (UV)IV_MIN)) {
2718 /* 2s complement assumption for (UV)IV_MIN */
2719 SvNOK_on(sv); /* Integer is too negative. */
2724 if (numtype & IS_NUMBER_NEG) {
2725 /* -IV_MIN is undefined, but we should never reach
2726 * this point with both IS_NUMBER_NEG and value ==
2728 assert(value != (UV)IV_MIN);
2729 SvIV_set(sv, -(IV)value);
2730 } else if (value <= (UV)IV_MAX) {
2731 SvIV_set(sv, (IV)value);
2733 SvUV_set(sv, value);
2737 if (numtype & IS_NUMBER_NOT_INT) {
2738 /* I believe that even if the original PV had decimals,
2739 they are lost beyond the limit of the FP precision.
2740 However, neither is canonical, so both only get p
2741 flags. NWC, 2000/11/25 */
2742 /* Both already have p flags, so do nothing */
2744 const NV nv = SvNVX(sv);
2745 /* XXX should this spot have NAN_COMPARE_BROKEN, too? */
2746 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2747 if (SvIVX(sv) == I_V(nv)) {
2750 /* It had no "." so it must be integer. */
2754 /* between IV_MAX and NV(UV_MAX).
2755 Could be slightly > UV_MAX */
2757 if (numtype & IS_NUMBER_NOT_INT) {
2758 /* UV and NV both imprecise. */
2760 const UV nv_as_uv = U_V(nv);
2762 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2771 /* It might be more code efficient to go through the entire logic above
2772 and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2773 gets complex and potentially buggy, so more programmer efficient
2774 to do it this way, by turning off the public flags: */
2776 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2777 #endif /* NV_PRESERVES_UV */
2780 if (isGV_with_GP(sv)) {
2781 glob_2number(MUTABLE_GV(sv));
2785 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2787 assert (SvTYPE(sv) >= SVt_NV);
2788 /* Typically the caller expects that sv_any is not NULL now. */
2789 /* XXX Ilya implies that this is a bug in callers that assume this
2790 and ideally should be fixed. */
2794 STORE_NUMERIC_LOCAL_SET_STANDARD();
2795 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" NVgf ")\n",
2796 PTR2UV(sv), SvNVX(sv));
2797 RESTORE_NUMERIC_LOCAL();
2805 Return an SV with the numeric value of the source SV, doing any necessary
2806 reference or overload conversion. The caller is expected to have handled
2813 Perl_sv_2num(pTHX_ SV *const sv)
2815 PERL_ARGS_ASSERT_SV_2NUM;
2820 SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2821 TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2822 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2823 return sv_2num(tmpsv);
2825 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2828 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2829 * UV as a string towards the end of buf, and return pointers to start and
2832 * We assume that buf is at least TYPE_CHARS(UV) long.
2836 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2838 char *ptr = buf + TYPE_CHARS(UV);
2839 char * const ebuf = ptr;
2842 PERL_ARGS_ASSERT_UIV_2BUF;
2850 uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv);
2854 *--ptr = '0' + (char)(uv % 10);
2862 /* Helper for sv_2pv_flags and sv_vcatpvfn_flags. If the NV is an
2863 * infinity or a not-a-number, writes the appropriate strings to the
2864 * buffer, including a zero byte. On success returns the written length,
2865 * excluding the zero byte, on failure (not an infinity, not a nan)
2866 * returns zero, assert-fails on maxlen being too short.
2868 * XXX for "Inf", "-Inf", and "NaN", we could have three read-only
2869 * shared string constants we point to, instead of generating a new
2870 * string for each instance. */
2872 S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char plus) {
2874 assert(maxlen >= 4);
2875 if (Perl_isinf(nv)) {
2877 if (maxlen < 5) /* "-Inf\0" */
2887 else if (Perl_isnan(nv)) {
2891 /* XXX optionally output the payload mantissa bits as
2892 * "(unsigned)" (to match the nan("...") C99 function,
2893 * or maybe as "(0xhhh...)" would make more sense...
2894 * provide a format string so that the user can decide?
2895 * NOTE: would affect the maxlen and assert() logic.*/
2900 assert((s == buffer + 3) || (s == buffer + 4));
2902 return s - buffer - 1; /* -1: excluding the zero byte */
2906 =for apidoc sv_2pv_flags
2908 Returns a pointer to the string value of an SV, and sets C<*lp> to its length.
2909 If flags has the C<SV_GMAGIC> bit set, does an C<mg_get()> first. Coerces C<sv> to a
2910 string if necessary. Normally invoked via the C<SvPV_flags> macro.
2911 C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
2917 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
2921 PERL_ARGS_ASSERT_SV_2PV_FLAGS;
2923 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2924 && SvTYPE(sv) != SVt_PVFM);
2925 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2930 if (flags & SV_SKIP_OVERLOAD)
2932 tmpstr = AMG_CALLunary(sv, string_amg);
2933 TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2934 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2936 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2940 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2941 if (flags & SV_CONST_RETURN) {
2942 pv = (char *) SvPVX_const(tmpstr);
2944 pv = (flags & SV_MUTABLE_RETURN)
2945 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2948 *lp = SvCUR(tmpstr);
2950 pv = sv_2pv_flags(tmpstr, lp, flags);
2963 SV *const referent = SvRV(sv);
2967 retval = buffer = savepvn("NULLREF", len);
2968 } else if (SvTYPE(referent) == SVt_REGEXP &&
2969 (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
2970 amagic_is_enabled(string_amg))) {
2971 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2975 /* If the regex is UTF-8 we want the containing scalar to
2976 have an UTF-8 flag too */
2983 *lp = RX_WRAPLEN(re);
2985 return RX_WRAPPED(re);
2987 const char *const typestr = sv_reftype(referent, 0);
2988 const STRLEN typelen = strlen(typestr);
2989 UV addr = PTR2UV(referent);
2990 const char *stashname = NULL;
2991 STRLEN stashnamelen = 0; /* hush, gcc */
2992 const char *buffer_end;
2994 if (SvOBJECT(referent)) {
2995 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2998 stashname = HEK_KEY(name);
2999 stashnamelen = HEK_LEN(name);
3001 if (HEK_UTF8(name)) {
3007 stashname = "__ANON__";
3010 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
3011 + 2 * sizeof(UV) + 2 /* )\0 */;
3013 len = typelen + 3 /* (0x */
3014 + 2 * sizeof(UV) + 2 /* )\0 */;
3017 Newx(buffer, len, char);
3018 buffer_end = retval = buffer + len;
3020 /* Working backwards */
3024 *--retval = PL_hexdigit[addr & 15];
3025 } while (addr >>= 4);
3031 memcpy(retval, typestr, typelen);
3035 retval -= stashnamelen;
3036 memcpy(retval, stashname, stashnamelen);
3038 /* retval may not necessarily have reached the start of the
3040 assert (retval >= buffer);
3042 len = buffer_end - retval - 1; /* -1 for that \0 */
3054 if (flags & SV_MUTABLE_RETURN)
3055 return SvPVX_mutable(sv);
3056 if (flags & SV_CONST_RETURN)
3057 return (char *)SvPVX_const(sv);
3062 /* I'm assuming that if both IV and NV are equally valid then
3063 converting the IV is going to be more efficient */
3064 const U32 isUIOK = SvIsUV(sv);
3065 char buf[TYPE_CHARS(UV)];
3069 if (SvTYPE(sv) < SVt_PVIV)
3070 sv_upgrade(sv, SVt_PVIV);
3071 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
3073 /* inlined from sv_setpvn */
3074 s = SvGROW_mutable(sv, len + 1);
3075 Move(ptr, s, len, char);
3080 else if (SvNOK(sv)) {
3081 if (SvTYPE(sv) < SVt_PVNV)
3082 sv_upgrade(sv, SVt_PVNV);
3083 if (SvNVX(sv) == 0.0
3084 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3085 && !Perl_isnan(SvNVX(sv))
3088 s = SvGROW_mutable(sv, 2);
3093 STRLEN size = 5; /* "-Inf\0" */
3095 s = SvGROW_mutable(sv, size);
3096 len = S_infnan_2pv(SvNVX(sv), s, size, 0);
3102 /* some Xenix systems wipe out errno here */
3111 5 + /* exponent digits */
3115 s = SvGROW_mutable(sv, size);
3116 #ifndef USE_LOCALE_NUMERIC
3117 SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3123 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3124 STORE_LC_NUMERIC_SET_TO_NEEDED();
3126 local_radix = PL_numeric_local && PL_numeric_radix_sv;
3127 if (local_radix && SvLEN(PL_numeric_radix_sv) > 1) {
3128 size += SvLEN(PL_numeric_radix_sv) - 1;
3129 s = SvGROW_mutable(sv, size);
3132 SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3134 /* If the radix character is UTF-8, and actually is in the
3135 * output, turn on the UTF-8 flag for the scalar */
3137 && SvUTF8(PL_numeric_radix_sv)
3138 && instr(s, SvPVX_const(PL_numeric_radix_sv)))
3143 RESTORE_LC_NUMERIC();
3146 /* We don't call SvPOK_on(), because it may come to
3147 * pass that the locale changes so that the
3148 * stringification we just did is no longer correct. We
3149 * will have to re-stringify every time it is needed */
3156 else if (isGV_with_GP(sv)) {
3157 GV *const gv = MUTABLE_GV(sv);
3158 SV *const buffer = sv_newmortal();
3160 gv_efullname3(buffer, gv, "*");
3162 assert(SvPOK(buffer));
3166 *lp = SvCUR(buffer);
3167 return SvPVX(buffer);
3169 else if (isREGEXP(sv)) {
3170 if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
3171 return RX_WRAPPED((REGEXP *)sv);
3176 if (flags & SV_UNDEF_RETURNS_NULL)
3178 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3180 /* Typically the caller expects that sv_any is not NULL now. */
3181 if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
3182 sv_upgrade(sv, SVt_PV);
3187 const STRLEN len = s - SvPVX_const(sv);
3192 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3193 PTR2UV(sv),SvPVX_const(sv)));
3194 if (flags & SV_CONST_RETURN)
3195 return (char *)SvPVX_const(sv);
3196 if (flags & SV_MUTABLE_RETURN)
3197 return SvPVX_mutable(sv);
3202 =for apidoc sv_copypv
3204 Copies a stringified representation of the source SV into the
3205 destination SV. Automatically performs any necessary C<mg_get> and
3206 coercion of numeric values into strings. Guaranteed to preserve
3207 C<UTF8> flag even from overloaded objects. Similar in nature to
3208 C<sv_2pv[_flags]> but operates directly on an SV instead of just the
3209 string. Mostly uses C<sv_2pv_flags> to do its work, except when that
3210 would lose the UTF-8'ness of the PV.
3212 =for apidoc sv_copypv_nomg
3214 Like C<sv_copypv>, but doesn't invoke get magic first.
3216 =for apidoc sv_copypv_flags
3218 Implementation of C<sv_copypv> and C<sv_copypv_nomg>. Calls get magic iff flags
3219 has the C<SV_GMAGIC> bit set.
3225 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3230 PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3232 s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC));
3233 sv_setpvn(dsv,s,len);
3241 =for apidoc sv_2pvbyte
3243 Return a pointer to the byte-encoded representation of the SV, and set C<*lp>
3244 to its length. May cause the SV to be downgraded from UTF-8 as a
3247 Usually accessed via the C<SvPVbyte> macro.
3253 Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
3255 PERL_ARGS_ASSERT_SV_2PVBYTE;
3258 if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3259 || isGV_with_GP(sv) || SvROK(sv)) {
3260 SV *sv2 = sv_newmortal();
3261 sv_copypv_nomg(sv2,sv);
3264 sv_utf8_downgrade(sv,0);
3265 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3269 =for apidoc sv_2pvutf8
3271 Return a pointer to the UTF-8-encoded representation of the SV, and set C<*lp>
3272 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3274 Usually accessed via the C<SvPVutf8> macro.
3280 Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
3282 PERL_ARGS_ASSERT_SV_2PVUTF8;
3284 if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3285 || isGV_with_GP(sv) || SvROK(sv))
3286 sv = sv_mortalcopy(sv);
3289 sv_utf8_upgrade_nomg(sv);
3290 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3295 =for apidoc sv_2bool
3297 This macro is only used by C<sv_true()> or its macro equivalent, and only if
3298 the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>.
3299 It calls C<sv_2bool_flags> with the C<SV_GMAGIC> flag.
3301 =for apidoc sv_2bool_flags
3303 This function is only used by C<sv_true()> and friends, and only if
3304 the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>. If the flags
3305 contain C<SV_GMAGIC>, then it does an C<mg_get()> first.
3312 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
3314 PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3317 if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3323 SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3324 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
3327 if(SvGMAGICAL(sv)) {
3329 goto restart; /* call sv_2bool */
3331 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
3332 else if(!SvOK(sv)) {
3335 else if(SvPOK(sv)) {
3336 svb = SvPVXtrue(sv);
3338 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
3339 svb = (SvIOK(sv) && SvIVX(sv) != 0)
3340 || (SvNOK(sv) && SvNVX(sv) != 0.0);
3344 goto restart; /* call sv_2bool_nomg */
3349 return SvRV(sv) != 0;
3353 RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
3354 return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
3358 =for apidoc sv_utf8_upgrade
3360 Converts the PV of an SV to its UTF-8-encoded form.
3361 Forces the SV to string form if it is not already.
3362 Will C<mg_get> on C<sv> if appropriate.
3363 Always sets the C<SvUTF8> flag to avoid future validity checks even
3364 if the whole string is the same in UTF-8 as not.
3365 Returns the number of bytes in the converted string
3367 This is not a general purpose byte encoding to Unicode interface:
3368 use the Encode extension for that.
3370 =for apidoc sv_utf8_upgrade_nomg
3372 Like C<sv_utf8_upgrade>, but doesn't do magic on C<sv>.
3374 =for apidoc sv_utf8_upgrade_flags
3376 Converts the PV of an SV to its UTF-8-encoded form.
3377 Forces the SV to string form if it is not already.
3378 Always sets the SvUTF8 flag to avoid future validity checks even
3379 if all the bytes are invariant in UTF-8.
3380 If C<flags> has C<SV_GMAGIC> bit set,
3381 will C<mg_get> on C<sv> if appropriate, else not.
3383 If C<flags> has C<SV_FORCE_UTF8_UPGRADE> set, this function assumes that the PV
3384 will expand when converted to UTF-8, and skips the extra work of checking for
3385 that. Typically this flag is used by a routine that has already parsed the
3386 string and found such characters, and passes this information on so that the
3387 work doesn't have to be repeated.
3389 Returns the number of bytes in the converted string.
3391 This is not a general purpose byte encoding to Unicode interface:
3392 use the Encode extension for that.
3394 =for apidoc sv_utf8_upgrade_flags_grow
3396 Like C<sv_utf8_upgrade_flags>, but has an additional parameter C<extra>, which is
3397 the number of unused bytes the string of C<sv> is guaranteed to have free after
3398 it upon return. This allows the caller to reserve extra space that it intends
3399 to fill, to avoid extra grows.
3401 C<sv_utf8_upgrade>, C<sv_utf8_upgrade_nomg>, and C<sv_utf8_upgrade_flags>
3402 are implemented in terms of this function.
3404 Returns the number of bytes in the converted string (not including the spares).
3408 (One might think that the calling routine could pass in the position of the
3409 first variant character when it has set SV_FORCE_UTF8_UPGRADE, so it wouldn't
3410 have to be found again. But that is not the case, because typically when the
3411 caller is likely to use this flag, it won't be calling this routine unless it
3412 finds something that won't fit into a byte. Otherwise it tries to not upgrade
3413 and just use bytes. But some things that do fit into a byte are variants in
3414 utf8, and the caller may not have been keeping track of these.)
3416 If the routine itself changes the string, it adds a trailing C<NUL>. Such a
3417 C<NUL> isn't guaranteed due to having other routines do the work in some input
3418 cases, or if the input is already flagged as being in utf8.
3420 The speed of this could perhaps be improved for many cases if someone wanted to
3421 write a fast function that counts the number of variant characters in a string,
3422 especially if it could return the position of the first one.
3427 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3429 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3431 if (sv == &PL_sv_undef)
3433 if (!SvPOK_nog(sv)) {
3435 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3436 (void) sv_2pv_flags(sv,&len, flags);
3438 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3442 (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3447 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3452 S_sv_uncow(aTHX_ sv, 0);
3455 if (IN_ENCODING && !(flags & SV_UTF8_NO_ENCODING)) {
3456 sv_recode_to_utf8(sv, _get_encoding());
3457 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3461 if (SvCUR(sv) == 0) {
3462 if (extra) SvGROW(sv, extra);
3463 } else { /* Assume Latin-1/EBCDIC */
3464 /* This function could be much more efficient if we
3465 * had a FLAG in SVs to signal if there are any variant
3466 * chars in the PV. Given that there isn't such a flag
3467 * make the loop as fast as possible (although there are certainly ways
3468 * to speed this up, eg. through vectorization) */
3469 U8 * s = (U8 *) SvPVX_const(sv);
3470 U8 * e = (U8 *) SvEND(sv);
3472 STRLEN two_byte_count = 0;
3474 if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3476 /* See if really will need to convert to utf8. We mustn't rely on our
3477 * incoming SV being well formed and having a trailing '\0', as certain
3478 * code in pp_formline can send us partially built SVs. */
3482 if (NATIVE_BYTE_IS_INVARIANT(ch)) continue;
3484 t--; /* t already incremented; re-point to first variant */
3489 /* utf8 conversion not needed because all are invariants. Mark as
3490 * UTF-8 even if no variant - saves scanning loop */
3492 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3497 /* Here, the string should be converted to utf8, either because of an
3498 * input flag (two_byte_count = 0), or because a character that
3499 * requires 2 bytes was found (two_byte_count = 1). t points either to
3500 * the beginning of the string (if we didn't examine anything), or to
3501 * the first variant. In either case, everything from s to t - 1 will
3502 * occupy only 1 byte each on output.
3504 * There are two main ways to convert. One is to create a new string
3505 * and go through the input starting from the beginning, appending each
3506 * converted value onto the new string as we go along. It's probably
3507 * best to allocate enough space in the string for the worst possible
3508 * case rather than possibly running out of space and having to
3509 * reallocate and then copy what we've done so far. Since everything
3510 * from s to t - 1 is invariant, the destination can be initialized
3511 * with these using a fast memory copy
3513 * The other way is to figure out exactly how big the string should be
3514 * by parsing the entire input. Then you don't have to make it big
3515 * enough to handle the worst possible case, and more importantly, if
3516 * the string you already have is large enough, you don't have to
3517 * allocate a new string, you can copy the last character in the input
3518 * string to the final position(s) that will be occupied by the
3519 * converted string and go backwards, stopping at t, since everything
3520 * before that is invariant.
3522 * There are advantages and disadvantages to each method.
3524 * In the first method, we can allocate a new string, do the memory
3525 * copy from the s to t - 1, and then proceed through the rest of the
3526 * string byte-by-byte.
3528 * In the second method, we proceed through the rest of the input
3529 * string just calculating how big the converted string will be. Then
3530 * there are two cases:
3531 * 1) if the string has enough extra space to handle the converted
3532 * value. We go backwards through the string, converting until we
3533 * get to the position we are at now, and then stop. If this
3534 * position is far enough along in the string, this method is
3535 * faster than the other method. If the memory copy were the same
3536 * speed as the byte-by-byte loop, that position would be about
3537 * half-way, as at the half-way mark, parsing to the end and back
3538 * is one complete string's parse, the same amount as starting
3539 * over and going all the way through. Actually, it would be
3540 * somewhat less than half-way, as it's faster to just count bytes
3541 * than to also copy, and we don't have the overhead of allocating
3542 * a new string, changing the scalar to use it, and freeing the
3543 * existing one. But if the memory copy is fast, the break-even
3544 * point is somewhere after half way. The counting loop could be
3545 * sped up by vectorization, etc, to move the break-even point
3546 * further towards the beginning.
3547 * 2) if the string doesn't have enough space to handle the converted
3548 * value. A new string will have to be allocated, and one might
3549 * as well, given that, start from the beginning doing the first
3550 * method. We've spent extra time parsing the string and in
3551 * exchange all we've gotten is that we know precisely how big to
3552 * make the new one. Perl is more optimized for time than space,
3553 * so this case is a loser.
3554 * So what I've decided to do is not use the 2nd method unless it is
3555 * guaranteed that a new string won't have to be allocated, assuming
3556 * the worst case. I also decided not to put any more conditions on it
3557 * than this, for now. It seems likely that, since the worst case is
3558 * twice as big as the unknown portion of the string (plus 1), we won't
3559 * be guaranteed enough space, causing us to go to the first method,
3560 * unless the string is short, or the first variant character is near
3561 * the end of it. In either of these cases, it seems best to use the
3562 * 2nd method. The only circumstance I can think of where this would
3563 * be really slower is if the string had once had much more data in it
3564 * than it does now, but there is still a substantial amount in it */
3567 STRLEN invariant_head = t - s;
3568 STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3569 if (SvLEN(sv) < size) {
3571 /* Here, have decided to allocate a new string */
3576 Newx(dst, size, U8);
3578 /* If no known invariants at the beginning of the input string,
3579 * set so starts from there. Otherwise, can use memory copy to
3580 * get up to where we are now, and then start from here */
3582 if (invariant_head == 0) {
3585 Copy(s, dst, invariant_head, char);
3586 d = dst + invariant_head;
3590 append_utf8_from_native_byte(*t, &d);
3594 SvPV_free(sv); /* No longer using pre-existing string */
3595 SvPV_set(sv, (char*)dst);
3596 SvCUR_set(sv, d - dst);
3597 SvLEN_set(sv, size);
3600 /* Here, have decided to get the exact size of the string.
3601 * Currently this happens only when we know that there is
3602 * guaranteed enough space to fit the converted string, so
3603 * don't have to worry about growing. If two_byte_count is 0,
3604 * then t points to the first byte of the string which hasn't
3605 * been examined yet. Otherwise two_byte_count is 1, and t
3606 * points to the first byte in the string that will expand to
3607 * two. Depending on this, start examining at t or 1 after t.
3610 U8 *d = t + two_byte_count;
3613 /* Count up the remaining bytes that expand to two */
3616 const U8 chr = *d++;
3617 if (! NATIVE_BYTE_IS_INVARIANT(chr)) two_byte_count++;
3620 /* The string will expand by just the number of bytes that
3621 * occupy two positions. But we are one afterwards because of
3622 * the increment just above. This is the place to put the
3623 * trailing NUL, and to set the length before we decrement */
3625 d += two_byte_count;
3626 SvCUR_set(sv, d - s);
3630 /* Having decremented d, it points to the position to put the
3631 * very last byte of the expanded string. Go backwards through
3632 * the string, copying and expanding as we go, stopping when we
3633 * get to the part that is invariant the rest of the way down */
3637 if (NATIVE_BYTE_IS_INVARIANT(*e)) {
3640 *d-- = UTF8_EIGHT_BIT_LO(*e);
3641 *d-- = UTF8_EIGHT_BIT_HI(*e);
3647 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3648 /* Update pos. We do it at the end rather than during
3649 * the upgrade, to avoid slowing down the common case
3650 * (upgrade without pos).
3651 * pos can be stored as either bytes or characters. Since
3652 * this was previously a byte string we can just turn off
3653 * the bytes flag. */
3654 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3656 mg->mg_flags &= ~MGf_BYTES;
3658 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3659 magic_setutf8(sv,mg); /* clear UTF8 cache */
3664 /* Mark as UTF-8 even if no variant - saves scanning loop */
3670 =for apidoc sv_utf8_downgrade
3672 Attempts to convert the PV of an SV from characters to bytes.
3673 If the PV contains a character that cannot fit
3674 in a byte, this conversion will fail;
3675 in this case, either returns false or, if C<fail_ok> is not
3678 This is not a general purpose Unicode to byte encoding interface:
3679 use the C<Encode> extension for that.
3685 Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
3687 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3689 if (SvPOKp(sv) && SvUTF8(sv)) {
3693 int mg_flags = SV_GMAGIC;
3696 S_sv_uncow(aTHX_ sv, 0);
3698 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3700 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3701 if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
3702 mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
3703 SV_GMAGIC|SV_CONST_RETURN);
3704 mg_flags = 0; /* sv_pos_b2u does get magic */
3706 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3707 magic_setutf8(sv,mg); /* clear UTF8 cache */
3710 s = (U8 *) SvPV_flags(sv, len, mg_flags);
3712 if (!utf8_to_bytes(s, &len)) {
3717 Perl_croak(aTHX_ "Wide character in %s",
3720 Perl_croak(aTHX_ "Wide character");
3731 =for apidoc sv_utf8_encode
3733 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3734 flag off so that it looks like octets again.
3740 Perl_sv_utf8_encode(pTHX_ SV *const sv)
3742 PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3744 if (SvREADONLY(sv)) {
3745 sv_force_normal_flags(sv, 0);
3747 (void) sv_utf8_upgrade(sv);
3752 =for apidoc sv_utf8_decode
3754 If the PV of the SV is an octet sequence in UTF-8
3755 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3756 so that it looks like a character. If the PV contains only single-byte
3757 characters, the C<SvUTF8> flag stays off.
3758 Scans PV for validity and returns false if the PV is invalid UTF-8.
3764 Perl_sv_utf8_decode(pTHX_ SV *const sv)
3766 PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3769 const U8 *start, *c;
3772 /* The octets may have got themselves encoded - get them back as
3775 if (!sv_utf8_downgrade(sv, TRUE))
3778 /* it is actually just a matter of turning the utf8 flag on, but
3779 * we want to make sure everything inside is valid utf8 first.
3781 c = start = (const U8 *) SvPVX_const(sv);
3782 if (!is_utf8_string(c, SvCUR(sv)))
3784 e = (const U8 *) SvEND(sv);
3787 if (!UTF8_IS_INVARIANT(ch)) {
3792 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3793 /* XXX Is this dead code? XS_utf8_decode calls SvSETMAGIC
3794 after this, clearing pos. Does anything on CPAN
3796 /* adjust pos to the start of a UTF8 char sequence */
3797 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3799 I32 pos = mg->mg_len;
3801 for (c = start + pos; c > start; c--) {
3802 if (UTF8_IS_START(*c))
3805 mg->mg_len = c - start;
3808 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3809 magic_setutf8(sv,mg); /* clear UTF8 cache */
3816 =for apidoc sv_setsv
3818 Copies the contents of the source SV C<ssv> into the destination SV
3819 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3820 function if the source SV needs to be reused. Does not handle 'set' magic on
3821 destination SV. Calls 'get' magic on source SV. Loosely speaking, it
3822 performs a copy-by-value, obliterating any previous content of the
3825 You probably want to use one of the assortment of wrappers, such as
3826 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3827 C<SvSetMagicSV_nosteal>.
3829 =for apidoc sv_setsv_flags
3831 Copies the contents of the source SV C<ssv> into the destination SV
3832 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3833 function if the source SV needs to be reused. Does not handle 'set' magic.
3834 Loosely speaking, it performs a copy-by-value, obliterating any previous
3835 content of the destination.
3836 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3837 C<ssv> if appropriate, else not. If the C<flags>
3838 parameter has the C<SV_NOSTEAL> bit set then the
3839 buffers of temps will not be stolen. C<sv_setsv>
3840 and C<sv_setsv_nomg> are implemented in terms of this function.
3842 You probably want to use one of the assortment of wrappers, such as
3843 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3844 C<SvSetMagicSV_nosteal>.
3846 This is the primary function for copying scalars, and most other
3847 copy-ish functions and macros use this underneath.
3853 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3855 I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3856 HV *old_stash = NULL;
3858 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3860 if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3861 const char * const name = GvNAME(sstr);
3862 const STRLEN len = GvNAMELEN(sstr);
3864 if (dtype >= SVt_PV) {
3870 SvUPGRADE(dstr, SVt_PVGV);
3871 (void)SvOK_off(dstr);
3872 isGV_with_GP_on(dstr);
3874 GvSTASH(dstr) = GvSTASH(sstr);
3876 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3877 gv_name_set(MUTABLE_GV(dstr), name, len,
3878 GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
3879 SvFAKE_on(dstr); /* can coerce to non-glob */
3882 if(GvGP(MUTABLE_GV(sstr))) {
3883 /* If source has method cache entry, clear it */
3885 SvREFCNT_dec(GvCV(sstr));
3886 GvCV_set(sstr, NULL);
3889 /* If source has a real method, then a method is
3892 GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3898 /* If dest already had a real method, that's a change as well */
3900 !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3901 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3906 /* We don't need to check the name of the destination if it was not a
3907 glob to begin with. */
3908 if(dtype == SVt_PVGV) {
3909 const char * const name = GvNAME((const GV *)dstr);
3912 /* The stash may have been detached from the symbol table, so
3914 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3918 const STRLEN len = GvNAMELEN(dstr);
3919 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3920 || (len == 1 && name[0] == ':')) {
3923 /* Set aside the old stash, so we can reset isa caches on
3925 if((old_stash = GvHV(dstr)))
3926 /* Make sure we do not lose it early. */
3927 SvREFCNT_inc_simple_void_NN(
3928 sv_2mortal((SV *)old_stash)
3933 SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
3936 /* freeing dstr's GP might free sstr (e.g. *x = $x),
3937 * so temporarily protect it */
3939 SAVEFREESV(SvREFCNT_inc_simple_NN(sstr));
3940 gp_free(MUTABLE_GV(dstr));
3941 GvINTRO_off(dstr); /* one-shot flag */
3942 GvGP_set(dstr, gp_ref(GvGP(sstr)));
3945 if (SvTAINTED(sstr))
3947 if (GvIMPORTED(dstr) != GVf_IMPORTED
3948 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3950 GvIMPORTED_on(dstr);
3953 if(mro_changes == 2) {
3954 if (GvAV((const GV *)sstr)) {
3956 SV * const sref = (SV *)GvAV((const GV *)dstr);
3957 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3958 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3959 AV * const ary = newAV();
3960 av_push(ary, mg->mg_obj); /* takes the refcount */
3961 mg->mg_obj = (SV *)ary;
3963 av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3965 else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3967 mro_isa_changed_in(GvSTASH(dstr));
3969 else if(mro_changes == 3) {
3970 HV * const stash = GvHV(dstr);
3971 if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3977 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3978 if (GvIO(dstr) && dtype == SVt_PVGV) {
3979 DEBUG_o(Perl_deb(aTHX_
3980 "glob_assign_glob clearing PL_stashcache\n"));
3981 /* It's a cache. It will rebuild itself quite happily.
3982 It's a lot of effort to work out exactly which key (or keys)
3983 might be invalidated by the creation of the this file handle.
3985 hv_clear(PL_stashcache);
3991 Perl_gv_setref(pTHX_ SV *const dstr, SV *const sstr)
3993 SV * const sref = SvRV(sstr);
3995 const int intro = GvINTRO(dstr);
3998 const U32 stype = SvTYPE(sref);
4000 PERL_ARGS_ASSERT_GV_SETREF;
4003 GvINTRO_off(dstr); /* one-shot flag */
4004 GvLINE(dstr) = CopLINE(PL_curcop);
4005 GvEGV(dstr) = MUTABLE_GV(dstr);
4010 location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
4011 import_flag = GVf_IMPORTED_CV;
4014 location = (SV **) &GvHV(dstr);
4015 import_flag = GVf_IMPORTED_HV;
4018 location = (SV **) &GvAV(dstr);
4019 import_flag = GVf_IMPORTED_AV;
4022 location = (SV **) &GvIOp(dstr);
4025 location = (SV **) &GvFORM(dstr);
4028 location = &GvSV(dstr);
4029 import_flag = GVf_IMPORTED_SV;
4032 if (stype == SVt_PVCV) {
4033 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
4034 if (GvCVGEN(dstr)) {
4035 SvREFCNT_dec(GvCV(dstr));
4036 GvCV_set(dstr, NULL);
4037 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4040 /* SAVEt_GVSLOT takes more room on the savestack and has more
4041 overhead in leave_scope than SAVEt_GENERIC_SV. But for CVs
4042 leave_scope needs access to the GV so it can reset method
4043 caches. We must use SAVEt_GVSLOT whenever the type is
4044 SVt_PVCV, even if the stash is anonymous, as the stash may
4045 gain a name somehow before leave_scope. */
4046 if (stype == SVt_PVCV) {
4047 /* There is no save_pushptrptrptr. Creating it for this
4048 one call site would be overkill. So inline the ss add
4052 SS_ADD_PTR(location);
4053 SS_ADD_PTR(SvREFCNT_inc(*location));
4054 SS_ADD_UV(SAVEt_GVSLOT);
4057 else SAVEGENERICSV(*location);
4060 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
4061 CV* const cv = MUTABLE_CV(*location);
4063 if (!GvCVGEN((const GV *)dstr) &&
4064 (CvROOT(cv) || CvXSUB(cv)) &&
4065 /* redundant check that avoids creating the extra SV
4066 most of the time: */
4067 (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
4069 SV * const new_const_sv =
4070 CvCONST((const CV *)sref)
4071 ? cv_const_sv((const CV *)sref)
4073 report_redefined_cv(
4074 sv_2mortal(Perl_newSVpvf(aTHX_
4077 HvNAME_HEK(GvSTASH((const GV *)dstr))
4079 HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
4082 CvCONST((const CV *)sref) ? &new_const_sv : NULL
4086 cv_ckproto_len_flags(cv, (const GV *)dstr,
4087 SvPOK(sref) ? CvPROTO(sref) : NULL,
4088 SvPOK(sref) ? CvPROTOLEN(sref) : 0,
4089 SvPOK(sref) ? SvUTF8(sref) : 0);
4091 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4092 GvASSUMECV_on(dstr);
4093 if(GvSTASH(dstr)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
4094 if (intro && GvREFCNT(dstr) > 1) {
4095 /* temporary remove extra savestack's ref */
4097 gv_method_changed(dstr);
4100 else gv_method_changed(dstr);
4103 *location = SvREFCNT_inc_simple_NN(sref);
4104 if (import_flag && !(GvFLAGS(dstr) & import_flag)
4105 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
4106 GvFLAGS(dstr) |= import_flag;
4109 if (stype == SVt_PVHV) {
4110 const char * const name = GvNAME((GV*)dstr);
4111 const STRLEN len = GvNAMELEN(dstr);
4114 (len > 1 && name[len-2] == ':' && name[len-1] == ':')
4115 || (len == 1 && name[0] == ':')
4117 && (!dref || HvENAME_get(dref))
4120 (HV *)sref, (HV *)dref,
4126 stype == SVt_PVAV && sref != dref
4127 && strEQ(GvNAME((GV*)dstr), "ISA")
4128 /* The stash may have been detached from the symbol table, so
4129 check its name before doing anything. */
4130 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
4133 MAGIC * const omg = dref && SvSMAGICAL(dref)
4134 ? mg_find(dref, PERL_MAGIC_isa)
4136 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
4137 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
4138 AV * const ary = newAV();
4139 av_push(ary, mg->mg_obj); /* takes the refcount */
4140 mg->mg_obj = (SV *)ary;
4143 if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
4144 SV **svp = AvARRAY((AV *)omg->mg_obj);
4145 I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
4149 SvREFCNT_inc_simple_NN(*svp++)
4155 SvREFCNT_inc_simple_NN(omg->mg_obj)
4159 av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
4165 sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
4167 for (i = 0; i <= AvFILL(sref); ++i) {
4168 SV **elem = av_fetch ((AV*)sref, i, 0);
4171 *elem, sref, PERL_MAGIC_isaelem, NULL, i
4175 mg = mg_find(sref, PERL_MAGIC_isa);
4177 /* Since the *ISA assignment could have affected more than
4178 one stash, don't call mro_isa_changed_in directly, but let
4179 magic_clearisa do it for us, as it already has the logic for
4180 dealing with globs vs arrays of globs. */
4182 Perl_magic_clearisa(aTHX_ NULL, mg);
4184 else if (stype == SVt_PVIO) {
4185 DEBUG_o(Perl_deb(aTHX_ "gv_setref clearing PL_stashcache\n"));
4186 /* It's a cache. It will rebuild itself quite happily.
4187 It's a lot of effort to work out exactly which key (or keys)
4188 might be invalidated by the creation of the this file handle.
4190 hv_clear(PL_stashcache);
4194 if (!intro) SvREFCNT_dec(dref);
4195 if (SvTAINTED(sstr))
4203 #ifdef PERL_DEBUG_READONLY_COW
4204 # include <sys/mman.h>
4206 # ifndef PERL_MEMORY_DEBUG_HEADER_SIZE
4207 # define PERL_MEMORY_DEBUG_HEADER_SIZE 0
4211 Perl_sv_buf_to_ro(pTHX_ SV *sv)
4213 struct perl_memory_debug_header * const header =
4214 (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4215 const MEM_SIZE len = header->size;
4216 PERL_ARGS_ASSERT_SV_BUF_TO_RO;
4217 # ifdef PERL_TRACK_MEMPOOL
4218 if (!header->readonly) header->readonly = 1;
4220 if (mprotect(header, len, PROT_READ))
4221 Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
4222 header, len, errno);
4226 S_sv_buf_to_rw(pTHX_ SV *sv)
4228 struct perl_memory_debug_header * const header =
4229 (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4230 const MEM_SIZE len = header->size;
4231 PERL_ARGS_ASSERT_SV_BUF_TO_RW;
4232 if (mprotect(header, len, PROT_READ|PROT_WRITE))
4233 Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
4234 header, len, errno);
4235 # ifdef PERL_TRACK_MEMPOOL
4236 header->readonly = 0;
4241 # define sv_buf_to_ro(sv) NOOP
4242 # define sv_buf_to_rw(sv) NOOP
4246 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
4251 unsigned int both_type;
4253 PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
4255 if (UNLIKELY( sstr == dstr ))
4258 if (UNLIKELY( !sstr ))
4259 sstr = &PL_sv_undef;
4261 stype = SvTYPE(sstr);
4262 dtype = SvTYPE(dstr);
4263 both_type = (stype | dtype);
4265 /* with these values, we can check that both SVs are NULL/IV (and not
4266 * freed) just by testing the or'ed types */
4267 STATIC_ASSERT_STMT(SVt_NULL == 0);
4268 STATIC_ASSERT_STMT(SVt_IV == 1);
4269 if (both_type <= 1) {
4270 /* both src and dst are UNDEF/IV/RV, so we can do a lot of
4275 /* minimal subset of SV_CHECK_THINKFIRST_COW_DROP(dstr) */
4276 if (SvREADONLY(dstr))
4277 Perl_croak_no_modify();
4279 sv_unref_flags(dstr, 0);
4281 assert(!SvGMAGICAL(sstr));
4282 assert(!SvGMAGICAL(dstr));
4284 sflags = SvFLAGS(sstr);
4285 if (sflags & (SVf_IOK|SVf_ROK)) {
4286 SET_SVANY_FOR_BODYLESS_IV(dstr);
4287 new_dflags = SVt_IV;
4289 if (sflags & SVf_ROK) {
4290 dstr->sv_u.svu_rv = SvREFCNT_inc(SvRV(sstr));
4291 new_dflags |= SVf_ROK;
4294 /* both src and dst are <= SVt_IV, so sv_any points to the
4295 * head; so access the head directly
4297 assert( &(sstr->sv_u.svu_iv)
4298 == &(((XPVIV*) SvANY(sstr))->xiv_iv));
4299 assert( &(dstr->sv_u.svu_iv)
4300 == &(((XPVIV*) SvANY(dstr))->xiv_iv));
4301 dstr->sv_u.svu_iv = sstr->sv_u.svu_iv;
4302 new_dflags |= (SVf_IOK|SVp_IOK|(sflags & SVf_IVisUV));
4306 new_dflags = dtype; /* turn off everything except the type */
4308 SvFLAGS(dstr) = new_dflags;
4313 if (UNLIKELY(both_type == SVTYPEMASK)) {
4314 if (SvIS_FREED(dstr)) {
4315 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
4316 " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
4318 if (SvIS_FREED(sstr)) {
4319 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
4320 (void*)sstr, (void*)dstr);
4326 SV_CHECK_THINKFIRST_COW_DROP(dstr);
4327 dtype = SvTYPE(dstr); /* THINKFIRST may have changed type */
4329 /* There's a lot of redundancy below but we're going for speed here */
4334 if (LIKELY( dtype != SVt_PVGV && dtype != SVt_PVLV )) {
4335 (void)SvOK_off(dstr);
4343 /* For performance, we inline promoting to type SVt_IV. */
4344 /* We're starting from SVt_NULL, so provided that define is
4345 * actual 0, we don't have to unset any SV type flags
4346 * to promote to SVt_IV. */
4347 STATIC_ASSERT_STMT(SVt_NULL == 0);
4348 SET_SVANY_FOR_BODYLESS_IV(dstr);
4349 SvFLAGS(dstr) |= SVt_IV;
4353 sv_upgrade(dstr, SVt_PVIV);
4357 goto end_of_first_switch;
4359 (void)SvIOK_only(dstr);
4360 SvIV_set(dstr, SvIVX(sstr));
4363 /* SvTAINTED can only be true if the SV has taint magic, which in
4364 turn means that the SV type is PVMG (or greater). This is the
4365 case statement for SVt_IV, so this cannot be true (whatever gcov
4367 assert(!SvTAINTED(sstr));
4372 if (dtype < SVt_PV && dtype != SVt_IV)
4373 sv_upgrade(dstr, SVt_IV);
4377 if (LIKELY( SvNOK(sstr) )) {
4381 sv_upgrade(dstr, SVt_NV);
4385 sv_upgrade(dstr, SVt_PVNV);
4389 goto end_of_first_switch;
4391 SvNV_set(dstr, SvNVX(sstr));
4392 (void)SvNOK_only(dstr);
4393 /* SvTAINTED can only be true if the SV has taint magic, which in
4394 turn means that the SV type is PVMG (or greater). This is the
4395 case statement for SVt_NV, so this cannot be true (whatever gcov
4397 assert(!SvTAINTED(sstr));
4404 sv_upgrade(dstr, SVt_PV);
4407 if (dtype < SVt_PVIV)
4408 sv_upgrade(dstr, SVt_PVIV);
4411 if (dtype < SVt_PVNV)
4412 sv_upgrade(dstr, SVt_PVNV);
4416 const char * const type = sv_reftype(sstr,0);
4418 /* diag_listed_as: Bizarre copy of %s */
4419 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4421 Perl_croak(aTHX_ "Bizarre copy of %s", type);
4423 NOT_REACHED; /* NOTREACHED */
4427 if (dtype < SVt_REGEXP)
4429 if (dtype >= SVt_PV) {
4435 sv_upgrade(dstr, SVt_REGEXP);
4443 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4445 if (SvTYPE(sstr) != stype)
4446 stype = SvTYPE(sstr);
4448 if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4449 glob_assign_glob(dstr, sstr, dtype);
4452 if (stype == SVt_PVLV)
4454 if (isREGEXP(sstr)) goto upgregexp;
4455 SvUPGRADE(dstr, SVt_PVNV);
4458 SvUPGRADE(dstr, (svtype)stype);
4460 end_of_first_switch:
4462 /* dstr may have been upgraded. */
4463 dtype = SvTYPE(dstr);
4464 sflags = SvFLAGS(sstr);
4466 if (UNLIKELY( dtype == SVt_PVCV )) {
4467 /* Assigning to a subroutine sets the prototype. */
4470 const char *const ptr = SvPV_const(sstr, len);
4472 SvGROW(dstr, len + 1);
4473 Copy(ptr, SvPVX(dstr), len + 1, char);
4474 SvCUR_set(dstr, len);
4476 SvFLAGS(dstr) |= sflags & SVf_UTF8;
4477 CvAUTOLOAD_off(dstr);
4482 else if (UNLIKELY(dtype == SVt_PVAV || dtype == SVt_PVHV
4483 || dtype == SVt_PVFM))
4485 const char * const type = sv_reftype(dstr,0);
4487 /* diag_listed_as: Cannot copy to %s */
4488 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4490 Perl_croak(aTHX_ "Cannot copy to %s", type);
4491 } else if (sflags & SVf_ROK) {
4492 if (isGV_with_GP(dstr)
4493 && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4496 if (GvIMPORTED(dstr) != GVf_IMPORTED
4497 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4499 GvIMPORTED_on(dstr);
4504 glob_assign_glob(dstr, sstr, dtype);
4508 if (dtype >= SVt_PV) {
4509 if (isGV_with_GP(dstr)) {
4510 gv_setref(dstr, sstr);
4513 if (SvPVX_const(dstr)) {
4519 (void)SvOK_off(dstr);
4520 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4521 SvFLAGS(dstr) |= sflags & SVf_ROK;
4522 assert(!(sflags & SVp_NOK));
4523 assert(!(sflags & SVp_IOK));
4524 assert(!(sflags & SVf_NOK));
4525 assert(!(sflags & SVf_IOK));
4527 else if (isGV_with_GP(dstr)) {
4528 if (!(sflags & SVf_OK)) {
4529 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4530 "Undefined value assigned to typeglob");
4533 GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
4534 if (dstr != (const SV *)gv) {
4535 const char * const name = GvNAME((const GV *)dstr);
4536 const STRLEN len = GvNAMELEN(dstr);
4537 HV *old_stash = NULL;
4538 bool reset_isa = FALSE;
4539 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4540 || (len == 1 && name[0] == ':')) {
4541 /* Set aside the old stash, so we can reset isa caches
4542 on its subclasses. */
4543 if((old_stash = GvHV(dstr))) {
4544 /* Make sure we do not lose it early. */
4545 SvREFCNT_inc_simple_void_NN(
4546 sv_2mortal((SV *)old_stash)
4553 SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
4554 gp_free(MUTABLE_GV(dstr));
4556 GvGP_set(dstr, gp_ref(GvGP(gv)));
4559 HV * const stash = GvHV(dstr);
4561 old_stash ? (HV *)HvENAME_get(old_stash) : stash
4571 else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4572 && (stype == SVt_REGEXP || isREGEXP(sstr))) {
4573 reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4575 else if (sflags & SVp_POK) {
4576 const STRLEN cur = SvCUR(sstr);
4577 const STRLEN len = SvLEN(sstr);
4580 * We have three basic ways to copy the string:
4586 * Which we choose is based on various factors. The following
4587 * things are listed in order of speed, fastest to slowest:
4589 * - Copying a short string
4590 * - Copy-on-write bookkeeping
4592 * - Copying a long string
4594 * We swipe the string (steal the string buffer) if the SV on the
4595 * rhs is about to be freed anyway (TEMP and refcnt==1). This is a
4596 * big win on long strings. It should be a win on short strings if
4597 * SvPVX_const(dstr) has to be allocated. If not, it should not
4598 * slow things down, as SvPVX_const(sstr) would have been freed
4601 * We also steal the buffer from a PADTMP (operator target) if it
4602 * is ‘long enough’. For short strings, a swipe does not help
4603 * here, as it causes more malloc calls the next time the target
4604 * is used. Benchmarks show that even if SvPVX_const(dstr) has to
4605 * be allocated it is still not worth swiping PADTMPs for short
4606 * strings, as the savings here are small.
4608 * If swiping is not an option, then we see whether it is
4609 * worth using copy-on-write. If the lhs already has a buf-
4610 * fer big enough and the string is short, we skip it and fall back
4611 * to method 3, since memcpy is faster for short strings than the
4612 * later bookkeeping overhead that copy-on-write entails.
4614 * If the rhs is not a copy-on-write string yet, then we also
4615 * consider whether the buffer is too large relative to the string
4616 * it holds. Some operations such as readline allocate a large
4617 * buffer in the expectation of reusing it. But turning such into
4618 * a COW buffer is counter-productive because it increases memory
4619 * usage by making readline allocate a new large buffer the sec-
4620 * ond time round. So, if the buffer is too large, again, we use
4623 * Finally, if there is no buffer on the left, or the buffer is too
4624 * small, then we use copy-on-write and make both SVs share the
4629 /* Whichever path we take through the next code, we want this true,