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 #ifdef PERL_OLD_COPY_ON_WRITE
129 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
130 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
133 /* ============================================================================
135 =head1 Allocation and deallocation of SVs.
136 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
137 sv, av, hv...) contains type and reference count information, and for
138 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
139 contains fields specific to each type. Some types store all they need
140 in the head, so don't have a body.
142 In all but the most memory-paranoid configurations (ex: PURIFY), heads
143 and bodies are allocated out of arenas, which by default are
144 approximately 4K chunks of memory parcelled up into N heads or bodies.
145 Sv-bodies are allocated by their sv-type, guaranteeing size
146 consistency needed to allocate safely from arrays.
148 For SV-heads, the first slot in each arena is reserved, and holds a
149 link to the next arena, some flags, and a note of the number of slots.
150 Snaked through each arena chain is a linked list of free items; when
151 this becomes empty, an extra arena is allocated and divided up into N
152 items which are threaded into the free list.
154 SV-bodies are similar, but they use arena-sets by default, which
155 separate the link and info from the arena itself, and reclaim the 1st
156 slot in the arena. SV-bodies are further described later.
158 The following global variables are associated with arenas:
160 PL_sv_arenaroot pointer to list of SV arenas
161 PL_sv_root pointer to list of free SV structures
163 PL_body_arenas head of linked-list of body arenas
164 PL_body_roots[] array of pointers to list of free bodies of svtype
165 arrays are indexed by the svtype needed
167 A few special SV heads are not allocated from an arena, but are
168 instead directly created in the interpreter structure, eg PL_sv_undef.
169 The size of arenas can be changed from the default by setting
170 PERL_ARENA_SIZE appropriately at compile time.
172 The SV arena serves the secondary purpose of allowing still-live SVs
173 to be located and destroyed during final cleanup.
175 At the lowest level, the macros new_SV() and del_SV() grab and free
176 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
177 to return the SV to the free list with error checking.) new_SV() calls
178 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
179 SVs in the free list have their SvTYPE field set to all ones.
181 At the time of very final cleanup, sv_free_arenas() is called from
182 perl_destruct() to physically free all the arenas allocated since the
183 start of the interpreter.
185 The function visit() scans the SV arenas list, and calls a specified
186 function for each SV it finds which is still live - ie which has an SvTYPE
187 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
188 following functions (specified as [function that calls visit()] / [function
189 called by visit() for each SV]):
191 sv_report_used() / do_report_used()
192 dump all remaining SVs (debugging aid)
194 sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
195 do_clean_named_io_objs(),do_curse()
196 Attempt to free all objects pointed to by RVs,
197 try to do the same for all objects indir-
198 ectly referenced by typeglobs too, and
199 then do a final sweep, cursing any
200 objects that remain. Called once from
201 perl_destruct(), prior to calling sv_clean_all()
204 sv_clean_all() / do_clean_all()
205 SvREFCNT_dec(sv) each remaining SV, possibly
206 triggering an sv_free(). It also sets the
207 SVf_BREAK flag on the SV to indicate that the
208 refcnt has been artificially lowered, and thus
209 stopping sv_free() from giving spurious warnings
210 about SVs which unexpectedly have a refcnt
211 of zero. called repeatedly from perl_destruct()
212 until there are no SVs left.
214 =head2 Arena allocator API Summary
216 Private API to rest of sv.c
220 new_XPVNV(), del_XPVGV(),
225 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
229 * ========================================================================= */
232 * "A time to plant, and a time to uproot what was planted..."
236 # define MEM_LOG_NEW_SV(sv, file, line, func) \
237 Perl_mem_log_new_sv(sv, file, line, func)
238 # define MEM_LOG_DEL_SV(sv, file, line, func) \
239 Perl_mem_log_del_sv(sv, file, line, func)
241 # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP
242 # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP
245 #ifdef DEBUG_LEAKING_SCALARS
246 # define FREE_SV_DEBUG_FILE(sv) STMT_START { \
247 if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \
249 # define DEBUG_SV_SERIAL(sv) \
250 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
251 PTR2UV(sv), (long)(sv)->sv_debug_serial))
253 # define FREE_SV_DEBUG_FILE(sv)
254 # define DEBUG_SV_SERIAL(sv) NOOP
258 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
259 # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val))
260 /* Whilst I'd love to do this, it seems that things like to check on
262 # define POISON_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
264 # define POISON_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
265 PoisonNew(&SvREFCNT(sv), 1, U32)
267 # define SvARENA_CHAIN(sv) SvANY(sv)
268 # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val)
269 # define POISON_SV_HEAD(sv)
272 /* Mark an SV head as unused, and add to free list.
274 * If SVf_BREAK is set, skip adding it to the free list, as this SV had
275 * its refcount artificially decremented during global destruction, so
276 * there may be dangling pointers to it. The last thing we want in that
277 * case is for it to be reused. */
279 #define plant_SV(p) \
281 const U32 old_flags = SvFLAGS(p); \
282 MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
283 DEBUG_SV_SERIAL(p); \
284 FREE_SV_DEBUG_FILE(p); \
286 SvFLAGS(p) = SVTYPEMASK; \
287 if (!(old_flags & SVf_BREAK)) { \
288 SvARENA_CHAIN_SET(p, PL_sv_root); \
294 #define uproot_SV(p) \
297 PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \
302 /* make some more SVs by adding another arena */
308 char *chunk; /* must use New here to match call to */
309 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
310 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
315 /* new_SV(): return a new, empty SV head */
317 #ifdef DEBUG_LEAKING_SCALARS
318 /* provide a real function for a debugger to play with */
320 S_new_SV(pTHX_ const char *file, int line, const char *func)
327 sv = S_more_sv(aTHX);
331 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
332 sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
338 sv->sv_debug_inpad = 0;
339 sv->sv_debug_parent = NULL;
340 sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
342 sv->sv_debug_serial = PL_sv_serial++;
344 MEM_LOG_NEW_SV(sv, file, line, func);
345 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
346 PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
350 # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
358 (p) = S_more_sv(aTHX); \
362 MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \
367 /* del_SV(): return an empty SV head to the free list */
380 S_del_sv(pTHX_ SV *p)
382 PERL_ARGS_ASSERT_DEL_SV;
387 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
388 const SV * const sv = sva + 1;
389 const SV * const svend = &sva[SvREFCNT(sva)];
390 if (p >= sv && p < svend) {
396 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
397 "Attempt to free non-arena SV: 0x%"UVxf
398 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
405 #else /* ! DEBUGGING */
407 #define del_SV(p) plant_SV(p)
409 #endif /* DEBUGGING */
412 * Bodyless IVs and NVs!
414 * Since 5.9.2, we can avoid allocating a body for SVt_IV-type SVs.
415 * Since the larger IV-holding variants of SVs store their integer
416 * values in their respective bodies, the family of SvIV() accessor
417 * macros would naively have to branch on the SV type to find the
418 * integer value either in the HEAD or BODY. In order to avoid this
419 * expensive branch, a clever soul has deployed a great hack:
420 * We set up the SvANY pointer such that instead of pointing to a
421 * real body, it points into the memory before the location of the
422 * head. We compute this pointer such that the location of
423 * the integer member of the hypothetical body struct happens to
424 * be the same as the location of the integer member of the bodyless
425 * SV head. This now means that the SvIV() family of accessors can
426 * always read from the (hypothetical or real) body via SvANY.
428 * Since the 5.21 dev series, we employ the same trick for NVs
429 * if the architecture can support it (NVSIZE <= IVSIZE).
432 /* The following two macros compute the necessary offsets for the above
433 * trick and store them in SvANY for SvIV() (and friends) to use. */
434 #define SET_SVANY_FOR_BODYLESS_IV(sv) \
435 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv))
437 #define SET_SVANY_FOR_BODYLESS_NV(sv) \
438 SvANY(sv) = (XPVNV*)((char*)&(sv->sv_u.svu_nv) - STRUCT_OFFSET(XPVNV, xnv_u.xnv_nv))
441 =head1 SV Manipulation Functions
443 =for apidoc sv_add_arena
445 Given a chunk of memory, link it to the head of the list of arenas,
446 and split it into a list of free SVs.
452 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
454 SV *const sva = MUTABLE_SV(ptr);
458 PERL_ARGS_ASSERT_SV_ADD_ARENA;
460 /* The first SV in an arena isn't an SV. */
461 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
462 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
463 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
465 PL_sv_arenaroot = sva;
466 PL_sv_root = sva + 1;
468 svend = &sva[SvREFCNT(sva) - 1];
471 SvARENA_CHAIN_SET(sv, (sv + 1));
475 /* Must always set typemask because it's always checked in on cleanup
476 when the arenas are walked looking for objects. */
477 SvFLAGS(sv) = SVTYPEMASK;
480 SvARENA_CHAIN_SET(sv, 0);
484 SvFLAGS(sv) = SVTYPEMASK;
487 /* visit(): call the named function for each non-free SV in the arenas
488 * whose flags field matches the flags/mask args. */
491 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
496 PERL_ARGS_ASSERT_VISIT;
498 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
499 const SV * const svend = &sva[SvREFCNT(sva)];
501 for (sv = sva + 1; sv < svend; ++sv) {
502 if (SvTYPE(sv) != (svtype)SVTYPEMASK
503 && (sv->sv_flags & mask) == flags
516 /* called by sv_report_used() for each live SV */
519 do_report_used(pTHX_ SV *const sv)
521 if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
522 PerlIO_printf(Perl_debug_log, "****\n");
529 =for apidoc sv_report_used
531 Dump the contents of all SVs not yet freed (debugging aid).
537 Perl_sv_report_used(pTHX)
540 visit(do_report_used, 0, 0);
546 /* called by sv_clean_objs() for each live SV */
549 do_clean_objs(pTHX_ SV *const ref)
553 SV * const target = SvRV(ref);
554 if (SvOBJECT(target)) {
555 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
556 if (SvWEAKREF(ref)) {
557 sv_del_backref(target, ref);
563 SvREFCNT_dec_NN(target);
570 /* clear any slots in a GV which hold objects - except IO;
571 * called by sv_clean_objs() for each live GV */
574 do_clean_named_objs(pTHX_ SV *const sv)
577 assert(SvTYPE(sv) == SVt_PVGV);
578 assert(isGV_with_GP(sv));
582 /* freeing GP entries may indirectly free the current GV;
583 * hold onto it while we mess with the GP slots */
586 if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
587 DEBUG_D((PerlIO_printf(Perl_debug_log,
588 "Cleaning named glob SV object:\n "), sv_dump(obj)));
590 SvREFCNT_dec_NN(obj);
592 if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
593 DEBUG_D((PerlIO_printf(Perl_debug_log,
594 "Cleaning named glob AV object:\n "), sv_dump(obj)));
596 SvREFCNT_dec_NN(obj);
598 if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
599 DEBUG_D((PerlIO_printf(Perl_debug_log,
600 "Cleaning named glob HV object:\n "), sv_dump(obj)));
602 SvREFCNT_dec_NN(obj);
604 if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
605 DEBUG_D((PerlIO_printf(Perl_debug_log,
606 "Cleaning named glob CV object:\n "), sv_dump(obj)));
608 SvREFCNT_dec_NN(obj);
610 SvREFCNT_dec_NN(sv); /* undo the inc above */
613 /* clear any IO slots in a GV which hold objects (except stderr, defout);
614 * called by sv_clean_objs() for each live GV */
617 do_clean_named_io_objs(pTHX_ SV *const sv)
620 assert(SvTYPE(sv) == SVt_PVGV);
621 assert(isGV_with_GP(sv));
622 if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
626 if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
627 DEBUG_D((PerlIO_printf(Perl_debug_log,
628 "Cleaning named glob IO object:\n "), sv_dump(obj)));
630 SvREFCNT_dec_NN(obj);
632 SvREFCNT_dec_NN(sv); /* undo the inc above */
635 /* Void wrapper to pass to visit() */
637 do_curse(pTHX_ SV * const sv) {
638 if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
639 || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
645 =for apidoc sv_clean_objs
647 Attempt to destroy all objects not yet freed.
653 Perl_sv_clean_objs(pTHX)
656 PL_in_clean_objs = TRUE;
657 visit(do_clean_objs, SVf_ROK, SVf_ROK);
658 /* Some barnacles may yet remain, clinging to typeglobs.
659 * Run the non-IO destructors first: they may want to output
660 * error messages, close files etc */
661 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
662 visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
663 /* And if there are some very tenacious barnacles clinging to arrays,
664 closures, or what have you.... */
665 visit(do_curse, SVs_OBJECT, SVs_OBJECT);
666 olddef = PL_defoutgv;
667 PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
668 if (olddef && isGV_with_GP(olddef))
669 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
670 olderr = PL_stderrgv;
671 PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
672 if (olderr && isGV_with_GP(olderr))
673 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
674 SvREFCNT_dec(olddef);
675 PL_in_clean_objs = FALSE;
678 /* called by sv_clean_all() for each live SV */
681 do_clean_all(pTHX_ SV *const sv)
683 if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
684 /* don't clean pid table and strtab */
687 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
688 SvFLAGS(sv) |= SVf_BREAK;
693 =for apidoc sv_clean_all
695 Decrement the refcnt of each remaining SV, possibly triggering a
696 cleanup. This function may have to be called multiple times to free
697 SVs which are in complex self-referential hierarchies.
703 Perl_sv_clean_all(pTHX)
706 PL_in_clean_all = TRUE;
707 cleaned = visit(do_clean_all, 0,0);
712 ARENASETS: a meta-arena implementation which separates arena-info
713 into struct arena_set, which contains an array of struct
714 arena_descs, each holding info for a single arena. By separating
715 the meta-info from the arena, we recover the 1st slot, formerly
716 borrowed for list management. The arena_set is about the size of an
717 arena, avoiding the needless malloc overhead of a naive linked-list.
719 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
720 memory in the last arena-set (1/2 on average). In trade, we get
721 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
722 smaller types). The recovery of the wasted space allows use of
723 small arenas for large, rare body types, by changing array* fields
724 in body_details_by_type[] below.
727 char *arena; /* the raw storage, allocated aligned */
728 size_t size; /* its size ~4k typ */
729 svtype utype; /* bodytype stored in arena */
734 /* Get the maximum number of elements in set[] such that struct arena_set
735 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
736 therefore likely to be 1 aligned memory page. */
738 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
739 - 2 * sizeof(int)) / sizeof (struct arena_desc))
742 struct arena_set* next;
743 unsigned int set_size; /* ie ARENAS_PER_SET */
744 unsigned int curr; /* index of next available arena-desc */
745 struct arena_desc set[ARENAS_PER_SET];
749 =for apidoc sv_free_arenas
751 Deallocate the memory used by all arenas. Note that all the individual SV
752 heads and bodies within the arenas must already have been freed.
758 Perl_sv_free_arenas(pTHX)
764 /* Free arenas here, but be careful about fake ones. (We assume
765 contiguity of the fake ones with the corresponding real ones.) */
767 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
768 svanext = MUTABLE_SV(SvANY(sva));
769 while (svanext && SvFAKE(svanext))
770 svanext = MUTABLE_SV(SvANY(svanext));
777 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
780 struct arena_set *current = aroot;
783 assert(aroot->set[i].arena);
784 Safefree(aroot->set[i].arena);
792 i = PERL_ARENA_ROOTS_SIZE;
794 PL_body_roots[i] = 0;
801 Here are mid-level routines that manage the allocation of bodies out
802 of the various arenas. There are 5 kinds of arenas:
804 1. SV-head arenas, which are discussed and handled above
805 2. regular body arenas
806 3. arenas for reduced-size bodies
809 Arena types 2 & 3 are chained by body-type off an array of
810 arena-root pointers, which is indexed by svtype. Some of the
811 larger/less used body types are malloced singly, since a large
812 unused block of them is wasteful. Also, several svtypes dont have
813 bodies; the data fits into the sv-head itself. The arena-root
814 pointer thus has a few unused root-pointers (which may be hijacked
815 later for arena types 4,5)
817 3 differs from 2 as an optimization; some body types have several
818 unused fields in the front of the structure (which are kept in-place
819 for consistency). These bodies can be allocated in smaller chunks,
820 because the leading fields arent accessed. Pointers to such bodies
821 are decremented to point at the unused 'ghost' memory, knowing that
822 the pointers are used with offsets to the real memory.
825 =head1 SV-Body Allocation
829 Allocation of SV-bodies is similar to SV-heads, differing as follows;
830 the allocation mechanism is used for many body types, so is somewhat
831 more complicated, it uses arena-sets, and has no need for still-live
834 At the outermost level, (new|del)_X*V macros return bodies of the
835 appropriate type. These macros call either (new|del)_body_type or
836 (new|del)_body_allocated macro pairs, depending on specifics of the
837 type. Most body types use the former pair, the latter pair is used to
838 allocate body types with "ghost fields".
840 "ghost fields" are fields that are unused in certain types, and
841 consequently don't need to actually exist. They are declared because
842 they're part of a "base type", which allows use of functions as
843 methods. The simplest examples are AVs and HVs, 2 aggregate types
844 which don't use the fields which support SCALAR semantics.
846 For these types, the arenas are carved up into appropriately sized
847 chunks, we thus avoid wasted memory for those unaccessed members.
848 When bodies are allocated, we adjust the pointer back in memory by the
849 size of the part not allocated, so it's as if we allocated the full
850 structure. (But things will all go boom if you write to the part that
851 is "not there", because you'll be overwriting the last members of the
852 preceding structure in memory.)
854 We calculate the correction using the STRUCT_OFFSET macro on the first
855 member present. If the allocated structure is smaller (no initial NV
856 actually allocated) then the net effect is to subtract the size of the NV
857 from the pointer, to return a new pointer as if an initial NV were actually
858 allocated. (We were using structures named *_allocated for this, but
859 this turned out to be a subtle bug, because a structure without an NV
860 could have a lower alignment constraint, but the compiler is allowed to
861 optimised accesses based on the alignment constraint of the actual pointer
862 to the full structure, for example, using a single 64 bit load instruction
863 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
865 This is the same trick as was used for NV and IV bodies. Ironically it
866 doesn't need to be used for NV bodies any more, because NV is now at
867 the start of the structure. IV bodies, and also in some builds NV bodies,
868 don't need it either, because they are no longer allocated.
870 In turn, the new_body_* allocators call S_new_body(), which invokes
871 new_body_inline macro, which takes a lock, and takes a body off the
872 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
873 necessary to refresh an empty list. Then the lock is released, and
874 the body is returned.
876 Perl_more_bodies allocates a new arena, and carves it up into an array of N
877 bodies, which it strings into a linked list. It looks up arena-size
878 and body-size from the body_details table described below, thus
879 supporting the multiple body-types.
881 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
882 the (new|del)_X*V macros are mapped directly to malloc/free.
884 For each sv-type, struct body_details bodies_by_type[] carries
885 parameters which control these aspects of SV handling:
887 Arena_size determines whether arenas are used for this body type, and if
888 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
889 zero, forcing individual mallocs and frees.
891 Body_size determines how big a body is, and therefore how many fit into
892 each arena. Offset carries the body-pointer adjustment needed for
893 "ghost fields", and is used in *_allocated macros.
895 But its main purpose is to parameterize info needed in
896 Perl_sv_upgrade(). The info here dramatically simplifies the function
897 vs the implementation in 5.8.8, making it table-driven. All fields
898 are used for this, except for arena_size.
900 For the sv-types that have no bodies, arenas are not used, so those
901 PL_body_roots[sv_type] are unused, and can be overloaded. In
902 something of a special case, SVt_NULL is borrowed for HE arenas;
903 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
904 bodies_by_type[SVt_NULL] slot is not used, as the table is not
909 struct body_details {
910 U8 body_size; /* Size to allocate */
911 U8 copy; /* Size of structure to copy (may be shorter) */
912 U8 offset; /* Size of unalloced ghost fields to first alloced field*/
913 PERL_BITFIELD8 type : 4; /* We have space for a sanity check. */
914 PERL_BITFIELD8 cant_upgrade : 1;/* Cannot upgrade this type */
915 PERL_BITFIELD8 zero_nv : 1; /* zero the NV when upgrading from this */
916 PERL_BITFIELD8 arena : 1; /* Allocated from an arena */
917 U32 arena_size; /* Size of arena to allocate */
925 /* With -DPURFIY we allocate everything directly, and don't use arenas.
926 This seems a rather elegant way to simplify some of the code below. */
927 #define HASARENA FALSE
929 #define HASARENA TRUE
931 #define NOARENA FALSE
933 /* Size the arenas to exactly fit a given number of bodies. A count
934 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
935 simplifying the default. If count > 0, the arena is sized to fit
936 only that many bodies, allowing arenas to be used for large, rare
937 bodies (XPVFM, XPVIO) without undue waste. The arena size is
938 limited by PERL_ARENA_SIZE, so we can safely oversize the
941 #define FIT_ARENA0(body_size) \
942 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
943 #define FIT_ARENAn(count,body_size) \
944 ( count * body_size <= PERL_ARENA_SIZE) \
945 ? count * body_size \
946 : FIT_ARENA0 (body_size)
947 #define FIT_ARENA(count,body_size) \
949 ? FIT_ARENAn (count, body_size) \
950 : FIT_ARENA0 (body_size))
952 /* Calculate the length to copy. Specifically work out the length less any
953 final padding the compiler needed to add. See the comment in sv_upgrade
954 for why copying the padding proved to be a bug. */
956 #define copy_length(type, last_member) \
957 STRUCT_OFFSET(type, last_member) \
958 + sizeof (((type*)SvANY((const SV *)0))->last_member)
960 static const struct body_details bodies_by_type[] = {
961 /* HEs use this offset for their arena. */
962 { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
964 /* IVs are in the head, so the allocation size is 0. */
966 sizeof(IV), /* This is used to copy out the IV body. */
967 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
968 NOARENA /* IVS don't need an arena */, 0
973 STRUCT_OFFSET(XPVNV, xnv_u),
974 SVt_NV, FALSE, HADNV, NOARENA, 0 },
976 { sizeof(NV), sizeof(NV),
977 STRUCT_OFFSET(XPVNV, xnv_u),
978 SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
981 { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
982 copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
983 + STRUCT_OFFSET(XPV, xpv_cur),
984 SVt_PV, FALSE, NONV, HASARENA,
985 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
987 { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur),
988 copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur),
989 + STRUCT_OFFSET(XPV, xpv_cur),
990 SVt_INVLIST, TRUE, NONV, HASARENA,
991 FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) },
993 { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
994 copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
995 + STRUCT_OFFSET(XPV, xpv_cur),
996 SVt_PVIV, FALSE, NONV, HASARENA,
997 FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
999 { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
1000 copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
1001 + STRUCT_OFFSET(XPV, xpv_cur),
1002 SVt_PVNV, FALSE, HADNV, HASARENA,
1003 FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
1005 { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
1006 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
1011 SVt_REGEXP, TRUE, NONV, HASARENA,
1012 FIT_ARENA(0, sizeof(regexp))
1015 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
1016 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
1018 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
1019 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
1022 copy_length(XPVAV, xav_alloc),
1024 SVt_PVAV, TRUE, NONV, HASARENA,
1025 FIT_ARENA(0, sizeof(XPVAV)) },
1028 copy_length(XPVHV, xhv_max),
1030 SVt_PVHV, TRUE, NONV, HASARENA,
1031 FIT_ARENA(0, sizeof(XPVHV)) },
1036 SVt_PVCV, TRUE, NONV, HASARENA,
1037 FIT_ARENA(0, sizeof(XPVCV)) },
1042 SVt_PVFM, TRUE, NONV, NOARENA,
1043 FIT_ARENA(20, sizeof(XPVFM)) },
1048 SVt_PVIO, TRUE, NONV, HASARENA,
1049 FIT_ARENA(24, sizeof(XPVIO)) },
1052 #define new_body_allocated(sv_type) \
1053 (void *)((char *)S_new_body(aTHX_ sv_type) \
1054 - bodies_by_type[sv_type].offset)
1056 /* return a thing to the free list */
1058 #define del_body(thing, root) \
1060 void ** const thing_copy = (void **)thing; \
1061 *thing_copy = *root; \
1062 *root = (void*)thing_copy; \
1066 #if !(NVSIZE <= IVSIZE)
1067 # define new_XNV() safemalloc(sizeof(XPVNV))
1069 #define new_XPVNV() safemalloc(sizeof(XPVNV))
1070 #define new_XPVMG() safemalloc(sizeof(XPVMG))
1072 #define del_XPVGV(p) safefree(p)
1076 #if !(NVSIZE <= IVSIZE)
1077 # define new_XNV() new_body_allocated(SVt_NV)
1079 #define new_XPVNV() new_body_allocated(SVt_PVNV)
1080 #define new_XPVMG() new_body_allocated(SVt_PVMG)
1082 #define del_XPVGV(p) del_body(p + bodies_by_type[SVt_PVGV].offset, \
1083 &PL_body_roots[SVt_PVGV])
1087 /* no arena for you! */
1089 #define new_NOARENA(details) \
1090 safemalloc((details)->body_size + (details)->offset)
1091 #define new_NOARENAZ(details) \
1092 safecalloc((details)->body_size + (details)->offset, 1)
1095 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
1096 const size_t arena_size)
1098 void ** const root = &PL_body_roots[sv_type];
1099 struct arena_desc *adesc;
1100 struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1104 const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1105 #if defined(DEBUGGING) && defined(PERL_GLOBAL_STRUCT)
1108 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1109 static bool done_sanity_check;
1111 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1112 * variables like done_sanity_check. */
1113 if (!done_sanity_check) {
1114 unsigned int i = SVt_LAST;
1116 done_sanity_check = TRUE;
1119 assert (bodies_by_type[i].type == i);
1125 /* may need new arena-set to hold new arena */
1126 if (!aroot || aroot->curr >= aroot->set_size) {
1127 struct arena_set *newroot;
1128 Newxz(newroot, 1, struct arena_set);
1129 newroot->set_size = ARENAS_PER_SET;
1130 newroot->next = aroot;
1132 PL_body_arenas = (void *) newroot;
1133 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1136 /* ok, now have arena-set with at least 1 empty/available arena-desc */
1137 curr = aroot->curr++;
1138 adesc = &(aroot->set[curr]);
1139 assert(!adesc->arena);
1141 Newx(adesc->arena, good_arena_size, char);
1142 adesc->size = good_arena_size;
1143 adesc->utype = sv_type;
1144 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
1145 curr, (void*)adesc->arena, (UV)good_arena_size));
1147 start = (char *) adesc->arena;
1149 /* Get the address of the byte after the end of the last body we can fit.
1150 Remember, this is integer division: */
1151 end = start + good_arena_size / body_size * body_size;
1153 /* computed count doesn't reflect the 1st slot reservation */
1154 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1155 DEBUG_m(PerlIO_printf(Perl_debug_log,
1156 "arena %p end %p arena-size %d (from %d) type %d "
1158 (void*)start, (void*)end, (int)good_arena_size,
1159 (int)arena_size, sv_type, (int)body_size,
1160 (int)good_arena_size / (int)body_size));
1162 DEBUG_m(PerlIO_printf(Perl_debug_log,
1163 "arena %p end %p arena-size %d type %d size %d ct %d\n",
1164 (void*)start, (void*)end,
1165 (int)arena_size, sv_type, (int)body_size,
1166 (int)good_arena_size / (int)body_size));
1168 *root = (void *)start;
1171 /* Where the next body would start: */
1172 char * const next = start + body_size;
1175 /* This is the last body: */
1176 assert(next == end);
1178 *(void **)start = 0;
1182 *(void**) start = (void *)next;
1187 /* grab a new thing from the free list, allocating more if necessary.
1188 The inline version is used for speed in hot routines, and the
1189 function using it serves the rest (unless PURIFY).
1191 #define new_body_inline(xpv, sv_type) \
1193 void ** const r3wt = &PL_body_roots[sv_type]; \
1194 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
1195 ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1196 bodies_by_type[sv_type].body_size,\
1197 bodies_by_type[sv_type].arena_size)); \
1198 *(r3wt) = *(void**)(xpv); \
1204 S_new_body(pTHX_ const svtype sv_type)
1207 new_body_inline(xpv, sv_type);
1213 static const struct body_details fake_rv =
1214 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1217 =for apidoc sv_upgrade
1219 Upgrade an SV to a more complex form. Generally adds a new body type to the
1220 SV, then copies across as much information as possible from the old body.
1221 It croaks if the SV is already in a more complex form than requested. You
1222 generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
1223 before calling C<sv_upgrade>, and hence does not croak. See also
1230 Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
1234 const svtype old_type = SvTYPE(sv);
1235 const struct body_details *new_type_details;
1236 const struct body_details *old_type_details
1237 = bodies_by_type + old_type;
1238 SV *referant = NULL;
1240 PERL_ARGS_ASSERT_SV_UPGRADE;
1242 if (old_type == new_type)
1245 /* This clause was purposefully added ahead of the early return above to
1246 the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1247 inference by Nick I-S that it would fix other troublesome cases. See
1248 changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1250 Given that shared hash key scalars are no longer PVIV, but PV, there is
1251 no longer need to unshare so as to free up the IVX slot for its proper
1252 purpose. So it's safe to move the early return earlier. */
1254 if (new_type > SVt_PVMG && SvIsCOW(sv)) {
1255 sv_force_normal_flags(sv, 0);
1258 old_body = SvANY(sv);
1260 /* Copying structures onto other structures that have been neatly zeroed
1261 has a subtle gotcha. Consider XPVMG
1263 +------+------+------+------+------+-------+-------+
1264 | NV | CUR | LEN | IV | MAGIC | STASH |
1265 +------+------+------+------+------+-------+-------+
1266 0 4 8 12 16 20 24 28
1268 where NVs are aligned to 8 bytes, so that sizeof that structure is
1269 actually 32 bytes long, with 4 bytes of padding at the end:
1271 +------+------+------+------+------+-------+-------+------+
1272 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1273 +------+------+------+------+------+-------+-------+------+
1274 0 4 8 12 16 20 24 28 32
1276 so what happens if you allocate memory for this structure:
1278 +------+------+------+------+------+-------+-------+------+------+...
1279 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1280 +------+------+------+------+------+-------+-------+------+------+...
1281 0 4 8 12 16 20 24 28 32 36
1283 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1284 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1285 started out as zero once, but it's quite possible that it isn't. So now,
1286 rather than a nicely zeroed GP, you have it pointing somewhere random.
1289 (In fact, GP ends up pointing at a previous GP structure, because the
1290 principle cause of the padding in XPVMG getting garbage is a copy of
1291 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1292 this happens to be moot because XPVGV has been re-ordered, with GP
1293 no longer after STASH)
1295 So we are careful and work out the size of used parts of all the
1303 referant = SvRV(sv);
1304 old_type_details = &fake_rv;
1305 if (new_type == SVt_NV)
1306 new_type = SVt_PVNV;
1308 if (new_type < SVt_PVIV) {
1309 new_type = (new_type == SVt_NV)
1310 ? SVt_PVNV : SVt_PVIV;
1315 if (new_type < SVt_PVNV) {
1316 new_type = SVt_PVNV;
1320 assert(new_type > SVt_PV);
1321 STATIC_ASSERT_STMT(SVt_IV < SVt_PV);
1322 STATIC_ASSERT_STMT(SVt_NV < SVt_PV);
1329 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1330 there's no way that it can be safely upgraded, because perl.c
1331 expects to Safefree(SvANY(PL_mess_sv)) */
1332 assert(sv != PL_mess_sv);
1335 if (UNLIKELY(old_type_details->cant_upgrade))
1336 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1337 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1340 if (UNLIKELY(old_type > new_type))
1341 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1342 (int)old_type, (int)new_type);
1344 new_type_details = bodies_by_type + new_type;
1346 SvFLAGS(sv) &= ~SVTYPEMASK;
1347 SvFLAGS(sv) |= new_type;
1349 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1350 the return statements above will have triggered. */
1351 assert (new_type != SVt_NULL);
1354 assert(old_type == SVt_NULL);
1355 SET_SVANY_FOR_BODYLESS_IV(sv);
1359 assert(old_type == SVt_NULL);
1360 #if NVSIZE <= IVSIZE
1361 SET_SVANY_FOR_BODYLESS_NV(sv);
1363 SvANY(sv) = new_XNV();
1369 assert(new_type_details->body_size);
1372 assert(new_type_details->arena);
1373 assert(new_type_details->arena_size);
1374 /* This points to the start of the allocated area. */
1375 new_body_inline(new_body, new_type);
1376 Zero(new_body, new_type_details->body_size, char);
1377 new_body = ((char *)new_body) - new_type_details->offset;
1379 /* We always allocated the full length item with PURIFY. To do this
1380 we fake things so that arena is false for all 16 types.. */
1381 new_body = new_NOARENAZ(new_type_details);
1383 SvANY(sv) = new_body;
1384 if (new_type == SVt_PVAV) {
1388 if (old_type_details->body_size) {
1391 /* It will have been zeroed when the new body was allocated.
1392 Lets not write to it, in case it confuses a write-back
1398 #ifndef NODEFAULT_SHAREKEYS
1399 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1401 /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
1402 HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
1405 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1406 The target created by newSVrv also is, and it can have magic.
1407 However, it never has SvPVX set.
1409 if (old_type == SVt_IV) {
1411 } else if (old_type >= SVt_PV) {
1412 assert(SvPVX_const(sv) == 0);
1415 if (old_type >= SVt_PVMG) {
1416 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1417 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1419 sv->sv_u.svu_array = NULL; /* or svu_hash */
1424 /* XXX Is this still needed? Was it ever needed? Surely as there is
1425 no route from NV to PVIV, NOK can never be true */
1426 assert(!SvNOKp(sv));
1439 assert(new_type_details->body_size);
1440 /* We always allocated the full length item with PURIFY. To do this
1441 we fake things so that arena is false for all 16 types.. */
1442 if(new_type_details->arena) {
1443 /* This points to the start of the allocated area. */
1444 new_body_inline(new_body, new_type);
1445 Zero(new_body, new_type_details->body_size, char);
1446 new_body = ((char *)new_body) - new_type_details->offset;
1448 new_body = new_NOARENAZ(new_type_details);
1450 SvANY(sv) = new_body;
1452 if (old_type_details->copy) {
1453 /* There is now the potential for an upgrade from something without
1454 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1455 int offset = old_type_details->offset;
1456 int length = old_type_details->copy;
1458 if (new_type_details->offset > old_type_details->offset) {
1459 const int difference
1460 = new_type_details->offset - old_type_details->offset;
1461 offset += difference;
1462 length -= difference;
1464 assert (length >= 0);
1466 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1470 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1471 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1472 * correct 0.0 for us. Otherwise, if the old body didn't have an
1473 * NV slot, but the new one does, then we need to initialise the
1474 * freshly created NV slot with whatever the correct bit pattern is
1476 if (old_type_details->zero_nv && !new_type_details->zero_nv
1477 && !isGV_with_GP(sv))
1481 if (UNLIKELY(new_type == SVt_PVIO)) {
1482 IO * const io = MUTABLE_IO(sv);
1483 GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1486 /* Clear the stashcache because a new IO could overrule a package
1488 DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
1489 hv_clear(PL_stashcache);
1491 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1492 IoPAGE_LEN(sv) = 60;
1494 if (UNLIKELY(new_type == SVt_REGEXP))
1495 sv->sv_u.svu_rx = (regexp *)new_body;
1496 else if (old_type < SVt_PV) {
1497 /* referant will be NULL unless the old type was SVt_IV emulating
1499 sv->sv_u.svu_rv = referant;
1503 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1504 (unsigned long)new_type);
1507 /* if this is zero, this is a body-less SVt_NULL, SVt_IV/SVt_RV,
1508 and sometimes SVt_NV */
1509 if (old_type_details->body_size) {
1513 /* Note that there is an assumption that all bodies of types that
1514 can be upgraded came from arenas. Only the more complex non-
1515 upgradable types are allowed to be directly malloc()ed. */
1516 assert(old_type_details->arena);
1517 del_body((void*)((char*)old_body + old_type_details->offset),
1518 &PL_body_roots[old_type]);
1524 =for apidoc sv_backoff
1526 Remove any string offset. You should normally use the C<SvOOK_off> macro
1533 Perl_sv_backoff(SV *const sv)
1536 const char * const s = SvPVX_const(sv);
1538 PERL_ARGS_ASSERT_SV_BACKOFF;
1541 assert(SvTYPE(sv) != SVt_PVHV);
1542 assert(SvTYPE(sv) != SVt_PVAV);
1544 SvOOK_offset(sv, delta);
1546 SvLEN_set(sv, SvLEN(sv) + delta);
1547 SvPV_set(sv, SvPVX(sv) - delta);
1548 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1549 SvFLAGS(sv) &= ~SVf_OOK;
1556 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1557 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1558 Use the C<SvGROW> wrapper instead.
1563 static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
1566 Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
1570 PERL_ARGS_ASSERT_SV_GROW;
1574 if (SvTYPE(sv) < SVt_PV) {
1575 sv_upgrade(sv, SVt_PV);
1576 s = SvPVX_mutable(sv);
1578 else if (SvOOK(sv)) { /* pv is offset? */
1580 s = SvPVX_mutable(sv);
1581 if (newlen > SvLEN(sv))
1582 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1586 if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0);
1587 s = SvPVX_mutable(sv);
1590 #ifdef PERL_NEW_COPY_ON_WRITE
1591 /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1592 * to store the COW count. So in general, allocate one more byte than
1593 * asked for, to make it likely this byte is always spare: and thus
1594 * make more strings COW-able.
1595 * If the new size is a big power of two, don't bother: we assume the
1596 * caller wanted a nice 2^N sized block and will be annoyed at getting
1598 * Only increment if the allocation isn't MEM_SIZE_MAX,
1599 * otherwise it will wrap to 0.
1601 if (newlen & 0xff && newlen != MEM_SIZE_MAX)
1605 #if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size)
1606 #define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1609 if (newlen > SvLEN(sv)) { /* need more room? */
1610 STRLEN minlen = SvCUR(sv);
1611 minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1612 if (newlen < minlen)
1614 #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1616 /* Don't round up on the first allocation, as odds are pretty good that
1617 * the initial request is accurate as to what is really needed */
1619 newlen = PERL_STRLEN_ROUNDUP(newlen);
1622 if (SvLEN(sv) && s) {
1623 s = (char*)saferealloc(s, newlen);
1626 s = (char*)safemalloc(newlen);
1627 if (SvPVX_const(sv) && SvCUR(sv)) {
1628 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1632 #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1633 /* Do this here, do it once, do it right, and then we will never get
1634 called back into sv_grow() unless there really is some growing
1636 SvLEN_set(sv, Perl_safesysmalloc_size(s));
1638 SvLEN_set(sv, newlen);
1645 =for apidoc sv_setiv
1647 Copies an integer into the given SV, upgrading first if necessary.
1648 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1654 Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
1656 PERL_ARGS_ASSERT_SV_SETIV;
1658 SV_CHECK_THINKFIRST_COW_DROP(sv);
1659 switch (SvTYPE(sv)) {
1662 sv_upgrade(sv, SVt_IV);
1665 sv_upgrade(sv, SVt_PVIV);
1669 if (!isGV_with_GP(sv))
1676 /* diag_listed_as: Can't coerce %s to %s in %s */
1677 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1681 (void)SvIOK_only(sv); /* validate number */
1687 =for apidoc sv_setiv_mg
1689 Like C<sv_setiv>, but also handles 'set' magic.
1695 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1697 PERL_ARGS_ASSERT_SV_SETIV_MG;
1704 =for apidoc sv_setuv
1706 Copies an unsigned integer into the given SV, upgrading first if necessary.
1707 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1713 Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1715 PERL_ARGS_ASSERT_SV_SETUV;
1717 /* With the if statement to ensure that integers are stored as IVs whenever
1719 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1722 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1724 If you wish to remove the following if statement, so that this routine
1725 (and its callers) always return UVs, please benchmark to see what the
1726 effect is. Modern CPUs may be different. Or may not :-)
1728 if (u <= (UV)IV_MAX) {
1729 sv_setiv(sv, (IV)u);
1738 =for apidoc sv_setuv_mg
1740 Like C<sv_setuv>, but also handles 'set' magic.
1746 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1748 PERL_ARGS_ASSERT_SV_SETUV_MG;
1755 =for apidoc sv_setnv
1757 Copies a double into the given SV, upgrading first if necessary.
1758 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1764 Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1766 PERL_ARGS_ASSERT_SV_SETNV;
1768 SV_CHECK_THINKFIRST_COW_DROP(sv);
1769 switch (SvTYPE(sv)) {
1772 sv_upgrade(sv, SVt_NV);
1776 sv_upgrade(sv, SVt_PVNV);
1780 if (!isGV_with_GP(sv))
1787 /* diag_listed_as: Can't coerce %s to %s in %s */
1788 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1793 (void)SvNOK_only(sv); /* validate number */
1798 =for apidoc sv_setnv_mg
1800 Like C<sv_setnv>, but also handles 'set' magic.
1806 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1808 PERL_ARGS_ASSERT_SV_SETNV_MG;
1814 /* Return a cleaned-up, printable version of sv, for non-numeric, or
1815 * not incrementable warning display.
1816 * Originally part of S_not_a_number().
1817 * The return value may be != tmpbuf.
1821 S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1824 PERL_ARGS_ASSERT_SV_DISPLAY;
1827 SV *dsv = newSVpvs_flags("", SVs_TEMP);
1828 pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
1831 const char * const limit = tmpbuf + tmpbuf_size - 8;
1832 /* each *s can expand to 4 chars + "...\0",
1833 i.e. need room for 8 chars */
1835 const char *s = SvPVX_const(sv);
1836 const char * const end = s + SvCUR(sv);
1837 for ( ; s < end && d < limit; s++ ) {
1839 if (! isASCII(ch) && !isPRINT_LC(ch)) {
1843 /* Map to ASCII "equivalent" of Latin1 */
1844 ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1850 else if (ch == '\r') {
1854 else if (ch == '\f') {
1858 else if (ch == '\\') {
1862 else if (ch == '\0') {
1866 else if (isPRINT_LC(ch))
1885 /* Print an "isn't numeric" warning, using a cleaned-up,
1886 * printable version of the offending string
1890 S_not_a_number(pTHX_ SV *const sv)
1895 PERL_ARGS_ASSERT_NOT_A_NUMBER;
1897 pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1900 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1901 /* diag_listed_as: Argument "%s" isn't numeric%s */
1902 "Argument \"%s\" isn't numeric in %s", pv,
1905 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1906 /* diag_listed_as: Argument "%s" isn't numeric%s */
1907 "Argument \"%s\" isn't numeric", pv);
1911 S_not_incrementable(pTHX_ SV *const sv) {
1915 PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1917 pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1919 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1920 "Argument \"%s\" treated as 0 in increment (++)", pv);
1924 =for apidoc looks_like_number
1926 Test if the content of an SV looks like a number (or is a number).
1927 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1928 non-numeric warning), even if your atof() doesn't grok them. Get-magic is
1935 Perl_looks_like_number(pTHX_ SV *const sv)
1941 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1943 if (SvPOK(sv) || SvPOKp(sv)) {
1944 sbegin = SvPV_nomg_const(sv, len);
1947 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1948 numtype = grok_number(sbegin, len, NULL);
1949 return ((numtype & IS_NUMBER_TRAILING)) ? 0 : numtype;
1953 S_glob_2number(pTHX_ GV * const gv)
1955 PERL_ARGS_ASSERT_GLOB_2NUMBER;
1957 /* We know that all GVs stringify to something that is not-a-number,
1958 so no need to test that. */
1959 if (ckWARN(WARN_NUMERIC))
1961 SV *const buffer = sv_newmortal();
1962 gv_efullname3(buffer, gv, "*");
1963 not_a_number(buffer);
1965 /* We just want something true to return, so that S_sv_2iuv_common
1966 can tail call us and return true. */
1970 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1971 until proven guilty, assume that things are not that bad... */
1976 As 64 bit platforms often have an NV that doesn't preserve all bits of
1977 an IV (an assumption perl has been based on to date) it becomes necessary
1978 to remove the assumption that the NV always carries enough precision to
1979 recreate the IV whenever needed, and that the NV is the canonical form.
1980 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1981 precision as a side effect of conversion (which would lead to insanity
1982 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1983 1) to distinguish between IV/UV/NV slots that have a valid conversion cached
1984 where precision was lost, and IV/UV/NV slots that have a valid conversion
1985 which has lost no precision
1986 2) to ensure that if a numeric conversion to one form is requested that
1987 would lose precision, the precise conversion (or differently
1988 imprecise conversion) is also performed and cached, to prevent
1989 requests for different numeric formats on the same SV causing
1990 lossy conversion chains. (lossless conversion chains are perfectly
1995 SvIOKp is true if the IV slot contains a valid value
1996 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1997 SvNOKp is true if the NV slot contains a valid value
1998 SvNOK is true only if the NV value is accurate
2001 while converting from PV to NV, check to see if converting that NV to an
2002 IV(or UV) would lose accuracy over a direct conversion from PV to
2003 IV(or UV). If it would, cache both conversions, return NV, but mark
2004 SV as IOK NOKp (ie not NOK).
2006 While converting from PV to IV, check to see if converting that IV to an
2007 NV would lose accuracy over a direct conversion from PV to NV. If it
2008 would, cache both conversions, flag similarly.
2010 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2011 correctly because if IV & NV were set NV *always* overruled.
2012 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2013 changes - now IV and NV together means that the two are interchangeable:
2014 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
2016 The benefit of this is that operations such as pp_add know that if
2017 SvIOK is true for both left and right operands, then integer addition
2018 can be used instead of floating point (for cases where the result won't
2019 overflow). Before, floating point was always used, which could lead to
2020 loss of precision compared with integer addition.
2022 * making IV and NV equal status should make maths accurate on 64 bit
2024 * may speed up maths somewhat if pp_add and friends start to use
2025 integers when possible instead of fp. (Hopefully the overhead in
2026 looking for SvIOK and checking for overflow will not outweigh the
2027 fp to integer speedup)
2028 * will slow down integer operations (callers of SvIV) on "inaccurate"
2029 values, as the change from SvIOK to SvIOKp will cause a call into
2030 sv_2iv each time rather than a macro access direct to the IV slot
2031 * should speed up number->string conversion on integers as IV is
2032 favoured when IV and NV are equally accurate
2034 ####################################################################
2035 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2036 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2037 On the other hand, SvUOK is true iff UV.
2038 ####################################################################
2040 Your mileage will vary depending your CPU's relative fp to integer
2044 #ifndef NV_PRESERVES_UV
2045 # define IS_NUMBER_UNDERFLOW_IV 1
2046 # define IS_NUMBER_UNDERFLOW_UV 2
2047 # define IS_NUMBER_IV_AND_UV 2
2048 # define IS_NUMBER_OVERFLOW_IV 4
2049 # define IS_NUMBER_OVERFLOW_UV 5
2051 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2053 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2055 S_sv_2iuv_non_preserve(pTHX_ SV *const sv
2061 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
2062 PERL_UNUSED_CONTEXT;
2064 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));
2065 if (SvNVX(sv) < (NV)IV_MIN) {
2066 (void)SvIOKp_on(sv);
2068 SvIV_set(sv, IV_MIN);
2069 return IS_NUMBER_UNDERFLOW_IV;
2071 if (SvNVX(sv) > (NV)UV_MAX) {
2072 (void)SvIOKp_on(sv);
2075 SvUV_set(sv, UV_MAX);
2076 return IS_NUMBER_OVERFLOW_UV;
2078 (void)SvIOKp_on(sv);
2080 /* Can't use strtol etc to convert this string. (See truth table in
2082 if (SvNVX(sv) <= (UV)IV_MAX) {
2083 SvIV_set(sv, I_V(SvNVX(sv)));
2084 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2085 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2087 /* Integer is imprecise. NOK, IOKp */
2089 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2092 SvUV_set(sv, U_V(SvNVX(sv)));
2093 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2094 if (SvUVX(sv) == UV_MAX) {
2095 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2096 possibly be preserved by NV. Hence, it must be overflow.
2098 return IS_NUMBER_OVERFLOW_UV;
2100 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2102 /* Integer is imprecise. NOK, IOKp */
2104 return IS_NUMBER_OVERFLOW_IV;
2106 #endif /* !NV_PRESERVES_UV*/
2108 /* If numtype is infnan, set the NV of the sv accordingly.
2109 * If numtype is anything else, try setting the NV using Atof(PV). */
2111 # pragma warning(push)
2112 # pragma warning(disable:4756;disable:4056)
2115 S_sv_setnv(pTHX_ SV* sv, int numtype, NV nanv)
2117 bool pok = cBOOL(SvPOK(sv));
2119 if ((numtype & IS_NUMBER_INFINITY)) {
2120 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
2123 else if ((numtype & IS_NUMBER_NAN)) {
2128 SvNV_set(sv, Atof(SvPVX_const(sv)));
2129 /* Purposefully no true nok here, since we don't want to blow
2130 * away the possible IOK/UV of an existing sv. */
2133 SvNOK_only(sv); /* No IV or UV please, this is pure infnan. */
2135 SvPOK_on(sv); /* PV is okay, though. */
2139 # pragma warning(pop)
2143 S_sv_2iuv_common(pTHX_ SV *const sv)
2145 PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2148 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2149 * without also getting a cached IV/UV from it at the same time
2150 * (ie PV->NV conversion should detect loss of accuracy and cache
2151 * IV or UV at same time to avoid this. */
2152 /* IV-over-UV optimisation - choose to cache IV if possible */
2154 if (SvTYPE(sv) == SVt_NV)
2155 sv_upgrade(sv, SVt_PVNV);
2157 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2158 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2159 certainly cast into the IV range at IV_MAX, whereas the correct
2160 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2162 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2163 if (Perl_isnan(SvNVX(sv))) {
2169 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2170 SvIV_set(sv, I_V(SvNVX(sv)));
2171 if (SvNVX(sv) == (NV) SvIVX(sv)
2172 #ifndef NV_PRESERVES_UV
2173 && SvIVX(sv) != IV_MIN /* avoid negating IV_MIN below */
2174 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2175 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2176 /* Don't flag it as "accurately an integer" if the number
2177 came from a (by definition imprecise) NV operation, and
2178 we're outside the range of NV integer precision */
2182 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2184 /* scalar has trailing garbage, eg "42a" */
2186 DEBUG_c(PerlIO_printf(Perl_debug_log,
2187 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2193 /* IV not precise. No need to convert from PV, as NV
2194 conversion would already have cached IV if it detected
2195 that PV->IV would be better than PV->NV->IV
2196 flags already correct - don't set public IOK. */
2197 DEBUG_c(PerlIO_printf(Perl_debug_log,
2198 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2203 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2204 but the cast (NV)IV_MIN rounds to a the value less (more
2205 negative) than IV_MIN which happens to be equal to SvNVX ??
2206 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2207 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2208 (NV)UVX == NVX are both true, but the values differ. :-(
2209 Hopefully for 2s complement IV_MIN is something like
2210 0x8000000000000000 which will be exact. NWC */
2213 SvUV_set(sv, U_V(SvNVX(sv)));
2215 (SvNVX(sv) == (NV) SvUVX(sv))
2216 #ifndef NV_PRESERVES_UV
2217 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2218 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2219 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2220 /* Don't flag it as "accurately an integer" if the number
2221 came from a (by definition imprecise) NV operation, and
2222 we're outside the range of NV integer precision */
2228 DEBUG_c(PerlIO_printf(Perl_debug_log,
2229 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2235 else if (SvPOKp(sv)) {
2238 const int numtype = grok_number2_flags(SvPVX_const(sv), SvCUR(sv), &value, &nanv, 0);
2239 /* We want to avoid a possible problem when we cache an IV/ a UV which
2240 may be later translated to an NV, and the resulting NV is not
2241 the same as the direct translation of the initial string
2242 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2243 be careful to ensure that the value with the .456 is around if the
2244 NV value is requested in the future).
2246 This means that if we cache such an IV/a UV, we need to cache the
2247 NV as well. Moreover, we trade speed for space, and do not
2248 cache the NV if we are sure it's not needed.
2251 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2252 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2253 == IS_NUMBER_IN_UV) {
2254 /* It's definitely an integer, only upgrade to PVIV */
2255 if (SvTYPE(sv) < SVt_PVIV)
2256 sv_upgrade(sv, SVt_PVIV);
2258 } else if (SvTYPE(sv) < SVt_PVNV)
2259 sv_upgrade(sv, SVt_PVNV);
2261 if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
2262 if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING)))
2264 S_sv_setnv(aTHX_ sv, numtype, nanv);
2268 /* If NVs preserve UVs then we only use the UV value if we know that
2269 we aren't going to call atof() below. If NVs don't preserve UVs
2270 then the value returned may have more precision than atof() will
2271 return, even though value isn't perfectly accurate. */
2272 if ((numtype & (IS_NUMBER_IN_UV
2273 #ifdef NV_PRESERVES_UV
2276 )) == IS_NUMBER_IN_UV) {
2277 /* This won't turn off the public IOK flag if it was set above */
2278 (void)SvIOKp_on(sv);
2280 if (!(numtype & IS_NUMBER_NEG)) {
2282 if (value <= (UV)IV_MAX) {
2283 SvIV_set(sv, (IV)value);
2285 /* it didn't overflow, and it was positive. */
2286 SvUV_set(sv, value);
2290 /* 2s complement assumption */
2291 if (value <= (UV)IV_MIN) {
2292 SvIV_set(sv, value == (UV)IV_MIN
2293 ? IV_MIN : -(IV)value);
2295 /* Too negative for an IV. This is a double upgrade, but
2296 I'm assuming it will be rare. */
2297 if (SvTYPE(sv) < SVt_PVNV)
2298 sv_upgrade(sv, SVt_PVNV);
2302 SvNV_set(sv, -(NV)value);
2303 SvIV_set(sv, IV_MIN);
2307 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2308 will be in the previous block to set the IV slot, and the next
2309 block to set the NV slot. So no else here. */
2311 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2312 != IS_NUMBER_IN_UV) {
2313 /* It wasn't an (integer that doesn't overflow the UV). */
2314 S_sv_setnv(aTHX_ sv, numtype, nanv);
2316 if (! numtype && ckWARN(WARN_NUMERIC))
2319 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" NVgf ")\n",
2320 PTR2UV(sv), SvNVX(sv)));
2322 #ifdef NV_PRESERVES_UV
2323 (void)SvIOKp_on(sv);
2325 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2326 if (Perl_isnan(SvNVX(sv))) {
2332 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2333 SvIV_set(sv, I_V(SvNVX(sv)));
2334 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2337 NOOP; /* Integer is imprecise. NOK, IOKp */
2339 /* UV will not work better than IV */
2341 if (SvNVX(sv) > (NV)UV_MAX) {
2343 /* Integer is inaccurate. NOK, IOKp, is UV */
2344 SvUV_set(sv, UV_MAX);
2346 SvUV_set(sv, U_V(SvNVX(sv)));
2347 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2348 NV preservse UV so can do correct comparison. */
2349 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2352 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
2357 #else /* NV_PRESERVES_UV */
2358 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2359 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2360 /* The IV/UV slot will have been set from value returned by
2361 grok_number above. The NV slot has just been set using
2364 assert (SvIOKp(sv));
2366 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2367 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2368 /* Small enough to preserve all bits. */
2369 (void)SvIOKp_on(sv);
2371 SvIV_set(sv, I_V(SvNVX(sv)));
2372 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2374 /* Assumption: first non-preserved integer is < IV_MAX,
2375 this NV is in the preserved range, therefore: */
2376 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2378 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);
2382 0 0 already failed to read UV.
2383 0 1 already failed to read UV.
2384 1 0 you won't get here in this case. IV/UV
2385 slot set, public IOK, Atof() unneeded.
2386 1 1 already read UV.
2387 so there's no point in sv_2iuv_non_preserve() attempting
2388 to use atol, strtol, strtoul etc. */
2390 sv_2iuv_non_preserve (sv, numtype);
2392 sv_2iuv_non_preserve (sv);
2396 #endif /* NV_PRESERVES_UV */
2397 /* It might be more code efficient to go through the entire logic above
2398 and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2399 gets complex and potentially buggy, so more programmer efficient
2400 to do it this way, by turning off the public flags: */
2402 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2406 if (isGV_with_GP(sv))
2407 return glob_2number(MUTABLE_GV(sv));
2409 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2411 if (SvTYPE(sv) < SVt_IV)
2412 /* Typically the caller expects that sv_any is not NULL now. */
2413 sv_upgrade(sv, SVt_IV);
2414 /* Return 0 from the caller. */
2421 =for apidoc sv_2iv_flags
2423 Return the integer value of an SV, doing any necessary string
2424 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2425 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2431 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2433 PERL_ARGS_ASSERT_SV_2IV_FLAGS;
2435 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2436 && SvTYPE(sv) != SVt_PVFM);
2438 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2444 if (flags & SV_SKIP_OVERLOAD)
2446 tmpstr = AMG_CALLunary(sv, numer_amg);
2447 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2448 return SvIV(tmpstr);
2451 return PTR2IV(SvRV(sv));
2454 if (SvVALID(sv) || isREGEXP(sv)) {
2455 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2456 the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2457 In practice they are extremely unlikely to actually get anywhere
2458 accessible by user Perl code - the only way that I'm aware of is when
2459 a constant subroutine which is used as the second argument to index.
2461 Regexps have no SvIVX and SvNVX fields.
2463 assert(isREGEXP(sv) || SvPOKp(sv));
2466 const char * const ptr =
2467 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2469 = grok_number(ptr, SvCUR(sv), &value);
2471 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2472 == IS_NUMBER_IN_UV) {
2473 /* It's definitely an integer */
2474 if (numtype & IS_NUMBER_NEG) {
2475 if (value < (UV)IV_MIN)
2478 if (value < (UV)IV_MAX)
2483 /* Quite wrong but no good choices. */
2484 if ((numtype & IS_NUMBER_INFINITY)) {
2485 return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX;
2486 } else if ((numtype & IS_NUMBER_NAN)) {
2487 return 0; /* So wrong. */
2491 if (ckWARN(WARN_NUMERIC))
2494 return I_V(Atof(ptr));
2498 if (SvTHINKFIRST(sv)) {
2499 #ifdef PERL_OLD_COPY_ON_WRITE
2501 sv_force_normal_flags(sv, 0);
2504 if (SvREADONLY(sv) && !SvOK(sv)) {
2505 if (ckWARN(WARN_UNINITIALIZED))
2512 if (S_sv_2iuv_common(aTHX_ sv))
2516 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2517 PTR2UV(sv),SvIVX(sv)));
2518 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2522 =for apidoc sv_2uv_flags
2524 Return the unsigned integer value of an SV, doing any necessary string
2525 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2526 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2532 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2534 PERL_ARGS_ASSERT_SV_2UV_FLAGS;
2536 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2542 if (flags & SV_SKIP_OVERLOAD)
2544 tmpstr = AMG_CALLunary(sv, numer_amg);
2545 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2546 return SvUV(tmpstr);
2549 return PTR2UV(SvRV(sv));
2552 if (SvVALID(sv) || isREGEXP(sv)) {
2553 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2554 the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2555 Regexps have no SvIVX and SvNVX fields. */
2556 assert(isREGEXP(sv) || SvPOKp(sv));
2559 const char * const ptr =
2560 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2562 = grok_number(ptr, SvCUR(sv), &value);
2564 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2565 == IS_NUMBER_IN_UV) {
2566 /* It's definitely an integer */
2567 if (!(numtype & IS_NUMBER_NEG))
2571 /* Quite wrong but no good choices. */
2572 if ((numtype & IS_NUMBER_INFINITY)) {
2573 return UV_MAX; /* So wrong. */
2574 } else if ((numtype & IS_NUMBER_NAN)) {
2575 return 0; /* So wrong. */
2579 if (ckWARN(WARN_NUMERIC))
2582 return U_V(Atof(ptr));
2586 if (SvTHINKFIRST(sv)) {
2587 #ifdef PERL_OLD_COPY_ON_WRITE
2589 sv_force_normal_flags(sv, 0);
2592 if (SvREADONLY(sv) && !SvOK(sv)) {
2593 if (ckWARN(WARN_UNINITIALIZED))
2600 if (S_sv_2iuv_common(aTHX_ sv))
2604 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2605 PTR2UV(sv),SvUVX(sv)));
2606 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2610 =for apidoc sv_2nv_flags
2612 Return the num value of an SV, doing any necessary string or integer
2613 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2614 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2620 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2622 PERL_ARGS_ASSERT_SV_2NV_FLAGS;
2624 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2625 && SvTYPE(sv) != SVt_PVFM);
2626 if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
2627 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2628 the same flag bit as SVf_IVisUV, so must not let them cache NVs.
2629 Regexps have no SvIVX and SvNVX fields. */
2631 if (flags & SV_GMAGIC)
2635 if (SvPOKp(sv) && !SvIOKp(sv)) {
2636 ptr = SvPVX_const(sv);
2638 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2639 !grok_number(ptr, SvCUR(sv), NULL))
2645 return (NV)SvUVX(sv);
2647 return (NV)SvIVX(sv);
2653 ptr = RX_WRAPPED((REGEXP *)sv);
2656 assert(SvTYPE(sv) >= SVt_PVMG);
2657 /* This falls through to the report_uninit near the end of the
2659 } else if (SvTHINKFIRST(sv)) {
2664 if (flags & SV_SKIP_OVERLOAD)
2666 tmpstr = AMG_CALLunary(sv, numer_amg);
2667 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2668 return SvNV(tmpstr);
2671 return PTR2NV(SvRV(sv));
2673 #ifdef PERL_OLD_COPY_ON_WRITE
2675 sv_force_normal_flags(sv, 0);
2678 if (SvREADONLY(sv) && !SvOK(sv)) {
2679 if (ckWARN(WARN_UNINITIALIZED))
2684 if (SvTYPE(sv) < SVt_NV) {
2685 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2686 sv_upgrade(sv, SVt_NV);
2688 STORE_NUMERIC_LOCAL_SET_STANDARD();
2689 PerlIO_printf(Perl_debug_log,
2690 "0x%"UVxf" num(%" NVgf ")\n",
2691 PTR2UV(sv), SvNVX(sv));
2692 RESTORE_NUMERIC_LOCAL();
2695 else if (SvTYPE(sv) < SVt_PVNV)
2696 sv_upgrade(sv, SVt_PVNV);
2701 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2702 #ifdef NV_PRESERVES_UV
2708 /* Only set the public NV OK flag if this NV preserves the IV */
2709 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2711 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2712 : (SvIVX(sv) == I_V(SvNVX(sv))))
2718 else if (SvPOKp(sv)) {
2721 const int numtype = grok_number2_flags(SvPVX_const(sv), SvCUR(sv), &value, &nanv, 0);
2722 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2724 #ifdef NV_PRESERVES_UV
2725 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2726 == IS_NUMBER_IN_UV) {
2727 /* It's definitely an integer */
2728 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2730 S_sv_setnv(aTHX_ sv, numtype, nanv);
2737 SvNV_set(sv, Atof(SvPVX_const(sv)));
2738 /* Only set the public NV OK flag if this NV preserves the value in
2739 the PV at least as well as an IV/UV would.
2740 Not sure how to do this 100% reliably. */
2741 /* if that shift count is out of range then Configure's test is
2742 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2744 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2745 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2746 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2747 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2748 /* Can't use strtol etc to convert this string, so don't try.
2749 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2752 /* value has been set. It may not be precise. */
2753 if ((numtype & IS_NUMBER_NEG) && (value >= (UV)IV_MIN)) {
2754 /* 2s complement assumption for (UV)IV_MIN */
2755 SvNOK_on(sv); /* Integer is too negative. */
2760 if (numtype & IS_NUMBER_NEG) {
2761 /* -IV_MIN is undefined, but we should never reach
2762 * this point with both IS_NUMBER_NEG and value ==
2764 assert(value != (UV)IV_MIN);
2765 SvIV_set(sv, -(IV)value);
2766 } else if (value <= (UV)IV_MAX) {
2767 SvIV_set(sv, (IV)value);
2769 SvUV_set(sv, value);
2773 if (numtype & IS_NUMBER_NOT_INT) {
2774 /* I believe that even if the original PV had decimals,
2775 they are lost beyond the limit of the FP precision.
2776 However, neither is canonical, so both only get p
2777 flags. NWC, 2000/11/25 */
2778 /* Both already have p flags, so do nothing */
2780 const NV nv = SvNVX(sv);
2781 /* XXX should this spot have NAN_COMPARE_BROKEN, too? */
2782 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2783 if (SvIVX(sv) == I_V(nv)) {
2786 /* It had no "." so it must be integer. */
2790 /* between IV_MAX and NV(UV_MAX).
2791 Could be slightly > UV_MAX */
2793 if (numtype & IS_NUMBER_NOT_INT) {
2794 /* UV and NV both imprecise. */
2796 const UV nv_as_uv = U_V(nv);
2798 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2807 /* It might be more code efficient to go through the entire logic above
2808 and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2809 gets complex and potentially buggy, so more programmer efficient
2810 to do it this way, by turning off the public flags: */
2812 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2813 #endif /* NV_PRESERVES_UV */
2816 if (isGV_with_GP(sv)) {
2817 glob_2number(MUTABLE_GV(sv));
2821 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2823 assert (SvTYPE(sv) >= SVt_NV);
2824 /* Typically the caller expects that sv_any is not NULL now. */
2825 /* XXX Ilya implies that this is a bug in callers that assume this
2826 and ideally should be fixed. */
2830 STORE_NUMERIC_LOCAL_SET_STANDARD();
2831 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" NVgf ")\n",
2832 PTR2UV(sv), SvNVX(sv));
2833 RESTORE_NUMERIC_LOCAL();
2841 Return an SV with the numeric value of the source SV, doing any necessary
2842 reference or overload conversion. The caller is expected to have handled
2849 Perl_sv_2num(pTHX_ SV *const sv)
2851 PERL_ARGS_ASSERT_SV_2NUM;
2856 SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2857 TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2858 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2859 return sv_2num(tmpsv);
2861 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2864 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2865 * UV as a string towards the end of buf, and return pointers to start and
2868 * We assume that buf is at least TYPE_CHARS(UV) long.
2872 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2874 char *ptr = buf + TYPE_CHARS(UV);
2875 char * const ebuf = ptr;
2878 PERL_ARGS_ASSERT_UIV_2BUF;
2886 uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv);
2890 *--ptr = '0' + (char)(uv % 10);
2898 #ifdef LONGDOUBLE_DOUBLEDOUBLE
2899 /* The first double can be as large as 2**1023, or '1' x '0' x 1023.
2900 * The second double can be as small as 2**-1074, or '0' x 1073 . '1'.
2901 * The sum of them can be '1' . '0' x 2096 . '1', with implied radix point
2902 * after the first 1023 zero bits.
2904 * XXX The 2098 is quite large (262.25 bytes) and therefore some sort
2905 * of dynamically growing buffer might be better, start at just 16 bytes
2906 * (for example) and grow only when necessary. Or maybe just by looking
2907 * at the exponents of the two doubles? */
2908 # define DOUBLEDOUBLE_MAXBITS 2098
2911 /* vhex will contain the values (0..15) of the hex digits ("nybbles"
2912 * of 4 bits); 1 for the implicit 1, and the mantissa bits, four bits
2913 * per xdigit. For the double-double case, this can be rather many.
2914 * The non-double-double-long-double overshoots since all bits of NV
2915 * are not mantissa bits, there are also exponent bits. */
2916 #ifdef LONGDOUBLE_DOUBLEDOUBLE
2917 # define VHEX_SIZE (1+DOUBLEDOUBLE_MAXBITS/4)
2919 # define VHEX_SIZE (1+(NVSIZE * 8)/4)
2922 /* If we do not have a known long double format, (including not using
2923 * long doubles, or long doubles being equal to doubles) then we will
2924 * fall back to the ldexp/frexp route, with which we can retrieve at
2925 * most as many bits as our widest unsigned integer type is. We try
2926 * to get a 64-bit unsigned integer even if we are not using a 64-bit UV.
2928 * (If you want to test the case of UVSIZE == 4, NVSIZE == 8,
2929 * set the MANTISSATYPE to int and the MANTISSASIZE to 4.)
2931 #if defined(HAS_QUAD) && defined(Uquad_t)
2932 # define MANTISSATYPE Uquad_t
2933 # define MANTISSASIZE 8
2935 # define MANTISSATYPE UV
2936 # define MANTISSASIZE UVSIZE
2939 #if defined(DOUBLE_LITTLE_ENDIAN) || defined(LONGDOUBLE_LITTLE_ENDIAN)
2940 # define HEXTRACT_LITTLE_ENDIAN
2941 #elif defined(DOUBLE_BIG_ENDIAN) || defined(LONGDOUBLE_BIG_ENDIAN)
2942 # define HEXTRACT_BIG_ENDIAN
2944 # define HEXTRACT_MIX_ENDIAN
2947 /* S_hextract() is a helper for Perl_sv_vcatpvfn_flags, for extracting
2948 * the hexadecimal values (for %a/%A). The nv is the NV where the value
2949 * are being extracted from (either directly from the long double in-memory
2950 * presentation, or from the uquad computed via frexp+ldexp). frexp also
2951 * is used to update the exponent. vhex is the pointer to the beginning
2952 * of the output buffer (of VHEX_SIZE).
2954 * The tricky part is that S_hextract() needs to be called twice:
2955 * the first time with vend as NULL, and the second time with vend as
2956 * the pointer returned by the first call. What happens is that on
2957 * the first round the output size is computed, and the intended
2958 * extraction sanity checked. On the second round the actual output
2959 * (the extraction of the hexadecimal values) takes place.
2960 * Sanity failures cause fatal failures during both rounds. */
2962 S_hextract(pTHX_ const NV nv, int* exponent, U8* vhex, U8* vend)
2966 int ixmin = 0, ixmax = 0;
2968 /* XXX Inf/NaN/denormal handling in the HEXTRACT_IMPLICIT_BIT,
2971 /* These macros are just to reduce typos, they have multiple
2972 * repetitions below, but usually only one (or sometimes two)
2973 * of them is really being used. */
2974 /* HEXTRACT_OUTPUT() extracts the high nybble first. */
2975 #define HEXTRACT_OUTPUT_HI(ix) (*v++ = nvp[ix] >> 4)
2976 #define HEXTRACT_OUTPUT_LO(ix) (*v++ = nvp[ix] & 0xF)
2977 #define HEXTRACT_OUTPUT(ix) \
2979 HEXTRACT_OUTPUT_HI(ix); HEXTRACT_OUTPUT_LO(ix); \
2981 #define HEXTRACT_COUNT(ix, c) \
2983 v += c; if (ix < ixmin) ixmin = ix; else if (ix > ixmax) ixmax = ix; \
2985 #define HEXTRACT_BYTE(ix) \
2987 if (vend) HEXTRACT_OUTPUT(ix); else HEXTRACT_COUNT(ix, 2); \
2989 #define HEXTRACT_LO_NYBBLE(ix) \
2991 if (vend) HEXTRACT_OUTPUT_LO(ix); else HEXTRACT_COUNT(ix, 1); \
2993 /* HEXTRACT_TOP_NYBBLE is just convenience disguise,
2994 * to make it look less odd when the top bits of a NV
2995 * are extracted using HEXTRACT_LO_NYBBLE: the highest
2996 * order bits can be in the "low nybble" of a byte. */
2997 #define HEXTRACT_TOP_NYBBLE(ix) HEXTRACT_LO_NYBBLE(ix)
2998 #define HEXTRACT_BYTES_LE(a, b) \
2999 for (ix = a; ix >= b; ix--) { HEXTRACT_BYTE(ix); }
3000 #define HEXTRACT_BYTES_BE(a, b) \
3001 for (ix = a; ix <= b; ix++) { HEXTRACT_BYTE(ix); }
3002 #define HEXTRACT_IMPLICIT_BIT(nv) \
3004 if (vend) *v++ = ((nv) == 0.0) ? 0 : 1; else v++; \
3007 /* Most formats do. Those which don't should undef this. */
3008 #define HEXTRACT_HAS_IMPLICIT_BIT
3009 /* Many formats do. Those which don't should undef this. */
3010 #define HEXTRACT_HAS_TOP_NYBBLE
3012 /* HEXTRACTSIZE is the maximum number of xdigits. */
3013 #if defined(USE_LONG_DOUBLE) && defined(LONGDOUBLE_DOUBLEDOUBLE)
3014 # define HEXTRACTSIZE (DOUBLEDOUBLE_MAXBITS/4)
3016 # define HEXTRACTSIZE 2 * NVSIZE
3019 const U8* vmaxend = vhex + HEXTRACTSIZE;
3020 PERL_UNUSED_VAR(ix); /* might happen */
3021 if (!Perl_isinfnan(nv)) {
3022 (void)Perl_frexp(PERL_ABS(nv), exponent);
3023 if (vend && (vend <= vhex || vend > vmaxend))
3024 Perl_croak(aTHX_ "Hexadecimal float: internal error");
3027 /* First check if using long doubles. */
3028 #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE)
3029 # if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
3030 /* Used in e.g. VMS and HP-UX IA-64, e.g. -0.1L:
3031 * 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f */
3032 /* The bytes 13..0 are the mantissa/fraction,
3033 * the 15,14 are the sign+exponent. */
3034 const U8* nvp = (const U8*)(&nv);
3035 HEXTRACT_IMPLICIT_BIT(nv);
3036 # undef HEXTRACT_HAS_TOP_NYBBLE
3037 HEXTRACT_BYTES_LE(13, 0);
3038 # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN
3039 /* Used in e.g. Solaris Sparc and HP-UX PA-RISC, e.g. -0.1L:
3040 * bf fb 99 99 99 99 99 99 99 99 99 99 99 99 99 9a */
3041 /* The bytes 2..15 are the mantissa/fraction,
3042 * the 0,1 are the sign+exponent. */
3043 const U8* nvp = (const U8*)(&nv);
3044 HEXTRACT_IMPLICIT_BIT(nv);
3045 # undef HEXTRACT_HAS_TOP_NYBBLE
3046 HEXTRACT_BYTES_BE(2, 15);
3047 # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
3048 /* x86 80-bit "extended precision", 64 bits of mantissa / fraction /
3049 * significand, 15 bits of exponent, 1 bit of sign. NVSIZE can
3050 * be either 12 (ILP32, Solaris x86) or 16 (LP64, Linux and OS X),
3051 * meaning that 2 or 6 bytes are empty padding. */
3052 /* The bytes 7..0 are the mantissa/fraction */
3053 const U8* nvp = (const U8*)(&nv);
3054 # undef HEXTRACT_HAS_IMPLICIT_BIT
3055 # undef HEXTRACT_HAS_TOP_NYBBLE
3056 HEXTRACT_BYTES_LE(7, 0);
3057 # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
3058 /* Does this format ever happen? (Wikipedia says the Motorola
3059 * 6888x math coprocessors used format _like_ this but padded
3060 * to 96 bits with 16 unused bits between the exponent and the
3062 const U8* nvp = (const U8*)(&nv);
3063 # undef HEXTRACT_HAS_IMPLICIT_BIT
3064 # undef HEXTRACT_HAS_TOP_NYBBLE
3065 HEXTRACT_BYTES_BE(0, 7);
3067 # define HEXTRACT_FALLBACK
3068 /* Double-double format: two doubles next to each other.
3069 * The first double is the high-order one, exactly like
3070 * it would be for a "lone" double. The second double
3071 * is shifted down using the exponent so that that there
3072 * are no common bits. The tricky part is that the value
3073 * of the double-double is the SUM of the two doubles and
3074 * the second one can be also NEGATIVE.
3076 * Because of this tricky construction the bytewise extraction we
3077 * use for the other long double formats doesn't work, we must
3078 * extract the values bit by bit.
3080 * The little-endian double-double is used .. somewhere?
3082 * The big endian double-double is used in e.g. PPC/Power (AIX)
3085 * The mantissa bits are in two separate stretches, e.g. for -0.1L:
3086 * 9a 99 99 99 99 99 59 bc 9a 99 99 99 99 99 b9 3f (LE)
3087 * 3f b9 99 99 99 99 99 9a bc 59 99 99 99 99 99 9a (BE)
3090 #else /* #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE) */
3091 /* Using normal doubles, not long doubles.
3093 * We generate 4-bit xdigits (nybble/nibble) instead of 8-bit
3094 * bytes, since we might need to handle printf precision, and
3095 * also need to insert the radix. */
3097 # ifdef HEXTRACT_LITTLE_ENDIAN
3098 /* 0 1 2 3 4 5 6 7 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */
3099 const U8* nvp = (const U8*)(&nv);
3100 HEXTRACT_IMPLICIT_BIT(nv);
3101 HEXTRACT_TOP_NYBBLE(6);
3102 HEXTRACT_BYTES_LE(5, 0);
3103 # elif defined(HEXTRACT_BIG_ENDIAN)
3104 /* 7 6 5 4 3 2 1 0 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */
3105 const U8* nvp = (const U8*)(&nv);
3106 HEXTRACT_IMPLICIT_BIT(nv);
3107 HEXTRACT_TOP_NYBBLE(1);
3108 HEXTRACT_BYTES_BE(2, 7);
3109 # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_LE_BE
3110 /* 4 5 6 7 0 1 2 3 (MSB = 7, LSB = 0, 6:7 = nybble:exponent:sign) */
3111 const U8* nvp = (const U8*)(&nv);
3112 HEXTRACT_IMPLICIT_BIT(nv);
3113 HEXTRACT_TOP_NYBBLE(2); /* 6 */
3114 HEXTRACT_BYTE(1); /* 5 */
3115 HEXTRACT_BYTE(0); /* 4 */
3116 HEXTRACT_BYTE(7); /* 3 */
3117 HEXTRACT_BYTE(6); /* 2 */
3118 HEXTRACT_BYTE(5); /* 1 */
3119 HEXTRACT_BYTE(4); /* 0 */
3120 # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_BE_LE
3121 /* 3 2 1 0 7 6 5 4 (MSB = 7, LSB = 0, 7:6 = sign:exponent:nybble) */
3122 const U8* nvp = (const U8*)(&nv);
3123 HEXTRACT_IMPLICIT_BIT(nv);
3124 HEXTRACT_TOP_NYBBLE(5); /* 6 */
3125 HEXTRACT_BYTE(6); /* 5 */
3126 HEXTRACT_BYTE(7); /* 4 */
3127 HEXTRACT_BYTE(0); /* 3 */
3128 HEXTRACT_BYTE(1); /* 2 */
3129 HEXTRACT_BYTE(2); /* 1 */
3130 HEXTRACT_BYTE(3); /* 0 */
3132 # define HEXTRACT_FALLBACK
3135 # define HEXTRACT_FALLBACK
3137 #endif /* #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE) #else */
3138 # ifdef HEXTRACT_FALLBACK
3139 # undef HEXTRACT_HAS_TOP_NYBBLE /* Meaningless, but consistent. */
3140 /* The fallback is used for the double-double format, and
3141 * for unknown long double formats, and for unknown double
3142 * formats, or in general unknown NV formats. */
3143 if (nv == (NV)0.0) {
3151 NV d = nv < 0 ? -nv : nv;
3153 U8 ha = 0x0; /* hexvalue accumulator */
3154 U8 hd = 0x8; /* hexvalue digit */
3156 /* Shift d and e (and update exponent) so that e <= d < 2*e,
3157 * this is essentially manual frexp(). Multiplying by 0.5 and
3158 * doubling should be lossless in binary floating point. */
3168 while (d >= e + e) {
3172 /* Now e <= d < 2*e */
3174 /* First extract the leading hexdigit (the implicit bit). */
3190 /* Then extract the remaining hexdigits. */
3191 while (d > (NV)0.0) {
3197 /* Output or count in groups of four bits,
3198 * that is, when the hexdigit is down to one. */
3203 /* Reset the hexvalue. */
3212 /* Flush possible pending hexvalue. */
3222 /* Croak for various reasons: if the output pointer escaped the
3223 * output buffer, if the extraction index escaped the extraction
3224 * buffer, or if the ending output pointer didn't match the
3225 * previously computed value. */
3226 if (v <= vhex || v - vhex >= VHEX_SIZE ||
3227 /* For double-double the ixmin and ixmax stay at zero,
3228 * which is convenient since the HEXTRACTSIZE is tricky
3229 * for double-double. */
3230 ixmin < 0 || ixmax >= NVSIZE ||
3231 (vend && v != vend))
3232 Perl_croak(aTHX_ "Hexadecimal float: internal error");
3236 /* Helper for sv_2pv_flags and sv_vcatpvfn_flags. If the NV is an
3237 * infinity or a not-a-number, writes the appropriate strings to the
3238 * buffer, including a zero byte. On success returns the written length,
3239 * excluding the zero byte, on failure (not an infinity, not a nan, or the
3240 * maxlen too small) returns zero. */
3242 S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char format, char plus, char alt) {
3243 assert(maxlen >= 4);
3244 if (maxlen < 4) /* "Inf\0", "NaN\0" */
3248 if (Perl_isinf(nv)) {
3250 if (maxlen < 5) /* "-Inf\0" */
3259 } else if (Perl_isnan(nv)) {
3262 U8* hibyte = nan_hibyte(&payload, &mask);
3266 if (nan_is_signaling(nv)) {
3269 /* Detect and clear the "quiet bit" from the NV copy.
3270 * This is done so that in *most* platforms the bit is
3271 * skipped and not included in the hexadecimal result. */
3279 bool upper = isUPPER(format);
3280 const char* xdig = PL_hexdigit + (upper ? 16 : 0);
3281 char xhex = upper ? 'X' : 'x';
3283 /* We need to clear the bits of the first
3284 * byte that are not part of the payload. */
3285 *hibyte &= (1 << (7 - NV_MANT_REAL_DIG % 8)) - 1;
3287 vend = S_hextract(aTHX_ payload, &exponent, vhex, NULL);
3288 S_hextract(aTHX_ payload, &exponent, vhex, vend);
3292 #ifdef NV_IMPLICIT_BIT
3293 /* S_hextract thinks it needs to extract the implicit bit,
3294 * which is bogus with NaN. */
3297 while (v < vend && *v == 0) v++;
3302 if (vend - v <= 2 * UVSIZE) {
3313 /* If not displayable as an UV, display as hex
3314 * bytes, then. This happens with e.g. 32-bit
3315 * (UVSIZE=4) platforms. The format is "\xHH..."
3317 * Similar formats are accepted on numification.
3319 * The choice of quoting in the result is not
3320 * customizable currently. Maybe something could
3321 * be rigged to follow the '%#'. */
3324 if ((vend - vhex) % 2) {
3346 return s - buffer - 1; /* -1: excluding the zero byte */
3351 =for apidoc sv_2pv_flags
3353 Returns a pointer to the string value of an SV, and sets *lp to its length.
3354 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a
3355 string if necessary. Normally invoked via the C<SvPV_flags> macro.
3356 C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
3362 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
3366 PERL_ARGS_ASSERT_SV_2PV_FLAGS;
3368 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
3369 && SvTYPE(sv) != SVt_PVFM);
3370 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
3375 if (flags & SV_SKIP_OVERLOAD)
3377 tmpstr = AMG_CALLunary(sv, string_amg);
3378 TAINT_IF(tmpstr && SvTAINTED(tmpstr));
3379 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3381 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
3385 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
3386 if (flags & SV_CONST_RETURN) {
3387 pv = (char *) SvPVX_const(tmpstr);
3389 pv = (flags & SV_MUTABLE_RETURN)
3390 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
3393 *lp = SvCUR(tmpstr);
3395 pv = sv_2pv_flags(tmpstr, lp, flags);
3408 SV *const referent = SvRV(sv);
3412 retval = buffer = savepvn("NULLREF", len);
3413 } else if (SvTYPE(referent) == SVt_REGEXP &&
3414 (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
3415 amagic_is_enabled(string_amg))) {
3416 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
3420 /* If the regex is UTF-8 we want the containing scalar to
3421 have an UTF-8 flag too */
3428 *lp = RX_WRAPLEN(re);
3430 return RX_WRAPPED(re);
3432 const char *const typestr = sv_reftype(referent, 0);
3433 const STRLEN typelen = strlen(typestr);
3434 UV addr = PTR2UV(referent);
3435 const char *stashname = NULL;
3436 STRLEN stashnamelen = 0; /* hush, gcc */
3437 const char *buffer_end;
3439 if (SvOBJECT(referent)) {
3440 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
3443 stashname = HEK_KEY(name);
3444 stashnamelen = HEK_LEN(name);
3446 if (HEK_UTF8(name)) {
3452 stashname = "__ANON__";
3455 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
3456 + 2 * sizeof(UV) + 2 /* )\0 */;
3458 len = typelen + 3 /* (0x */
3459 + 2 * sizeof(UV) + 2 /* )\0 */;
3462 Newx(buffer, len, char);
3463 buffer_end = retval = buffer + len;
3465 /* Working backwards */
3469 *--retval = PL_hexdigit[addr & 15];
3470 } while (addr >>= 4);
3476 memcpy(retval, typestr, typelen);
3480 retval -= stashnamelen;
3481 memcpy(retval, stashname, stashnamelen);
3483 /* retval may not necessarily have reached the start of the
3485 assert (retval >= buffer);
3487 len = buffer_end - retval - 1; /* -1 for that \0 */
3499 if (flags & SV_MUTABLE_RETURN)
3500 return SvPVX_mutable(sv);
3501 if (flags & SV_CONST_RETURN)
3502 return (char *)SvPVX_const(sv);
3507 /* I'm assuming that if both IV and NV are equally valid then
3508 converting the IV is going to be more efficient */
3509 const U32 isUIOK = SvIsUV(sv);
3510 char buf[TYPE_CHARS(UV)];
3514 if (SvTYPE(sv) < SVt_PVIV)
3515 sv_upgrade(sv, SVt_PVIV);
3516 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
3518 /* inlined from sv_setpvn */
3519 s = SvGROW_mutable(sv, len + 1);
3520 Move(ptr, s, len, char);
3525 else if (SvNOK(sv)) {
3526 if (SvTYPE(sv) < SVt_PVNV)
3527 sv_upgrade(sv, SVt_PVNV);
3528 if (SvNVX(sv) == 0.0
3529 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3530 && !Perl_isnan(SvNVX(sv))
3533 s = SvGROW_mutable(sv, 2);
3538 STRLEN size = 5; /* "-Inf\0" */
3540 s = SvGROW_mutable(sv, size);
3541 len = S_infnan_2pv(SvNVX(sv), s, size, 'g', 0, 0);
3547 /* some Xenix systems wipe out errno here */
3556 5 + /* exponent digits */
3560 s = SvGROW_mutable(sv, size);
3561 #ifndef USE_LOCALE_NUMERIC
3562 SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3568 DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
3572 PL_numeric_radix_sv &&
3573 SvUTF8(PL_numeric_radix_sv);
3574 if (local_radix && SvLEN(PL_numeric_radix_sv) > 1) {
3575 size += SvLEN(PL_numeric_radix_sv) - 1;
3576 s = SvGROW_mutable(sv, size);
3579 SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3581 /* If the radix character is UTF-8, and actually is in the
3582 * output, turn on the UTF-8 flag for the scalar */
3584 instr(s, SvPVX_const(PL_numeric_radix_sv))) {
3588 RESTORE_LC_NUMERIC();
3591 /* We don't call SvPOK_on(), because it may come to
3592 * pass that the locale changes so that the
3593 * stringification we just did is no longer correct. We
3594 * will have to re-stringify every time it is needed */
3601 else if (isGV_with_GP(sv)) {
3602 GV *const gv = MUTABLE_GV(sv);
3603 SV *const buffer = sv_newmortal();
3605 gv_efullname3(buffer, gv, "*");
3607 assert(SvPOK(buffer));
3611 *lp = SvCUR(buffer);
3612 return SvPVX(buffer);
3614 else if (isREGEXP(sv)) {
3615 if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
3616 return RX_WRAPPED((REGEXP *)sv);
3621 if (flags & SV_UNDEF_RETURNS_NULL)
3623 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3625 /* Typically the caller expects that sv_any is not NULL now. */
3626 if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
3627 sv_upgrade(sv, SVt_PV);
3632 const STRLEN len = s - SvPVX_const(sv);
3637 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3638 PTR2UV(sv),SvPVX_const(sv)));
3639 if (flags & SV_CONST_RETURN)
3640 return (char *)SvPVX_const(sv);
3641 if (flags & SV_MUTABLE_RETURN)
3642 return SvPVX_mutable(sv);
3647 =for apidoc sv_copypv
3649 Copies a stringified representation of the source SV into the
3650 destination SV. Automatically performs any necessary mg_get and
3651 coercion of numeric values into strings. Guaranteed to preserve
3652 UTF8 flag even from overloaded objects. Similar in nature to
3653 sv_2pv[_flags] but operates directly on an SV instead of just the
3654 string. Mostly uses sv_2pv_flags to do its work, except when that
3655 would lose the UTF-8'ness of the PV.
3657 =for apidoc sv_copypv_nomg
3659 Like sv_copypv, but doesn't invoke get magic first.
3661 =for apidoc sv_copypv_flags
3663 Implementation of sv_copypv and sv_copypv_nomg. Calls get magic iff flags
3670 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3675 PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3677 s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC));
3678 sv_setpvn(dsv,s,len);
3686 =for apidoc sv_2pvbyte
3688 Return a pointer to the byte-encoded representation of the SV, and set *lp
3689 to its length. May cause the SV to be downgraded from UTF-8 as a
3692 Usually accessed via the C<SvPVbyte> macro.
3698 Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
3700 PERL_ARGS_ASSERT_SV_2PVBYTE;
3703 if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3704 || isGV_with_GP(sv) || SvROK(sv)) {
3705 SV *sv2 = sv_newmortal();
3706 sv_copypv_nomg(sv2,sv);
3709 sv_utf8_downgrade(sv,0);
3710 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3714 =for apidoc sv_2pvutf8
3716 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3717 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3719 Usually accessed via the C<SvPVutf8> macro.
3725 Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
3727 PERL_ARGS_ASSERT_SV_2PVUTF8;
3729 if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3730 || isGV_with_GP(sv) || SvROK(sv))
3731 sv = sv_mortalcopy(sv);
3734 sv_utf8_upgrade_nomg(sv);
3735 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3740 =for apidoc sv_2bool
3742 This macro is only used by sv_true() or its macro equivalent, and only if
3743 the latter's argument is neither SvPOK, SvIOK nor SvNOK.
3744 It calls sv_2bool_flags with the SV_GMAGIC flag.
3746 =for apidoc sv_2bool_flags
3748 This function is only used by sv_true() and friends, and only if
3749 the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags
3750 contain SV_GMAGIC, then it does an mg_get() first.
3757 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
3759 PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3762 if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3768 SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3769 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
3772 if(SvGMAGICAL(sv)) {
3774 goto restart; /* call sv_2bool */
3776 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
3777 else if(!SvOK(sv)) {
3780 else if(SvPOK(sv)) {
3781 svb = SvPVXtrue(sv);
3783 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
3784 svb = (SvIOK(sv) && SvIVX(sv) != 0)
3785 || (SvNOK(sv) && SvNVX(sv) != 0.0);
3789 goto restart; /* call sv_2bool_nomg */
3794 return SvRV(sv) != 0;
3798 RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
3799 return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
3803 =for apidoc sv_utf8_upgrade
3805 Converts the PV of an SV to its UTF-8-encoded form.
3806 Forces the SV to string form if it is not already.
3807 Will C<mg_get> on C<sv> if appropriate.
3808 Always sets the SvUTF8 flag to avoid future validity checks even
3809 if the whole string is the same in UTF-8 as not.
3810 Returns the number of bytes in the converted string
3812 This is not a general purpose byte encoding to Unicode interface:
3813 use the Encode extension for that.
3815 =for apidoc sv_utf8_upgrade_nomg
3817 Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
3819 =for apidoc sv_utf8_upgrade_flags
3821 Converts the PV of an SV to its UTF-8-encoded form.
3822 Forces the SV to string form if it is not already.
3823 Always sets the SvUTF8 flag to avoid future validity checks even
3824 if all the bytes are invariant in UTF-8.
3825 If C<flags> has C<SV_GMAGIC> bit set,
3826 will C<mg_get> on C<sv> if appropriate, else not.
3828 If C<flags> has SV_FORCE_UTF8_UPGRADE set, this function assumes that the PV
3829 will expand when converted to UTF-8, and skips the extra work of checking for
3830 that. Typically this flag is used by a routine that has already parsed the
3831 string and found such characters, and passes this information on so that the
3832 work doesn't have to be repeated.
3834 Returns the number of bytes in the converted string.
3836 This is not a general purpose byte encoding to Unicode interface:
3837 use the Encode extension for that.
3839 =for apidoc sv_utf8_upgrade_flags_grow
3841 Like sv_utf8_upgrade_flags, but has an additional parameter C<extra>, which is
3842 the number of unused bytes the string of 'sv' is guaranteed to have free after
3843 it upon return. This allows the caller to reserve extra space that it intends
3844 to fill, to avoid extra grows.
3846 C<sv_utf8_upgrade>, C<sv_utf8_upgrade_nomg>, and C<sv_utf8_upgrade_flags>
3847 are implemented in terms of this function.
3849 Returns the number of bytes in the converted string (not including the spares).
3853 (One might think that the calling routine could pass in the position of the
3854 first variant character when it has set SV_FORCE_UTF8_UPGRADE, so it wouldn't
3855 have to be found again. But that is not the case, because typically when the
3856 caller is likely to use this flag, it won't be calling this routine unless it
3857 finds something that won't fit into a byte. Otherwise it tries to not upgrade
3858 and just use bytes. But some things that do fit into a byte are variants in
3859 utf8, and the caller may not have been keeping track of these.)
3861 If the routine itself changes the string, it adds a trailing C<NUL>. Such a
3862 C<NUL> isn't guaranteed due to having other routines do the work in some input
3863 cases, or if the input is already flagged as being in utf8.
3865 The speed of this could perhaps be improved for many cases if someone wanted to
3866 write a fast function that counts the number of variant characters in a string,
3867 especially if it could return the position of the first one.
3872 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3874 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3876 if (sv == &PL_sv_undef)
3878 if (!SvPOK_nog(sv)) {
3880 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3881 (void) sv_2pv_flags(sv,&len, flags);
3883 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3887 (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3892 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3897 S_sv_uncow(aTHX_ sv, 0);
3900 if (IN_ENCODING && !(flags & SV_UTF8_NO_ENCODING)) {
3901 sv_recode_to_utf8(sv, _get_encoding());
3902 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3906 if (SvCUR(sv) == 0) {
3907 if (extra) SvGROW(sv, extra);
3908 } else { /* Assume Latin-1/EBCDIC */
3909 /* This function could be much more efficient if we
3910 * had a FLAG in SVs to signal if there are any variant
3911 * chars in the PV. Given that there isn't such a flag
3912 * make the loop as fast as possible (although there are certainly ways
3913 * to speed this up, eg. through vectorization) */
3914 U8 * s = (U8 *) SvPVX_const(sv);
3915 U8 * e = (U8 *) SvEND(sv);
3917 STRLEN two_byte_count = 0;
3919 if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3921 /* See if really will need to convert to utf8. We mustn't rely on our
3922 * incoming SV being well formed and having a trailing '\0', as certain
3923 * code in pp_formline can send us partially built SVs. */
3927 if (NATIVE_BYTE_IS_INVARIANT(ch)) continue;
3929 t--; /* t already incremented; re-point to first variant */
3934 /* utf8 conversion not needed because all are invariants. Mark as
3935 * UTF-8 even if no variant - saves scanning loop */
3937 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3942 /* Here, the string should be converted to utf8, either because of an
3943 * input flag (two_byte_count = 0), or because a character that
3944 * requires 2 bytes was found (two_byte_count = 1). t points either to
3945 * the beginning of the string (if we didn't examine anything), or to
3946 * the first variant. In either case, everything from s to t - 1 will
3947 * occupy only 1 byte each on output.
3949 * There are two main ways to convert. One is to create a new string
3950 * and go through the input starting from the beginning, appending each
3951 * converted value onto the new string as we go along. It's probably
3952 * best to allocate enough space in the string for the worst possible
3953 * case rather than possibly running out of space and having to
3954 * reallocate and then copy what we've done so far. Since everything
3955 * from s to t - 1 is invariant, the destination can be initialized
3956 * with these using a fast memory copy
3958 * The other way is to figure out exactly how big the string should be
3959 * by parsing the entire input. Then you don't have to make it big
3960 * enough to handle the worst possible case, and more importantly, if
3961 * the string you already have is large enough, you don't have to
3962 * allocate a new string, you can copy the last character in the input
3963 * string to the final position(s) that will be occupied by the
3964 * converted string and go backwards, stopping at t, since everything
3965 * before that is invariant.
3967 * There are advantages and disadvantages to each method.
3969 * In the first method, we can allocate a new string, do the memory
3970 * copy from the s to t - 1, and then proceed through the rest of the
3971 * string byte-by-byte.
3973 * In the second method, we proceed through the rest of the input
3974 * string just calculating how big the converted string will be. Then
3975 * there are two cases:
3976 * 1) if the string has enough extra space to handle the converted
3977 * value. We go backwards through the string, converting until we
3978 * get to the position we are at now, and then stop. If this
3979 * position is far enough along in the string, this method is
3980 * faster than the other method. If the memory copy were the same
3981 * speed as the byte-by-byte loop, that position would be about
3982 * half-way, as at the half-way mark, parsing to the end and back
3983 * is one complete string's parse, the same amount as starting
3984 * over and going all the way through. Actually, it would be
3985 * somewhat less than half-way, as it's faster to just count bytes
3986 * than to also copy, and we don't have the overhead of allocating
3987 * a new string, changing the scalar to use it, and freeing the
3988 * existing one. But if the memory copy is fast, the break-even
3989 * point is somewhere after half way. The counting loop could be
3990 * sped up by vectorization, etc, to move the break-even point
3991 * further towards the beginning.
3992 * 2) if the string doesn't have enough space to handle the converted
3993 * value. A new string will have to be allocated, and one might
3994 * as well, given that, start from the beginning doing the first
3995 * method. We've spent extra time parsing the string and in
3996 * exchange all we've gotten is that we know precisely how big to
3997 * make the new one. Perl is more optimized for time than space,
3998 * so this case is a loser.
3999 * So what I've decided to do is not use the 2nd method unless it is
4000 * guaranteed that a new string won't have to be allocated, assuming
4001 * the worst case. I also decided not to put any more conditions on it
4002 * than this, for now. It seems likely that, since the worst case is
4003 * twice as big as the unknown portion of the string (plus 1), we won't
4004 * be guaranteed enough space, causing us to go to the first method,
4005 * unless the string is short, or the first variant character is near
4006 * the end of it. In either of these cases, it seems best to use the
4007 * 2nd method. The only circumstance I can think of where this would
4008 * be really slower is if the string had once had much more data in it
4009 * than it does now, but there is still a substantial amount in it */
4012 STRLEN invariant_head = t - s;
4013 STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
4014 if (SvLEN(sv) < size) {
4016 /* Here, have decided to allocate a new string */
4021 Newx(dst, size, U8);
4023 /* If no known invariants at the beginning of the input string,
4024 * set so starts from there. Otherwise, can use memory copy to
4025 * get up to where we are now, and then start from here */
4027 if (invariant_head == 0) {
4030 Copy(s, dst, invariant_head, char);
4031 d = dst + invariant_head;
4035 append_utf8_from_native_byte(*t, &d);
4039 SvPV_free(sv); /* No longer using pre-existing string */
4040 SvPV_set(sv, (char*)dst);
4041 SvCUR_set(sv, d - dst);
4042 SvLEN_set(sv, size);
4045 /* Here, have decided to get the exact size of the string.
4046 * Currently this happens only when we know that there is
4047 * guaranteed enough space to fit the converted string, so
4048 * don't have to worry about growing. If two_byte_count is 0,
4049 * then t points to the first byte of the string which hasn't
4050 * been examined yet. Otherwise two_byte_count is 1, and t
4051 * points to the first byte in the string that will expand to
4052 * two. Depending on this, start examining at t or 1 after t.
4055 U8 *d = t + two_byte_count;
4058 /* Count up the remaining bytes that expand to two */
4061 const U8 chr = *d++;
4062 if (! NATIVE_BYTE_IS_INVARIANT(chr)) two_byte_count++;
4065 /* The string will expand by just the number of bytes that
4066 * occupy two positions. But we are one afterwards because of
4067 * the increment just above. This is the place to put the
4068 * trailing NUL, and to set the length before we decrement */
4070 d += two_byte_count;
4071 SvCUR_set(sv, d - s);
4075 /* Having decremented d, it points to the position to put the
4076 * very last byte of the expanded string. Go backwards through
4077 * the string, copying and expanding as we go, stopping when we
4078 * get to the part that is invariant the rest of the way down */
4082 if (NATIVE_BYTE_IS_INVARIANT(*e)) {
4085 *d-- = UTF8_EIGHT_BIT_LO(*e);
4086 *d-- = UTF8_EIGHT_BIT_HI(*e);
4092 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4093 /* Update pos. We do it at the end rather than during
4094 * the upgrade, to avoid slowing down the common case
4095 * (upgrade without pos).
4096 * pos can be stored as either bytes or characters. Since
4097 * this was previously a byte string we can just turn off
4098 * the bytes flag. */
4099 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
4101 mg->mg_flags &= ~MGf_BYTES;
4103 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
4104 magic_setutf8(sv,mg); /* clear UTF8 cache */
4109 /* Mark as UTF-8 even if no variant - saves scanning loop */
4115 =for apidoc sv_utf8_downgrade
4117 Attempts to convert the PV of an SV from characters to bytes.
4118 If the PV contains a character that cannot fit
4119 in a byte, this conversion will fail;
4120 in this case, either returns false or, if C<fail_ok> is not
4123 This is not a general purpose Unicode to byte encoding interface:
4124 use the Encode extension for that.
4130 Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
4132 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
4134 if (SvPOKp(sv) && SvUTF8(sv)) {
4138 int mg_flags = SV_GMAGIC;
4141 S_sv_uncow(aTHX_ sv, 0);
4143 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4145 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
4146 if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
4147 mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
4148 SV_GMAGIC|SV_CONST_RETURN);
4149 mg_flags = 0; /* sv_pos_b2u does get magic */
4151 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
4152 magic_setutf8(sv,mg); /* clear UTF8 cache */
4155 s = (U8 *) SvPV_flags(sv, len, mg_flags);
4157 if (!utf8_to_bytes(s, &len)) {
4162 Perl_croak(aTHX_ "Wide character in %s",
4165 Perl_croak(aTHX_ "Wide character");
4176 =for apidoc sv_utf8_encode
4178 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
4179 flag off so that it looks like octets again.
4185 Perl_sv_utf8_encode(pTHX_ SV *const sv)
4187 PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
4189 if (SvREADONLY(sv)) {
4190 sv_force_normal_flags(sv, 0);
4192 (void) sv_utf8_upgrade(sv);
4197 =for apidoc sv_utf8_decode
4199 If the PV of the SV is an octet sequence in UTF-8
4200 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
4201 so that it looks like a character. If the PV contains only single-byte
4202 characters, the C<SvUTF8> flag stays off.
4203 Scans PV for validity and returns false if the PV is invalid UTF-8.
4209 Perl_sv_utf8_decode(pTHX_ SV *const sv)
4211 PERL_ARGS_ASSERT_SV_UTF8_DECODE;
4214 const U8 *start, *c;
4217 /* The octets may have got themselves encoded - get them back as
4220 if (!sv_utf8_downgrade(sv, TRUE))
4223 /* it is actually just a matter of turning the utf8 flag on, but
4224 * we want to make sure everything inside is valid utf8 first.
4226 c = start = (const U8 *) SvPVX_const(sv);
4227 if (!is_utf8_string(c, SvCUR(sv)))
4229 e = (const U8 *) SvEND(sv);
4232 if (!UTF8_IS_INVARIANT(ch)) {
4237 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4238 /* XXX Is this dead code? XS_utf8_decode calls SvSETMAGIC
4239 after this, clearing pos. Does anything on CPAN
4241 /* adjust pos to the start of a UTF8 char sequence */
4242 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
4244 I32 pos = mg->mg_len;
4246 for (c = start + pos; c > start; c--) {
4247 if (UTF8_IS_START(*c))
4250 mg->mg_len = c - start;
4253 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
4254 magic_setutf8(sv,mg); /* clear UTF8 cache */
4261 =for apidoc sv_setsv
4263 Copies the contents of the source SV C<ssv> into the destination SV
4264 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4265 function if the source SV needs to be reused. Does not handle 'set' magic on
4266 destination SV. Calls 'get' magic on source SV. Loosely speaking, it
4267 performs a copy-by-value, obliterating any previous content of the
4270 You probably want to use one of the assortment of wrappers, such as
4271 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4272 C<SvSetMagicSV_nosteal>.
4274 =for apidoc sv_setsv_flags
4276 Copies the contents of the source SV C<ssv> into the destination SV
4277 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4278 function if the source SV needs to be reused. Does not handle 'set' magic.
4279 Loosely speaking, it performs a copy-by-value, obliterating any previous
4280 content of the destination.
4281 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
4282 C<ssv> if appropriate, else not. If the C<flags>
4283 parameter has the C<SV_NOSTEAL> bit set then the
4284 buffers of temps will not be stolen. <sv_setsv>
4285 and C<sv_setsv_nomg> are implemented in terms of this function.
4287 You probably want to use one of the assortment of wrappers, such as
4288 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4289 C<SvSetMagicSV_nosteal>.
4291 This is the primary function for copying scalars, and most other
4292 copy-ish functions and macros use this underneath.
4298 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
4300 I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
4301 HV *old_stash = NULL;
4303 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
4305 if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
4306 const char * const name = GvNAME(sstr);
4307 const STRLEN len = GvNAMELEN(sstr);
4309 if (dtype >= SVt_PV) {
4315 SvUPGRADE(dstr, SVt_PVGV);
4316 (void)SvOK_off(dstr);
4317 isGV_with_GP_on(dstr);
4319 GvSTASH(dstr) = GvSTASH(sstr);
4321 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
4322 gv_name_set(MUTABLE_GV(dstr), name, len,
4323 GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
4324 SvFAKE_on(dstr); /* can coerce to non-glob */
4327 if(GvGP(MUTABLE_GV(sstr))) {
4328 /* If source has method cache entry, clear it */
4330 SvREFCNT_dec(GvCV(sstr));
4331 GvCV_set(sstr, NULL);
4334 /* If source has a real method, then a method is
4337 GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
4343 /* If dest already had a real method, that's a change as well */
4345 !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
4346 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
4351 /* We don't need to check the name of the destination if it was not a
4352 glob to begin with. */
4353 if(dtype == SVt_PVGV) {
4354 const char * const name = GvNAME((const GV *)dstr);
4357 /* The stash may have been detached from the symbol table, so
4359 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
4363 const STRLEN len = GvNAMELEN(dstr);
4364 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4365 || (len == 1 && name[0] == ':')) {
4368 /* Set aside the old stash, so we can reset isa caches on
4370 if((old_stash = GvHV(dstr)))
4371 /* Make sure we do not lose it early. */
4372 SvREFCNT_inc_simple_void_NN(
4373 sv_2mortal((SV *)old_stash)
4378 SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
4381 gp_free(MUTABLE_GV(dstr));
4382 GvINTRO_off(dstr); /* one-shot flag */
4383 GvGP_set(dstr, gp_ref(GvGP(sstr)));
4384 if (SvTAINTED(sstr))
4386 if (GvIMPORTED(dstr) != GVf_IMPORTED
4387 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4389 GvIMPORTED_on(dstr);
4392 if(mro_changes == 2) {
4393 if (GvAV((const GV *)sstr)) {
4395 SV * const sref = (SV *)GvAV((const GV *)dstr);
4396 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
4397 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
4398 AV * const ary = newAV();
4399 av_push(ary, mg->mg_obj); /* takes the refcount */
4400 mg->mg_obj = (SV *)ary;
4402 av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
4404 else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
4406 mro_isa_changed_in(GvSTASH(dstr));
4408 else if(mro_changes == 3) {
4409 HV * const stash = GvHV(dstr);
4410 if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
4416 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
4417 if (GvIO(dstr) && dtype == SVt_PVGV) {
4418 DEBUG_o(Perl_deb(aTHX_
4419 "glob_assign_glob clearing PL_stashcache\n"));
4420 /* It's a cache. It will rebuild itself quite happily.
4421 It's a lot of effort to work out exactly which key (or keys)
4422 might be invalidated by the creation of the this file handle.
4424 hv_clear(PL_stashcache);
4430 Perl_gv_setref(pTHX_ SV *const dstr, SV *const sstr)
4432 SV * const sref = SvRV(sstr);
4434 const int intro = GvINTRO(dstr);
4437 const U32 stype = SvTYPE(sref);
4439 PERL_ARGS_ASSERT_GV_SETREF;
4442 GvINTRO_off(dstr); /* one-shot flag */
4443 GvLINE(dstr) = CopLINE(PL_curcop);
4444 GvEGV(dstr) = MUTABLE_GV(dstr);
4449 location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
4450 import_flag = GVf_IMPORTED_CV;
4453 location = (SV **) &GvHV(dstr);
4454 import_flag = GVf_IMPORTED_HV;
4457 location = (SV **) &GvAV(dstr);
4458 import_flag = GVf_IMPORTED_AV;
4461 location = (SV **) &GvIOp(dstr);
4464 location = (SV **) &GvFORM(dstr);
4467 location = &GvSV(dstr);
4468 import_flag = GVf_IMPORTED_SV;
4471 if (stype == SVt_PVCV) {
4472 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
4473 if (GvCVGEN(dstr)) {
4474 SvREFCNT_dec(GvCV(dstr));
4475 GvCV_set(dstr, NULL);
4476 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4479 /* SAVEt_GVSLOT takes more room on the savestack and has more
4480 overhead in leave_scope than SAVEt_GENERIC_SV. But for CVs
4481 leave_scope needs access to the GV so it can reset method
4482 caches. We must use SAVEt_GVSLOT whenever the type is
4483 SVt_PVCV, even if the stash is anonymous, as the stash may
4484 gain a name somehow before leave_scope. */
4485 if (stype == SVt_PVCV) {
4486 /* There is no save_pushptrptrptr. Creating it for this
4487 one call site would be overkill. So inline the ss add
4491 SS_ADD_PTR(location);
4492 SS_ADD_PTR(SvREFCNT_inc(*location));
4493 SS_ADD_UV(SAVEt_GVSLOT);
4496 else SAVEGENERICSV(*location);
4499 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
4500 CV* const cv = MUTABLE_CV(*location);
4502 if (!GvCVGEN((const GV *)dstr) &&
4503 (CvROOT(cv) || CvXSUB(cv)) &&
4504 /* redundant check that avoids creating the extra SV
4505 most of the time: */
4506 (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
4508 SV * const new_const_sv =
4509 CvCONST((const CV *)sref)
4510 ? cv_const_sv((const CV *)sref)
4512 report_redefined_cv(
4513 sv_2mortal(Perl_newSVpvf(aTHX_
4516 HvNAME_HEK(GvSTASH((const GV *)dstr))
4518 HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
4521 CvCONST((const CV *)sref) ? &new_const_sv : NULL
4525 cv_ckproto_len_flags(cv, (const GV *)dstr,
4526 SvPOK(sref) ? CvPROTO(sref) : NULL,
4527 SvPOK(sref) ? CvPROTOLEN(sref) : 0,
4528 SvPOK(sref) ? SvUTF8(sref) : 0);
4530 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4531 GvASSUMECV_on(dstr);
4532 if(GvSTASH(dstr)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
4533 if (intro && GvREFCNT(dstr) > 1) {
4534 /* temporary remove extra savestack's ref */
4536 gv_method_changed(dstr);
4539 else gv_method_changed(dstr);
4542 *location = SvREFCNT_inc_simple_NN(sref);
4543 if (import_flag && !(GvFLAGS(dstr) & import_flag)
4544 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
4545 GvFLAGS(dstr) |= import_flag;
4547 if (import_flag == GVf_IMPORTED_SV) {
4549 save_aliased_sv((GV *)dstr);
4551 /* Turn off the flag if sref is not referenced elsewhere,
4552 even by weak refs. (SvRMAGICAL is a pessimistic check for
4554 if (SvREFCNT(sref) <= 2 && !SvRMAGICAL(sref))
4555 GvALIASED_SV_off(dstr);
4557 GvALIASED_SV_on(dstr);
4559 if (stype == SVt_PVHV) {
4560 const char * const name = GvNAME((GV*)dstr);
4561 const STRLEN len = GvNAMELEN(dstr);
4564 (len > 1 && name[len-2] == ':' && name[len-1] == ':')
4565 || (len == 1 && name[0] == ':')
4567 && (!dref || HvENAME_get(dref))
4570 (HV *)sref, (HV *)dref,
4576 stype == SVt_PVAV && sref != dref
4577 && strEQ(GvNAME((GV*)dstr), "ISA")
4578 /* The stash may have been detached from the symbol table, so
4579 check its name before doing anything. */
4580 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
4583 MAGIC * const omg = dref && SvSMAGICAL(dref)
4584 ? mg_find(dref, PERL_MAGIC_isa)
4586 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
4587 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
4588 AV * const ary = newAV();
4589 av_push(ary, mg->mg_obj); /* takes the refcount */
4590 mg->mg_obj = (SV *)ary;
4593 if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
4594 SV **svp = AvARRAY((AV *)omg->mg_obj);
4595 I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
4599 SvREFCNT_inc_simple_NN(*svp++)
4605 SvREFCNT_inc_simple_NN(omg->mg_obj)
4609 av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
4614 sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
4616 mg = mg_find(sref, PERL_MAGIC_isa);
4618 /* Since the *ISA assignment could have affected more than