3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'I wonder what the Entish is for "yes" and "no",' he thought.
16 * [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
22 * This file contains the code that creates, manipulates and destroys
23 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
24 * structure of an SV, so their creation and destruction is handled
25 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
26 * level functions (eg. substr, split, join) for each of the types are
39 /* Missing proto on LynxOS */
40 char *gconvert(double, int, int, char *);
44 # define SNPRINTF_G(nv, buffer, size, ndig) \
45 quadmath_snprintf(buffer, size, "%.*Qg", (int)ndig, (NV)(nv))
47 # define SNPRINTF_G(nv, buffer, size, ndig) \
48 PERL_UNUSED_RESULT(Gconvert((NV)(nv), (int)ndig, 0, buffer))
51 #ifndef SV_COW_THRESHOLD
52 # define SV_COW_THRESHOLD 0 /* COW iff len > K */
54 #ifndef SV_COWBUF_THRESHOLD
55 # define SV_COWBUF_THRESHOLD 1250 /* COW iff len > K */
57 #ifndef SV_COW_MAX_WASTE_THRESHOLD
58 # define SV_COW_MAX_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */
60 #ifndef SV_COWBUF_WASTE_THRESHOLD
61 # define SV_COWBUF_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */
63 #ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD
64 # define SV_COW_MAX_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */
66 #ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD
67 # define SV_COWBUF_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */
69 /* Work around compiler warnings about unsigned >= THRESHOLD when thres-
72 # define GE_COW_THRESHOLD(cur) ((cur) >= SV_COW_THRESHOLD)
74 # define GE_COW_THRESHOLD(cur) 1
76 #if SV_COWBUF_THRESHOLD
77 # define GE_COWBUF_THRESHOLD(cur) ((cur) >= SV_COWBUF_THRESHOLD)
79 # define GE_COWBUF_THRESHOLD(cur) 1
81 #if SV_COW_MAX_WASTE_THRESHOLD
82 # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COW_MAX_WASTE_THRESHOLD)
84 # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) 1
86 #if SV_COWBUF_WASTE_THRESHOLD
87 # define GE_COWBUF_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COWBUF_WASTE_THRESHOLD)
89 # define GE_COWBUF_WASTE_THRESHOLD(cur,len) 1
91 #if SV_COW_MAX_WASTE_FACTOR_THRESHOLD
92 # define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COW_MAX_WASTE_FACTOR_THRESHOLD * (cur))
94 # define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) 1
96 #if SV_COWBUF_WASTE_FACTOR_THRESHOLD
97 # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COWBUF_WASTE_FACTOR_THRESHOLD * (cur))
99 # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) 1
102 #define CHECK_COW_THRESHOLD(cur,len) (\
103 GE_COW_THRESHOLD((cur)) && \
104 GE_COW_MAX_WASTE_THRESHOLD((cur),(len)) && \
105 GE_COW_MAX_WASTE_FACTOR_THRESHOLD((cur),(len)) \
107 #define CHECK_COWBUF_THRESHOLD(cur,len) (\
108 GE_COWBUF_THRESHOLD((cur)) && \
109 GE_COWBUF_WASTE_THRESHOLD((cur),(len)) && \
110 GE_COWBUF_WASTE_FACTOR_THRESHOLD((cur),(len)) \
113 #ifdef PERL_UTF8_CACHE_ASSERT
114 /* if adding more checks watch out for the following tests:
115 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
116 * lib/utf8.t lib/Unicode/Collate/t/index.t
119 # define ASSERT_UTF8_CACHE(cache) \
120 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
121 assert((cache)[2] <= (cache)[3]); \
122 assert((cache)[3] <= (cache)[1]);} \
125 # define ASSERT_UTF8_CACHE(cache) NOOP
128 static const char S_destroy[] = "DESTROY";
129 #define S_destroy_len (sizeof(S_destroy)-1)
131 /* ============================================================================
133 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
134 sv, av, hv...) contains type and reference count information, and for
135 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
136 contains fields specific to each type. Some types store all they need
137 in the head, so don't have a body.
139 In all but the most memory-paranoid configurations (ex: PURIFY), heads
140 and bodies are allocated out of arenas, which by default are
141 approximately 4K chunks of memory parcelled up into N heads or bodies.
142 Sv-bodies are allocated by their sv-type, guaranteeing size
143 consistency needed to allocate safely from arrays.
145 For SV-heads, the first slot in each arena is reserved, and holds a
146 link to the next arena, some flags, and a note of the number of slots.
147 Snaked through each arena chain is a linked list of free items; when
148 this becomes empty, an extra arena is allocated and divided up into N
149 items which are threaded into the free list.
151 SV-bodies are similar, but they use arena-sets by default, which
152 separate the link and info from the arena itself, and reclaim the 1st
153 slot in the arena. SV-bodies are further described later.
155 The following global variables are associated with arenas:
157 PL_sv_arenaroot pointer to list of SV arenas
158 PL_sv_root pointer to list of free SV structures
160 PL_body_arenas head of linked-list of body arenas
161 PL_body_roots[] array of pointers to list of free bodies of svtype
162 arrays are indexed by the svtype needed
164 A few special SV heads are not allocated from an arena, but are
165 instead directly created in the interpreter structure, eg PL_sv_undef.
166 The size of arenas can be changed from the default by setting
167 PERL_ARENA_SIZE appropriately at compile time.
169 The SV arena serves the secondary purpose of allowing still-live SVs
170 to be located and destroyed during final cleanup.
172 At the lowest level, the macros new_SV() and del_SV() grab and free
173 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
174 to return the SV to the free list with error checking.) new_SV() calls
175 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
176 SVs in the free list have their SvTYPE field set to all ones.
178 At the time of very final cleanup, sv_free_arenas() is called from
179 perl_destruct() to physically free all the arenas allocated since the
180 start of the interpreter.
182 The internal function visit() scans the SV arenas list, and calls a specified
183 function for each SV it finds which is still live, I<i.e.> which has an SvTYPE
184 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
185 following functions (specified as [function that calls visit()] / [function
186 called by visit() for each SV]):
188 sv_report_used() / do_report_used()
189 dump all remaining SVs (debugging aid)
191 sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
192 do_clean_named_io_objs(),do_curse()
193 Attempt to free all objects pointed to by RVs,
194 try to do the same for all objects indir-
195 ectly referenced by typeglobs too, and
196 then do a final sweep, cursing any
197 objects that remain. Called once from
198 perl_destruct(), prior to calling sv_clean_all()
201 sv_clean_all() / do_clean_all()
202 SvREFCNT_dec(sv) each remaining SV, possibly
203 triggering an sv_free(). It also sets the
204 SVf_BREAK flag on the SV to indicate that the
205 refcnt has been artificially lowered, and thus
206 stopping sv_free() from giving spurious warnings
207 about SVs which unexpectedly have a refcnt
208 of zero. called repeatedly from perl_destruct()
209 until there are no SVs left.
211 =head2 Arena allocator API Summary
213 Private API to rest of sv.c
217 new_XPVNV(), del_body()
222 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
226 * ========================================================================= */
229 * "A time to plant, and a time to uproot what was planted..."
232 #ifdef DEBUG_LEAKING_SCALARS
233 # define FREE_SV_DEBUG_FILE(sv) STMT_START { \
234 if ((sv)->sv_debug_file) { \
235 PerlMemShared_free((sv)->sv_debug_file); \
236 sv->sv_debug_file = NULL; \
239 # define DEBUG_SV_SERIAL(sv) \
240 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) del_SV\n", \
241 PTR2UV(sv), (long)(sv)->sv_debug_serial))
243 # define FREE_SV_DEBUG_FILE(sv)
244 # define DEBUG_SV_SERIAL(sv) NOOP
247 /* Mark an SV head as unused, and add to free list.
249 * If SVf_BREAK is set, skip adding it to the free list, as this SV had
250 * its refcount artificially decremented during global destruction, so
251 * there may be dangling pointers to it. The last thing we want in that
252 * case is for it to be reused. */
254 #define plant_SV(p) \
256 const U32 old_flags = SvFLAGS(p); \
257 MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
258 DEBUG_SV_SERIAL(p); \
259 FREE_SV_DEBUG_FILE(p); \
261 SvFLAGS(p) = SVTYPEMASK; \
262 if (!(old_flags & SVf_BREAK)) { \
263 SvARENA_CHAIN_SET(p, PL_sv_root); \
270 /* make some more SVs by adding another arena */
276 char *chunk; /* must use New here to match call to */
277 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
278 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
283 /* del_SV(): return an empty SV head to the free list */
296 S_del_sv(pTHX_ SV *p)
298 PERL_ARGS_ASSERT_DEL_SV;
303 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
304 const SV * const sv = sva + 1;
305 const SV * const svend = &sva[SvREFCNT(sva)];
306 if (p >= sv && p < svend) {
312 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
313 "Attempt to free non-arena SV: 0x%" UVxf
314 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
321 #else /* ! DEBUGGING */
323 #define del_SV(p) plant_SV(p)
325 #endif /* DEBUGGING */
329 =for apidoc_section $SV
331 =for apidoc sv_add_arena
333 Given a chunk of memory, link it to the head of the list of arenas,
334 and split it into a list of free SVs.
340 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
342 SV *const sva = MUTABLE_SV(ptr);
346 PERL_ARGS_ASSERT_SV_ADD_ARENA;
348 /* The first SV in an arena isn't an SV. */
349 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
350 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
351 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
353 PL_sv_arenaroot = sva;
354 PL_sv_root = sva + 1;
356 svend = &sva[SvREFCNT(sva) - 1];
359 SvARENA_CHAIN_SET(sv, (sv + 1));
363 /* Must always set typemask because it's always checked in on cleanup
364 when the arenas are walked looking for objects. */
365 SvFLAGS(sv) = SVTYPEMASK;
368 SvARENA_CHAIN_SET(sv, 0);
372 SvFLAGS(sv) = SVTYPEMASK;
375 /* visit(): call the named function for each non-free SV in the arenas
376 * whose flags field matches the flags/mask args. */
379 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
384 PERL_ARGS_ASSERT_VISIT;
386 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
387 const SV * const svend = &sva[SvREFCNT(sva)];
389 for (sv = sva + 1; sv < svend; ++sv) {
391 && (sv->sv_flags & mask) == flags
404 /* called by sv_report_used() for each live SV */
407 do_report_used(pTHX_ SV *const sv)
409 if (!SvIS_FREED(sv)) {
410 PerlIO_printf(Perl_debug_log, "****\n");
417 =for apidoc sv_report_used
419 Dump the contents of all SVs not yet freed (debugging aid).
425 Perl_sv_report_used(pTHX)
428 visit(do_report_used, 0, 0);
434 /* called by sv_clean_objs() for each live SV */
437 do_clean_objs(pTHX_ SV *const ref)
441 SV * const target = SvRV(ref);
442 if (SvOBJECT(target)) {
443 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
444 if (SvWEAKREF(ref)) {
445 sv_del_backref(target, ref);
451 SvREFCNT_dec_NN(target);
458 /* clear any slots in a GV which hold objects - except IO;
459 * called by sv_clean_objs() for each live GV */
462 do_clean_named_objs(pTHX_ SV *const sv)
465 assert(SvTYPE(sv) == SVt_PVGV);
466 assert(isGV_with_GP(sv));
470 /* freeing GP entries may indirectly free the current GV;
471 * hold onto it while we mess with the GP slots */
474 if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
475 DEBUG_D((PerlIO_printf(Perl_debug_log,
476 "Cleaning named glob SV object:\n "), sv_dump(obj)));
478 SvREFCNT_dec_NN(obj);
480 if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
481 DEBUG_D((PerlIO_printf(Perl_debug_log,
482 "Cleaning named glob AV object:\n "), sv_dump(obj)));
484 SvREFCNT_dec_NN(obj);
486 if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
487 DEBUG_D((PerlIO_printf(Perl_debug_log,
488 "Cleaning named glob HV object:\n "), sv_dump(obj)));
490 SvREFCNT_dec_NN(obj);
492 if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
493 DEBUG_D((PerlIO_printf(Perl_debug_log,
494 "Cleaning named glob CV object:\n "), sv_dump(obj)));
496 SvREFCNT_dec_NN(obj);
498 SvREFCNT_dec_NN(sv); /* undo the inc above */
501 /* clear any IO slots in a GV which hold objects (except stderr, defout);
502 * called by sv_clean_objs() for each live GV */
505 do_clean_named_io_objs(pTHX_ SV *const sv)
508 assert(SvTYPE(sv) == SVt_PVGV);
509 assert(isGV_with_GP(sv));
510 if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
514 if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
515 DEBUG_D((PerlIO_printf(Perl_debug_log,
516 "Cleaning named glob IO object:\n "), sv_dump(obj)));
518 SvREFCNT_dec_NN(obj);
520 SvREFCNT_dec_NN(sv); /* undo the inc above */
523 /* Void wrapper to pass to visit() */
525 do_curse(pTHX_ SV * const sv) {
526 if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
527 || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
533 =for apidoc sv_clean_objs
535 Attempt to destroy all objects not yet freed.
541 Perl_sv_clean_objs(pTHX)
544 PL_in_clean_objs = TRUE;
545 visit(do_clean_objs, SVf_ROK, SVf_ROK);
546 /* Some barnacles may yet remain, clinging to typeglobs.
547 * Run the non-IO destructors first: they may want to output
548 * error messages, close files etc */
549 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
550 visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
551 /* And if there are some very tenacious barnacles clinging to arrays,
552 closures, or what have you.... */
553 visit(do_curse, SVs_OBJECT, SVs_OBJECT);
554 olddef = PL_defoutgv;
555 PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
556 if (olddef && isGV_with_GP(olddef))
557 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
558 olderr = PL_stderrgv;
559 PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
560 if (olderr && isGV_with_GP(olderr))
561 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
562 SvREFCNT_dec(olddef);
563 PL_in_clean_objs = FALSE;
566 /* called by sv_clean_all() for each live SV */
569 do_clean_all(pTHX_ SV *const sv)
571 if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
572 /* don't clean pid table and strtab */
575 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%" UVxf "\n", PTR2UV(sv)) ));
576 SvFLAGS(sv) |= SVf_BREAK;
581 =for apidoc sv_clean_all
583 Decrement the refcnt of each remaining SV, possibly triggering a
584 cleanup. This function may have to be called multiple times to free
585 SVs which are in complex self-referential hierarchies.
591 Perl_sv_clean_all(pTHX)
594 PL_in_clean_all = TRUE;
595 cleaned = visit(do_clean_all, 0,0);
600 ARENASETS: a meta-arena implementation which separates arena-info
601 into struct arena_set, which contains an array of struct
602 arena_descs, each holding info for a single arena. By separating
603 the meta-info from the arena, we recover the 1st slot, formerly
604 borrowed for list management. The arena_set is about the size of an
605 arena, avoiding the needless malloc overhead of a naive linked-list.
607 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
608 memory in the last arena-set (1/2 on average). In trade, we get
609 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
610 smaller types). The recovery of the wasted space allows use of
611 small arenas for large, rare body types, by changing array* fields
612 in body_details_by_type[] below.
615 char *arena; /* the raw storage, allocated aligned */
616 size_t size; /* its size ~4k typ */
617 svtype utype; /* bodytype stored in arena */
622 /* Get the maximum number of elements in set[] such that struct arena_set
623 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
624 therefore likely to be 1 aligned memory page. */
626 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
627 - 2 * sizeof(int)) / sizeof (struct arena_desc))
630 struct arena_set* next;
631 unsigned int set_size; /* ie ARENAS_PER_SET */
632 unsigned int curr; /* index of next available arena-desc */
633 struct arena_desc set[ARENAS_PER_SET];
637 =for apidoc sv_free_arenas
639 Deallocate the memory used by all arenas. Note that all the individual SV
640 heads and bodies within the arenas must already have been freed.
646 Perl_sv_free_arenas(pTHX)
652 /* Free arenas here, but be careful about fake ones. (We assume
653 contiguity of the fake ones with the corresponding real ones.) */
655 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
656 svanext = MUTABLE_SV(SvANY(sva));
657 while (svanext && SvFAKE(svanext))
658 svanext = MUTABLE_SV(SvANY(svanext));
665 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
668 struct arena_set *current = aroot;
671 assert(aroot->set[i].arena);
672 Safefree(aroot->set[i].arena);
680 i = PERL_ARENA_ROOTS_SIZE;
682 PL_body_roots[i] = 0;
689 Historically, here were mid-level routines that manage the
690 allocation of bodies out of the various arenas. Some of these
691 routines and related definitions remain here, but others were
692 moved into sv_inline.h to facilitate inlining of newSV_type().
694 There are 4 kinds of arenas:
696 1. SV-head arenas, which are discussed and handled above
697 2. regular body arenas
698 3. arenas for reduced-size bodies
701 Arena types 2 & 3 are chained by body-type off an array of
702 arena-root pointers, which is indexed by svtype. Some of the
703 larger/less used body types are malloced singly, since a large
704 unused block of them is wasteful. Also, several svtypes don't have
705 bodies; the data fits into the sv-head itself. The arena-root
706 pointer thus has a few unused root-pointers (which may be hijacked
707 later for arena type 4)
709 3 differs from 2 as an optimization; some body types have several
710 unused fields in the front of the structure (which are kept in-place
711 for consistency). These bodies can be allocated in smaller chunks,
712 because the leading fields arent accessed. Pointers to such bodies
713 are decremented to point at the unused 'ghost' memory, knowing that
714 the pointers are used with offsets to the real memory.
716 Allocation of SV-bodies is similar to SV-heads, differing as follows;
717 the allocation mechanism is used for many body types, so is somewhat
718 more complicated, it uses arena-sets, and has no need for still-live
721 At the outermost level, (new|del)_X*V macros return bodies of the
722 appropriate type. These macros call either (new|del)_body_type or
723 (new|del)_body_allocated macro pairs, depending on specifics of the
724 type. Most body types use the former pair, the latter pair is used to
725 allocate body types with "ghost fields".
727 "ghost fields" are fields that are unused in certain types, and
728 consequently don't need to actually exist. They are declared because
729 they're part of a "base type", which allows use of functions as
730 methods. The simplest examples are AVs and HVs, 2 aggregate types
731 which don't use the fields which support SCALAR semantics.
733 For these types, the arenas are carved up into appropriately sized
734 chunks, we thus avoid wasted memory for those unaccessed members.
735 When bodies are allocated, we adjust the pointer back in memory by the
736 size of the part not allocated, so it's as if we allocated the full
737 structure. (But things will all go boom if you write to the part that
738 is "not there", because you'll be overwriting the last members of the
739 preceding structure in memory.)
741 We calculate the correction using the STRUCT_OFFSET macro on the first
742 member present. If the allocated structure is smaller (no initial NV
743 actually allocated) then the net effect is to subtract the size of the NV
744 from the pointer, to return a new pointer as if an initial NV were actually
745 allocated. (We were using structures named *_allocated for this, but
746 this turned out to be a subtle bug, because a structure without an NV
747 could have a lower alignment constraint, but the compiler is allowed to
748 optimised accesses based on the alignment constraint of the actual pointer
749 to the full structure, for example, using a single 64 bit load instruction
750 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
752 This is the same trick as was used for NV and IV bodies. Ironically it
753 doesn't need to be used for NV bodies any more, because NV is now at
754 the start of the structure. IV bodies, and also in some builds NV bodies,
755 don't need it either, because they are no longer allocated.
757 In turn, the new_body_* allocators call S_new_body(), which invokes
758 new_body_from_arena macro, which takes a lock, and takes a body off the
759 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
760 necessary to refresh an empty list. Then the lock is released, and
761 the body is returned.
763 Perl_more_bodies allocates a new arena, and carves it up into an array of N
764 bodies, which it strings into a linked list. It looks up arena-size
765 and body-size from the body_details table described below, thus
766 supporting the multiple body-types.
768 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
769 the (new|del)_X*V macros are mapped directly to malloc/free.
771 For each sv-type, struct body_details bodies_by_type[] carries
772 parameters which control these aspects of SV handling:
774 Arena_size determines whether arenas are used for this body type, and if
775 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
776 zero, forcing individual mallocs and frees.
778 Body_size determines how big a body is, and therefore how many fit into
779 each arena. Offset carries the body-pointer adjustment needed for
780 "ghost fields", and is used in *_allocated macros.
782 But its main purpose is to parameterize info needed in
783 Perl_sv_upgrade(). The info here dramatically simplifies the function
784 vs the implementation in 5.8.8, making it table-driven. All fields
785 are used for this, except for arena_size.
787 For the sv-types that have no bodies, arenas are not used, so those
788 PL_body_roots[sv_type] are unused, and can be overloaded. In
789 something of a special case, SVt_NULL is borrowed for HE arenas;
790 PL_body_roots[HE_ARENA_ROOT_IX=SVt_NULL] is filled by S_more_he, but the
791 bodies_by_type[SVt_NULL] slot is not used, as the table is not
792 available in hv.c. Similarly SVt_IV is re-used for HVAUX_ARENA_ROOT_IX.
796 /* return a thing to the free list */
798 #define del_body(thing, root) \
800 void ** const thing_copy = (void **)thing; \
801 *thing_copy = *root; \
802 *root = (void*)thing_copy; \
807 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
808 const size_t arena_size)
810 void ** const root = &PL_body_roots[sv_type];
811 struct arena_desc *adesc;
812 struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
816 const size_t good_arena_size = Perl_malloc_good_size(arena_size);
817 #if defined(DEBUGGING)
818 static bool done_sanity_check;
820 if (!done_sanity_check) {
821 unsigned int i = SVt_LAST;
823 done_sanity_check = TRUE;
826 assert (bodies_by_type[i].type == i);
832 /* may need new arena-set to hold new arena */
833 if (!aroot || aroot->curr >= aroot->set_size) {
834 struct arena_set *newroot;
835 Newxz(newroot, 1, struct arena_set);
836 newroot->set_size = ARENAS_PER_SET;
837 newroot->next = aroot;
839 PL_body_arenas = (void *) newroot;
840 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
843 /* ok, now have arena-set with at least 1 empty/available arena-desc */
844 curr = aroot->curr++;
845 adesc = &(aroot->set[curr]);
846 assert(!adesc->arena);
848 Newx(adesc->arena, good_arena_size, char);
849 adesc->size = good_arena_size;
850 adesc->utype = sv_type;
851 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %" UVuf "\n",
852 curr, (void*)adesc->arena, (UV)good_arena_size));
854 start = (char *) adesc->arena;
856 /* Get the address of the byte after the end of the last body we can fit.
857 Remember, this is integer division: */
858 end = start + good_arena_size / body_size * body_size;
860 /* computed count doesn't reflect the 1st slot reservation */
861 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
862 DEBUG_m(PerlIO_printf(Perl_debug_log,
863 "arena %p end %p arena-size %d (from %d) type %d "
865 (void*)start, (void*)end, (int)good_arena_size,
866 (int)arena_size, sv_type, (int)body_size,
867 (int)good_arena_size / (int)body_size));
869 DEBUG_m(PerlIO_printf(Perl_debug_log,
870 "arena %p end %p arena-size %d type %d size %d ct %d\n",
871 (void*)start, (void*)end,
872 (int)arena_size, sv_type, (int)body_size,
873 (int)good_arena_size / (int)body_size));
875 *root = (void *)start;
878 /* Where the next body would start: */
879 char * const next = start + body_size;
882 /* This is the last body: */
889 *(void**) start = (void *)next;
895 =for apidoc sv_upgrade
897 Upgrade an SV to a more complex form. Generally adds a new body type to the
898 SV, then copies across as much information as possible from the old body.
899 It croaks if the SV is already in a more complex form than requested. You
900 generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
901 before calling C<sv_upgrade>, and hence does not croak. See also
908 Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
912 const svtype old_type = SvTYPE(sv);
913 const struct body_details *new_type_details;
914 const struct body_details *old_type_details
915 = bodies_by_type + old_type;
918 PERL_ARGS_ASSERT_SV_UPGRADE;
920 if (old_type == new_type)
923 /* This clause was purposefully added ahead of the early return above to
924 the shared string hackery for (sort {$a <=> $b} keys %hash), with the
925 inference by Nick I-S that it would fix other troublesome cases. See
926 changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
928 Given that shared hash key scalars are no longer PVIV, but PV, there is
929 no longer need to unshare so as to free up the IVX slot for its proper
930 purpose. So it's safe to move the early return earlier. */
932 if (new_type > SVt_PVMG && SvIsCOW(sv)) {
933 sv_force_normal_flags(sv, 0);
936 old_body = SvANY(sv);
938 /* Copying structures onto other structures that have been neatly zeroed
939 has a subtle gotcha. Consider XPVMG
941 +------+------+------+------+------+-------+-------+
942 | NV | CUR | LEN | IV | MAGIC | STASH |
943 +------+------+------+------+------+-------+-------+
946 where NVs are aligned to 8 bytes, so that sizeof that structure is
947 actually 32 bytes long, with 4 bytes of padding at the end:
949 +------+------+------+------+------+-------+-------+------+
950 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
951 +------+------+------+------+------+-------+-------+------+
952 0 4 8 12 16 20 24 28 32
954 so what happens if you allocate memory for this structure:
956 +------+------+------+------+------+-------+-------+------+------+...
957 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
958 +------+------+------+------+------+-------+-------+------+------+...
959 0 4 8 12 16 20 24 28 32 36
961 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
962 expect, because you copy the area marked ??? onto GP. Now, ??? may have
963 started out as zero once, but it's quite possible that it isn't. So now,
964 rather than a nicely zeroed GP, you have it pointing somewhere random.
967 (In fact, GP ends up pointing at a previous GP structure, because the
968 principle cause of the padding in XPVMG getting garbage is a copy of
969 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
970 this happens to be moot because XPVGV has been re-ordered, with GP
971 no longer after STASH)
973 So we are careful and work out the size of used parts of all the
982 old_type_details = &fake_rv;
983 if (new_type == SVt_NV)
986 if (new_type < SVt_PVIV) {
987 new_type = (new_type == SVt_NV)
988 ? SVt_PVNV : SVt_PVIV;
993 if (new_type < SVt_PVNV) {
998 assert(new_type > SVt_PV);
999 STATIC_ASSERT_STMT(SVt_IV < SVt_PV);
1000 STATIC_ASSERT_STMT(SVt_NV < SVt_PV);
1007 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1008 there's no way that it can be safely upgraded, because perl.c
1009 expects to Safefree(SvANY(PL_mess_sv)) */
1010 assert(sv != PL_mess_sv);
1013 if (UNLIKELY(old_type_details->cant_upgrade))
1014 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1015 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1018 if (UNLIKELY(old_type > new_type))
1019 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1020 (int)old_type, (int)new_type);
1022 new_type_details = bodies_by_type + new_type;
1024 SvFLAGS(sv) &= ~SVTYPEMASK;
1025 SvFLAGS(sv) |= new_type;
1027 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1028 the return statements above will have triggered. */
1029 assert (new_type != SVt_NULL);
1032 assert(old_type == SVt_NULL);
1033 SET_SVANY_FOR_BODYLESS_IV(sv);
1037 assert(old_type == SVt_NULL);
1038 #if NVSIZE <= IVSIZE
1039 SET_SVANY_FOR_BODYLESS_NV(sv);
1041 SvANY(sv) = new_XNV();
1048 assert(new_type_details->body_size);
1051 assert(new_type_details->arena);
1052 assert(new_type_details->arena_size);
1053 /* This points to the start of the allocated area. */
1054 new_body = S_new_body(aTHX_ new_type);
1055 /* xpvav and xpvhv have no offset, so no need to adjust new_body */
1056 assert(!(new_type_details->offset));
1058 /* We always allocated the full length item with PURIFY. To do this
1059 we fake things so that arena is false for all 16 types.. */
1060 new_body = new_NOARENAZ(new_type_details);
1062 SvANY(sv) = new_body;
1068 .xmg_u = {.xmg_magic = NULL},
1069 .xav_fill = -1, .xav_max = -1, .xav_alloc = 0
1071 *((XPVAV*) SvANY(sv)) = pvav;
1080 .xmg_u = {.xmg_magic = NULL},
1082 /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
1083 .xhv_max = PERL_HASH_DEFAULT_HvMAX
1085 *((XPVHV*) SvANY(sv)) = pvhv;
1090 #ifndef NODEFAULT_SHAREKEYS
1091 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1097 .xmg_stash = NULL, .xmg_u = {.xmg_magic = NULL},
1098 .xobject_maxfield = -1,
1099 .xobject_iter_sv_at = 0,
1100 .xobject_fields = NULL,
1102 *((XPVOBJ*) SvANY(sv)) = pvo;
1109 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1110 The target created by newSVrv also is, and it can have magic.
1111 However, it never has SvPVX set.
1113 if (old_type == SVt_IV) {
1115 } else if (old_type >= SVt_PV) {
1116 assert(SvPVX_const(sv) == 0);
1119 if (old_type >= SVt_PVMG) {
1120 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1121 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1123 sv->sv_u.svu_array = NULL; /* or svu_hash */
1128 /* XXX Is this still needed? Was it ever needed? Surely as there is
1129 no route from NV to PVIV, NOK can never be true */
1130 assert(!SvNOKp(sv));
1144 assert(new_type_details->body_size);
1145 /* We always allocated the full length item with PURIFY. To do this
1146 we fake things so that arena is false for all 16 types.. */
1148 if(new_type_details->arena) {
1149 /* This points to the start of the allocated area. */
1150 new_body = S_new_body(aTHX_ new_type);
1151 Zero(new_body, new_type_details->body_size, char);
1152 new_body = ((char *)new_body) - new_type_details->offset;
1156 new_body = new_NOARENAZ(new_type_details);
1158 SvANY(sv) = new_body;
1160 if (old_type_details->copy) {
1161 /* There is now the potential for an upgrade from something without
1162 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1163 int offset = old_type_details->offset;
1164 int length = old_type_details->copy;
1166 if (new_type_details->offset > old_type_details->offset) {
1167 const int difference
1168 = new_type_details->offset - old_type_details->offset;
1169 offset += difference;
1170 length -= difference;
1172 assert (length >= 0);
1174 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1178 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1179 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1180 * correct 0.0 for us. Otherwise, if the old body didn't have an
1181 * NV slot, but the new one does, then we need to initialise the
1182 * freshly created NV slot with whatever the correct bit pattern is
1184 if (old_type_details->zero_nv && !new_type_details->zero_nv
1185 && !isGV_with_GP(sv))
1189 if (UNLIKELY(new_type == SVt_PVIO)) {
1190 IO * const io = MUTABLE_IO(sv);
1191 GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1194 /* Clear the stashcache because a new IO could overrule a package
1196 DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
1197 hv_clear(PL_stashcache);
1199 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1200 IoPAGE_LEN(sv) = 60;
1202 if (old_type < SVt_PV) {
1203 /* referent will be NULL unless the old type was SVt_IV emulating
1205 sv->sv_u.svu_rv = referent;
1209 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1210 (unsigned long)new_type);
1213 /* if this is zero, this is a body-less SVt_NULL, SVt_IV/SVt_RV,
1214 and sometimes SVt_NV */
1215 if (old_type_details->body_size) {
1219 /* Note that there is an assumption that all bodies of types that
1220 can be upgraded came from arenas. Only the more complex non-
1221 upgradable types are allowed to be directly malloc()ed. */
1222 assert(old_type_details->arena);
1223 del_body((void*)((char*)old_body + old_type_details->offset),
1224 &PL_body_roots[old_type]);
1230 Perl_hv_auxalloc(pTHX_ HV *hv) {
1231 const struct body_details *old_type_details = bodies_by_type + SVt_PVHV;
1235 PERL_ARGS_ASSERT_HV_AUXALLOC;
1236 assert(SvTYPE(hv) == SVt_PVHV);
1237 assert(!HvHasAUX(hv));
1240 new_body = new_NOARENAZ(&fake_hv_with_aux);
1242 new_body_from_arena(new_body, HVAUX_ARENA_ROOT_IX, fake_hv_with_aux);
1245 old_body = SvANY(hv);
1247 Copy((char *)old_body + old_type_details->offset,
1248 (char *)new_body + fake_hv_with_aux.offset,
1249 old_type_details->copy,
1255 assert(old_type_details->arena);
1256 del_body((void*)((char*)old_body + old_type_details->offset),
1257 &PL_body_roots[SVt_PVHV]);
1260 SvANY(hv) = (XPVHV *) new_body;
1261 SvFLAGS(hv) |= SVphv_HasAUX;
1266 =for apidoc sv_backoff
1268 Remove any string offset. You should normally use the C<SvOOK_off> macro
1274 /* prior to 5.000 stable, this function returned the new OOK-less SvFLAGS
1275 prior to 5.23.4 this function always returned 0
1279 Perl_sv_backoff(SV *const sv)
1282 const char * const s = SvPVX_const(sv);
1284 PERL_ARGS_ASSERT_SV_BACKOFF;
1287 assert(SvTYPE(sv) != SVt_PVHV);
1288 assert(SvTYPE(sv) != SVt_PVAV);
1290 SvOOK_offset(sv, delta);
1292 SvLEN_set(sv, SvLEN(sv) + delta);
1293 SvPV_set(sv, SvPVX(sv) - delta);
1294 SvFLAGS(sv) &= ~SVf_OOK;
1295 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1300 /* forward declaration */
1301 static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
1307 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1308 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1309 Use the C<SvGROW> wrapper instead.
1316 Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
1320 PERL_ARGS_ASSERT_SV_GROW;
1324 if (SvTYPE(sv) < SVt_PV) {
1325 sv_upgrade(sv, SVt_PV);
1326 s = SvPVX_mutable(sv);
1328 else if (SvOOK(sv)) { /* pv is offset? */
1330 s = SvPVX_mutable(sv);
1331 if (newlen > SvLEN(sv))
1332 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1336 if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0);
1337 s = SvPVX_mutable(sv);
1340 #ifdef PERL_COPY_ON_WRITE
1341 /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1342 * to store the COW count. So in general, allocate one more byte than
1343 * asked for, to make it likely this byte is always spare: and thus
1344 * make more strings COW-able.
1346 * Only increment if the allocation isn't MEM_SIZE_MAX,
1347 * otherwise it will wrap to 0.
1349 if ( newlen != MEM_SIZE_MAX )
1353 #if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size)
1354 #define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1357 if (newlen > SvLEN(sv)) { /* need more room? */
1358 STRLEN minlen = SvCUR(sv);
1359 minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + PERL_STRLEN_NEW_MIN;
1360 if (newlen < minlen)
1362 #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1364 /* Don't round up on the first allocation, as odds are pretty good that
1365 * the initial request is accurate as to what is really needed */
1367 STRLEN rounded = PERL_STRLEN_ROUNDUP(newlen);
1368 if (rounded > newlen)
1372 if (SvLEN(sv) && s) {
1373 s = (char*)saferealloc(s, newlen);
1376 s = (char*)safemalloc(newlen);
1377 if (SvPVX_const(sv) && SvCUR(sv)) {
1378 Move(SvPVX_const(sv), s, SvCUR(sv), char);
1382 #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1383 /* Do this here, do it once, do it right, and then we will never get
1384 called back into sv_grow() unless there really is some growing
1386 SvLEN_set(sv, Perl_safesysmalloc_size(s));
1388 SvLEN_set(sv, newlen);
1395 =for apidoc sv_grow_fresh
1397 A cut-down version of sv_grow intended only for when sv is a freshly-minted
1398 SVt_PV, SVt_PVIV, SVt_PVNV, or SVt_PVMG. i.e. sv has the default flags, has
1399 never been any other type, and does not have an existing string. Basically,
1400 just assigns a char buffer and returns a pointer to it.
1407 Perl_sv_grow_fresh(pTHX_ SV *const sv, STRLEN newlen)
1411 PERL_ARGS_ASSERT_SV_GROW_FRESH;
1413 assert(SvTYPE(sv) >= SVt_PV && SvTYPE(sv) <= SVt_PVMG);
1416 assert(!SvIsCOW(sv));
1420 #ifdef PERL_COPY_ON_WRITE
1421 /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1422 * to store the COW count. So in general, allocate one more byte than
1423 * asked for, to make it likely this byte is always spare: and thus
1424 * make more strings COW-able.
1426 * Only increment if the allocation isn't MEM_SIZE_MAX,
1427 * otherwise it will wrap to 0.
1429 if ( newlen != MEM_SIZE_MAX )
1433 if (newlen < PERL_STRLEN_NEW_MIN)
1434 newlen = PERL_STRLEN_NEW_MIN;
1436 s = (char*)safemalloc(newlen);
1439 /* No PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC here, since many strings */
1440 /* will never be grown once set. Let the real sv_grow worry about that. */
1441 SvLEN_set(sv, newlen);
1446 =for apidoc sv_setiv
1447 =for apidoc_item sv_setiv_mg
1449 These copy an integer into the given SV, upgrading first if necessary.
1451 They differ only in that C<sv_setiv_mg> handles 'set' magic; C<sv_setiv> does
1458 Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
1460 PERL_ARGS_ASSERT_SV_SETIV;
1462 SV_CHECK_THINKFIRST_COW_DROP(sv);
1463 switch (SvTYPE(sv)) {
1464 #if NVSIZE <= IVSIZE
1467 SET_SVANY_FOR_BODYLESS_IV(sv);
1468 SvFLAGS(sv) &= ~SVTYPEMASK;
1469 SvFLAGS(sv) |= SVt_IV;
1473 SET_SVANY_FOR_BODYLESS_IV(sv);
1474 SvFLAGS(sv) &= ~SVTYPEMASK;
1475 SvFLAGS(sv) |= SVt_IV;
1478 sv_upgrade(sv, SVt_IV);
1482 sv_upgrade(sv, SVt_PVIV);
1486 if (!isGV_with_GP(sv))
1494 /* diag_listed_as: Can't coerce %s to %s in %s */
1495 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1497 NOT_REACHED; /* NOTREACHED */
1501 (void)SvIOK_only(sv); /* validate number */
1507 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1509 PERL_ARGS_ASSERT_SV_SETIV_MG;
1516 =for apidoc sv_setuv
1517 =for apidoc_item sv_setuv_mg
1519 These copy an unsigned integer into the given SV, upgrading first if necessary.
1522 They differ only in that C<sv_setuv_mg> handles 'set' magic; C<sv_setuv> does
1529 Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1531 PERL_ARGS_ASSERT_SV_SETUV;
1533 /* With the if statement to ensure that integers are stored as IVs whenever
1535 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1538 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1540 If you wish to remove the following if statement, so that this routine
1541 (and its callers) always return UVs, please benchmark to see what the
1542 effect is. Modern CPUs may be different. Or may not :-)
1544 if (u <= (UV)IV_MAX) {
1545 sv_setiv(sv, (IV)u);
1554 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1556 PERL_ARGS_ASSERT_SV_SETUV_MG;
1563 =for apidoc sv_setnv
1564 =for apidoc_item sv_setnv_mg
1566 These copy a double into the given SV, upgrading first if necessary.
1568 They differ only in that C<sv_setnv_mg> handles 'set' magic; C<sv_setnv> does
1575 Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1577 PERL_ARGS_ASSERT_SV_SETNV;
1579 SV_CHECK_THINKFIRST_COW_DROP(sv);
1580 switch (SvTYPE(sv)) {
1583 #if NVSIZE <= IVSIZE
1584 SET_SVANY_FOR_BODYLESS_NV(sv);
1585 SvFLAGS(sv) &= ~SVTYPEMASK;
1586 SvFLAGS(sv) |= SVt_NV;
1589 sv_upgrade(sv, SVt_NV);
1594 sv_upgrade(sv, SVt_PVNV);
1598 if (!isGV_with_GP(sv))
1606 /* diag_listed_as: Can't coerce %s to %s in %s */
1607 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1609 NOT_REACHED; /* NOTREACHED */
1614 (void)SvNOK_only(sv); /* validate number */
1619 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1621 PERL_ARGS_ASSERT_SV_SETNV_MG;
1628 =for apidoc sv_setrv_noinc
1629 =for apidoc_item sv_setrv_noinc_mg
1631 Copies an SV pointer into the given SV as an SV reference, upgrading it if
1632 necessary. After this, C<SvRV(sv)> is equal to I<ref>. This does not adjust
1633 the reference count of I<ref>. The reference I<ref> must not be NULL.
1635 C<sv_setrv_noinc_mg> will invoke 'set' magic on the SV; C<sv_setrv_noinc> will
1642 Perl_sv_setrv_noinc(pTHX_ SV *const sv, SV *const ref)
1644 PERL_ARGS_ASSERT_SV_SETRV_NOINC;
1646 SV_CHECK_THINKFIRST_COW_DROP(sv);
1647 prepare_SV_for_RV(sv);
1655 Perl_sv_setrv_noinc_mg(pTHX_ SV *const sv, SV *const ref)
1657 PERL_ARGS_ASSERT_SV_SETRV_NOINC_MG;
1659 sv_setrv_noinc(sv, ref);
1664 =for apidoc sv_setrv_inc
1665 =for apidoc_item sv_setrv_inc_mg
1667 As C<sv_setrv_noinc> but increments the reference count of I<ref>.
1669 C<sv_setrv_inc_mg> will invoke 'set' magic on the SV; C<sv_setrv_inc> will
1676 Perl_sv_setrv_inc(pTHX_ SV *const sv, SV *const ref)
1678 PERL_ARGS_ASSERT_SV_SETRV_INC;
1680 sv_setrv_noinc(sv, SvREFCNT_inc_simple_NN(ref));
1684 Perl_sv_setrv_inc_mg(pTHX_ SV *const sv, SV *const ref)
1686 PERL_ARGS_ASSERT_SV_SETRV_INC_MG;
1688 sv_setrv_noinc(sv, SvREFCNT_inc_simple_NN(ref));
1692 /* Return a cleaned-up, printable version of sv, for non-numeric, or
1693 * not incrementable warning display.
1694 * Originally part of S_not_a_number().
1695 * The return value may be != tmpbuf.
1699 S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1702 PERL_ARGS_ASSERT_SV_DISPLAY;
1705 SV *dsv = newSVpvs_flags("", SVs_TEMP);
1706 pv = sv_uni_display(dsv, sv, 32, UNI_DISPLAY_ISPRINT);
1709 const char * const limit = tmpbuf + tmpbuf_size - 8;
1710 /* each *s can expand to 4 chars + "...\0",
1711 i.e. need room for 8 chars */
1713 const char *s = SvPVX_const(sv);
1714 const char * const end = s + SvCUR(sv);
1715 for ( ; s < end && d < limit; s++ ) {
1717 if (! isASCII(ch) && !isPRINT_LC(ch)) {
1721 /* Map to ASCII "equivalent" of Latin1 */
1722 ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1728 else if (ch == '\r') {
1732 else if (ch == '\f') {
1736 else if (ch == '\\') {
1740 else if (ch == '\0') {
1744 else if (isPRINT_LC(ch))
1763 /* Print an "isn't numeric" warning, using a cleaned-up,
1764 * printable version of the offending string
1768 S_not_a_number(pTHX_ SV *const sv)
1773 PERL_ARGS_ASSERT_NOT_A_NUMBER;
1775 pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1778 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1779 /* diag_listed_as: Argument "%s" isn't numeric%s */
1780 "Argument \"%s\" isn't numeric in %s", pv,
1783 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1784 /* diag_listed_as: Argument "%s" isn't numeric%s */
1785 "Argument \"%s\" isn't numeric", pv);
1789 S_not_incrementable(pTHX_ SV *const sv) {
1793 PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1795 pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1797 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1798 "Argument \"%s\" treated as 0 in increment (++)", pv);
1802 =for apidoc looks_like_number
1804 Test if the content of an SV looks like a number (or is a number).
1805 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1806 non-numeric warning), even if your C<atof()> doesn't grok them. Get-magic is
1813 Perl_looks_like_number(pTHX_ SV *const sv)
1819 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1821 if (SvPOK(sv) || SvPOKp(sv)) {
1822 sbegin = SvPV_nomg_const(sv, len);
1825 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1826 numtype = grok_number(sbegin, len, NULL);
1827 return ((numtype & IS_NUMBER_TRAILING)) ? 0 : numtype;
1831 S_glob_2number(pTHX_ GV * const gv)
1833 PERL_ARGS_ASSERT_GLOB_2NUMBER;
1835 /* We know that all GVs stringify to something that is not-a-number,
1836 so no need to test that. */
1837 if (ckWARN(WARN_NUMERIC))
1839 SV *const buffer = sv_newmortal();
1840 gv_efullname3(buffer, gv, "*");
1841 not_a_number(buffer);
1843 /* We just want something true to return, so that S_sv_2iuv_common
1844 can tail call us and return true. */
1848 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1849 until proven guilty, assume that things are not that bad... */
1854 As 64 bit platforms often have an NV that doesn't preserve all bits of
1855 an IV (an assumption perl has been based on to date) it becomes necessary
1856 to remove the assumption that the NV always carries enough precision to
1857 recreate the IV whenever needed, and that the NV is the canonical form.
1858 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1859 precision as a side effect of conversion (which would lead to insanity
1860 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1861 1) to distinguish between IV/UV/NV slots that have a valid conversion cached
1862 where precision was lost, and IV/UV/NV slots that have a valid conversion
1863 which has lost no precision
1864 2) to ensure that if a numeric conversion to one form is requested that
1865 would lose precision, the precise conversion (or differently
1866 imprecise conversion) is also performed and cached, to prevent
1867 requests for different numeric formats on the same SV causing
1868 lossy conversion chains. (lossless conversion chains are perfectly
1873 SvIOKp is true if the IV slot contains a valid value
1874 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1875 SvNOKp is true if the NV slot contains a valid value
1876 SvNOK is true only if the NV value is accurate
1879 while converting from PV to NV, check to see if converting that NV to an
1880 IV(or UV) would lose accuracy over a direct conversion from PV to
1881 IV(or UV). If it would, cache both conversions, return NV, but mark
1882 SV as IOK NOKp (ie not NOK).
1884 While converting from PV to IV, check to see if converting that IV to an
1885 NV would lose accuracy over a direct conversion from PV to NV. If it
1886 would, cache both conversions, flag similarly.
1888 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1889 correctly because if IV & NV were set NV *always* overruled.
1890 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1891 changes - now IV and NV together means that the two are interchangeable:
1892 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1894 The benefit of this is that operations such as pp_add know that if
1895 SvIOK is true for both left and right operands, then integer addition
1896 can be used instead of floating point (for cases where the result won't
1897 overflow). Before, floating point was always used, which could lead to
1898 loss of precision compared with integer addition.
1900 * making IV and NV equal status should make maths accurate on 64 bit
1902 * may speed up maths somewhat if pp_add and friends start to use
1903 integers when possible instead of fp. (Hopefully the overhead in
1904 looking for SvIOK and checking for overflow will not outweigh the
1905 fp to integer speedup)
1906 * will slow down integer operations (callers of SvIV) on "inaccurate"
1907 values, as the change from SvIOK to SvIOKp will cause a call into
1908 sv_2iv each time rather than a macro access direct to the IV slot
1909 * should speed up number->string conversion on integers as IV is
1910 favoured when IV and NV are equally accurate
1912 ####################################################################
1913 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1914 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1915 On the other hand, SvUOK is true iff UV.
1916 ####################################################################
1918 Your mileage will vary depending your CPU's relative fp to integer
1922 #ifndef NV_PRESERVES_UV
1923 # define IS_NUMBER_UNDERFLOW_IV 1
1924 # define IS_NUMBER_UNDERFLOW_UV 2
1925 # define IS_NUMBER_IV_AND_UV 2
1926 # define IS_NUMBER_OVERFLOW_IV 4
1927 # define IS_NUMBER_OVERFLOW_UV 5
1929 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1931 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1933 S_sv_2iuv_non_preserve(pTHX_ SV *const sv
1939 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1940 PERL_UNUSED_CONTEXT;
1942 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));
1943 if (SvNVX(sv) < (NV)IV_MIN) {
1944 (void)SvIOKp_on(sv);
1946 SvIV_set(sv, IV_MIN);
1947 return IS_NUMBER_UNDERFLOW_IV;
1949 if (SvNVX(sv) > (NV)UV_MAX) {
1950 (void)SvIOKp_on(sv);
1953 SvUV_set(sv, UV_MAX);
1954 return IS_NUMBER_OVERFLOW_UV;
1956 (void)SvIOKp_on(sv);
1958 /* Can't use strtol etc to convert this string. (See truth table in
1960 if (SvNVX(sv) < IV_MAX_P1) {
1961 SvIV_set(sv, I_V(SvNVX(sv)));
1962 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1963 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1965 /* Integer is imprecise. NOK, IOKp */
1967 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1970 SvUV_set(sv, U_V(SvNVX(sv)));
1971 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1972 if (SvUVX(sv) == UV_MAX) {
1973 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1974 possibly be preserved by NV. Hence, it must be overflow.
1976 return IS_NUMBER_OVERFLOW_UV;
1978 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1980 /* Integer is imprecise. NOK, IOKp */
1982 return IS_NUMBER_OVERFLOW_IV;
1984 #endif /* !NV_PRESERVES_UV*/
1986 /* If numtype is infnan, set the NV of the sv accordingly.
1987 * If numtype is anything else, try setting the NV using Atof(PV). */
1989 S_sv_setnv(pTHX_ SV* sv, int numtype)
1991 bool pok = cBOOL(SvPOK(sv));
1994 if ((numtype & IS_NUMBER_INFINITY)) {
1995 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
2000 if ((numtype & IS_NUMBER_NAN)) {
2001 SvNV_set(sv, NV_NAN);
2006 SvNV_set(sv, Atof(SvPVX_const(sv)));
2007 /* Purposefully no true nok here, since we don't want to blow
2008 * away the possible IOK/UV of an existing sv. */
2011 SvNOK_only(sv); /* No IV or UV please, this is pure infnan. */
2013 SvPOK_on(sv); /* PV is okay, though. */
2018 S_sv_2iuv_common(pTHX_ SV *const sv)
2020 PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2023 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2024 * without also getting a cached IV/UV from it at the same time
2025 * (ie PV->NV conversion should detect loss of accuracy and cache
2026 * IV or UV at same time to avoid this. */
2027 /* IV-over-UV optimisation - choose to cache IV if possible */
2029 if (SvTYPE(sv) == SVt_NV)
2030 sv_upgrade(sv, SVt_PVNV);
2033 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2034 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2035 certainly cast into the IV range at IV_MAX, whereas the correct
2036 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2038 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2039 if (Perl_isnan(SvNVX(sv))) {
2045 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2046 SvIV_set(sv, I_V(SvNVX(sv)));
2047 if (SvNVX(sv) == (NV) SvIVX(sv)
2048 #ifndef NV_PRESERVES_UV
2049 && SvIVX(sv) != IV_MIN /* avoid negating IV_MIN below */
2050 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2051 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2052 /* Don't flag it as "accurately an integer" if the number
2053 came from a (by definition imprecise) NV operation, and
2054 we're outside the range of NV integer precision */
2058 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2060 /* scalar has trailing garbage, eg "42a" */
2062 DEBUG_c(PerlIO_printf(Perl_debug_log,
2063 "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (precise)\n",
2069 /* IV not precise. No need to convert from PV, as NV
2070 conversion would already have cached IV if it detected
2071 that PV->IV would be better than PV->NV->IV
2072 flags already correct - don't set public IOK. */
2073 DEBUG_c(PerlIO_printf(Perl_debug_log,
2074 "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (imprecise)\n",
2079 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2080 but the cast (NV)IV_MIN rounds to a the value less (more
2081 negative) than IV_MIN which happens to be equal to SvNVX ??
2082 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2083 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2084 (NV)UVX == NVX are both true, but the values differ. :-(
2085 Hopefully for 2s complement IV_MIN is something like
2086 0x8000000000000000 which will be exact. NWC */
2089 SvUV_set(sv, U_V(SvNVX(sv)));
2091 (SvNVX(sv) == (NV) SvUVX(sv))
2092 #ifndef NV_PRESERVES_UV
2093 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2094 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2095 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2096 /* Don't flag it as "accurately an integer" if the number
2097 came from a (by definition imprecise) NV operation, and
2098 we're outside the range of NV integer precision */
2104 DEBUG_c(PerlIO_printf(Perl_debug_log,
2105 "0x%" UVxf " 2iv(%" UVuf " => %" IVdf ") (as unsigned)\n",
2111 else if (SvPOKp(sv)) {
2114 const char *s = SvPVX_const(sv);
2115 const STRLEN cur = SvCUR(sv);
2117 /* short-cut for a single digit string like "1" */
2122 if (SvTYPE(sv) < SVt_PVIV)
2123 sv_upgrade(sv, SVt_PVIV);
2125 SvIV_set(sv, (IV)(c - '0'));
2130 numtype = grok_number(s, cur, &value);
2131 /* We want to avoid a possible problem when we cache an IV/ a UV which
2132 may be later translated to an NV, and the resulting NV is not
2133 the same as the direct translation of the initial string
2134 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2135 be careful to ensure that the value with the .456 is around if the
2136 NV value is requested in the future).
2138 This means that if we cache such an IV/a UV, we need to cache the
2139 NV as well. Moreover, we trade speed for space, and do not
2140 cache the NV if we are sure it's not needed.
2143 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2144 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2145 == IS_NUMBER_IN_UV) {
2146 /* It's definitely an integer, only upgrade to PVIV */
2147 if (SvTYPE(sv) < SVt_PVIV)
2148 sv_upgrade(sv, SVt_PVIV);
2150 } else if (SvTYPE(sv) < SVt_PVNV)
2151 sv_upgrade(sv, SVt_PVNV);
2153 if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
2154 if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING)))
2156 S_sv_setnv(aTHX_ sv, numtype);
2157 goto got_nv; /* Fill IV/UV slot and set IOKp */
2160 /* If NVs preserve UVs then we only use the UV value if we know that
2161 we aren't going to call atof() below. If NVs don't preserve UVs
2162 then the value returned may have more precision than atof() will
2163 return, even though value isn't perfectly accurate. */
2164 if ((numtype & (IS_NUMBER_IN_UV
2165 #ifdef NV_PRESERVES_UV
2168 )) == IS_NUMBER_IN_UV) {
2169 /* This won't turn off the public IOK flag if it was set above */
2170 (void)SvIOKp_on(sv);
2172 if (!(numtype & IS_NUMBER_NEG)) {
2174 if (value <= (UV)IV_MAX) {
2175 SvIV_set(sv, (IV)value);
2177 /* it didn't overflow, and it was positive. */
2178 SvUV_set(sv, value);
2182 /* 2s complement assumption */
2183 if (value <= (UV)IV_MIN) {
2184 SvIV_set(sv, value == (UV)IV_MIN
2185 ? IV_MIN : -(IV)value);
2187 /* Too negative for an IV. This is a double upgrade, but
2188 I'm assuming it will be rare. */
2189 if (SvTYPE(sv) < SVt_PVNV)
2190 sv_upgrade(sv, SVt_PVNV);
2194 SvNV_set(sv, -(NV)value);
2195 SvIV_set(sv, IV_MIN);
2199 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2200 will be in the previous block to set the IV slot, and the next
2201 block to set the NV slot. So no else here. */
2203 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2204 != IS_NUMBER_IN_UV) {
2205 /* It wasn't an (integer that doesn't overflow the UV). */
2206 S_sv_setnv(aTHX_ sv, numtype);
2208 if (! numtype && ckWARN(WARN_NUMERIC))
2211 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" NVgf ")\n",
2212 PTR2UV(sv), SvNVX(sv)));
2214 #ifdef NV_PRESERVES_UV
2218 goto got_nv; /* Fill IV/UV slot and set IOKp, maybe IOK */
2219 #else /* NV_PRESERVES_UV */
2220 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2221 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2222 /* The IV/UV slot will have been set from value returned by
2223 grok_number above. The NV slot has just been set using
2226 assert (SvIOKp(sv));
2228 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2229 U_V(Perl_fabs(SvNVX(sv)))) {
2230 /* Small enough to preserve all bits. */
2231 (void)SvIOKp_on(sv);
2233 SvIV_set(sv, I_V(SvNVX(sv)));
2234 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2236 /* There had been runtime checking for
2237 "U_V(Perl_fabs(SvNVX(sv))) < (UV)IV_MAX" here to ensure
2238 that this NV is in the preserved range, but this should
2239 be always true if the following assertion is true: */
2240 STATIC_ASSERT_STMT(((UV)1 << NV_PRESERVES_UV_BITS) <=
2244 0 0 already failed to read UV.
2245 0 1 already failed to read UV.
2246 1 0 you won't get here in this case. IV/UV
2247 slot set, public IOK, Atof() unneeded.
2248 1 1 already read UV.
2249 so there's no point in sv_2iuv_non_preserve() attempting
2250 to use atol, strtol, strtoul etc. */
2252 sv_2iuv_non_preserve (sv, numtype);
2254 sv_2iuv_non_preserve (sv);
2258 /* It might be more code efficient to go through the entire logic above
2259 and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2260 gets complex and potentially buggy, so more programmer efficient
2261 to do it this way, by turning off the public flags: */
2263 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2264 #endif /* NV_PRESERVES_UV */
2268 if (isGV_with_GP(sv))
2269 return glob_2number(MUTABLE_GV(sv));
2271 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2273 if (SvTYPE(sv) < SVt_IV)
2274 /* Typically the caller expects that sv_any is not NULL now. */
2275 sv_upgrade(sv, SVt_IV);
2276 /* Return 0 from the caller. */
2283 =for apidoc sv_2iv_flags
2285 Return the integer value of an SV, doing any necessary string
2286 conversion. If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2287 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2293 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2295 PERL_ARGS_ASSERT_SV_2IV_FLAGS;
2297 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2298 && SvTYPE(sv) != SVt_PVFM);
2300 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2306 if (flags & SV_SKIP_OVERLOAD)
2308 tmpstr = AMG_CALLunary(sv, numer_amg);
2309 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2310 return SvIV(tmpstr);
2313 return PTR2IV(SvRV(sv));
2316 if (SvVALID(sv) || isREGEXP(sv)) {
2317 /* FBMs use the space for SvIVX and SvNVX for other purposes, so
2318 must not let them cache IVs.
2319 In practice they are extremely unlikely to actually get anywhere
2320 accessible by user Perl code - the only way that I'm aware of is when
2321 a constant subroutine which is used as the second argument to index.
2323 Regexps have no SvIVX and SvNVX fields.
2328 const char * const ptr =
2329 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2331 = grok_number(ptr, SvCUR(sv), &value);
2333 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2334 == IS_NUMBER_IN_UV) {
2335 /* It's definitely an integer */
2336 if (numtype & IS_NUMBER_NEG) {
2337 if (value < (UV)IV_MIN)
2340 if (value < (UV)IV_MAX)
2345 /* Quite wrong but no good choices. */
2346 if ((numtype & IS_NUMBER_INFINITY)) {
2347 return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX;
2348 } else if ((numtype & IS_NUMBER_NAN)) {
2349 return 0; /* So wrong. */
2353 if (ckWARN(WARN_NUMERIC))
2356 return I_V(Atof(ptr));
2360 if (SvTHINKFIRST(sv)) {
2361 if (SvREADONLY(sv) && !SvOK(sv)) {
2362 if (ckWARN(WARN_UNINITIALIZED))
2369 if (S_sv_2iuv_common(aTHX_ sv))
2373 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" IVdf ")\n",
2374 PTR2UV(sv),SvIVX(sv)));
2375 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2379 =for apidoc sv_2uv_flags
2381 Return the unsigned integer value of an SV, doing any necessary string
2382 conversion. If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2383 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2385 =for apidoc Amnh||SV_GMAGIC
2391 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2393 PERL_ARGS_ASSERT_SV_2UV_FLAGS;
2395 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2401 if (flags & SV_SKIP_OVERLOAD)
2403 tmpstr = AMG_CALLunary(sv, numer_amg);
2404 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2405 return SvUV(tmpstr);
2408 return PTR2UV(SvRV(sv));
2411 if (SvVALID(sv) || isREGEXP(sv)) {
2412 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2413 the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2414 Regexps have no SvIVX and SvNVX fields. */
2418 const char * const ptr =
2419 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2421 = grok_number(ptr, SvCUR(sv), &value);
2423 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2424 == IS_NUMBER_IN_UV) {
2425 /* It's definitely an integer */
2426 if (!(numtype & IS_NUMBER_NEG))
2430 /* Quite wrong but no good choices. */
2431 if ((numtype & IS_NUMBER_INFINITY)) {
2432 return UV_MAX; /* So wrong. */
2433 } else if ((numtype & IS_NUMBER_NAN)) {
2434 return 0; /* So wrong. */
2438 if (ckWARN(WARN_NUMERIC))
2441 return U_V(Atof(ptr));
2445 if (SvTHINKFIRST(sv)) {
2446 if (SvREADONLY(sv) && !SvOK(sv)) {
2447 if (ckWARN(WARN_UNINITIALIZED))
2454 if (S_sv_2iuv_common(aTHX_ sv))
2458 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2uv(%" UVuf ")\n",
2459 PTR2UV(sv),SvUVX(sv)));
2460 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2464 =for apidoc sv_2nv_flags
2466 Return the num value of an SV, doing any necessary string or integer
2467 conversion. If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2468 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2474 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2476 PERL_ARGS_ASSERT_SV_2NV_FLAGS;
2478 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2479 && SvTYPE(sv) != SVt_PVFM);
2480 if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
2481 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2482 the same flag bit as SVf_IVisUV, so must not let them cache NVs.
2483 Regexps have no SvIVX and SvNVX fields. */
2485 if (flags & SV_GMAGIC)
2489 if (SvPOKp(sv) && !SvIOKp(sv)) {
2490 ptr = SvPVX_const(sv);
2491 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2492 !grok_number(ptr, SvCUR(sv), NULL))
2498 return (NV)SvUVX(sv);
2500 return (NV)SvIVX(sv);
2505 assert(SvTYPE(sv) >= SVt_PVMG);
2506 /* This falls through to the report_uninit near the end of the
2508 } else if (SvTHINKFIRST(sv)) {
2513 if (flags & SV_SKIP_OVERLOAD)
2515 tmpstr = AMG_CALLunary(sv, numer_amg);
2516 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2517 return SvNV(tmpstr);
2520 return PTR2NV(SvRV(sv));
2522 if (SvREADONLY(sv) && !SvOK(sv)) {
2523 if (ckWARN(WARN_UNINITIALIZED))
2528 if (SvTYPE(sv) < SVt_NV) {
2529 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2530 sv_upgrade(sv, SVt_NV);
2531 CLANG_DIAG_IGNORE_STMT(-Wthread-safety);
2533 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2534 STORE_LC_NUMERIC_SET_STANDARD();
2535 PerlIO_printf(Perl_debug_log,
2536 "0x%" UVxf " num(%" NVgf ")\n",
2537 PTR2UV(sv), SvNVX(sv));
2538 RESTORE_LC_NUMERIC();
2540 CLANG_DIAG_RESTORE_STMT;
2543 else if (SvTYPE(sv) < SVt_PVNV)
2544 sv_upgrade(sv, SVt_PVNV);
2549 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2550 #ifdef NV_PRESERVES_UV
2556 /* Only set the public NV OK flag if this NV preserves the IV */
2557 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2559 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2560 : (SvIVX(sv) == I_V(SvNVX(sv))))
2566 else if (SvPOKp(sv)) {
2568 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2569 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2571 #ifdef NV_PRESERVES_UV
2572 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2573 == IS_NUMBER_IN_UV) {
2574 /* It's definitely an integer */
2575 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2577 S_sv_setnv(aTHX_ sv, numtype);
2584 SvNV_set(sv, Atof(SvPVX_const(sv)));
2585 /* Only set the public NV OK flag if this NV preserves the value in
2586 the PV at least as well as an IV/UV would.
2587 Not sure how to do this 100% reliably. */
2588 /* if that shift count is out of range then Configure's test is
2589 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2591 if (((UV)1 << NV_PRESERVES_UV_BITS) > U_V(Perl_fabs(SvNVX(sv)))) {
2592 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2593 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2594 /* Can't use strtol etc to convert this string, so don't try.
2595 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2598 /* value has been set. It may not be precise. */
2599 if ((numtype & IS_NUMBER_NEG) && (value >= (UV)IV_MIN)) {
2600 /* 2s complement assumption for (UV)IV_MIN */
2601 SvNOK_on(sv); /* Integer is too negative. */
2606 if (numtype & IS_NUMBER_NEG) {
2607 /* -IV_MIN is undefined, but we should never reach
2608 * this point with both IS_NUMBER_NEG and value ==
2610 assert(value != (UV)IV_MIN);
2611 SvIV_set(sv, -(IV)value);
2612 } else if (value <= (UV)IV_MAX) {
2613 SvIV_set(sv, (IV)value);
2615 SvUV_set(sv, value);
2619 if (numtype & IS_NUMBER_NOT_INT) {
2620 /* I believe that even if the original PV had decimals,
2621 they are lost beyond the limit of the FP precision.
2622 However, neither is canonical, so both only get p
2623 flags. NWC, 2000/11/25 */
2624 /* Both already have p flags, so do nothing */
2626 const NV nv = SvNVX(sv);
2627 /* XXX should this spot have NAN_COMPARE_BROKEN, too? */
2628 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2629 if (SvIVX(sv) == I_V(nv)) {
2632 /* It had no "." so it must be integer. */
2636 /* between IV_MAX and NV(UV_MAX).
2637 Could be slightly > UV_MAX */
2639 if (numtype & IS_NUMBER_NOT_INT) {
2640 /* UV and NV both imprecise. */
2642 const UV nv_as_uv = U_V(nv);
2644 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2653 /* It might be more code efficient to go through the entire logic above
2654 and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2655 gets complex and potentially buggy, so more programmer efficient
2656 to do it this way, by turning off the public flags: */
2658 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2659 #endif /* NV_PRESERVES_UV */
2662 if (isGV_with_GP(sv)) {
2663 glob_2number(MUTABLE_GV(sv));
2667 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2669 assert (SvTYPE(sv) >= SVt_NV);
2670 /* Typically the caller expects that sv_any is not NULL now. */
2671 /* XXX Ilya implies that this is a bug in callers that assume this
2672 and ideally should be fixed. */
2675 CLANG_DIAG_IGNORE_STMT(-Wthread-safety);
2677 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2678 STORE_LC_NUMERIC_SET_STANDARD();
2679 PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2nv(%" NVgf ")\n",
2680 PTR2UV(sv), SvNVX(sv));
2681 RESTORE_LC_NUMERIC();
2683 CLANG_DIAG_RESTORE_STMT;
2690 Return an SV with the numeric value of the source SV, doing any necessary
2691 reference or overload conversion. The caller is expected to have handled
2698 Perl_sv_2num(pTHX_ SV *const sv)
2700 PERL_ARGS_ASSERT_SV_2NUM;
2705 SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2706 TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2707 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2708 return sv_2num(tmpsv);
2710 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2713 /* int2str_table: lookup table containing string representations of all
2714 * two digit numbers. For example, int2str_table.arr[0] is "00" and
2715 * int2str_table.arr[12*2] is "12".
2717 * We are going to read two bytes at a time, so we have to ensure that
2718 * the array is aligned to a 2 byte boundary. That's why it was made a
2719 * union with a dummy U16 member. */
2720 static const union {
2723 } int2str_table = {{
2724 '0', '0', '0', '1', '0', '2', '0', '3', '0', '4', '0', '5', '0', '6',
2725 '0', '7', '0', '8', '0', '9', '1', '0', '1', '1', '1', '2', '1', '3',
2726 '1', '4', '1', '5', '1', '6', '1', '7', '1', '8', '1', '9', '2', '0',
2727 '2', '1', '2', '2', '2', '3', '2', '4', '2', '5', '2', '6', '2', '7',
2728 '2', '8', '2', '9', '3', '0', '3', '1', '3', '2', '3', '3', '3', '4',
2729 '3', '5', '3', '6', '3', '7', '3', '8', '3', '9', '4', '0', '4', '1',
2730 '4', '2', '4', '3', '4', '4', '4', '5', '4', '6', '4', '7', '4', '8',
2731 '4', '9', '5', '0', '5', '1', '5', '2', '5', '3', '5', '4', '5', '5',
2732 '5', '6', '5', '7', '5', '8', '5', '9', '6', '0', '6', '1', '6', '2',
2733 '6', '3', '6', '4', '6', '5', '6', '6', '6', '7', '6', '8', '6', '9',
2734 '7', '0', '7', '1', '7', '2', '7', '3', '7', '4', '7', '5', '7', '6',
2735 '7', '7', '7', '8', '7', '9', '8', '0', '8', '1', '8', '2', '8', '3',
2736 '8', '4', '8', '5', '8', '6', '8', '7', '8', '8', '8', '9', '9', '0',
2737 '9', '1', '9', '2', '9', '3', '9', '4', '9', '5', '9', '6', '9', '7',
2741 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2742 * UV as a string towards the end of buf, and return pointers to start and
2745 * We assume that buf is at least TYPE_CHARS(UV) long.
2748 PERL_STATIC_INLINE char *
2749 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2751 char *ptr = buf + TYPE_CHARS(UV);
2752 char * const ebuf = ptr;
2754 U16 *word_ptr, *word_table;
2756 PERL_ARGS_ASSERT_UIV_2BUF;
2758 /* ptr has to be properly aligned, because we will cast it to U16* */
2759 assert(PTR2nat(ptr) % 2 == 0);
2760 /* we are going to read/write two bytes at a time */
2761 word_ptr = (U16*)ptr;
2762 word_table = (U16*)int2str_table.arr;
2764 if (UNLIKELY(is_uv))
2770 /* Using 0- here to silence bogus warning from MS VC */
2771 uv = (UV) (0 - (UV) iv);
2776 *--word_ptr = word_table[uv % 100];
2779 ptr = (char*)word_ptr;
2782 *--ptr = (char)uv + '0';
2784 *--word_ptr = word_table[uv];
2785 ptr = (char*)word_ptr;
2795 /* Helper for sv_2pv_flags and sv_vcatpvfn_flags. If the NV is an
2796 * infinity or a not-a-number, writes the appropriate strings to the
2797 * buffer, including a zero byte. On success returns the written length,
2798 * excluding the zero byte, on failure (not an infinity, not a nan)
2799 * returns zero, assert-fails on maxlen being too short.
2801 * XXX for "Inf", "-Inf", and "NaN", we could have three read-only
2802 * shared string constants we point to, instead of generating a new
2803 * string for each instance. */
2805 S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char plus) {
2807 assert(maxlen >= 4);
2808 if (Perl_isinf(nv)) {
2810 if (maxlen < 5) /* "-Inf\0" */
2820 else if (Perl_isnan(nv)) {
2824 /* XXX optionally output the payload mantissa bits as
2825 * "(unsigned)" (to match the nan("...") C99 function,
2826 * or maybe as "(0xhhh...)" would make more sense...
2827 * provide a format string so that the user can decide?
2828 * NOTE: would affect the maxlen and assert() logic.*/
2833 assert((s == buffer + 3) || (s == buffer + 4));
2840 =for apidoc_item sv_2pv_flags
2842 These implement the various forms of the L<perlapi/C<SvPV>> macros.
2843 The macros are the preferred interface.
2845 These return a pointer to the string value of an SV (coercing it to a string if
2846 necessary), and set C<*lp> to its length in bytes.
2848 The forms differ in that plain C<sv_2pvbyte> always processes 'get' magic; and
2849 C<sv_2pvbyte_flags> processes 'get' magic if and only if C<flags> contains
2852 =for apidoc Amnh||SV_GMAGIC
2858 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const U32 flags)
2861 bool done_gmagic = FALSE;
2863 PERL_ARGS_ASSERT_SV_2PV_FLAGS;
2865 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2866 && SvTYPE(sv) != SVt_PVFM);
2867 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) {
2876 if (flags & SV_SKIP_OVERLOAD)
2879 nsv = sv_mortalcopy_flags(sv,0);
2880 tmpstr = AMG_CALLunary(nsv, string_amg);
2881 TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2882 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(nsv)))) {
2884 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2888 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2889 if (flags & SV_CONST_RETURN) {
2890 pv = (char *) SvPVX_const(tmpstr);
2892 pv = (flags & SV_MUTABLE_RETURN)
2893 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2896 *lp = SvCUR(tmpstr);
2898 pv = sv_2pv_flags(tmpstr, lp, flags);
2911 SV *const referent = SvRV(sv);
2915 retval = buffer = savepvn("NULLREF", len);
2916 } else if (SvTYPE(referent) == SVt_REGEXP &&
2917 (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
2918 amagic_is_enabled(string_amg))) {
2919 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2923 /* If the regex is UTF-8 we want the containing scalar to
2924 have an UTF-8 flag too */
2931 *lp = RX_WRAPLEN(re);
2933 return RX_WRAPPED(re);
2935 const char *const typestring = sv_reftype(referent, 0);
2936 const STRLEN typelen = strlen(typestring);
2937 UV addr = PTR2UV(referent);
2938 const char *stashname = NULL;
2939 STRLEN stashnamelen = 0; /* hush, gcc */
2940 const char *buffer_end;
2942 if (SvOBJECT(referent)) {
2943 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2946 stashname = HEK_KEY(name);
2947 stashnamelen = HEK_LEN(name);
2949 if (HEK_UTF8(name)) {
2955 stashname = "__ANON__";
2958 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2959 + 2 * sizeof(UV) + 2 /* )\0 */;
2961 len = typelen + 3 /* (0x */
2962 + 2 * sizeof(UV) + 2 /* )\0 */;
2965 Newx(buffer, len, char);
2966 buffer_end = retval = buffer + len;
2968 /* Working backwards */
2972 *--retval = PL_hexdigit[addr & 15];
2973 } while (addr >>= 4);
2979 memcpy(retval, typestring, typelen);
2983 retval -= stashnamelen;
2984 memcpy(retval, stashname, stashnamelen);
2986 /* retval may not necessarily have reached the start of the
2988 assert (retval >= buffer);
2990 len = buffer_end - retval - 1; /* -1 for that \0 */
3002 if (flags & SV_MUTABLE_RETURN)
3003 return SvPVX_mutable(sv);
3004 if (flags & SV_CONST_RETURN)
3005 return (char *)SvPVX_const(sv);
3010 /* I'm assuming that if both IV and NV are equally valid then
3011 converting the IV is going to be more efficient */
3012 const U32 isUIOK = SvIsUV(sv);
3013 /* The purpose of this union is to ensure that arr is aligned on
3014 a 2 byte boundary, because that is what uiv_2buf() requires */
3016 char arr[TYPE_CHARS(UV)];
3022 if (SvTYPE(sv) < SVt_PVIV)
3023 sv_upgrade(sv, SVt_PVIV);
3024 ptr = uiv_2buf(buf.arr, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
3026 /* inlined from sv_setpvn */
3027 s = SvGROW_mutable(sv, len + 1);
3028 Move(ptr, s, len, char);
3031 /* We used to call SvPOK_on(). Whilst this is fine for (most) Perl code,
3032 it means that after this stringification is cached, there is no way
3033 to distinguish between values originally assigned as $a = 42; and
3034 $a = "42"; (or results of string operators vs numeric operators)
3035 where the value has subsequently been used in the other sense
3036 and had a value cached.
3037 This (somewhat) hack means that we retain the cached stringification,
3038 but don't set SVf_POK. Hence if a value is SVf_IOK|SVf_POK then it
3039 originated as "42", whereas if it's SVf_IOK then it originated as 42.
3040 (ignore SVp_IOK and SVp_POK)
3041 The SvPV macros are now updated to recognise this specific case
3042 (and that there isn't overloading or magic that could alter the
3043 cached value) and so return the cached value immediately without
3044 re-entering this function, getting back here to this block of code,
3045 and repeating the same conversion. */
3048 else if (SvNOK(sv)) {
3049 if (SvTYPE(sv) < SVt_PVNV)
3050 sv_upgrade(sv, SVt_PVNV);
3051 if (SvNVX(sv) == 0.0
3052 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3053 && !Perl_isnan(SvNVX(sv))
3056 s = SvGROW_mutable(sv, 2);
3061 STRLEN size = 5; /* "-Inf\0" */
3063 s = SvGROW_mutable(sv, size);
3064 len = S_infnan_2pv(SvNVX(sv), s, size, 0);
3070 /* some Xenix systems wipe out errno here */
3079 5 + /* exponent digits */
3083 s = SvGROW_mutable(sv, size);
3084 #ifndef USE_LOCALE_NUMERIC
3085 SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3091 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3092 STORE_LC_NUMERIC_SET_TO_NEEDED();
3094 local_radix = NOT_IN_NUMERIC_STANDARD_;
3095 if (local_radix && SvCUR(PL_numeric_radix_sv) > 1) {
3096 size += SvCUR(PL_numeric_radix_sv) - 1;
3097 s = SvGROW_mutable(sv, size);
3100 SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3102 /* If the radix character is UTF-8, and actually is in the
3103 * output, turn on the UTF-8 flag for the scalar */
3105 && SvUTF8(PL_numeric_radix_sv)
3106 && instr(s, SvPVX_const(PL_numeric_radix_sv)))
3111 RESTORE_LC_NUMERIC();
3114 /* We don't call SvPOK_on(), because it may come to
3115 * pass that the locale changes so that the
3116 * stringification we just did is no longer correct. We
3117 * will have to re-stringify every time it is needed */
3124 else if (isGV_with_GP(sv)) {
3125 GV *const gv = MUTABLE_GV(sv);
3126 SV *const buffer = sv_newmortal();
3128 gv_efullname3(buffer, gv, "*");
3130 assert(SvPOK(buffer));
3136 *lp = SvCUR(buffer);
3137 return SvPVX(buffer);
3142 if (flags & SV_UNDEF_RETURNS_NULL)
3144 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3146 /* Typically the caller expects that sv_any is not NULL now. */
3147 if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
3148 sv_upgrade(sv, SVt_PV);
3153 const STRLEN len = s - SvPVX_const(sv);
3158 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2pv(%s)\n",
3159 PTR2UV(sv),SvPVX_const(sv)));
3160 if (flags & SV_CONST_RETURN)
3161 return (char *)SvPVX_const(sv);
3162 if (flags & SV_MUTABLE_RETURN)
3163 return SvPVX_mutable(sv);
3168 =for apidoc sv_copypv
3169 =for apidoc_item sv_copypv_flags
3170 =for apidoc_item sv_copypv_nomg
3172 These copy a stringified representation of the source SV into the
3173 destination SV. They automatically perform coercion of numeric values into
3174 strings. Guaranteed to preserve the C<UTF8> flag even from overloaded objects.
3175 Similar in nature to C<sv_2pv[_flags]> but they operate directly on an SV
3176 instead of just the string. Mostly they use L</C<sv_2pv_flags>> to
3177 do the work, except when that would lose the UTF-8'ness of the PV.
3179 The three forms differ only in whether or not they perform 'get magic' on
3180 C<sv>. C<sv_copypv_nomg> skips 'get magic'; C<sv_copypv> performs it; and
3181 C<sv_copypv_flags> either performs it (if the C<SV_GMAGIC> bit is set in
3182 C<flags>) or doesn't (if that bit is cleared).
3188 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3193 PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3195 s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC));
3196 sv_setpvn(dsv,s,len);
3204 =for apidoc sv_2pvbyte
3205 =for apidoc_item sv_2pvbyte_flags
3207 These implement the various forms of the L<perlapi/C<SvPVbyte>> macros.
3208 The macros are the preferred interface.
3210 These return a pointer to the byte-encoded representation of the SV, and set
3211 C<*lp> to its length. If the SV is marked as being encoded as UTF-8, it will
3212 be downgraded, if possible, to a byte string. If the SV cannot be downgraded,
3215 The forms differ in that plain C<sv_2pvbyte> always processes 'get' magic; and
3216 C<sv_2pvbyte_flags> processes 'get' magic if and only if C<flags> contains
3219 =for apidoc Amnh||SV_GMAGIC
3225 Perl_sv_2pvbyte_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags)
3227 PERL_ARGS_ASSERT_SV_2PVBYTE_FLAGS;
3229 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
3231 if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3232 || isGV_with_GP(sv) || SvROK(sv)) {
3233 SV *sv2 = sv_newmortal();
3234 sv_copypv_nomg(sv2,sv);
3237 sv_utf8_downgrade_nomg(sv,0);
3238 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3242 =for apidoc sv_2pvutf8
3243 =for apidoc_item sv_2pvutf8_flags
3245 These implement the various forms of the L<perlapi/C<SvPVutf8>> macros.
3246 The macros are the preferred interface.
3248 These return a pointer to the UTF-8-encoded representation of the SV, and set
3249 C<*lp> to its length in bytes. They may cause the SV to be upgraded to UTF-8
3252 The forms differ in that plain C<sv_2pvutf8> always processes 'get' magic; and
3253 C<sv_2pvutf8_flags> processes 'get' magic if and only if C<flags> contains
3260 Perl_sv_2pvutf8_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags)
3262 PERL_ARGS_ASSERT_SV_2PVUTF8_FLAGS;
3264 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
3266 if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3267 || isGV_with_GP(sv) || SvROK(sv)) {
3268 SV *sv2 = sv_newmortal();
3269 sv_copypv_nomg(sv2,sv);
3272 sv_utf8_upgrade_nomg(sv);
3273 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3278 =for apidoc sv_2bool
3280 This macro is only used by C<sv_true()> or its macro equivalent, and only if
3281 the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>.
3282 It calls C<sv_2bool_flags> with the C<SV_GMAGIC> flag.
3284 =for apidoc sv_2bool_flags
3286 This function is only used by C<sv_true()> and friends, and only if
3287 the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>. If the flags
3288 contain C<SV_GMAGIC>, then it does an C<mg_get()> first.
3295 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
3297 PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3300 if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3306 SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3307 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
3310 if(SvGMAGICAL(sv)) {
3312 goto restart; /* call sv_2bool */
3314 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
3315 else if(!SvOK(sv)) {
3318 else if(SvPOK(sv)) {
3319 svb = SvPVXtrue(sv);
3321 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
3322 svb = (SvIOK(sv) && SvIVX(sv) != 0)
3323 || (SvNOK(sv) && SvNVX(sv) != 0.0);
3327 goto restart; /* call sv_2bool_nomg */
3337 RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
3339 if (SvNOK(sv) && !SvPOK(sv))
3340 return SvNVX(sv) != 0.0;
3342 return SvTRUE_common(sv, 0);
3346 =for apidoc sv_utf8_upgrade
3347 =for apidoc_item sv_utf8_upgrade_flags
3348 =for apidoc_item sv_utf8_upgrade_flags_grow
3349 =for apidoc_item sv_utf8_upgrade_nomg
3351 These convert the PV of an SV to its UTF-8-encoded form.
3352 The SV is forced to string form if it is not already.
3353 They always set the C<SvUTF8> flag to avoid future validity checks even if the
3354 whole string is the same in UTF-8 as not.
3355 They return the number of bytes in the converted string
3357 The forms differ in just two ways. The main difference is whether or not they
3358 perform 'get magic' on C<sv>. C<sv_utf8_upgrade_nomg> skips 'get magic';
3359 C<sv_utf8_upgrade> performs it; and C<sv_utf8_upgrade_flags> and
3360 C<sv_utf8_upgrade_flags_grow> either perform it (if the C<SV_GMAGIC> bit is set
3361 in C<flags>) or don't (if that bit is cleared).
3363 The other difference is that C<sv_utf8_upgrade_flags_grow> has an additional
3364 parameter, C<extra>, which allows the caller to specify an amount of space to
3365 be reserved as spare beyond what is needed for the actual conversion. This is
3366 used when the caller knows it will soon be needing yet more space, and it is
3367 more efficient to request space from the system in a single call.
3368 This form is otherwise identical to C<sv_utf8_upgrade_flags>.
3370 These are not a general purpose byte encoding to Unicode interface: use the
3371 Encode extension for that.
3373 The C<SV_FORCE_UTF8_UPGRADE> flag is now ignored.
3375 =for apidoc Amnh||SV_GMAGIC|
3376 =for apidoc Amnh||SV_FORCE_UTF8_UPGRADE|
3380 If the routine itself changes the string, it adds a trailing C<NUL>. Such a
3381 C<NUL> isn't guaranteed due to having other routines do the work in some input
3382 cases, or if the input is already flagged as being in utf8.
3387 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3389 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3391 if (sv == &PL_sv_undef)
3393 if (!SvPOK_nog(sv)) {
3395 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3396 (void) sv_2pv_flags(sv,&len, flags);
3398 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3402 (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3406 /* SVt_REGEXP's shouldn't be upgraded to UTF8 - they're already
3407 * compiled and individual nodes will remain non-utf8 even if the
3408 * stringified version of the pattern gets upgraded. Whether the
3409 * PVX of a REGEXP should be grown or we should just croak, I don't
3411 if (SvUTF8(sv) || isREGEXP(sv)) {
3412 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3417 S_sv_uncow(aTHX_ sv, 0);
3420 if (SvCUR(sv) == 0) {
3421 if (extra) SvGROW(sv, extra + 1); /* Make sure is room for a trailing
3423 } else { /* Assume Latin-1/EBCDIC */
3424 /* This function could be much more efficient if we
3425 * had a FLAG in SVs to signal if there are any variant
3426 * chars in the PV. Given that there isn't such a flag
3427 * make the loop as fast as possible. */
3428 U8 * s = (U8 *) SvPVX_const(sv);
3431 if (is_utf8_invariant_string_loc(s, SvCUR(sv), (const U8 **) &t)) {
3433 /* utf8 conversion not needed because all are invariants. Mark
3434 * as UTF-8 even if no variant - saves scanning loop */
3436 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3440 /* Here, there is at least one variant (t points to the first one), so
3441 * the string should be converted to utf8. Everything from 's' to
3442 * 't - 1' will occupy only 1 byte each on output.
3444 * Note that the incoming SV may not have a trailing '\0', as certain
3445 * code in pp_formline can send us partially built SVs.
3447 * There are two main ways to convert. One is to create a new string
3448 * and go through the input starting from the beginning, appending each
3449 * converted value onto the new string as we go along. Going this
3450 * route, it's probably best to initially allocate enough space in the
3451 * string rather than possibly running out of space and having to
3452 * reallocate and then copy what we've done so far. Since everything
3453 * from 's' to 't - 1' is invariant, the destination can be initialized
3454 * with these using a fast memory copy. To be sure to allocate enough
3455 * space, one could use the worst case scenario, where every remaining
3456 * byte expands to two under UTF-8, or one could parse it and count
3457 * exactly how many do expand.
3459 * The other way is to unconditionally parse the remainder of the
3460 * string to figure out exactly how big the expanded string will be,
3461 * growing if needed. Then start at the end of the string and place
3462 * the character there at the end of the unfilled space in the expanded
3463 * one, working backwards until reaching 't'.
3465 * The problem with assuming the worst case scenario is that for very
3466 * long strings, we could allocate much more memory than actually
3467 * needed, which can create performance problems. If we have to parse
3468 * anyway, the second method is the winner as it may avoid an extra
3469 * copy. The code used to use the first method under some
3470 * circumstances, but now that there is faster variant counting on
3471 * ASCII platforms, the second method is used exclusively, eliminating
3472 * some code that no longer has to be maintained. */
3475 /* Count the total number of variants there are. We can start
3476 * just beyond the first one, which is known to be at 't' */
3477 const Size_t invariant_length = t - s;
3478 U8 * e = (U8 *) SvEND(sv);
3480 /* The length of the left overs, plus 1. */
3481 const Size_t remaining_length_p1 = e - t;
3483 /* We expand by 1 for the variant at 't' and one for each remaining
3484 * variant (we start looking at 't+1') */
3485 Size_t expansion = 1 + variant_under_utf8_count(t + 1, e);
3487 /* +1 = trailing NUL */
3488 Size_t need = SvCUR(sv) + expansion + extra + 1;
3491 /* Grow if needed */
3492 if (SvLEN(sv) < need) {
3493 t = invariant_length + (U8*) SvGROW(sv, need);
3494 e = t + remaining_length_p1;
3496 SvCUR_set(sv, invariant_length + remaining_length_p1 + expansion);
3498 /* Set the NUL at the end */
3499 d = (U8 *) SvEND(sv);
3502 /* Having decremented d, it points to the position to put the
3503 * very last byte of the expanded string. Go backwards through
3504 * the string, copying and expanding as we go, stopping when we
3505 * get to the part that is invariant the rest of the way down */
3509 if (NATIVE_BYTE_IS_INVARIANT(*e)) {
3512 *d-- = UTF8_EIGHT_BIT_LO(*e);
3513 *d-- = UTF8_EIGHT_BIT_HI(*e);
3518 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3519 /* Update pos. We do it at the end rather than during
3520 * the upgrade, to avoid slowing down the common case
3521 * (upgrade without pos).
3522 * pos can be stored as either bytes or characters. Since
3523 * this was previously a byte string we can just turn off
3524 * the bytes flag. */
3525 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3527 mg->mg_flags &= ~MGf_BYTES;
3529 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3530 magic_setutf8(sv,mg); /* clear UTF8 cache */
3540 =for apidoc sv_utf8_downgrade
3541 =for apidoc_item sv_utf8_downgrade_flags
3542 =for apidoc_item sv_utf8_downgrade_nomg
3544 These attempt to convert the PV of an SV from characters to bytes. If the PV
3545 contains a character that cannot fit in a byte, this conversion will fail; in
3546 this case, C<FALSE> is returned if C<fail_ok> is true; otherwise they croak.
3548 They are not a general purpose Unicode to byte encoding interface:
3549 use the C<Encode> extension for that.
3551 They differ only in that:
3553 C<sv_utf8_downgrade> processes 'get' magic on C<sv>.
3555 C<sv_utf8_downgrade_nomg> does not.
3557 C<sv_utf8_downgrade_flags> has an additional C<flags> parameter in which you can specify
3558 C<SV_GMAGIC> to process 'get' magic, or leave it cleared to not process 'get' magic.
3564 Perl_sv_utf8_downgrade_flags(pTHX_ SV *const sv, const bool fail_ok, const U32 flags)
3566 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE_FLAGS;
3568 if (SvPOKp(sv) && SvUTF8(sv)) {
3572 U32 mg_flags = flags & SV_GMAGIC;
3575 S_sv_uncow(aTHX_ sv, 0);
3577 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3579 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3580 if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
3581 mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
3582 mg_flags|SV_CONST_RETURN);
3583 mg_flags = 0; /* sv_pos_b2u does get magic */
3585 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3586 magic_setutf8(sv,mg); /* clear UTF8 cache */
3589 s = (U8 *) SvPV_flags(sv, len, mg_flags);
3591 if (!utf8_to_bytes(s, &len)) {
3596 Perl_croak(aTHX_ "Wide character in %s",
3599 Perl_croak(aTHX_ "Wide character");
3610 =for apidoc sv_utf8_encode
3612 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3613 flag off so that it looks like octets again.
3619 Perl_sv_utf8_encode(pTHX_ SV *const sv)
3621 PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3623 if (SvREADONLY(sv)) {
3624 sv_force_normal_flags(sv, 0);
3626 (void) sv_utf8_upgrade(sv);
3631 =for apidoc sv_utf8_decode
3633 If the PV of the SV is an octet sequence in Perl's extended UTF-8
3634 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3635 so that it looks like a character. If the PV contains only single-byte
3636 characters, the C<SvUTF8> flag stays off.
3637 Scans PV for validity and returns FALSE if the PV is invalid UTF-8.
3643 Perl_sv_utf8_decode(pTHX_ SV *const sv)
3645 PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3648 const U8 *start, *c, *first_variant;
3650 /* The octets may have got themselves encoded - get them back as
3653 if (!sv_utf8_downgrade(sv, TRUE))
3656 /* it is actually just a matter of turning the utf8 flag on, but
3657 * we want to make sure everything inside is valid utf8 first.
3659 c = start = (const U8 *) SvPVX_const(sv);
3660 if (! is_utf8_invariant_string_loc(c, SvCUR(sv), &first_variant)) {
3661 if (!is_utf8_string(first_variant, SvCUR(sv) - (first_variant -c)))
3665 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3666 /* XXX Is this dead code? XS_utf8_decode calls SvSETMAGIC
3667 after this, clearing pos. Does anything on CPAN
3669 /* adjust pos to the start of a UTF8 char sequence */
3670 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3672 I32 pos = mg->mg_len;
3674 for (c = start + pos; c > start; c--) {
3675 if (UTF8_IS_START(*c))
3678 mg->mg_len = c - start;
3681 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3682 magic_setutf8(sv,mg); /* clear UTF8 cache */
3689 =for apidoc sv_setsv
3690 =for apidoc_item sv_setsv_flags
3691 =for apidoc_item sv_setsv_mg
3692 =for apidoc_item sv_setsv_nomg
3694 These copy the contents of the source SV C<ssv> into the destination SV C<dsv>.
3695 C<ssv> may be destroyed if it is mortal, so don't use these functions if
3696 the source SV needs to be reused.
3697 Loosely speaking, they perform a copy-by-value, obliterating any previous
3698 content of the destination.
3700 They differ only in that:
3702 C<sv_setsv> calls 'get' magic on C<ssv>, but skips 'set' magic on C<dsv>.
3704 C<sv_setsv_mg> calls both 'get' magic on C<ssv> and 'set' magic on C<dsv>.
3706 C<sv_setsv_nomg> skips all magic.
3708 C<sv_setsv_flags> has a C<flags> parameter which you can use to specify any
3709 combination of magic handling, and also you can specify C<SV_NOSTEAL> so that
3710 the buffers of temps will not be stolen.
3712 You probably want to instead use one of the assortment of wrappers, such as
3713 C<L</SvSetSV>>, C<L</SvSetSV_nosteal>>, C<L</SvSetMagicSV>> and
3714 C<L</SvSetMagicSV_nosteal>>.
3716 C<sv_setsv_flags> is the primary function for copying scalars, and most other
3717 copy-ish functions and macros use it underneath.
3719 =for apidoc Amnh||SV_NOSTEAL
3725 S_glob_assign_glob(pTHX_ SV *const dsv, SV *const ssv, const int dtype)
3727 I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3728 HV *old_stash = NULL;
3730 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3732 if (dtype != SVt_PVGV && !isGV_with_GP(dsv)) {
3733 const char * const name = GvNAME(ssv);
3734 const STRLEN len = GvNAMELEN(ssv);
3736 if (dtype >= SVt_PV) {
3742 SvUPGRADE(dsv, SVt_PVGV);
3743 (void)SvOK_off(dsv);
3744 isGV_with_GP_on(dsv);
3746 GvSTASH(dsv) = GvSTASH(ssv);
3748 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dsv)), dsv);
3749 gv_name_set(MUTABLE_GV(dsv), name, len,
3750 GV_ADD | (GvNAMEUTF8(ssv) ? SVf_UTF8 : 0 ));
3751 SvFAKE_on(dsv); /* can coerce to non-glob */
3754 if(GvGP(MUTABLE_GV(ssv))) {
3755 /* If source has method cache entry, clear it */
3757 SvREFCNT_dec(GvCV(ssv));
3758 GvCV_set(ssv, NULL);
3761 /* If source has a real method, then a method is
3764 GvCV((const GV *)ssv) && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
3770 /* If dest already had a real method, that's a change as well */
3772 !mro_changes && GvGP(MUTABLE_GV(dsv)) && GvCVu((const GV *)dsv)
3773 && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
3778 /* We don't need to check the name of the destination if it was not a
3779 glob to begin with. */
3780 if(dtype == SVt_PVGV) {
3781 const char * const name = GvNAME((const GV *)dsv);
3782 const STRLEN len = GvNAMELEN(dsv);
3783 if(memEQs(name, len, "ISA")
3784 /* The stash may have been detached from the symbol table, so
3786 && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
3790 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3791 || (len == 1 && name[0] == ':')) {
3794 /* Set aside the old stash, so we can reset isa caches on
3796 if((old_stash = GvHV(dsv)))
3797 /* Make sure we do not lose it early. */
3798 SvREFCNT_inc_simple_void_NN(
3799 sv_2mortal((SV *)old_stash)
3804 SvREFCNT_inc_simple_void_NN(sv_2mortal(dsv));
3807 /* freeing dsv's GP might free ssv (e.g. *x = $x),
3808 * so temporarily protect it */
3810 SAVEFREESV(SvREFCNT_inc_simple_NN(ssv));
3811 gp_free(MUTABLE_GV(dsv));
3812 GvINTRO_off(dsv); /* one-shot flag */
3813 GvGP_set(dsv, gp_ref(GvGP(ssv)));
3818 if (GvIMPORTED(dsv) != GVf_IMPORTED
3819 && CopSTASH_ne(PL_curcop, GvSTASH(dsv)))
3824 if(mro_changes == 2) {
3825 if (GvAV((const GV *)ssv)) {
3827 SV * const sref = (SV *)GvAV((const GV *)dsv);
3828 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3829 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3830 AV * const ary = newAV_alloc_x(2);
3831 av_push_simple(ary, mg->mg_obj); /* takes the refcount */
3832 av_push_simple(ary, SvREFCNT_inc_simple_NN(dsv));
3833 mg->mg_obj = (SV *)ary;
3835 av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dsv));
3838 else sv_magic(sref, dsv, PERL_MAGIC_isa, NULL, 0);
3840 mro_isa_changed_in(GvSTASH(dsv));
3842 else if(mro_changes == 3) {
3843 HV * const stash = GvHV(dsv);
3844 if(old_stash ? HvHasENAME(old_stash) : cBOOL(stash))
3850 else if(mro_changes) mro_method_changed_in(GvSTASH(dsv));
3851 if (GvIO(dsv) && dtype == SVt_PVGV) {
3852 DEBUG_o(Perl_deb(aTHX_
3853 "glob_assign_glob clearing PL_stashcache\n"));
3854 /* It's a cache. It will rebuild itself quite happily.
3855 It's a lot of effort to work out exactly which key (or keys)
3856 might be invalidated by the creation of the this file handle.
3858 hv_clear(PL_stashcache);
3864 Perl_gv_setref(pTHX_ SV *const dsv, SV *const ssv)
3866 SV * const sref = SvRV(ssv);
3868 const int intro = GvINTRO(dsv);
3871 const U32 stype = SvTYPE(sref);
3873 PERL_ARGS_ASSERT_GV_SETREF;
3876 GvINTRO_off(dsv); /* one-shot flag */
3877 GvLINE(dsv) = CopLINE(PL_curcop);
3878 GvEGV(dsv) = MUTABLE_GV(dsv);
3883 location = (SV **) &(GvGP(dsv)->gp_cv); /* XXX bypassing GvCV_set */
3884 import_flag = GVf_IMPORTED_CV;
3887 location = (SV **) &GvHV(dsv);
3888 import_flag = GVf_IMPORTED_HV;
3891 location = (SV **) &GvAV(dsv);
3892 import_flag = GVf_IMPORTED_AV;
3895 location = (SV **) &GvIOp(dsv);
3898 location = (SV **) &GvFORM(dsv);
3901 location = &GvSV(dsv);
3902 import_flag = GVf_IMPORTED_SV;
3905 if (stype == SVt_PVCV) {
3906 /*if (GvCVGEN(dsv) && (GvCV(dsv) != (const CV *)sref || GvCVGEN(dsv))) {*/
3908 SvREFCNT_dec(GvCV(dsv));
3909 GvCV_set(dsv, NULL);
3910 GvCVGEN(dsv) = 0; /* Switch off cacheness. */
3913 /* SAVEt_GVSLOT takes more room on the savestack and has more
3914 overhead in leave_scope than SAVEt_GENERIC_SV. But for CVs
3915 leave_scope needs access to the GV so it can reset method
3916 caches. We must use SAVEt_GVSLOT whenever the type is
3917 SVt_PVCV, even if the stash is anonymous, as the stash may
3918 gain a name somehow before leave_scope. */
3919 if (stype == SVt_PVCV) {
3920 /* There is no save_pushptrptrptr. Creating it for this
3921 one call site would be overkill. So inline the ss add
3925 SS_ADD_PTR(location);
3926 SS_ADD_PTR(SvREFCNT_inc(*location));
3927 SS_ADD_UV(SAVEt_GVSLOT);
3930 else SAVEGENERICSV(*location);
3933 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dsv))) {
3934 CV* const cv = MUTABLE_CV(*location);
3936 if (!GvCVGEN((const GV *)dsv) &&
3937 (CvROOT(cv) || CvXSUB(cv)) &&
3938 /* redundant check that avoids creating the extra SV
3939 most of the time: */
3940 (CvCONST(cv) || (ckWARN(WARN_REDEFINE) && !intro)))
3942 SV * const new_const_sv =
3943 CvCONST((const CV *)sref)
3944 ? cv_const_sv_or_av((const CV *)sref)
3946 HV * const stash = GvSTASH((const GV *)dsv);
3947 report_redefined_cv(
3950 ? Perl_newSVpvf(aTHX_
3951 "%" HEKf "::%" HEKf,
3952 HEKfARG(HvNAME_HEK(stash)),
3953 HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv))))
3954 : Perl_newSVpvf(aTHX_
3956 HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv))))
3959 CvCONST((const CV *)sref) ? &new_const_sv : NULL
3963 cv_ckproto_len_flags(cv, (const GV *)dsv,
3964 SvPOK(sref) ? CvPROTO(sref) : NULL,
3965 SvPOK(sref) ? CvPROTOLEN(sref) : 0,
3966 SvPOK(sref) ? SvUTF8(sref) : 0);
3968 GvCVGEN(dsv) = 0; /* Switch off cacheness. */
3970 if(GvSTASH(dsv)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3971 if (intro && GvREFCNT(dsv) > 1) {
3972 /* temporary remove extra savestack's ref */
3974 gv_method_changed(dsv);
3977 else gv_method_changed(dsv);
3980 *location = SvREFCNT_inc_simple_NN(sref);
3981 if (import_flag && !(GvFLAGS(dsv) & import_flag)
3982 && CopSTASH_ne(PL_curcop, GvSTASH(dsv))) {
3983 GvFLAGS(dsv) |= import_flag;
3986 if (stype == SVt_PVHV) {
3987 const char * const name = GvNAME((GV*)dsv);
3988 const STRLEN len = GvNAMELEN(dsv);
3991 (len > 1 && name[len-2] == ':' && name[len-1] == ':')
3992 || (len == 1 && name[0] == ':')
3994 && (!dref || HvHasENAME(dref))
3997 (HV *)sref, (HV *)dref,
4003 stype == SVt_PVAV && sref != dref
4004 && memEQs(GvNAME((GV*)dsv), GvNAMELEN((GV*)dsv), "ISA")
4005 /* The stash may have been detached from the symbol table, so
4006 check its name before doing anything. */
4007 && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
4010 MAGIC * const omg = dref && SvSMAGICAL(dref)
4011 ? mg_find(dref, PERL_MAGIC_isa)
4013 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
4014 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
4015 AV * const ary = newAV_alloc_xz(4);
4016 av_push_simple(ary, mg->mg_obj); /* takes the refcount */
4017 mg->mg_obj = (SV *)ary;
4020 if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
4021 SV **svp = AvARRAY((AV *)omg->mg_obj);
4022 I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
4026 SvREFCNT_inc_simple_NN(*svp++)
4032 SvREFCNT_inc_simple_NN(omg->mg_obj)
4036 av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dsv));
4042 sref, omg ? omg->mg_obj : dsv, PERL_MAGIC_isa, NULL, 0
4044 for (i = 0; i <= AvFILL(sref); ++i) {
4045 SV **elem = av_fetch ((AV*)sref, i, 0);
4048 *elem, sref, PERL_MAGIC_isaelem, NULL, i
4052 mg = mg_find(sref, PERL_MAGIC_isa);
4054 /* Since the *ISA assignment could have affected more than
4055 one stash, don't call mro_isa_changed_in directly, but let
4056 magic_clearisa do it for us, as it already has the logic for
4057 dealing with globs vs arrays of globs. */
4059 Perl_magic_clearisa(aTHX_ NULL, mg);
4061 else if (stype == SVt_PVIO) {
4062 DEBUG_o(Perl_deb(aTHX_ "gv_setref clearing PL_stashcache\n"));
4063 /* It's a cache. It will rebuild itself quite happily.
4064 It's a lot of effort to work out exactly which key (or keys)
4065 might be invalidated by the creation of the this file handle.
4067 hv_clear(PL_stashcache);
4071 if (!intro) SvREFCNT_dec(dref);
4080 #ifdef PERL_DEBUG_READONLY_COW
4081 # include <sys/mman.h>
4083 # ifndef PERL_MEMORY_DEBUG_HEADER_SIZE
4084 # define PERL_MEMORY_DEBUG_HEADER_SIZE 0
4088 Perl_sv_buf_to_ro(pTHX_ SV *sv)
4090 struct perl_memory_debug_header * const header =
4091 (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4092 const MEM_SIZE len = header->size;
4093 PERL_ARGS_ASSERT_SV_BUF_TO_RO;
4094 # ifdef PERL_TRACK_MEMPOOL
4095 if (!header->readonly) header->readonly = 1;
4097 if (mprotect(header, len, PROT_READ))
4098 Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
4099 header, len, errno);
4103 S_sv_buf_to_rw(pTHX_ SV *sv)
4105 struct perl_memory_debug_header * const header =
4106 (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4107 const MEM_SIZE len = header->size;
4108 PERL_ARGS_ASSERT_SV_BUF_TO_RW;
4109 if (mprotect(header, len, PROT_READ|PROT_WRITE))
4110 Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
4111 header, len, errno);
4112 # ifdef PERL_TRACK_MEMPOOL
4113 header->readonly = 0;
4118 # define sv_buf_to_ro(sv) NOOP
4119 # define sv_buf_to_rw(sv) NOOP
4123 Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags)
4128 unsigned int both_type;
4130 PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
4132 if (UNLIKELY( ssv == dsv ))
4135 if (UNLIKELY( !ssv ))
4138 stype = SvTYPE(ssv);
4139 dtype = SvTYPE(dsv);
4140 both_type = (stype | dtype);
4142 /* with these values, we can check that both SVs are NULL/IV (and not
4143 * freed) just by testing the or'ed types */
4144 STATIC_ASSERT_STMT(SVt_NULL == 0);
4145 STATIC_ASSERT_STMT(SVt_IV == 1);
4146 STATIC_ASSERT_STMT(SVt_NV == 2);
4147 #if NVSIZE <= IVSIZE
4148 if (both_type <= 2) {
4150 if (both_type <= 1) {
4152 /* both src and dst are UNDEF/IV/RV - maybe NV depending on config,
4153 * so we can do a lot of special-casing */
4158 /* minimal subset of SV_CHECK_THINKFIRST_COW_DROP(dsv) */
4159 if (SvREADONLY(dsv))
4160 Perl_croak_no_modify();
4163 sv_unref_flags(dsv, 0);
4169 assert(!SvGMAGICAL(ssv));
4170 assert(!SvGMAGICAL(dsv));
4172 sflags = SvFLAGS(ssv);
4173 if (sflags & (SVf_IOK|SVf_ROK)) {
4174 SET_SVANY_FOR_BODYLESS_IV(dsv);
4175 new_dflags = SVt_IV;
4177 if (sflags & SVf_ROK) {
4178 dsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(ssv));
4179 new_dflags |= SVf_ROK;
4182 /* both src and dst are <= SVt_IV, so sv_any points to the
4183 * head; so access the head directly
4185 assert( &(ssv->sv_u.svu_iv)
4186 == &(((XPVIV*) SvANY(ssv))->xiv_iv));
4187 assert( &(dsv->sv_u.svu_iv)
4188 == &(((XPVIV*) SvANY(dsv))->xiv_iv));
4189 dsv->sv_u.svu_iv = ssv->sv_u.svu_iv;
4190 new_dflags |= (SVf_IOK|SVp_IOK|(sflags & SVf_IVisUV));
4193 #if NVSIZE <= IVSIZE
4194 else if (sflags & SVf_NOK) {
4195 SET_SVANY_FOR_BODYLESS_NV(dsv);
4196 new_dflags = (SVt_NV|SVf_NOK|SVp_NOK);
4198 /* both src and dst are <= SVt_MV, so sv_any points to the
4199 * head; so access the head directly
4201 assert( &(ssv->sv_u.svu_nv)
4202 == &(((XPVNV*) SvANY(ssv))->xnv_u.xnv_nv));
4203 assert( &(dsv->sv_u.svu_nv)
4204 == &(((XPVNV*) SvANY(dsv))->xnv_u.xnv_nv));
4205 dsv->sv_u.svu_nv = ssv->sv_u.svu_nv;
4209 new_dflags = dtype; /* turn off everything except the type */
4211 /* Should preserve some dsv flags - at least SVs_TEMP, */
4212 /* so cannot just set SvFLAGS(dsv) = new_dflags */
4213 /* First clear the flags that we do want to clobber */
4214 (void)SvOK_off(dsv);
4215 SvFLAGS(dsv) &= ~SVTYPEMASK;
4216 /* Now set the new flags */
4217 SvFLAGS(dsv) |= new_dflags;
4219 SvREFCNT_dec(old_rv);
4223 if (UNLIKELY(both_type == SVTYPEMASK)) {
4224 if (SvIS_FREED(dsv)) {
4225 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
4226 " to a freed scalar %p", SVfARG(ssv), (void *)dsv);
4228 if (SvIS_FREED(ssv)) {
4229 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
4230 (void*)ssv, (void*)dsv);
4236 SV_CHECK_THINKFIRST_COW_DROP(dsv);
4237 dtype = SvTYPE(dsv); /* THINKFIRST may have changed type */
4239 /* There's a lot of redundancy below but we're going for speed here
4240 * Note: some of the cases below do return; rather than break; so the
4241 * if-elseif-else logic below this switch does not see all cases. */
4246 if (LIKELY( dtype != SVt_PVGV && dtype != SVt_PVLV )) {
4247 (void)SvOK_off(dsv);
4255 /* For performance, we inline promoting to type SVt_IV. */
4256 /* We're starting from SVt_NULL, so provided that define is
4257 * actual 0, we don't have to unset any SV type flags
4258 * to promote to SVt_IV. */
4259 STATIC_ASSERT_STMT(SVt_NULL == 0);
4260 SET_SVANY_FOR_BODYLESS_IV(dsv);
4261 SvFLAGS(dsv) |= SVt_IV;
4265 sv_upgrade(dsv, SVt_PVIV);
4269 goto end_of_first_switch;
4271 (void)SvIOK_only(dsv);
4272 SvIV_set(dsv, SvIVX(ssv));
4275 /* SvTAINTED can only be true if the SV has taint magic, which in
4276 turn means that the SV type is PVMG (or greater). This is the
4277 case statement for SVt_IV, so this cannot be true (whatever gcov
4279 assert(!SvTAINTED(ssv));
4284 if (dtype < SVt_PV && dtype != SVt_IV)
4285 sv_upgrade(dsv, SVt_IV);
4289 if (LIKELY( SvNOK(ssv) )) {
4293 sv_upgrade(dsv, SVt_NV);
4297 sv_upgrade(dsv, SVt_PVNV);
4301 goto end_of_first_switch;
4303 SvNV_set(dsv, SvNVX(ssv));
4304 (void)SvNOK_only(dsv);
4305 /* SvTAINTED can only be true if the SV has taint magic, which in
4306 turn means that the SV type is PVMG (or greater). This is the
4307 case statement for SVt_NV, so this cannot be true (whatever gcov
4309 assert(!SvTAINTED(ssv));
4316 sv_upgrade(dsv, SVt_PV);
4319 if (dtype < SVt_PVIV)
4320 sv_upgrade(dsv, SVt_PVIV);
4323 if (dtype < SVt_PVNV)
4324 sv_upgrade(dsv, SVt_PVNV);
4328 invlist_clone(ssv, dsv);
4332 const char * const type = sv_reftype(ssv,0);
4334 /* diag_listed_as: Bizarre copy of %s */
4335 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4337 Perl_croak(aTHX_ "Bizarre copy of %s", type);
4339 NOT_REACHED; /* NOTREACHED */
4343 if (dtype < SVt_REGEXP)
4344 sv_upgrade(dsv, SVt_REGEXP);
4350 if (SvGMAGICAL(ssv) && (flags & SV_GMAGIC)) {
4352 if (SvTYPE(ssv) != stype)
4353 stype = SvTYPE(ssv);
4355 if (isGV_with_GP(ssv) && dtype <= SVt_PVLV) {
4356 glob_assign_glob(dsv, ssv, dtype);
4359 if (stype == SVt_PVLV)
4361 if (isREGEXP(ssv)) goto upgregexp;
4362 SvUPGRADE(dsv, SVt_PVNV);
4365 SvUPGRADE(dsv, (svtype)stype);
4367 end_of_first_switch:
4369 /* dsv may have been upgraded. */
4370 dtype = SvTYPE(dsv);
4371 sflags = SvFLAGS(ssv);
4373 if (UNLIKELY( dtype == SVt_PVCV )) {
4374 /* Assigning to a subroutine sets the prototype. */
4377 const char *const ptr = SvPV_const(ssv, len);
4379 SvGROW(dsv, len + 1);
4380 Copy(ptr, SvPVX(dsv), len + 1, char);
4381 SvCUR_set(dsv, len);
4383 SvFLAGS(dsv) |= sflags & SVf_UTF8;
4384 CvAUTOLOAD_off(dsv);
4389 else if (UNLIKELY(dtype == SVt_PVAV || dtype == SVt_PVHV
4390 || dtype == SVt_PVFM))
4392 const char * const type = sv_reftype(dsv,0);
4394 /* diag_listed_as: Cannot copy to %s */
4395 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4397 Perl_croak(aTHX_ "Cannot copy to %s", type);
4398 } else if (sflags & SVf_ROK) {
4399 if (isGV_with_GP(dsv)
4400 && SvTYPE(SvRV(ssv)) == SVt_PVGV && isGV_with_GP(SvRV(ssv))) {
4403 if (GvIMPORTED(dsv) != GVf_IMPORTED
4404 && CopSTASH_ne(PL_curcop, GvSTASH(dsv)))
4411 glob_assign_glob(dsv, ssv, dtype);
4415 if (dtype >= SVt_PV) {
4416 if (isGV_with_GP(dsv)) {
4417 gv_setref(dsv, ssv);
4420 if (SvPVX_const(dsv)) {
4426 (void)SvOK_off(dsv);
4427 SvRV_set(dsv, SvREFCNT_inc(SvRV(ssv)));
4428 SvFLAGS(dsv) |= sflags & SVf_ROK;
4429 assert(!(sflags & SVp_NOK));
4430 assert(!(sflags & SVp_IOK));
4431 assert(!(sflags & SVf_NOK));
4432 assert(!(sflags & SVf_IOK));
4434 else if (isGV_with_GP(dsv)) {
4435 if (!(sflags & SVf_OK)) {
4436 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4437 "Undefined value assigned to typeglob");
4440 GV *gv = gv_fetchsv_nomg(ssv, GV_ADD, SVt_PVGV);
4441 if (dsv != (const SV *)gv) {
4442 const char * const name = GvNAME((const GV *)dsv);
4443 const STRLEN len = GvNAMELEN(dsv);
4444 HV *old_stash = NULL;
4445 bool reset_isa = FALSE;
4446 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4447 || (len == 1 && name[0] == ':')) {
4448 /* Set aside the old stash, so we can reset isa caches
4449 on its subclasses. */
4450 if((old_stash = GvHV(dsv))) {
4451 /* Make sure we do not lose it early. */
4452 SvREFCNT_inc_simple_void_NN(
4453 sv_2mortal((SV *)old_stash)
4460 SvREFCNT_inc_simple_void_NN(sv_2mortal(dsv));
4461 gp_free(MUTABLE_GV(dsv));
4463 GvGP_set(dsv, gp_ref(GvGP(gv)));
4466 HV * const stash = GvHV(dsv);
4468 old_stash ? HvHasENAME(old_stash) : cBOOL(stash)
4478 else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4479 && (stype == SVt_REGEXP || isREGEXP(ssv))) {
4480 reg_temp_copy((REGEXP*)dsv, (REGEXP*)ssv);
4482 else if (sflags & SVp_POK) {
4483 const STRLEN cur = SvCUR(ssv);
4484 const STRLEN len = SvLEN(ssv);
4487 * We have three basic ways to copy the string:
4493 * Which we choose is based on various factors. The following
4494 * things are listed in order of speed, fastest to slowest:
4496 * - Copying a short string
4497 * - Copy-on-write bookkeeping
4499 * - Copying a long string
4501 * We swipe the string (steal the string buffer) if the SV on the
4502 * rhs is about to be freed anyway (TEMP and refcnt==1). This is a
4503 * big win on long strings. It should be a win on short strings if
4504 * SvPVX_const(dsv) has to be allocated. If not, it should not
4505 * slow things down, as SvPVX_const(ssv) would have been freed
4508 * We also steal the buffer from a PADTMP (operator target) if it
4509 * is ‘long enough’. For short strings, a swipe does not help
4510 * here, as it causes more malloc calls the next time the target
4511 * is used. Benchmarks show that even if SvPVX_const(dsv) has to
4512 * be allocated it is still not worth swiping PADTMPs for short
4513 * strings, as the savings here are small.
4515 * If swiping is not an option, then we see whether it is worth using
4516 * copy-on-write. If the lhs already has a buffer big enough and the
4517 * string is short, we skip it and fall back to method 3, since memcpy
4518 * is faster for short strings than the later bookkeeping overhead that
4519 * copy-on-write entails.
4521 * If the rhs is not a copy-on-write string yet, then we also
4522 * consider whether the buffer is too large relative to the string
4523 * it holds. Some operations such as readline allocate a large
4524 * buffer in the expectation of reusing it. But turning such into
4525 * a COW buffer is counter-productive because it increases memory
4526 * usage by making readline allocate a new large buffer the sec-
4527 * ond time round. So, if the buffer is too large, again, we use
4530 * Finally, if there is no buffer on the left, or the buffer is too
4531 * small, then we use copy-on-write and make both SVs share the
4536 /* Whichever path we take through the next code, we want this true,
4537 and doing it now facilitates the COW check. */
4538 (void)SvPOK_only(dsv);
4542 /* slated for free anyway (and not COW)? */
4543 (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
4544 /* or a swipable TARG */
4546 (SVs_PADTMP|SVf_READONLY|SVf_PROTECT|SVf_IsCOW))
4548 /* whose buffer is worth stealing */
4549 && CHECK_COWBUF_THRESHOLD(cur,len)
4552 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4553 (!(flags & SV_NOSTEAL)) &&
4554 /* and we're allowed to steal temps */
4555 SvREFCNT(ssv) == 1 && /* and no other references to it? */
4556 len) /* and really is a string */
4557 { /* Passes the swipe test. */
4558 if (SvPVX_const(dsv)) /* we know that dtype >= SVt_PV */
4560 SvPV_set(dsv, SvPVX_mutable(ssv));
4561 SvLEN_set(dsv, SvLEN(ssv));
4562 SvCUR_set(dsv, SvCUR(ssv));
4565 (void)SvOK_off(ssv); /* NOTE: nukes most SvFLAGS on ssv */
4566 SvPV_set(ssv, NULL);
4571 /* We must check for SvIsCOW_static() even without
4572 * SV_COW_SHARED_HASH_KEYS being set or else we'll break SvIsBOOL()
4574 else if (SvIsCOW_static(ssv)) {
4575 if (SvPVX_const(dsv)) { /* we know that dtype >= SVt_PV */
4578 SvPV_set(dsv, SvPVX(ssv));
4580 SvCUR_set(dsv, cur);
4581 SvFLAGS(dsv) |= (SVf_IsCOW|SVppv_STATIC);
4583 else if (flags & SV_COW_SHARED_HASH_KEYS
4585 #ifdef PERL_COPY_ON_WRITE
4588 ( (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dsv) < cur+1)
4589 /* If this is a regular (non-hek) COW, only so
4590 many COW "copies" are possible. */
4591 && CowREFCNT(ssv) != SV_COW_REFCNT_MAX ))
4592 : ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4593 && !(SvFLAGS(dsv) & SVf_BREAK)
4594 && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len
4595 && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dsv) < cur+1)
4599 && !(SvFLAGS(dsv) & SVf_BREAK)
4602 /* Either it's a shared hash key, or it's suitable for
4606 PerlIO_printf(Perl_debug_log, "Copy on write: ssv --> dsv\n");
4612 if (!(sflags & SVf_IsCOW)) {
4617 if (SvPVX_const(dsv)) { /* we know that dtype >= SVt_PV */
4623 if (sflags & SVf_IsCOW) {
4627 SvPV_set(dsv, SvPVX_mutable(ssv));
4632 /* SvIsCOW_shared_hash */
4633 DEBUG_C(PerlIO_printf(Perl_debug_log,
4634 "Copy on write: Sharing hash\n"));
4636 assert (SvTYPE(dsv) >= SVt_PV);
4638 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv)))));
4640 SvLEN_set(dsv, len);
4641 SvCUR_set(dsv, cur);
4644 /* Failed the swipe test, and we cannot do copy-on-write either.
4645 Have to copy the string. */
4646 SvGROW(dsv, cur + 1); /* inlined from sv_setpvn */
4647 Move(SvPVX_const(ssv),SvPVX(dsv),cur,char);
4648 SvCUR_set(dsv, cur);
4651 if (sflags & SVp_NOK) {
4652 SvNV_set(dsv, SvNVX(ssv));
4653 if ((sflags & SVf_NOK) && !(sflags & SVf_POK)) {
4654 /* Source was SVf_NOK|SVp_NOK|SVp_POK but not SVf_POK, meaning
4655 a value set as floating point and later stringified, where
4656 the value happens to be one of the few that we know aren't
4657 affected by the numeric locale, hence we can cache the
4658 stringification. Currently that's +Inf, -Inf and NaN, but
4659 conceivably we might extend this to -9 .. +9 (excluding -0).
4660 So mark destination the same: */
4661 SvFLAGS(dsv) &= ~SVf_POK;
4664 if (sflags & SVp_IOK) {
4665 SvIV_set(dsv, SvIVX(ssv));
4666 if (sflags & SVf_IVisUV)
4668 if ((sflags & SVf_IOK) && !(sflags & SVf_POK)) {
4669 /* Source was SVf_IOK|SVp_IOK|SVp_POK but not SVf_POK, meaning
4670 a value set as an integer and later stringified. So mark
4671 destination the same: */
4672 SvFLAGS(dsv) &= ~SVf_POK;
4675 SvFLAGS(dsv) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4677 const MAGIC * const smg = SvVSTRING_mg(ssv);
4679 sv_magic(dsv, NULL, PERL_MAGIC_vstring,
4680 smg->mg_ptr, smg->mg_len);
4685 else if (sflags & (SVp_IOK|SVp_NOK)) {
4686 (void)SvOK_off(dsv);
4687 SvFLAGS(dsv) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4688 if (sflags & SVp_IOK) {
4689 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4690 SvIV_set(dsv, SvIVX(ssv));
4692 if (sflags & SVp_NOK) {
4693 SvNV_set(dsv, SvNVX(ssv));
4697 if (isGV_with_GP(ssv)) {
4698 gv_efullname3(dsv, MUTABLE_GV(ssv), "*");
4701 (void)SvOK_off(dsv);
4709 =for apidoc sv_set_undef
4711 Equivalent to C<sv_setsv(sv, &PL_sv_undef)>, but more efficient.
4712 Doesn't handle set magic.
4714 The perl equivalent is C<$sv = undef;>. Note that it doesn't free any string
4715 buffer, unlike C<undef $sv>.
4717 Introduced in perl 5.25.12.
4723 Perl_sv_set_undef(pTHX_ SV *sv)
4725 U32 type = SvTYPE(sv);
4727 PERL_ARGS_ASSERT_SV_SET_UNDEF;
4729 /* shortcut, NULL, IV, RV */
4731 if (type <= SVt_IV) {
4732 assert(!SvGMAGICAL(sv));
4733 if (SvREADONLY(sv)) {
4734 /* does undeffing PL_sv_undef count as modifying a read-only
4735 * variable? Some XS code does this */
4736 if (sv == &PL_sv_undef)
4738 Perl_croak_no_modify();
4743 sv_unref_flags(sv, 0);
4746 SvFLAGS(sv) = type; /* quickly turn off all flags */
4747 SvREFCNT_dec_NN(rv);
4751 SvFLAGS(sv) = type; /* quickly turn off all flags */
4756 Perl_croak(aTHX_ "panic: attempt to undefine a freed scalar %p",
4759 SV_CHECK_THINKFIRST_COW_DROP(sv);
4761 if (isGV_with_GP(sv))
4762 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4763 "Undefined value assigned to typeglob");
4769 =for apidoc sv_set_true
4771 Equivalent to C<sv_setsv(sv, &PL_sv_yes)>, but may be made more
4772 efficient in the future. Doesn't handle set magic.
4774 The perl equivalent is C<$sv = !0;>.
4776 Introduced in perl 5.35.11.
4782 Perl_sv_set_true(pTHX_ SV *sv)
4784 PERL_ARGS_ASSERT_SV_SET_TRUE;
4785 sv_setsv(sv, &PL_sv_yes);
4789 =for apidoc sv_set_false
4791 Equivalent to C<sv_setsv(sv, &PL_sv_no)>, but may be made more
4792 efficient in the future. Doesn't handle set magic.
4794 The perl equivalent is C<$sv = !1;>.
4796 Introduced in perl 5.35.11.
4802 Perl_sv_set_false(pTHX_ SV *sv)
4804 PERL_ARGS_ASSERT_SV_SET_FALSE;
4805 sv_setsv(sv, &PL_sv_no);
4809 =for apidoc sv_set_bool
4811 Equivalent to C<sv_setsv(sv, bool_val ? &Pl_sv_yes : &PL_sv_no)>, but
4812 may be made more efficient in the future. Doesn't handle set magic.
4814 The perl equivalent is C<$sv = !!$expr;>.
4816 Introduced in perl 5.35.11.
4822 Perl_sv_set_bool(pTHX_ SV *sv, const bool bool_val)
4824 PERL_ARGS_ASSERT_SV_SET_BOOL;
4825 sv_setsv(sv, bool_val ? &PL_sv_yes : &PL_sv_no);
4830 Perl_sv_setsv_mg(pTHX_ SV *const dsv, SV *const ssv)
4832 PERL_ARGS_ASSERT_SV_SETSV_MG;
4839 # define SVt_COW SVt_PV
4841 Perl_sv_setsv_cow(pTHX_ SV *dsv, SV *ssv)
4843 STRLEN cur = SvCUR(ssv);
4844 STRLEN len = SvLEN(ssv);
4846 U32 new_flags = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
4847 #if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_COPY_ON_WRITE)
4848 const bool already = cBOOL(SvIsCOW(ssv));
4851 PERL_ARGS_ASSERT_SV_SETSV_COW;
4854 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4855 (void*)ssv, (void*)dsv);
4862 if (SvTHINKFIRST(dsv))
4863 sv_force_normal_flags(dsv, SV_COW_DROP_PV);
4864 else if (SvPVX_const(dsv))
4865 Safefree(SvPVX_mutable(dsv));
4866 SvUPGRADE(dsv, SVt_COW);
4869 dsv = newSV_type(SVt_COW);
4871 assert (SvPOK(ssv));
4872 assert (SvPOKp(ssv));
4875 if (SvIsCOW_shared_hash(ssv)) {
4876 /* source is a COW shared hash key. */
4877 DEBUG_C(PerlIO_printf(Perl_debug_log,
4878 "Fast copy on write: Sharing hash\n"));
4879 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv))));
4882 else if (SvIsCOW_static(ssv)) {
4883 /* source is static constant; preserve this */
4884 new_pv = SvPVX(ssv);
4885 new_flags |= SVppv_STATIC;
4888 assert(SvCUR(ssv)+1 < SvLEN(ssv));
4889 assert(CowREFCNT(ssv) < SV_COW_REFCNT_MAX);
4891 assert ((SvFLAGS(ssv) & CAN_COW_MASK) == CAN_COW_FLAGS);
4892 SvUPGRADE(ssv, SVt_COW);
4894 DEBUG_C(PerlIO_printf(Perl_debug_log,
4895 "Fast copy on write: Converting ssv to COW\n"));
4898 # ifdef PERL_DEBUG_READONLY_COW
4899 if (already) sv_buf_to_rw(ssv);
4902 new_pv = SvPVX_mutable(ssv);
4906 SvPV_set(dsv, new_pv);
4907 SvFLAGS(dsv) = new_flags;
4910 SvLEN_set(dsv, len);
4911 SvCUR_set(dsv, cur);
4921 =for apidoc sv_setpv_bufsize
4923 Sets the SV to be a string of cur bytes length, with at least
4924 len bytes available. Ensures that there is a null byte at SvEND.
4925 Returns a char * pointer to the SvPV buffer.
4931 Perl_sv_setpv_bufsize(pTHX_ SV *const sv, const STRLEN cur, const STRLEN len)
4935 PERL_ARGS_ASSERT_SV_SETPV_BUFSIZE;
4937 SV_CHECK_THINKFIRST_COW_DROP(sv);
4938 SvUPGRADE(sv, SVt_PV);
4939 pv = SvGROW(sv, len + 1);
4942 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4945 if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4950 =for apidoc sv_setpv
4951 =for apidoc_item sv_setpv_mg
4952 =for apidoc_item sv_setpvn
4953 =for apidoc_item sv_setpvn_fresh
4954 =for apidoc_item sv_setpvn_mg
4955 =for apidoc_item |void|sv_setpvs|SV* sv|"literal string"
4956 =for apidoc_item |void|sv_setpvs_mg|SV* sv|"literal string"
4958 These copy a string into the SV C<sv>, making sure it is C<L</SvPOK_only>>.
4960 In the C<pvs> forms, the string must be a C literal string, enclosed in double
4963 In the C<pvn> forms, the first byte of the string is pointed to by C<ptr>, and
4964 C<len> indicates the number of bytes to be copied, potentially including
4965 embedded C<NUL> characters.
4967 In the plain C<pv> forms, C<ptr> points to a NUL-terminated C string. That is,
4968 it points to the first byte of the string, and the copy proceeds up through the
4969 first encountered C<NUL> byte.
4971 In the forms that take a C<ptr> argument, if it is NULL, the SV will become
4974 The UTF-8 flag is not changed by these functions. A terminating NUL byte is
4975 guaranteed in the result.
4977 The C<_mg> forms handle 'set' magic; the other forms skip all magic.
4979 C<sv_setpvn_fresh> is a cut-down alternative to C<sv_setpvn>, intended ONLY
4980 to be used with a fresh sv that has been upgraded to a SVt_PV, SVt_PVIV,
4981 SVt_PVNV, or SVt_PVMG.
4987 Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4991 PERL_ARGS_ASSERT_SV_SETPVN;
4993 SV_CHECK_THINKFIRST_COW_DROP(sv);
4994 if (isGV_with_GP(sv))
4995 Perl_croak_no_modify();
5001 /* len is STRLEN which is unsigned, need to copy to signed */
5004 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
5007 SvUPGRADE(sv, SVt_PV);
5009 dptr = SvGROW(sv, len + 1);
5010 Move(ptr,dptr,len,char);
5013 (void)SvPOK_only_UTF8(sv); /* validate pointer */
5015 if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
5019 Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
5021 PERL_ARGS_ASSERT_SV_SETPVN_MG;
5023 sv_setpvn(sv,ptr,len);
5028 Perl_sv_setpvn_fresh(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
5032 PERL_ARGS_ASSERT_SV_SETPVN_FRESH;
5033 assert(SvTYPE(sv) >= SVt_PV && SvTYPE(sv) <= SVt_PVMG);
5034 assert(!SvTHINKFIRST(sv));
5035 assert(!isGV_with_GP(sv));
5039 /* len is STRLEN which is unsigned, need to copy to signed */
5041 Perl_croak(aTHX_ "panic: sv_setpvn_fresh called with negative strlen %"
5044 dptr = sv_grow_fresh(sv, len + 1);
5045 Move(ptr,dptr,len,char);
5054 Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
5058 PERL_ARGS_ASSERT_SV_SETPV;
5060 SV_CHECK_THINKFIRST_COW_DROP(sv);
5066 SvUPGRADE(sv, SVt_PV);
5068 SvGROW(sv, len + 1);
5069 Move(ptr,SvPVX(sv),len+1,char);
5071 (void)SvPOK_only_UTF8(sv); /* validate pointer */
5073 if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
5077 Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
5079 PERL_ARGS_ASSERT_SV_SETPV_MG;
5086 Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
5088 PERL_ARGS_ASSERT_SV_SETHEK;
5094 if (HEK_LEN(hek) == HEf_SVKEY) {
5095 sv_setsv(sv, *(SV**)HEK_KEY(hek));
5098 const int flags = HEK_FLAGS(hek);
5099 if (flags & HVhek_WASUTF8) {
5100 STRLEN utf8_len = HEK_LEN(hek);
5101 char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
5102 sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
5105 } else if (flags & HVhek_NOTSHARED) {
5106 sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
5109 else SvUTF8_off(sv);
5113 SV_CHECK_THINKFIRST_COW_DROP(sv);
5114 SvUPGRADE(sv, SVt_PV);
5116 SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
5117 SvCUR_set(sv, HEK_LEN(hek));
5123 else SvUTF8_off(sv);
5131 =for apidoc sv_usepvn
5132 =for apidoc_item sv_usepvn_flags
5133 =for apidoc_item sv_usepvn_mg
5135 These tell an SV to use C<ptr> for its string value. Normally SVs have
5136 their string stored inside the SV, but these tell the SV to use an
5137 external string instead.
5139 C<ptr> should point to memory that was allocated
5140 by L</C<Newx>>. It must be
5141 the start of a C<Newx>-ed block of memory, and not a pointer to the
5142 middle of it (beware of L<C<OOK>|perlguts/Offsets> and copy-on-write),
5143 and not be from a non-C<Newx> memory allocator like C<malloc>. The
5144 string length, C<len>, must be supplied. By default this function
5145 will L</C<Renew>> (i.e. realloc, move) the memory pointed to by C<ptr>,
5146 so that the pointer should not be freed or used by the programmer after giving
5147 it to C<sv_usepvn>, and neither should any pointers from "behind" that pointer
5148 (I<e.g.>, S<C<ptr> + 1>) be used.
5150 In the C<sv_usepvn_flags> form, if S<C<flags & SV_SMAGIC>> is true,
5151 C<SvSETMAGIC> is called before returning.
5152 And if S<C<flags & SV_HAS_TRAILING_NUL>> is true, then C<ptr[len]> must be
5153 C<NUL>, and the realloc will be skipped (I<i.e.>, the buffer is actually at
5154 least 1 byte longer than C<len>, and already meets the requirements for storing
5157 C<sv_usepvn> is merely C<sv_usepvn_flags> with C<flags> set to 0, so 'set'
5160 C<sv_usepvn_mg> is merely C<sv_usepvn_flags> with C<flags> set to C<SV_SMAGIC>,
5161 so 'set' magic is performed.
5163 =for apidoc Amnh||SV_SMAGIC
5164 =for apidoc Amnh||SV_HAS_TRAILING_NUL
5170 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
5174 PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
5176 SV_CHECK_THINKFIRST_COW_DROP(sv);
5177 SvUPGRADE(sv, SVt_PV);
5180 if (flags & SV_SMAGIC)
5184 if (SvPVX_const(sv))
5188 if (flags & SV_HAS_TRAILING_NUL)
5189 assert(ptr[len] == '\0');
5192 allocate = (flags & SV_HAS_TRAILING_NUL)
5194 #ifdef Perl_safesysmalloc_size
5197 PERL_STRLEN_ROUNDUP(len + 1);
5199 if (flags & SV_HAS_TRAILING_NUL) {
5200 /* It's long enough - do nothing.
5201 Specifically Perl_newCONSTSUB is relying on this. */
5204 /* Force a move to shake out bugs in callers. */
5205 char *new_ptr = (char*)safemalloc(allocate);
5206 Copy(ptr, new_ptr, len, char);
5207 PoisonFree(ptr,len,char);
5211 ptr = (char*) saferealloc (ptr, allocate);
5214 #ifdef Perl_safesysmalloc_size
5215 SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
5217 SvLEN_set(sv, allocate);
5221 if (!(flags & SV_HAS_TRAILING_NUL)) {
5224 (void)SvPOK_only_UTF8(sv); /* validate pointer */
5226 if (flags & SV_SMAGIC)
5232 S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
5234 assert(SvIsCOW(sv));
5237 const char * const pvx = SvPVX_const(sv);
5238 const STRLEN len = SvLEN(sv);
5239 const STRLEN cur = SvCUR(sv);
5240 const bool was_shared_hek = SvIsCOW_shared_hash(sv);
5244 PerlIO_printf(Perl_debug_log,
5245 "Copy on write: Force normal %ld\n",
5251 # ifdef PERL_COPY_ON_WRITE
5253 /* Must do this first, since the CowREFCNT uses SvPVX and
5254 we need to write to CowREFCNT, or de-RO the whole buffer if we are
5255 the only owner left of the buffer. */
5256 sv_buf_to_rw(sv); /* NOOP if RO-ing not supported */
5258 U8 cowrefcnt = CowREFCNT(sv);
5259 if(cowrefcnt != 0) {
5261 CowREFCNT(sv) = cowrefcnt;
5266 /* Else we are the only owner of the buffer. */
5271 /* This SV doesn't own the buffer, so need to Newx() a new one: */
5276 if (flags & SV_COW_DROP_PV) {
5277 /* OK, so we don't need to copy our buffer. */
5280 SvGROW(sv, cur + 1);
5281 Move(pvx,SvPVX(sv),cur,char);
5285 if (was_shared_hek) {
5286 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5294 const char * const pvx = SvPVX_const(sv);
5295 const STRLEN len = SvCUR(sv);
5299 if (flags & SV_COW_DROP_PV) {
5300 /* OK, so we don't need to copy our buffer. */
5303 SvGROW(sv, len + 1);
5304 Move(pvx,SvPVX(sv),len,char);
5307 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5314 =for apidoc sv_force_normal_flags
5316 Undo various types of fakery on an SV, where fakery means
5317 "more than" a string: if the PV is a shared string, make
5318 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5319 an C<xpvmg>; if we're a copy-on-write scalar, this is the on-write time when
5320 we do the copy, and is also used locally; if this is a
5321 vstring, drop the vstring magic. If C<SV_COW_DROP_PV> is set
5322 then a copy-on-write scalar drops its PV buffer (if any) and becomes
5323 C<SvPOK_off> rather than making a copy. (Used where this
5324 scalar is about to be set to some other value.) In addition,
5325 the C<flags> parameter gets passed to C<sv_unref_flags()>
5326 when unreffing. C<sv_force_normal> calls this function
5327 with flags set to 0.
5329 This function is expected to be used to signal to perl that this SV is
5330 about to be written to, and any extra book-keeping needs to be taken care
5331 of. Hence, it croaks on read-only values.
5333 =for apidoc Amnh||SV_COW_DROP_PV
5339 Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
5341 PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
5344 Perl_croak_no_modify();
5345 else if (SvIsCOW(sv) && LIKELY(SvTYPE(sv) != SVt_PVHV))
5346 S_sv_uncow(aTHX_ sv, flags);
5348 sv_unref_flags(sv, flags);
5349 else if (SvFAKE(sv) && isGV_with_GP(sv))
5350 sv_unglob(sv, flags);
5351 else if (SvFAKE(sv) && isREGEXP(sv)) {
5352 /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
5353 to sv_unglob. We only need it here, so inline it. */
5354 const bool islv = SvTYPE(sv) == SVt_PVLV;
5355 const svtype new_type =
5356 islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
5357 SV *const temp = newSV_type(new_type);
5358 regexp *old_rx_body;
5360 if (new_type == SVt_PVMG) {
5361 SvMAGIC_set(temp, SvMAGIC(sv));
5362 SvMAGIC_set(sv, NULL);
5363 SvSTASH_set(temp, SvSTASH(sv));
5364 SvSTASH_set(sv, NULL);
5367 SvCUR_set(temp, SvCUR(sv));
5368 /* Remember that SvPVX is in the head, not the body. */
5369 assert(ReANY((REGEXP *)sv)->mother_re);
5372 /* LV-as-regex has sv->sv_any pointing to an XPVLV body,
5373 * whose xpvlenu_rx field points to the regex body */
5374 XPV *xpv = (XPV*)(SvANY(sv));
5375 old_rx_body = xpv->xpv_len_u.xpvlenu_rx;
5376 xpv->xpv_len_u.xpvlenu_rx = NULL;
5379 old_rx_body = ReANY((REGEXP *)sv);
5381 /* Their buffer is already owned by someone else. */
5382 if (flags & SV_COW_DROP_PV) {
5383 /* SvLEN is already 0. For SVt_REGEXP, we have a brand new
5384 zeroed body. For SVt_PVLV, we zeroed it above (len field
5385 a union with xpvlenu_rx) */
5386 assert(!SvLEN(islv ? sv : temp));
5387 sv->sv_u.svu_pv = 0;
5390 sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
5391 SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
5395 /* Now swap the rest of the bodies. */
5399 SvFLAGS(sv) &= ~SVTYPEMASK;
5400 SvFLAGS(sv) |= new_type;
5401 SvANY(sv) = SvANY(temp);
5404 SvFLAGS(temp) &= ~(SVTYPEMASK);
5405 SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
5406 SvANY(temp) = old_rx_body;
5408 /* temp is now rebuilt as a correctly structured SVt_REGEXP, so this
5409 * will trigger a call to sv_clear() which will correctly free the
5411 SvREFCNT_dec_NN(temp);
5413 else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
5419 Efficient removal of characters from the beginning of the string buffer.
5420 C<SvPOK(sv)>, or at least C<SvPOKp(sv)>, must be true and C<ptr> must be a
5421 pointer to somewhere inside the string buffer. C<ptr> becomes the first
5422 character of the adjusted string. Uses the C<OOK> hack. On return, only
5423 C<SvPOK(sv)> and C<SvPOKp(sv)> among the C<OK> flags will be true.
5425 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
5426 refer to the same chunk of data.
5428 The unfortunate similarity of this function's name to that of Perl's C<chop>
5429 operator is strictly coincidental. This function works from the left;
5430 C<chop> works from the right.
5436 Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
5447 PERL_ARGS_ASSERT_SV_CHOP;
5449 if (!ptr || !SvPOKp(sv))
5451 delta = ptr - SvPVX_const(sv);
5453 /* Nothing to do. */
5456 max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
5457 if (delta > max_delta)
5458 Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
5459 ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
5460 /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
5461 SV_CHECK_THINKFIRST(sv);
5462 SvPOK_only_UTF8(sv);
5465 if (!SvLEN(sv)) { /* make copy of shared string */
5466 const char *pvx = SvPVX_const(sv);
5467 const STRLEN len = SvCUR(sv);
5468 SvGROW(sv, len + 1);
5469 Move(pvx,SvPVX(sv),len,char);
5475 SvOOK_offset(sv, old_delta);
5477 SvLEN_set(sv, SvLEN(sv) - delta);
5478 SvCUR_set(sv, SvCUR(sv) - delta);
5479 SvPV_set(sv, SvPVX(sv) + delta);
5481 p = (U8 *)SvPVX_const(sv);
5484 /* how many bytes were evacuated? we will fill them with sentinel
5485 bytes, except for the part holding the new offset of course. */
5488 evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
5490 assert(evacn <= delta + old_delta);
5494 /* This sets 'delta' to the accumulated value of all deltas so far */
5498 /* If 'delta' fits in a byte, store it just prior to the new beginning of
5499 * the string; otherwise store a 0 byte there and store 'delta' just prior
5500 * to that, using as many bytes as a STRLEN occupies. Thus it overwrites a
5501 * portion of the chopped part of the string */
5502 if (delta < 0x100) {
5506 p -= sizeof(STRLEN);
5507 Copy((U8*)&delta, p, sizeof(STRLEN), U8);
5511 /* Fill the preceding buffer with sentinals to verify that no-one is
5521 =for apidoc sv_catpvn
5522 =for apidoc_item sv_catpvn_flags
5523 =for apidoc_item sv_catpvn_mg
5524 =for apidoc_item sv_catpvn_nomg
5526 These concatenate the C<len> bytes of the string beginning at C<ptr> onto the
5527 end of the string which is in C<dsv>. The caller must make sure C<ptr>
5528 contains at least C<len> bytes.
5530 For all but C<sv_catpvn_flags>, the string appended is assumed to be valid
5531 UTF-8 if the SV has the UTF-8 status set, and a string of bytes otherwise.
5533 They differ in that:
5535 C<sv_catpvn_mg> performs both 'get' and 'set' magic on C<dsv>.
5537 C<sv_catpvn> performs only 'get' magic.
5539 C<sv_catpvn_nomg> skips all magic.
5541 C<sv_catpvn_flags> has an extra C<flags> parameter which allows you to specify
5542 any combination of magic handling (using C<SV_GMAGIC> and/or C<SV_SMAGIC>) and
5543 to also override the UTF-8 handling. By supplying the C<SV_CATBYTES> flag, the
5544 appended string is interpreted as plain bytes; by supplying instead the
5545 C<SV_CATUTF8> flag, it will be interpreted as UTF-8, and the C<dsv> will be
5546 upgraded to UTF-8 if necessary.
5548 C<sv_catpvn>, C<sv_catpvn_mg>, and C<sv_catpvn_nomg> are implemented
5549 in terms of C<sv_catpvn_flags>.
5551 =for apidoc Amnh||SV_CATUTF8
5552 =for apidoc Amnh||SV_CATBYTES
5558 Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
5561 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5563 PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5564 assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5566 if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
5567 if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
5568 sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5571 else SvGROW(dsv, dlen + slen + 3);
5573 sstr = SvPVX_const(dsv);
5574 Move(sstr, SvPVX(dsv) + dlen, slen, char);
5575 SvCUR_set(dsv, SvCUR(dsv) + slen);
5578 /* We inline bytes_to_utf8, to avoid an extra malloc. */
5579 const char * const send = sstr + slen;
5582 /* Something this code does not account for, which I think is
5583 impossible; it would require the same pv to be treated as
5584 bytes *and* utf8, which would indicate a bug elsewhere. */
5585 assert(sstr != dstr);
5587 SvGROW(dsv, dlen + slen * 2 + 3);
5588 d = (U8 *)SvPVX(dsv) + dlen;
5590 while (sstr < send) {
5591 append_utf8_from_native_byte(*sstr, &d);
5594 SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5597 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
5599 if (flags & SV_SMAGIC)
5604 =for apidoc sv_catsv
5605 =for apidoc_item sv_catsv_flags
5606 =for apidoc_item sv_catsv_mg
5607 =for apidoc_item sv_catsv_nomg
5609 These concatenate the string from SV C<sstr> onto the end of the string in SV
5610 C<dsv>. If C<sstr> is null, these are no-ops; otherwise only C<dsv> is
5613 They differ only in what magic they perform:
5615 C<sv_catsv_mg> performs 'get' magic on both SVs before the copy, and 'set' magic
5616 on C<dsv> afterwards.
5618 C<sv_catsv> performs just 'get' magic, on both SVs.
5620 C<sv_catsv_nomg> skips all magic.
5622 C<sv_catsv_flags> has an extra C<flags> parameter which allows you to use
5623 C<SV_GMAGIC> and/or C<SV_SMAGIC> to specify any combination of magic handling
5624 (although either both or neither SV will have 'get' magic applied to it.)
5626 C<sv_catsv>, C<sv_catsv_mg>, and C<sv_catsv_nomg> are implemented
5627 in terms of C<sv_catsv_flags>.
5632 Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const sstr, const I32 flags)
5634 PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5638 const char *spv = SvPV_flags_const(sstr, slen, flags);
5639 if (flags & SV_GMAGIC)
5641 sv_catpvn_flags(dsv, spv, slen,
5642 DO_UTF8(sstr) ? SV_CATUTF8 : SV_CATBYTES);