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) PerlMemShared_free((sv)->sv_debug_file); \
236 # define DEBUG_SV_SERIAL(sv) \
237 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) del_SV\n", \
238 PTR2UV(sv), (long)(sv)->sv_debug_serial))
240 # define FREE_SV_DEBUG_FILE(sv)
241 # define DEBUG_SV_SERIAL(sv) NOOP
244 /* Mark an SV head as unused, and add to free list.
246 * If SVf_BREAK is set, skip adding it to the free list, as this SV had
247 * its refcount artificially decremented during global destruction, so
248 * there may be dangling pointers to it. The last thing we want in that
249 * case is for it to be reused. */
251 #define plant_SV(p) \
253 const U32 old_flags = SvFLAGS(p); \
254 MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
255 DEBUG_SV_SERIAL(p); \
256 FREE_SV_DEBUG_FILE(p); \
258 SvFLAGS(p) = SVTYPEMASK; \
259 if (!(old_flags & SVf_BREAK)) { \
260 SvARENA_CHAIN_SET(p, PL_sv_root); \
267 /* make some more SVs by adding another arena */
273 char *chunk; /* must use New here to match call to */
274 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
275 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
280 /* del_SV(): return an empty SV head to the free list */
293 S_del_sv(pTHX_ SV *p)
295 PERL_ARGS_ASSERT_DEL_SV;
300 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
301 const SV * const sv = sva + 1;
302 const SV * const svend = &sva[SvREFCNT(sva)];
303 if (p >= sv && p < svend) {
309 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
310 "Attempt to free non-arena SV: 0x%" UVxf
311 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
318 #else /* ! DEBUGGING */
320 #define del_SV(p) plant_SV(p)
322 #endif /* DEBUGGING */
326 =for apidoc_section $SV
328 =for apidoc sv_add_arena
330 Given a chunk of memory, link it to the head of the list of arenas,
331 and split it into a list of free SVs.
337 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
339 SV *const sva = MUTABLE_SV(ptr);
343 PERL_ARGS_ASSERT_SV_ADD_ARENA;
345 /* The first SV in an arena isn't an SV. */
346 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
347 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
348 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
350 PL_sv_arenaroot = sva;
351 PL_sv_root = sva + 1;
353 svend = &sva[SvREFCNT(sva) - 1];
356 SvARENA_CHAIN_SET(sv, (sv + 1));
360 /* Must always set typemask because it's always checked in on cleanup
361 when the arenas are walked looking for objects. */
362 SvFLAGS(sv) = SVTYPEMASK;
365 SvARENA_CHAIN_SET(sv, 0);
369 SvFLAGS(sv) = SVTYPEMASK;
372 /* visit(): call the named function for each non-free SV in the arenas
373 * whose flags field matches the flags/mask args. */
376 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
381 PERL_ARGS_ASSERT_VISIT;
383 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
384 const SV * const svend = &sva[SvREFCNT(sva)];
386 for (sv = sva + 1; sv < svend; ++sv) {
387 if (SvTYPE(sv) != (svtype)SVTYPEMASK
388 && (sv->sv_flags & mask) == flags
401 /* called by sv_report_used() for each live SV */
404 do_report_used(pTHX_ SV *const sv)
406 if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
407 PerlIO_printf(Perl_debug_log, "****\n");
414 =for apidoc sv_report_used
416 Dump the contents of all SVs not yet freed (debugging aid).
422 Perl_sv_report_used(pTHX)
425 visit(do_report_used, 0, 0);
431 /* called by sv_clean_objs() for each live SV */
434 do_clean_objs(pTHX_ SV *const ref)
438 SV * const target = SvRV(ref);
439 if (SvOBJECT(target)) {
440 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
441 if (SvWEAKREF(ref)) {
442 sv_del_backref(target, ref);
448 SvREFCNT_dec_NN(target);
455 /* clear any slots in a GV which hold objects - except IO;
456 * called by sv_clean_objs() for each live GV */
459 do_clean_named_objs(pTHX_ SV *const sv)
462 assert(SvTYPE(sv) == SVt_PVGV);
463 assert(isGV_with_GP(sv));
467 /* freeing GP entries may indirectly free the current GV;
468 * hold onto it while we mess with the GP slots */
471 if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
472 DEBUG_D((PerlIO_printf(Perl_debug_log,
473 "Cleaning named glob SV object:\n "), sv_dump(obj)));
475 SvREFCNT_dec_NN(obj);
477 if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
478 DEBUG_D((PerlIO_printf(Perl_debug_log,
479 "Cleaning named glob AV object:\n "), sv_dump(obj)));
481 SvREFCNT_dec_NN(obj);
483 if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
484 DEBUG_D((PerlIO_printf(Perl_debug_log,
485 "Cleaning named glob HV object:\n "), sv_dump(obj)));
487 SvREFCNT_dec_NN(obj);
489 if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
490 DEBUG_D((PerlIO_printf(Perl_debug_log,
491 "Cleaning named glob CV object:\n "), sv_dump(obj)));
493 SvREFCNT_dec_NN(obj);
495 SvREFCNT_dec_NN(sv); /* undo the inc above */
498 /* clear any IO slots in a GV which hold objects (except stderr, defout);
499 * called by sv_clean_objs() for each live GV */
502 do_clean_named_io_objs(pTHX_ SV *const sv)
505 assert(SvTYPE(sv) == SVt_PVGV);
506 assert(isGV_with_GP(sv));
507 if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
511 if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
512 DEBUG_D((PerlIO_printf(Perl_debug_log,
513 "Cleaning named glob IO object:\n "), sv_dump(obj)));
515 SvREFCNT_dec_NN(obj);
517 SvREFCNT_dec_NN(sv); /* undo the inc above */
520 /* Void wrapper to pass to visit() */
522 do_curse(pTHX_ SV * const sv) {
523 if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
524 || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
530 =for apidoc sv_clean_objs
532 Attempt to destroy all objects not yet freed.
538 Perl_sv_clean_objs(pTHX)
541 PL_in_clean_objs = TRUE;
542 visit(do_clean_objs, SVf_ROK, SVf_ROK);
543 /* Some barnacles may yet remain, clinging to typeglobs.
544 * Run the non-IO destructors first: they may want to output
545 * error messages, close files etc */
546 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
547 visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
548 /* And if there are some very tenacious barnacles clinging to arrays,
549 closures, or what have you.... */
550 visit(do_curse, SVs_OBJECT, SVs_OBJECT);
551 olddef = PL_defoutgv;
552 PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
553 if (olddef && isGV_with_GP(olddef))
554 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
555 olderr = PL_stderrgv;
556 PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
557 if (olderr && isGV_with_GP(olderr))
558 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
559 SvREFCNT_dec(olddef);
560 PL_in_clean_objs = FALSE;
563 /* called by sv_clean_all() for each live SV */
566 do_clean_all(pTHX_ SV *const sv)
568 if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
569 /* don't clean pid table and strtab */
572 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%" UVxf "\n", PTR2UV(sv)) ));
573 SvFLAGS(sv) |= SVf_BREAK;
578 =for apidoc sv_clean_all
580 Decrement the refcnt of each remaining SV, possibly triggering a
581 cleanup. This function may have to be called multiple times to free
582 SVs which are in complex self-referential hierarchies.
588 Perl_sv_clean_all(pTHX)
591 PL_in_clean_all = TRUE;
592 cleaned = visit(do_clean_all, 0,0);
597 ARENASETS: a meta-arena implementation which separates arena-info
598 into struct arena_set, which contains an array of struct
599 arena_descs, each holding info for a single arena. By separating
600 the meta-info from the arena, we recover the 1st slot, formerly
601 borrowed for list management. The arena_set is about the size of an
602 arena, avoiding the needless malloc overhead of a naive linked-list.
604 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
605 memory in the last arena-set (1/2 on average). In trade, we get
606 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
607 smaller types). The recovery of the wasted space allows use of
608 small arenas for large, rare body types, by changing array* fields
609 in body_details_by_type[] below.
612 char *arena; /* the raw storage, allocated aligned */
613 size_t size; /* its size ~4k typ */
614 svtype utype; /* bodytype stored in arena */
619 /* Get the maximum number of elements in set[] such that struct arena_set
620 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
621 therefore likely to be 1 aligned memory page. */
623 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
624 - 2 * sizeof(int)) / sizeof (struct arena_desc))
627 struct arena_set* next;
628 unsigned int set_size; /* ie ARENAS_PER_SET */
629 unsigned int curr; /* index of next available arena-desc */
630 struct arena_desc set[ARENAS_PER_SET];
634 =for apidoc sv_free_arenas
636 Deallocate the memory used by all arenas. Note that all the individual SV
637 heads and bodies within the arenas must already have been freed.
643 Perl_sv_free_arenas(pTHX)
649 /* Free arenas here, but be careful about fake ones. (We assume
650 contiguity of the fake ones with the corresponding real ones.) */
652 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
653 svanext = MUTABLE_SV(SvANY(sva));
654 while (svanext && SvFAKE(svanext))
655 svanext = MUTABLE_SV(SvANY(svanext));
662 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
665 struct arena_set *current = aroot;
668 assert(aroot->set[i].arena);
669 Safefree(aroot->set[i].arena);
677 i = PERL_ARENA_ROOTS_SIZE;
679 PL_body_roots[i] = 0;
686 Historically, here were mid-level routines that manage the
687 allocation of bodies out of the various arenas. Some of these
688 routines and related definitions remain here, but otherse were
689 moved into sv_inline.h to facilitate inlining of newSV_type().
691 There are 4 kinds of arenas:
693 1. SV-head arenas, which are discussed and handled above
694 2. regular body arenas
695 3. arenas for reduced-size bodies
698 Arena types 2 & 3 are chained by body-type off an array of
699 arena-root pointers, which is indexed by svtype. Some of the
700 larger/less used body types are malloced singly, since a large
701 unused block of them is wasteful. Also, several svtypes dont have
702 bodies; the data fits into the sv-head itself. The arena-root
703 pointer thus has a few unused root-pointers (which may be hijacked
704 later for arena type 4)
706 3 differs from 2 as an optimization; some body types have several
707 unused fields in the front of the structure (which are kept in-place
708 for consistency). These bodies can be allocated in smaller chunks,
709 because the leading fields arent accessed. Pointers to such bodies
710 are decremented to point at the unused 'ghost' memory, knowing that
711 the pointers are used with offsets to the real memory.
713 Allocation of SV-bodies is similar to SV-heads, differing as follows;
714 the allocation mechanism is used for many body types, so is somewhat
715 more complicated, it uses arena-sets, and has no need for still-live
718 At the outermost level, (new|del)_X*V macros return bodies of the
719 appropriate type. These macros call either (new|del)_body_type or
720 (new|del)_body_allocated macro pairs, depending on specifics of the
721 type. Most body types use the former pair, the latter pair is used to
722 allocate body types with "ghost fields".
724 "ghost fields" are fields that are unused in certain types, and
725 consequently don't need to actually exist. They are declared because
726 they're part of a "base type", which allows use of functions as
727 methods. The simplest examples are AVs and HVs, 2 aggregate types
728 which don't use the fields which support SCALAR semantics.
730 For these types, the arenas are carved up into appropriately sized
731 chunks, we thus avoid wasted memory for those unaccessed members.
732 When bodies are allocated, we adjust the pointer back in memory by the
733 size of the part not allocated, so it's as if we allocated the full
734 structure. (But things will all go boom if you write to the part that
735 is "not there", because you'll be overwriting the last members of the
736 preceding structure in memory.)
738 We calculate the correction using the STRUCT_OFFSET macro on the first
739 member present. If the allocated structure is smaller (no initial NV
740 actually allocated) then the net effect is to subtract the size of the NV
741 from the pointer, to return a new pointer as if an initial NV were actually
742 allocated. (We were using structures named *_allocated for this, but
743 this turned out to be a subtle bug, because a structure without an NV
744 could have a lower alignment constraint, but the compiler is allowed to
745 optimised accesses based on the alignment constraint of the actual pointer
746 to the full structure, for example, using a single 64 bit load instruction
747 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
749 This is the same trick as was used for NV and IV bodies. Ironically it
750 doesn't need to be used for NV bodies any more, because NV is now at
751 the start of the structure. IV bodies, and also in some builds NV bodies,
752 don't need it either, because they are no longer allocated.
754 In turn, the new_body_* allocators call S_new_body(), which invokes
755 new_body_from_arena macro, which takes a lock, and takes a body off the
756 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
757 necessary to refresh an empty list. Then the lock is released, and
758 the body is returned.
760 Perl_more_bodies allocates a new arena, and carves it up into an array of N
761 bodies, which it strings into a linked list. It looks up arena-size
762 and body-size from the body_details table described below, thus
763 supporting the multiple body-types.
765 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
766 the (new|del)_X*V macros are mapped directly to malloc/free.
768 For each sv-type, struct body_details bodies_by_type[] carries
769 parameters which control these aspects of SV handling:
771 Arena_size determines whether arenas are used for this body type, and if
772 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
773 zero, forcing individual mallocs and frees.
775 Body_size determines how big a body is, and therefore how many fit into
776 each arena. Offset carries the body-pointer adjustment needed for
777 "ghost fields", and is used in *_allocated macros.
779 But its main purpose is to parameterize info needed in
780 Perl_sv_upgrade(). The info here dramatically simplifies the function
781 vs the implementation in 5.8.8, making it table-driven. All fields
782 are used for this, except for arena_size.
784 For the sv-types that have no bodies, arenas are not used, so those
785 PL_body_roots[sv_type] are unused, and can be overloaded. In
786 something of a special case, SVt_NULL is borrowed for HE arenas;
787 PL_body_roots[HE_ARENA_ROOT_IX=SVt_NULL] is filled by S_more_he, but the
788 bodies_by_type[SVt_NULL] slot is not used, as the table is not
789 available in hv.c. Similarly SVt_IV is re-used for HVAUX_ARENA_ROOT_IX.
793 /* return a thing to the free list */
795 #define del_body(thing, root) \
797 void ** const thing_copy = (void **)thing; \
798 *thing_copy = *root; \
799 *root = (void*)thing_copy; \
804 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
805 const size_t arena_size)
807 void ** const root = &PL_body_roots[sv_type];
808 struct arena_desc *adesc;
809 struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
813 const size_t good_arena_size = Perl_malloc_good_size(arena_size);
814 #if defined(DEBUGGING)
815 static bool done_sanity_check;
817 if (!done_sanity_check) {
818 unsigned int i = SVt_LAST;
820 done_sanity_check = TRUE;
823 assert (bodies_by_type[i].type == i);
829 /* may need new arena-set to hold new arena */
830 if (!aroot || aroot->curr >= aroot->set_size) {
831 struct arena_set *newroot;
832 Newxz(newroot, 1, struct arena_set);
833 newroot->set_size = ARENAS_PER_SET;
834 newroot->next = aroot;
836 PL_body_arenas = (void *) newroot;
837 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
840 /* ok, now have arena-set with at least 1 empty/available arena-desc */
841 curr = aroot->curr++;
842 adesc = &(aroot->set[curr]);
843 assert(!adesc->arena);
845 Newx(adesc->arena, good_arena_size, char);
846 adesc->size = good_arena_size;
847 adesc->utype = sv_type;
848 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %" UVuf "\n",
849 curr, (void*)adesc->arena, (UV)good_arena_size));
851 start = (char *) adesc->arena;
853 /* Get the address of the byte after the end of the last body we can fit.
854 Remember, this is integer division: */
855 end = start + good_arena_size / body_size * body_size;
857 /* computed count doesn't reflect the 1st slot reservation */
858 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
859 DEBUG_m(PerlIO_printf(Perl_debug_log,
860 "arena %p end %p arena-size %d (from %d) type %d "
862 (void*)start, (void*)end, (int)good_arena_size,
863 (int)arena_size, sv_type, (int)body_size,
864 (int)good_arena_size / (int)body_size));
866 DEBUG_m(PerlIO_printf(Perl_debug_log,
867 "arena %p end %p arena-size %d type %d size %d ct %d\n",
868 (void*)start, (void*)end,
869 (int)arena_size, sv_type, (int)body_size,
870 (int)good_arena_size / (int)body_size));
872 *root = (void *)start;
875 /* Where the next body would start: */
876 char * const next = start + body_size;
879 /* This is the last body: */
886 *(void**) start = (void *)next;
892 =for apidoc sv_upgrade
894 Upgrade an SV to a more complex form. Generally adds a new body type to the
895 SV, then copies across as much information as possible from the old body.
896 It croaks if the SV is already in a more complex form than requested. You
897 generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
898 before calling C<sv_upgrade>, and hence does not croak. See also
905 Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
909 const svtype old_type = SvTYPE(sv);
910 const struct body_details *new_type_details;
911 const struct body_details *old_type_details
912 = bodies_by_type + old_type;
915 PERL_ARGS_ASSERT_SV_UPGRADE;
917 if (old_type == new_type)
920 /* This clause was purposefully added ahead of the early return above to
921 the shared string hackery for (sort {$a <=> $b} keys %hash), with the
922 inference by Nick I-S that it would fix other troublesome cases. See
923 changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
925 Given that shared hash key scalars are no longer PVIV, but PV, there is
926 no longer need to unshare so as to free up the IVX slot for its proper
927 purpose. So it's safe to move the early return earlier. */
929 if (new_type > SVt_PVMG && SvIsCOW(sv)) {
930 sv_force_normal_flags(sv, 0);
933 old_body = SvANY(sv);
935 /* Copying structures onto other structures that have been neatly zeroed
936 has a subtle gotcha. Consider XPVMG
938 +------+------+------+------+------+-------+-------+
939 | NV | CUR | LEN | IV | MAGIC | STASH |
940 +------+------+------+------+------+-------+-------+
943 where NVs are aligned to 8 bytes, so that sizeof that structure is
944 actually 32 bytes long, with 4 bytes of padding at the end:
946 +------+------+------+------+------+-------+-------+------+
947 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
948 +------+------+------+------+------+-------+-------+------+
949 0 4 8 12 16 20 24 28 32
951 so what happens if you allocate memory for this structure:
953 +------+------+------+------+------+-------+-------+------+------+...
954 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
955 +------+------+------+------+------+-------+-------+------+------+...
956 0 4 8 12 16 20 24 28 32 36
958 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
959 expect, because you copy the area marked ??? onto GP. Now, ??? may have
960 started out as zero once, but it's quite possible that it isn't. So now,
961 rather than a nicely zeroed GP, you have it pointing somewhere random.
964 (In fact, GP ends up pointing at a previous GP structure, because the
965 principle cause of the padding in XPVMG getting garbage is a copy of
966 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
967 this happens to be moot because XPVGV has been re-ordered, with GP
968 no longer after STASH)
970 So we are careful and work out the size of used parts of all the
979 old_type_details = &fake_rv;
980 if (new_type == SVt_NV)
983 if (new_type < SVt_PVIV) {
984 new_type = (new_type == SVt_NV)
985 ? SVt_PVNV : SVt_PVIV;
990 if (new_type < SVt_PVNV) {
995 assert(new_type > SVt_PV);
996 STATIC_ASSERT_STMT(SVt_IV < SVt_PV);
997 STATIC_ASSERT_STMT(SVt_NV < SVt_PV);
1004 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1005 there's no way that it can be safely upgraded, because perl.c
1006 expects to Safefree(SvANY(PL_mess_sv)) */
1007 assert(sv != PL_mess_sv);
1010 if (UNLIKELY(old_type_details->cant_upgrade))
1011 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1012 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1015 if (UNLIKELY(old_type > new_type))
1016 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1017 (int)old_type, (int)new_type);
1019 new_type_details = bodies_by_type + new_type;
1021 SvFLAGS(sv) &= ~SVTYPEMASK;
1022 SvFLAGS(sv) |= new_type;
1024 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1025 the return statements above will have triggered. */
1026 assert (new_type != SVt_NULL);
1029 assert(old_type == SVt_NULL);
1030 SET_SVANY_FOR_BODYLESS_IV(sv);
1034 assert(old_type == SVt_NULL);
1035 #if NVSIZE <= IVSIZE
1036 SET_SVANY_FOR_BODYLESS_NV(sv);
1038 SvANY(sv) = new_XNV();
1044 assert(new_type_details->body_size);
1047 assert(new_type_details->arena);
1048 assert(new_type_details->arena_size);
1049 /* This points to the start of the allocated area. */
1050 new_body = S_new_body(aTHX_ new_type);
1051 /* xpvav and xpvhv have no offset, so no need to adjust new_body */
1052 assert(!(new_type_details->offset));
1054 /* We always allocated the full length item with PURIFY. To do this
1055 we fake things so that arena is false for all 16 types.. */
1056 new_body = new_NOARENAZ(new_type_details);
1058 SvANY(sv) = new_body;
1059 if (new_type == SVt_PVAV) {
1060 *((XPVAV*) SvANY(sv)) = (XPVAV) {
1061 .xmg_stash = NULL, .xmg_u = {.xmg_magic = NULL},
1062 .xav_fill = -1, .xav_max = -1, .xav_alloc = 0
1067 *((XPVHV*) SvANY(sv)) = (XPVHV) {
1068 .xmg_stash = NULL, .xmg_u = {.xmg_magic = NULL},
1070 /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
1071 .xhv_max = PERL_HASH_DEFAULT_HvMAX
1076 #ifndef NODEFAULT_SHAREKEYS
1077 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1081 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1082 The target created by newSVrv also is, and it can have magic.
1083 However, it never has SvPVX set.
1085 if (old_type == SVt_IV) {
1087 } else if (old_type >= SVt_PV) {
1088 assert(SvPVX_const(sv) == 0);
1091 if (old_type >= SVt_PVMG) {
1092 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1093 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1095 sv->sv_u.svu_array = NULL; /* or svu_hash */
1100 /* XXX Is this still needed? Was it ever needed? Surely as there is
1101 no route from NV to PVIV, NOK can never be true */
1102 assert(!SvNOKp(sv));
1116 assert(new_type_details->body_size);
1117 /* We always allocated the full length item with PURIFY. To do this
1118 we fake things so that arena is false for all 16 types.. */
1120 if(new_type_details->arena) {
1121 /* This points to the start of the allocated area. */
1122 new_body = S_new_body(aTHX_ new_type);
1123 Zero(new_body, new_type_details->body_size, char);
1124 new_body = ((char *)new_body) - new_type_details->offset;
1128 new_body = new_NOARENAZ(new_type_details);
1130 SvANY(sv) = new_body;
1132 if (old_type_details->copy) {
1133 /* There is now the potential for an upgrade from something without
1134 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1135 int offset = old_type_details->offset;
1136 int length = old_type_details->copy;
1138 if (new_type_details->offset > old_type_details->offset) {
1139 const int difference
1140 = new_type_details->offset - old_type_details->offset;
1141 offset += difference;
1142 length -= difference;
1144 assert (length >= 0);
1146 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1150 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1151 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1152 * correct 0.0 for us. Otherwise, if the old body didn't have an
1153 * NV slot, but the new one does, then we need to initialise the
1154 * freshly created NV slot with whatever the correct bit pattern is
1156 if (old_type_details->zero_nv && !new_type_details->zero_nv
1157 && !isGV_with_GP(sv))
1161 if (UNLIKELY(new_type == SVt_PVIO)) {
1162 IO * const io = MUTABLE_IO(sv);
1163 GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1166 /* Clear the stashcache because a new IO could overrule a package
1168 DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
1169 hv_clear(PL_stashcache);
1171 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1172 IoPAGE_LEN(sv) = 60;
1174 if (old_type < SVt_PV) {
1175 /* referent will be NULL unless the old type was SVt_IV emulating
1177 sv->sv_u.svu_rv = referent;
1181 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1182 (unsigned long)new_type);
1185 /* if this is zero, this is a body-less SVt_NULL, SVt_IV/SVt_RV,
1186 and sometimes SVt_NV */
1187 if (old_type_details->body_size) {
1191 /* Note that there is an assumption that all bodies of types that
1192 can be upgraded came from arenas. Only the more complex non-
1193 upgradable types are allowed to be directly malloc()ed. */
1194 assert(old_type_details->arena);
1195 del_body((void*)((char*)old_body + old_type_details->offset),
1196 &PL_body_roots[old_type]);
1202 Perl_hv_auxalloc(pTHX_ HV *hv) {
1203 const struct body_details *old_type_details = bodies_by_type + SVt_PVHV;
1207 PERL_ARGS_ASSERT_HV_AUXALLOC;
1208 assert(SvTYPE(hv) == SVt_PVHV);
1212 new_body = new_NOARENAZ(&fake_hv_with_aux);
1214 new_body_from_arena(new_body, HVAUX_ARENA_ROOT_IX, fake_hv_with_aux);
1217 old_body = SvANY(hv);
1219 Copy((char *)old_body + old_type_details->offset,
1220 (char *)new_body + fake_hv_with_aux.offset,
1221 old_type_details->copy,
1227 assert(old_type_details->arena);
1228 del_body((void*)((char*)old_body + old_type_details->offset),
1229 &PL_body_roots[SVt_PVHV]);
1232 SvANY(hv) = (XPVHV *) new_body;
1238 =for apidoc sv_backoff
1240 Remove any string offset. You should normally use the C<SvOOK_off> macro
1246 /* prior to 5.000 stable, this function returned the new OOK-less SvFLAGS
1247 prior to 5.23.4 this function always returned 0
1251 Perl_sv_backoff(SV *const sv)
1254 const char * const s = SvPVX_const(sv);
1256 PERL_ARGS_ASSERT_SV_BACKOFF;
1259 assert(SvTYPE(sv) != SVt_PVHV);
1260 assert(SvTYPE(sv) != SVt_PVAV);
1262 SvOOK_offset(sv, delta);
1264 SvLEN_set(sv, SvLEN(sv) + delta);
1265 SvPV_set(sv, SvPVX(sv) - delta);
1266 SvFLAGS(sv) &= ~SVf_OOK;
1267 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1272 /* forward declaration */
1273 static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
1279 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1280 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1281 Use the C<SvGROW> wrapper instead.
1288 Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
1292 PERL_ARGS_ASSERT_SV_GROW;
1296 if (SvTYPE(sv) < SVt_PV) {
1297 sv_upgrade(sv, SVt_PV);
1298 s = SvPVX_mutable(sv);
1300 else if (SvOOK(sv)) { /* pv is offset? */
1302 s = SvPVX_mutable(sv);
1303 if (newlen > SvLEN(sv))
1304 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1308 if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0);
1309 s = SvPVX_mutable(sv);
1312 #ifdef PERL_COPY_ON_WRITE
1313 /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1314 * to store the COW count. So in general, allocate one more byte than
1315 * asked for, to make it likely this byte is always spare: and thus
1316 * make more strings COW-able.
1318 * Only increment if the allocation isn't MEM_SIZE_MAX,
1319 * otherwise it will wrap to 0.
1321 if ( newlen != MEM_SIZE_MAX )
1325 #if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size)
1326 #define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1329 if (newlen > SvLEN(sv)) { /* need more room? */
1330 STRLEN minlen = SvCUR(sv);
1331 minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1332 if (newlen < minlen)
1334 #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1336 /* Don't round up on the first allocation, as odds are pretty good that
1337 * the initial request is accurate as to what is really needed */
1339 STRLEN rounded = PERL_STRLEN_ROUNDUP(newlen);
1340 if (rounded > newlen)
1344 if (SvLEN(sv) && s) {
1345 s = (char*)saferealloc(s, newlen);
1348 s = (char*)safemalloc(newlen);
1349 if (SvPVX_const(sv) && SvCUR(sv)) {
1350 Move(SvPVX_const(sv), s, SvCUR(sv), char);
1354 #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1355 /* Do this here, do it once, do it right, and then we will never get
1356 called back into sv_grow() unless there really is some growing
1358 SvLEN_set(sv, Perl_safesysmalloc_size(s));
1360 SvLEN_set(sv, newlen);
1367 =for apidoc sv_grow_fresh
1369 A cut-down version of sv_grow intended only for when sv is a freshly-minted
1370 SVt_PV, SVt_PVIV, SVt_PVNV, or SVt_PVMG. i.e. sv has the default flags, has
1371 never been any other type, and does not have an existing string. Basically,
1372 just assigns a char buffer and returns a pointer to it.
1379 Perl_sv_grow_fresh(pTHX_ SV *const sv, STRLEN newlen)
1383 PERL_ARGS_ASSERT_SV_GROW_FRESH;
1385 assert(SvTYPE(sv) >= SVt_PV && SvTYPE(sv) <= SVt_PVMG);
1388 assert(!SvIsCOW(sv));
1392 #ifdef PERL_COPY_ON_WRITE
1393 /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1394 * to store the COW count. So in general, allocate one more byte than
1395 * asked for, to make it likely this byte is always spare: and thus
1396 * make more strings COW-able.
1398 * Only increment if the allocation isn't MEM_SIZE_MAX,
1399 * otherwise it will wrap to 0.
1401 if ( newlen != MEM_SIZE_MAX )
1405 /* 10 is a longstanding, hardcoded minimum length in sv_grow. */
1406 /* Just doing the same here for consistency. */
1410 s = (char*)safemalloc(newlen);
1413 /* No PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC here, since many strings */
1414 /* will never be grown once set. Let the real sv_grow worry about that. */
1415 SvLEN_set(sv, newlen);
1420 =for apidoc sv_setiv
1421 =for apidoc_item sv_setiv_mg
1423 These copy an integer into the given SV, upgrading first if necessary.
1425 They differ only in that C<sv_setiv_mg> handles 'set' magic; C<sv_setiv> does
1432 Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
1434 PERL_ARGS_ASSERT_SV_SETIV;
1436 SV_CHECK_THINKFIRST_COW_DROP(sv);
1437 switch (SvTYPE(sv)) {
1440 sv_upgrade(sv, SVt_IV);
1443 sv_upgrade(sv, SVt_PVIV);
1447 if (!isGV_with_GP(sv))
1455 /* diag_listed_as: Can't coerce %s to %s in %s */
1456 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1458 NOT_REACHED; /* NOTREACHED */
1462 (void)SvIOK_only(sv); /* validate number */
1468 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1470 PERL_ARGS_ASSERT_SV_SETIV_MG;
1477 =for apidoc sv_setuv
1478 =for apidoc_item sv_setuv_mg
1480 These copy an unsigned integer into the given SV, upgrading first if necessary.
1483 They differ only in that C<sv_setuv_mg> handles 'set' magic; C<sv_setuv> does
1490 Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1492 PERL_ARGS_ASSERT_SV_SETUV;
1494 /* With the if statement to ensure that integers are stored as IVs whenever
1496 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1499 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1501 If you wish to remove the following if statement, so that this routine
1502 (and its callers) always return UVs, please benchmark to see what the
1503 effect is. Modern CPUs may be different. Or may not :-)
1505 if (u <= (UV)IV_MAX) {
1506 sv_setiv(sv, (IV)u);
1515 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1517 PERL_ARGS_ASSERT_SV_SETUV_MG;
1524 =for apidoc sv_setnv
1525 =for apidoc_item sv_setnv_mg
1527 These copy a double into the given SV, upgrading first if necessary.
1529 They differ only in that C<sv_setnv_mg> handles 'set' magic; C<sv_setnv> does
1536 Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1538 PERL_ARGS_ASSERT_SV_SETNV;
1540 SV_CHECK_THINKFIRST_COW_DROP(sv);
1541 switch (SvTYPE(sv)) {
1544 sv_upgrade(sv, SVt_NV);
1548 sv_upgrade(sv, SVt_PVNV);
1552 if (!isGV_with_GP(sv))
1560 /* diag_listed_as: Can't coerce %s to %s in %s */
1561 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1563 NOT_REACHED; /* NOTREACHED */
1568 (void)SvNOK_only(sv); /* validate number */
1573 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1575 PERL_ARGS_ASSERT_SV_SETNV_MG;
1582 =for apidoc sv_setrv_noinc
1583 =for apidoc_item sv_setrv_noinc_mg
1585 Copies an SV pointer into the given SV as an SV reference, upgrading it if
1586 necessary. After this, C<SvRV(sv)> is equal to I<ref>. This does not adjust
1587 the reference count of I<ref>. The reference I<ref> must not be NULL.
1589 C<sv_setrv_noinc_mg> will invoke 'set' magic on the SV; C<sv_setrv_noinc> will
1596 Perl_sv_setrv_noinc(pTHX_ SV *const sv, SV *const ref)
1598 PERL_ARGS_ASSERT_SV_SETRV_NOINC;
1600 SV_CHECK_THINKFIRST_COW_DROP(sv);
1601 prepare_SV_for_RV(sv);
1609 Perl_sv_setrv_noinc_mg(pTHX_ SV *const sv, SV *const ref)
1611 PERL_ARGS_ASSERT_SV_SETRV_NOINC_MG;
1613 sv_setrv_noinc(sv, ref);
1618 =for apidoc sv_setrv_inc
1619 =for apidoc_item sv_setrv_inc_mg
1621 As C<sv_setrv_noinc> but increments the reference count of I<ref>.
1623 C<sv_setrv_inc_mg> will invoke 'set' magic on the SV; C<sv_setrv_inc> will
1630 Perl_sv_setrv_inc(pTHX_ SV *const sv, SV *const ref)
1632 PERL_ARGS_ASSERT_SV_SETRV_INC;
1634 sv_setrv_noinc(sv, SvREFCNT_inc_simple_NN(ref));
1638 Perl_sv_setrv_inc_mg(pTHX_ SV *const sv, SV *const ref)
1640 PERL_ARGS_ASSERT_SV_SETRV_INC_MG;
1642 sv_setrv_noinc(sv, SvREFCNT_inc_simple_NN(ref));
1646 /* Return a cleaned-up, printable version of sv, for non-numeric, or
1647 * not incrementable warning display.
1648 * Originally part of S_not_a_number().
1649 * The return value may be != tmpbuf.
1653 S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1656 PERL_ARGS_ASSERT_SV_DISPLAY;
1659 SV *dsv = newSVpvs_flags("", SVs_TEMP);
1660 pv = sv_uni_display(dsv, sv, 32, UNI_DISPLAY_ISPRINT);
1663 const char * const limit = tmpbuf + tmpbuf_size - 8;
1664 /* each *s can expand to 4 chars + "...\0",
1665 i.e. need room for 8 chars */
1667 const char *s = SvPVX_const(sv);
1668 const char * const end = s + SvCUR(sv);
1669 for ( ; s < end && d < limit; s++ ) {
1671 if (! isASCII(ch) && !isPRINT_LC(ch)) {
1675 /* Map to ASCII "equivalent" of Latin1 */
1676 ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1682 else if (ch == '\r') {
1686 else if (ch == '\f') {
1690 else if (ch == '\\') {
1694 else if (ch == '\0') {
1698 else if (isPRINT_LC(ch))
1717 /* Print an "isn't numeric" warning, using a cleaned-up,
1718 * printable version of the offending string
1722 S_not_a_number(pTHX_ SV *const sv)
1727 PERL_ARGS_ASSERT_NOT_A_NUMBER;
1729 pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1732 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1733 /* diag_listed_as: Argument "%s" isn't numeric%s */
1734 "Argument \"%s\" isn't numeric in %s", pv,
1737 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1738 /* diag_listed_as: Argument "%s" isn't numeric%s */
1739 "Argument \"%s\" isn't numeric", pv);
1743 S_not_incrementable(pTHX_ SV *const sv) {
1747 PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1749 pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1751 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1752 "Argument \"%s\" treated as 0 in increment (++)", pv);
1756 =for apidoc looks_like_number
1758 Test if the content of an SV looks like a number (or is a number).
1759 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1760 non-numeric warning), even if your C<atof()> doesn't grok them. Get-magic is
1767 Perl_looks_like_number(pTHX_ SV *const sv)
1773 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1775 if (SvPOK(sv) || SvPOKp(sv)) {
1776 sbegin = SvPV_nomg_const(sv, len);
1779 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1780 numtype = grok_number(sbegin, len, NULL);
1781 return ((numtype & IS_NUMBER_TRAILING)) ? 0 : numtype;
1785 S_glob_2number(pTHX_ GV * const gv)
1787 PERL_ARGS_ASSERT_GLOB_2NUMBER;
1789 /* We know that all GVs stringify to something that is not-a-number,
1790 so no need to test that. */
1791 if (ckWARN(WARN_NUMERIC))
1793 SV *const buffer = sv_newmortal();
1794 gv_efullname3(buffer, gv, "*");
1795 not_a_number(buffer);
1797 /* We just want something true to return, so that S_sv_2iuv_common
1798 can tail call us and return true. */
1802 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1803 until proven guilty, assume that things are not that bad... */
1808 As 64 bit platforms often have an NV that doesn't preserve all bits of
1809 an IV (an assumption perl has been based on to date) it becomes necessary
1810 to remove the assumption that the NV always carries enough precision to
1811 recreate the IV whenever needed, and that the NV is the canonical form.
1812 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1813 precision as a side effect of conversion (which would lead to insanity
1814 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1815 1) to distinguish between IV/UV/NV slots that have a valid conversion cached
1816 where precision was lost, and IV/UV/NV slots that have a valid conversion
1817 which has lost no precision
1818 2) to ensure that if a numeric conversion to one form is requested that
1819 would lose precision, the precise conversion (or differently
1820 imprecise conversion) is also performed and cached, to prevent
1821 requests for different numeric formats on the same SV causing
1822 lossy conversion chains. (lossless conversion chains are perfectly
1827 SvIOKp is true if the IV slot contains a valid value
1828 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1829 SvNOKp is true if the NV slot contains a valid value
1830 SvNOK is true only if the NV value is accurate
1833 while converting from PV to NV, check to see if converting that NV to an
1834 IV(or UV) would lose accuracy over a direct conversion from PV to
1835 IV(or UV). If it would, cache both conversions, return NV, but mark
1836 SV as IOK NOKp (ie not NOK).
1838 While converting from PV to IV, check to see if converting that IV to an
1839 NV would lose accuracy over a direct conversion from PV to NV. If it
1840 would, cache both conversions, flag similarly.
1842 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1843 correctly because if IV & NV were set NV *always* overruled.
1844 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1845 changes - now IV and NV together means that the two are interchangeable:
1846 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1848 The benefit of this is that operations such as pp_add know that if
1849 SvIOK is true for both left and right operands, then integer addition
1850 can be used instead of floating point (for cases where the result won't
1851 overflow). Before, floating point was always used, which could lead to
1852 loss of precision compared with integer addition.
1854 * making IV and NV equal status should make maths accurate on 64 bit
1856 * may speed up maths somewhat if pp_add and friends start to use
1857 integers when possible instead of fp. (Hopefully the overhead in
1858 looking for SvIOK and checking for overflow will not outweigh the
1859 fp to integer speedup)
1860 * will slow down integer operations (callers of SvIV) on "inaccurate"
1861 values, as the change from SvIOK to SvIOKp will cause a call into
1862 sv_2iv each time rather than a macro access direct to the IV slot
1863 * should speed up number->string conversion on integers as IV is
1864 favoured when IV and NV are equally accurate
1866 ####################################################################
1867 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1868 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1869 On the other hand, SvUOK is true iff UV.
1870 ####################################################################
1872 Your mileage will vary depending your CPU's relative fp to integer
1876 #ifndef NV_PRESERVES_UV
1877 # define IS_NUMBER_UNDERFLOW_IV 1
1878 # define IS_NUMBER_UNDERFLOW_UV 2
1879 # define IS_NUMBER_IV_AND_UV 2
1880 # define IS_NUMBER_OVERFLOW_IV 4
1881 # define IS_NUMBER_OVERFLOW_UV 5
1883 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1885 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1887 S_sv_2iuv_non_preserve(pTHX_ SV *const sv
1893 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1894 PERL_UNUSED_CONTEXT;
1896 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));
1897 if (SvNVX(sv) < (NV)IV_MIN) {
1898 (void)SvIOKp_on(sv);
1900 SvIV_set(sv, IV_MIN);
1901 return IS_NUMBER_UNDERFLOW_IV;
1903 if (SvNVX(sv) > (NV)UV_MAX) {
1904 (void)SvIOKp_on(sv);
1907 SvUV_set(sv, UV_MAX);
1908 return IS_NUMBER_OVERFLOW_UV;
1910 (void)SvIOKp_on(sv);
1912 /* Can't use strtol etc to convert this string. (See truth table in
1914 if (SvNVX(sv) < IV_MAX_P1) {
1915 SvIV_set(sv, I_V(SvNVX(sv)));
1916 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1917 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1919 /* Integer is imprecise. NOK, IOKp */
1921 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1924 SvUV_set(sv, U_V(SvNVX(sv)));
1925 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1926 if (SvUVX(sv) == UV_MAX) {
1927 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1928 possibly be preserved by NV. Hence, it must be overflow.
1930 return IS_NUMBER_OVERFLOW_UV;
1932 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1934 /* Integer is imprecise. NOK, IOKp */
1936 return IS_NUMBER_OVERFLOW_IV;
1938 #endif /* !NV_PRESERVES_UV*/
1940 /* If numtype is infnan, set the NV of the sv accordingly.
1941 * If numtype is anything else, try setting the NV using Atof(PV). */
1943 S_sv_setnv(pTHX_ SV* sv, int numtype)
1945 bool pok = cBOOL(SvPOK(sv));
1948 if ((numtype & IS_NUMBER_INFINITY)) {
1949 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
1954 if ((numtype & IS_NUMBER_NAN)) {
1955 SvNV_set(sv, NV_NAN);
1960 SvNV_set(sv, Atof(SvPVX_const(sv)));
1961 /* Purposefully no true nok here, since we don't want to blow
1962 * away the possible IOK/UV of an existing sv. */
1965 SvNOK_only(sv); /* No IV or UV please, this is pure infnan. */
1967 SvPOK_on(sv); /* PV is okay, though. */
1972 S_sv_2iuv_common(pTHX_ SV *const sv)
1974 PERL_ARGS_ASSERT_SV_2IUV_COMMON;
1977 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1978 * without also getting a cached IV/UV from it at the same time
1979 * (ie PV->NV conversion should detect loss of accuracy and cache
1980 * IV or UV at same time to avoid this. */
1981 /* IV-over-UV optimisation - choose to cache IV if possible */
1983 if (SvTYPE(sv) == SVt_NV)
1984 sv_upgrade(sv, SVt_PVNV);
1987 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1988 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1989 certainly cast into the IV range at IV_MAX, whereas the correct
1990 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1992 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1993 if (Perl_isnan(SvNVX(sv))) {
1999 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2000 SvIV_set(sv, I_V(SvNVX(sv)));
2001 if (SvNVX(sv) == (NV) SvIVX(sv)
2002 #ifndef NV_PRESERVES_UV
2003 && SvIVX(sv) != IV_MIN /* avoid negating IV_MIN below */
2004 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2005 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2006 /* Don't flag it as "accurately an integer" if the number
2007 came from a (by definition imprecise) NV operation, and
2008 we're outside the range of NV integer precision */
2012 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2014 /* scalar has trailing garbage, eg "42a" */
2016 DEBUG_c(PerlIO_printf(Perl_debug_log,
2017 "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (precise)\n",
2023 /* IV not precise. No need to convert from PV, as NV
2024 conversion would already have cached IV if it detected
2025 that PV->IV would be better than PV->NV->IV
2026 flags already correct - don't set public IOK. */
2027 DEBUG_c(PerlIO_printf(Perl_debug_log,
2028 "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (imprecise)\n",
2033 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2034 but the cast (NV)IV_MIN rounds to a the value less (more
2035 negative) than IV_MIN which happens to be equal to SvNVX ??
2036 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2037 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2038 (NV)UVX == NVX are both true, but the values differ. :-(
2039 Hopefully for 2s complement IV_MIN is something like
2040 0x8000000000000000 which will be exact. NWC */
2043 SvUV_set(sv, U_V(SvNVX(sv)));
2045 (SvNVX(sv) == (NV) SvUVX(sv))
2046 #ifndef NV_PRESERVES_UV
2047 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2048 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2049 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2050 /* Don't flag it as "accurately an integer" if the number
2051 came from a (by definition imprecise) NV operation, and
2052 we're outside the range of NV integer precision */
2058 DEBUG_c(PerlIO_printf(Perl_debug_log,
2059 "0x%" UVxf " 2iv(%" UVuf " => %" IVdf ") (as unsigned)\n",
2065 else if (SvPOKp(sv)) {
2068 const char *s = SvPVX_const(sv);
2069 const STRLEN cur = SvCUR(sv);
2071 /* short-cut for a single digit string like "1" */
2076 if (SvTYPE(sv) < SVt_PVIV)
2077 sv_upgrade(sv, SVt_PVIV);
2079 SvIV_set(sv, (IV)(c - '0'));
2084 numtype = grok_number(s, cur, &value);
2085 /* We want to avoid a possible problem when we cache an IV/ a UV which
2086 may be later translated to an NV, and the resulting NV is not
2087 the same as the direct translation of the initial string
2088 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2089 be careful to ensure that the value with the .456 is around if the
2090 NV value is requested in the future).
2092 This means that if we cache such an IV/a UV, we need to cache the
2093 NV as well. Moreover, we trade speed for space, and do not
2094 cache the NV if we are sure it's not needed.
2097 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2098 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2099 == IS_NUMBER_IN_UV) {
2100 /* It's definitely an integer, only upgrade to PVIV */
2101 if (SvTYPE(sv) < SVt_PVIV)
2102 sv_upgrade(sv, SVt_PVIV);
2104 } else if (SvTYPE(sv) < SVt_PVNV)
2105 sv_upgrade(sv, SVt_PVNV);
2107 if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
2108 if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING)))
2110 S_sv_setnv(aTHX_ sv, numtype);
2111 goto got_nv; /* Fill IV/UV slot and set IOKp */
2114 /* If NVs preserve UVs then we only use the UV value if we know that
2115 we aren't going to call atof() below. If NVs don't preserve UVs
2116 then the value returned may have more precision than atof() will
2117 return, even though value isn't perfectly accurate. */
2118 if ((numtype & (IS_NUMBER_IN_UV
2119 #ifdef NV_PRESERVES_UV
2122 )) == IS_NUMBER_IN_UV) {
2123 /* This won't turn off the public IOK flag if it was set above */
2124 (void)SvIOKp_on(sv);
2126 if (!(numtype & IS_NUMBER_NEG)) {
2128 if (value <= (UV)IV_MAX) {
2129 SvIV_set(sv, (IV)value);
2131 /* it didn't overflow, and it was positive. */
2132 SvUV_set(sv, value);
2136 /* 2s complement assumption */
2137 if (value <= (UV)IV_MIN) {
2138 SvIV_set(sv, value == (UV)IV_MIN
2139 ? IV_MIN : -(IV)value);
2141 /* Too negative for an IV. This is a double upgrade, but
2142 I'm assuming it will be rare. */
2143 if (SvTYPE(sv) < SVt_PVNV)
2144 sv_upgrade(sv, SVt_PVNV);
2148 SvNV_set(sv, -(NV)value);
2149 SvIV_set(sv, IV_MIN);
2153 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2154 will be in the previous block to set the IV slot, and the next
2155 block to set the NV slot. So no else here. */
2157 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2158 != IS_NUMBER_IN_UV) {
2159 /* It wasn't an (integer that doesn't overflow the UV). */
2160 S_sv_setnv(aTHX_ sv, numtype);
2162 if (! numtype && ckWARN(WARN_NUMERIC))
2165 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" NVgf ")\n",
2166 PTR2UV(sv), SvNVX(sv)));
2168 #ifdef NV_PRESERVES_UV
2172 goto got_nv; /* Fill IV/UV slot and set IOKp, maybe IOK */
2173 #else /* NV_PRESERVES_UV */
2174 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2175 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2176 /* The IV/UV slot will have been set from value returned by
2177 grok_number above. The NV slot has just been set using
2180 assert (SvIOKp(sv));
2182 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2183 U_V(Perl_fabs(SvNVX(sv)))) {
2184 /* Small enough to preserve all bits. */
2185 (void)SvIOKp_on(sv);
2187 SvIV_set(sv, I_V(SvNVX(sv)));
2188 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2190 /* There had been runtime checking for
2191 "U_V(Perl_fabs(SvNVX(sv))) < (UV)IV_MAX" here to ensure
2192 that this NV is in the preserved range, but this should
2193 be always true if the following assertion is true: */
2194 STATIC_ASSERT_STMT(((UV)1 << NV_PRESERVES_UV_BITS) <=
2198 0 0 already failed to read UV.
2199 0 1 already failed to read UV.
2200 1 0 you won't get here in this case. IV/UV
2201 slot set, public IOK, Atof() unneeded.
2202 1 1 already read UV.
2203 so there's no point in sv_2iuv_non_preserve() attempting
2204 to use atol, strtol, strtoul etc. */
2206 sv_2iuv_non_preserve (sv, numtype);
2208 sv_2iuv_non_preserve (sv);
2212 /* It might be more code efficient to go through the entire logic above
2213 and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2214 gets complex and potentially buggy, so more programmer efficient
2215 to do it this way, by turning off the public flags: */
2217 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2218 #endif /* NV_PRESERVES_UV */
2222 if (isGV_with_GP(sv))
2223 return glob_2number(MUTABLE_GV(sv));
2225 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2227 if (SvTYPE(sv) < SVt_IV)
2228 /* Typically the caller expects that sv_any is not NULL now. */
2229 sv_upgrade(sv, SVt_IV);
2230 /* Return 0 from the caller. */
2237 =for apidoc sv_2iv_flags
2239 Return the integer value of an SV, doing any necessary string
2240 conversion. If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2241 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2247 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2249 PERL_ARGS_ASSERT_SV_2IV_FLAGS;
2251 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2252 && SvTYPE(sv) != SVt_PVFM);
2254 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2260 if (flags & SV_SKIP_OVERLOAD)
2262 tmpstr = AMG_CALLunary(sv, numer_amg);
2263 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2264 return SvIV(tmpstr);
2267 return PTR2IV(SvRV(sv));
2270 if (SvVALID(sv) || isREGEXP(sv)) {
2271 /* FBMs use the space for SvIVX and SvNVX for other purposes, so
2272 must not let them cache IVs.
2273 In practice they are extremely unlikely to actually get anywhere
2274 accessible by user Perl code - the only way that I'm aware of is when
2275 a constant subroutine which is used as the second argument to index.
2277 Regexps have no SvIVX and SvNVX fields.
2282 const char * const ptr =
2283 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2285 = grok_number(ptr, SvCUR(sv), &value);
2287 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2288 == IS_NUMBER_IN_UV) {
2289 /* It's definitely an integer */
2290 if (numtype & IS_NUMBER_NEG) {
2291 if (value < (UV)IV_MIN)
2294 if (value < (UV)IV_MAX)
2299 /* Quite wrong but no good choices. */
2300 if ((numtype & IS_NUMBER_INFINITY)) {
2301 return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX;
2302 } else if ((numtype & IS_NUMBER_NAN)) {
2303 return 0; /* So wrong. */
2307 if (ckWARN(WARN_NUMERIC))
2310 return I_V(Atof(ptr));
2314 if (SvTHINKFIRST(sv)) {
2315 if (SvREADONLY(sv) && !SvOK(sv)) {
2316 if (ckWARN(WARN_UNINITIALIZED))
2323 if (S_sv_2iuv_common(aTHX_ sv))
2327 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" IVdf ")\n",
2328 PTR2UV(sv),SvIVX(sv)));
2329 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2333 =for apidoc sv_2uv_flags
2335 Return the unsigned integer value of an SV, doing any necessary string
2336 conversion. If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2337 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2339 =for apidoc Amnh||SV_GMAGIC
2345 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2347 PERL_ARGS_ASSERT_SV_2UV_FLAGS;
2349 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2355 if (flags & SV_SKIP_OVERLOAD)
2357 tmpstr = AMG_CALLunary(sv, numer_amg);
2358 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2359 return SvUV(tmpstr);
2362 return PTR2UV(SvRV(sv));
2365 if (SvVALID(sv) || isREGEXP(sv)) {
2366 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2367 the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2368 Regexps have no SvIVX and SvNVX fields. */
2372 const char * const ptr =
2373 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2375 = grok_number(ptr, SvCUR(sv), &value);
2377 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2378 == IS_NUMBER_IN_UV) {
2379 /* It's definitely an integer */
2380 if (!(numtype & IS_NUMBER_NEG))
2384 /* Quite wrong but no good choices. */
2385 if ((numtype & IS_NUMBER_INFINITY)) {
2386 return UV_MAX; /* So wrong. */
2387 } else if ((numtype & IS_NUMBER_NAN)) {
2388 return 0; /* So wrong. */
2392 if (ckWARN(WARN_NUMERIC))
2395 return U_V(Atof(ptr));
2399 if (SvTHINKFIRST(sv)) {
2400 if (SvREADONLY(sv) && !SvOK(sv)) {
2401 if (ckWARN(WARN_UNINITIALIZED))
2408 if (S_sv_2iuv_common(aTHX_ sv))
2412 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2uv(%" UVuf ")\n",
2413 PTR2UV(sv),SvUVX(sv)));
2414 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2418 =for apidoc sv_2nv_flags
2420 Return the num value of an SV, doing any necessary string or integer
2421 conversion. If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2422 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2428 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2430 PERL_ARGS_ASSERT_SV_2NV_FLAGS;
2432 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2433 && SvTYPE(sv) != SVt_PVFM);
2434 if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
2435 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2436 the same flag bit as SVf_IVisUV, so must not let them cache NVs.
2437 Regexps have no SvIVX and SvNVX fields. */
2439 if (flags & SV_GMAGIC)
2443 if (SvPOKp(sv) && !SvIOKp(sv)) {
2444 ptr = SvPVX_const(sv);
2445 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2446 !grok_number(ptr, SvCUR(sv), NULL))
2452 return (NV)SvUVX(sv);
2454 return (NV)SvIVX(sv);
2459 assert(SvTYPE(sv) >= SVt_PVMG);
2460 /* This falls through to the report_uninit near the end of the
2462 } else if (SvTHINKFIRST(sv)) {
2467 if (flags & SV_SKIP_OVERLOAD)
2469 tmpstr = AMG_CALLunary(sv, numer_amg);
2470 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2471 return SvNV(tmpstr);
2474 return PTR2NV(SvRV(sv));
2476 if (SvREADONLY(sv) && !SvOK(sv)) {
2477 if (ckWARN(WARN_UNINITIALIZED))
2482 if (SvTYPE(sv) < SVt_NV) {
2483 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2484 sv_upgrade(sv, SVt_NV);
2485 CLANG_DIAG_IGNORE_STMT(-Wthread-safety);
2487 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2488 STORE_LC_NUMERIC_SET_STANDARD();
2489 PerlIO_printf(Perl_debug_log,
2490 "0x%" UVxf " num(%" NVgf ")\n",
2491 PTR2UV(sv), SvNVX(sv));
2492 RESTORE_LC_NUMERIC();
2494 CLANG_DIAG_RESTORE_STMT;
2497 else if (SvTYPE(sv) < SVt_PVNV)
2498 sv_upgrade(sv, SVt_PVNV);
2503 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2504 #ifdef NV_PRESERVES_UV
2510 /* Only set the public NV OK flag if this NV preserves the IV */
2511 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2513 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2514 : (SvIVX(sv) == I_V(SvNVX(sv))))
2520 else if (SvPOKp(sv)) {
2522 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2523 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2525 #ifdef NV_PRESERVES_UV
2526 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2527 == IS_NUMBER_IN_UV) {
2528 /* It's definitely an integer */
2529 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2531 S_sv_setnv(aTHX_ sv, numtype);
2538 SvNV_set(sv, Atof(SvPVX_const(sv)));
2539 /* Only set the public NV OK flag if this NV preserves the value in
2540 the PV at least as well as an IV/UV would.
2541 Not sure how to do this 100% reliably. */
2542 /* if that shift count is out of range then Configure's test is
2543 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2545 if (((UV)1 << NV_PRESERVES_UV_BITS) > U_V(Perl_fabs(SvNVX(sv)))) {
2546 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2547 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2548 /* Can't use strtol etc to convert this string, so don't try.
2549 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2552 /* value has been set. It may not be precise. */
2553 if ((numtype & IS_NUMBER_NEG) && (value >= (UV)IV_MIN)) {
2554 /* 2s complement assumption for (UV)IV_MIN */
2555 SvNOK_on(sv); /* Integer is too negative. */
2560 if (numtype & IS_NUMBER_NEG) {
2561 /* -IV_MIN is undefined, but we should never reach
2562 * this point with both IS_NUMBER_NEG and value ==
2564 assert(value != (UV)IV_MIN);
2565 SvIV_set(sv, -(IV)value);
2566 } else if (value <= (UV)IV_MAX) {
2567 SvIV_set(sv, (IV)value);
2569 SvUV_set(sv, value);
2573 if (numtype & IS_NUMBER_NOT_INT) {
2574 /* I believe that even if the original PV had decimals,
2575 they are lost beyond the limit of the FP precision.
2576 However, neither is canonical, so both only get p
2577 flags. NWC, 2000/11/25 */
2578 /* Both already have p flags, so do nothing */
2580 const NV nv = SvNVX(sv);
2581 /* XXX should this spot have NAN_COMPARE_BROKEN, too? */
2582 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2583 if (SvIVX(sv) == I_V(nv)) {
2586 /* It had no "." so it must be integer. */
2590 /* between IV_MAX and NV(UV_MAX).
2591 Could be slightly > UV_MAX */
2593 if (numtype & IS_NUMBER_NOT_INT) {
2594 /* UV and NV both imprecise. */
2596 const UV nv_as_uv = U_V(nv);
2598 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2607 /* It might be more code efficient to go through the entire logic above
2608 and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2609 gets complex and potentially buggy, so more programmer efficient
2610 to do it this way, by turning off the public flags: */
2612 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2613 #endif /* NV_PRESERVES_UV */
2616 if (isGV_with_GP(sv)) {
2617 glob_2number(MUTABLE_GV(sv));
2621 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2623 assert (SvTYPE(sv) >= SVt_NV);
2624 /* Typically the caller expects that sv_any is not NULL now. */
2625 /* XXX Ilya implies that this is a bug in callers that assume this
2626 and ideally should be fixed. */
2629 CLANG_DIAG_IGNORE_STMT(-Wthread-safety);
2631 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2632 STORE_LC_NUMERIC_SET_STANDARD();
2633 PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2nv(%" NVgf ")\n",
2634 PTR2UV(sv), SvNVX(sv));
2635 RESTORE_LC_NUMERIC();
2637 CLANG_DIAG_RESTORE_STMT;
2644 Return an SV with the numeric value of the source SV, doing any necessary
2645 reference or overload conversion. The caller is expected to have handled
2652 Perl_sv_2num(pTHX_ SV *const sv)
2654 PERL_ARGS_ASSERT_SV_2NUM;
2659 SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2660 TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2661 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2662 return sv_2num(tmpsv);
2664 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2667 /* int2str_table: lookup table containing string representations of all
2668 * two digit numbers. For example, int2str_table.arr[0] is "00" and
2669 * int2str_table.arr[12*2] is "12".
2671 * We are going to read two bytes at a time, so we have to ensure that
2672 * the array is aligned to a 2 byte boundary. That's why it was made a
2673 * union with a dummy U16 member. */
2674 static const union {
2677 } int2str_table = {{
2678 '0', '0', '0', '1', '0', '2', '0', '3', '0', '4', '0', '5', '0', '6',
2679 '0', '7', '0', '8', '0', '9', '1', '0', '1', '1', '1', '2', '1', '3',
2680 '1', '4', '1', '5', '1', '6', '1', '7', '1', '8', '1', '9', '2', '0',
2681 '2', '1', '2', '2', '2', '3', '2', '4', '2', '5', '2', '6', '2', '7',
2682 '2', '8', '2', '9', '3', '0', '3', '1', '3', '2', '3', '3', '3', '4',
2683 '3', '5', '3', '6', '3', '7', '3', '8', '3', '9', '4', '0', '4', '1',
2684 '4', '2', '4', '3', '4', '4', '4', '5', '4', '6', '4', '7', '4', '8',
2685 '4', '9', '5', '0', '5', '1', '5', '2', '5', '3', '5', '4', '5', '5',
2686 '5', '6', '5', '7', '5', '8', '5', '9', '6', '0', '6', '1', '6', '2',
2687 '6', '3', '6', '4', '6', '5', '6', '6', '6', '7', '6', '8', '6', '9',
2688 '7', '0', '7', '1', '7', '2', '7', '3', '7', '4', '7', '5', '7', '6',
2689 '7', '7', '7', '8', '7', '9', '8', '0', '8', '1', '8', '2', '8', '3',
2690 '8', '4', '8', '5', '8', '6', '8', '7', '8', '8', '8', '9', '9', '0',
2691 '9', '1', '9', '2', '9', '3', '9', '4', '9', '5', '9', '6', '9', '7',
2695 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2696 * UV as a string towards the end of buf, and return pointers to start and
2699 * We assume that buf is at least TYPE_CHARS(UV) long.
2702 PERL_STATIC_INLINE char *
2703 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2705 char *ptr = buf + TYPE_CHARS(UV);
2706 char * const ebuf = ptr;
2708 U16 *word_ptr, *word_table;
2710 PERL_ARGS_ASSERT_UIV_2BUF;
2712 /* ptr has to be properly aligned, because we will cast it to U16* */
2713 assert(PTR2nat(ptr) % 2 == 0);
2714 /* we are going to read/write two bytes at a time */
2715 word_ptr = (U16*)ptr;
2716 word_table = (U16*)int2str_table.arr;
2718 if (UNLIKELY(is_uv))
2724 /* Using 0- here to silence bogus warning from MS VC */
2725 uv = (UV) (0 - (UV) iv);
2730 *--word_ptr = word_table[uv % 100];
2733 ptr = (char*)word_ptr;
2736 *--ptr = (char)uv + '0';
2738 *--word_ptr = word_table[uv];
2739 ptr = (char*)word_ptr;
2749 /* Helper for sv_2pv_flags and sv_vcatpvfn_flags. If the NV is an
2750 * infinity or a not-a-number, writes the appropriate strings to the
2751 * buffer, including a zero byte. On success returns the written length,
2752 * excluding the zero byte, on failure (not an infinity, not a nan)
2753 * returns zero, assert-fails on maxlen being too short.
2755 * XXX for "Inf", "-Inf", and "NaN", we could have three read-only
2756 * shared string constants we point to, instead of generating a new
2757 * string for each instance. */
2759 S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char plus) {
2761 assert(maxlen >= 4);
2762 if (Perl_isinf(nv)) {
2764 if (maxlen < 5) /* "-Inf\0" */
2774 else if (Perl_isnan(nv)) {
2778 /* XXX optionally output the payload mantissa bits as
2779 * "(unsigned)" (to match the nan("...") C99 function,
2780 * or maybe as "(0xhhh...)" would make more sense...
2781 * provide a format string so that the user can decide?
2782 * NOTE: would affect the maxlen and assert() logic.*/
2787 assert((s == buffer + 3) || (s == buffer + 4));
2794 =for apidoc_item sv_2pv_flags
2796 These implement the various forms of the L<perlapi/C<SvPV>> macros.
2797 The macros are the preferred interface.
2799 These return a pointer to the string value of an SV (coercing it to a string if
2800 necessary), and set C<*lp> to its length in bytes.
2802 The forms differ in that plain C<sv_2pvbyte> always processes 'get' magic; and
2803 C<sv_2pvbyte_flags> processes 'get' magic if and only if C<flags> contains
2806 =for apidoc Amnh||SV_GMAGIC
2812 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const U32 flags)
2816 PERL_ARGS_ASSERT_SV_2PV_FLAGS;
2818 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2819 && SvTYPE(sv) != SVt_PVFM);
2820 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2825 if (flags & SV_SKIP_OVERLOAD)
2827 tmpstr = AMG_CALLunary(sv, string_amg);
2828 TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2829 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2831 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2835 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2836 if (flags & SV_CONST_RETURN) {
2837 pv = (char *) SvPVX_const(tmpstr);
2839 pv = (flags & SV_MUTABLE_RETURN)
2840 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2843 *lp = SvCUR(tmpstr);
2845 pv = sv_2pv_flags(tmpstr, lp, flags);
2858 SV *const referent = SvRV(sv);
2862 retval = buffer = savepvn("NULLREF", len);
2863 } else if (SvTYPE(referent) == SVt_REGEXP &&
2864 (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
2865 amagic_is_enabled(string_amg))) {
2866 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2870 /* If the regex is UTF-8 we want the containing scalar to
2871 have an UTF-8 flag too */
2878 *lp = RX_WRAPLEN(re);
2880 return RX_WRAPPED(re);
2882 const char *const typestring = sv_reftype(referent, 0);
2883 const STRLEN typelen = strlen(typestring);
2884 UV addr = PTR2UV(referent);
2885 const char *stashname = NULL;
2886 STRLEN stashnamelen = 0; /* hush, gcc */
2887 const char *buffer_end;
2889 if (SvOBJECT(referent)) {
2890 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2893 stashname = HEK_KEY(name);
2894 stashnamelen = HEK_LEN(name);
2896 if (HEK_UTF8(name)) {
2902 stashname = "__ANON__";
2905 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2906 + 2 * sizeof(UV) + 2 /* )\0 */;
2908 len = typelen + 3 /* (0x */
2909 + 2 * sizeof(UV) + 2 /* )\0 */;
2912 Newx(buffer, len, char);
2913 buffer_end = retval = buffer + len;
2915 /* Working backwards */
2919 *--retval = PL_hexdigit[addr & 15];
2920 } while (addr >>= 4);
2926 memcpy(retval, typestring, typelen);
2930 retval -= stashnamelen;
2931 memcpy(retval, stashname, stashnamelen);
2933 /* retval may not necessarily have reached the start of the
2935 assert (retval >= buffer);
2937 len = buffer_end - retval - 1; /* -1 for that \0 */
2949 if (flags & SV_MUTABLE_RETURN)
2950 return SvPVX_mutable(sv);
2951 if (flags & SV_CONST_RETURN)
2952 return (char *)SvPVX_const(sv);
2957 /* I'm assuming that if both IV and NV are equally valid then
2958 converting the IV is going to be more efficient */
2959 const U32 isUIOK = SvIsUV(sv);
2960 /* The purpose of this union is to ensure that arr is aligned on
2961 a 2 byte boundary, because that is what uiv_2buf() requires */
2963 char arr[TYPE_CHARS(UV)];
2969 if (SvTYPE(sv) < SVt_PVIV)
2970 sv_upgrade(sv, SVt_PVIV);
2971 ptr = uiv_2buf(buf.arr, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2973 /* inlined from sv_setpvn */
2974 s = SvGROW_mutable(sv, len + 1);
2975 Move(ptr, s, len, char);
2978 /* We used to call SvPOK_on(). Whilst this is fine for (most) Perl code,
2979 it means that after this stringification is cached, there is no way
2980 to distinguish between values originally assigned as $a = 42; and
2981 $a = "42"; (or results of string operators vs numeric operators)
2982 where the value has subsequently been used in the other sense
2983 and had a value cached.
2984 This (somewhat) hack means that we retain the cached stringification,
2985 but don't set SVf_POK. Hence if a value is SVf_IOK|SVf_POK then it
2986 originated as "42", whereas if it's SVf_IOK then it originated as 42.
2987 (ignore SVp_IOK and SVp_POK)
2988 The SvPV macros are now updated to recognise this specific case
2989 (and that there isn't overloading or magic that could alter the
2990 cached value) and so return the cached value immediately without
2991 re-entering this function, getting back here to this block of code,
2992 and repeating the same conversion. */
2995 else if (SvNOK(sv)) {
2996 if (SvTYPE(sv) < SVt_PVNV)
2997 sv_upgrade(sv, SVt_PVNV);
2998 if (SvNVX(sv) == 0.0
2999 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3000 && !Perl_isnan(SvNVX(sv))
3003 s = SvGROW_mutable(sv, 2);
3008 STRLEN size = 5; /* "-Inf\0" */
3010 s = SvGROW_mutable(sv, size);
3011 len = S_infnan_2pv(SvNVX(sv), s, size, 0);
3017 /* some Xenix systems wipe out errno here */
3026 5 + /* exponent digits */
3030 s = SvGROW_mutable(sv, size);
3031 #ifndef USE_LOCALE_NUMERIC
3032 SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3038 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3039 STORE_LC_NUMERIC_SET_TO_NEEDED();
3041 local_radix = _NOT_IN_NUMERIC_STANDARD;
3042 if (local_radix && SvCUR(PL_numeric_radix_sv) > 1) {
3043 size += SvCUR(PL_numeric_radix_sv) - 1;
3044 s = SvGROW_mutable(sv, size);
3047 SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3049 /* If the radix character is UTF-8, and actually is in the
3050 * output, turn on the UTF-8 flag for the scalar */
3052 && SvUTF8(PL_numeric_radix_sv)
3053 && instr(s, SvPVX_const(PL_numeric_radix_sv)))
3058 RESTORE_LC_NUMERIC();
3061 /* We don't call SvPOK_on(), because it may come to
3062 * pass that the locale changes so that the
3063 * stringification we just did is no longer correct. We
3064 * will have to re-stringify every time it is needed */
3071 else if (isGV_with_GP(sv)) {
3072 GV *const gv = MUTABLE_GV(sv);
3073 SV *const buffer = sv_newmortal();
3075 gv_efullname3(buffer, gv, "*");
3077 assert(SvPOK(buffer));
3083 *lp = SvCUR(buffer);
3084 return SvPVX(buffer);
3089 if (flags & SV_UNDEF_RETURNS_NULL)
3091 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3093 /* Typically the caller expects that sv_any is not NULL now. */
3094 if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
3095 sv_upgrade(sv, SVt_PV);
3100 const STRLEN len = s - SvPVX_const(sv);
3105 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2pv(%s)\n",
3106 PTR2UV(sv),SvPVX_const(sv)));
3107 if (flags & SV_CONST_RETURN)
3108 return (char *)SvPVX_const(sv);
3109 if (flags & SV_MUTABLE_RETURN)
3110 return SvPVX_mutable(sv);
3115 =for apidoc sv_copypv
3116 =for apidoc_item sv_copypv_flags
3117 =for apidoc_item sv_copypv_nomg
3119 These copy a stringified representation of the source SV into the
3120 destination SV. They automatically perform coercion of numeric values into
3121 strings. Guaranteed to preserve the C<UTF8> flag even from overloaded objects.
3122 Similar in nature to C<sv_2pv[_flags]> but they operate directly on an SV
3123 instead of just the string. Mostly they use L</C<sv_2pv_flags>> to
3124 do the work, except when that would lose the UTF-8'ness of the PV.
3126 The three forms differ only in whether or not they perform 'get magic' on
3127 C<sv>. C<sv_copypv_nomg> skips 'get magic'; C<sv_copypv> performs it; and
3128 C<sv_copypv_flags> either performs it (if the C<SV_GMAGIC> bit is set in
3129 C<flags>) or doesn't (if that bit is cleared).
3135 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3140 PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3142 s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC));
3143 sv_setpvn(dsv,s,len);
3151 =for apidoc sv_2pvbyte
3152 =for apidoc_item sv_2pvbyte_flags
3154 These implement the various forms of the L<perlapi/C<SvPVbyte>> macros.
3155 The macros are the preferred interface.
3157 These return a pointer to the byte-encoded representation of the SV, and set
3158 C<*lp> to its length. If the SV is marked as being encoded as UTF-8, it will
3159 be downgraded, if possible, to a byte string. If the SV cannot be downgraded,
3162 The forms differ in that plain C<sv_2pvbyte> always processes 'get' magic; and
3163 C<sv_2pvbyte_flags> processes 'get' magic if and only if C<flags> contains
3166 =for apidoc Amnh||SV_GMAGIC
3172 Perl_sv_2pvbyte_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags)
3174 PERL_ARGS_ASSERT_SV_2PVBYTE_FLAGS;
3176 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
3178 if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3179 || isGV_with_GP(sv) || SvROK(sv)) {
3180 SV *sv2 = sv_newmortal();
3181 sv_copypv_nomg(sv2,sv);
3184 sv_utf8_downgrade_nomg(sv,0);
3185 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3189 =for apidoc sv_2pvutf8
3190 =for apidoc_item sv_2pvutf8_flags
3192 These implement the various forms of the L<perlapi/C<SvPVutf8>> macros.
3193 The macros are the preferred interface.
3195 These return a pointer to the UTF-8-encoded representation of the SV, and set
3196 C<*lp> to its length in bytes. They may cause the SV to be upgraded to UTF-8
3199 The forms differ in that plain C<sv_2pvutf8> always processes 'get' magic; and
3200 C<sv_2pvutf8_flags> processes 'get' magic if and only if C<flags> contains
3207 Perl_sv_2pvutf8_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags)
3209 PERL_ARGS_ASSERT_SV_2PVUTF8_FLAGS;
3211 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
3213 if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3214 || isGV_with_GP(sv) || SvROK(sv)) {
3215 SV *sv2 = sv_newmortal();
3216 sv_copypv_nomg(sv2,sv);
3219 sv_utf8_upgrade_nomg(sv);
3220 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3225 =for apidoc sv_2bool
3227 This macro is only used by C<sv_true()> or its macro equivalent, and only if
3228 the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>.
3229 It calls C<sv_2bool_flags> with the C<SV_GMAGIC> flag.
3231 =for apidoc sv_2bool_flags
3233 This function is only used by C<sv_true()> and friends, and only if
3234 the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>. If the flags
3235 contain C<SV_GMAGIC>, then it does an C<mg_get()> first.
3242 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
3244 PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3247 if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3253 SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3254 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
3257 if(SvGMAGICAL(sv)) {
3259 goto restart; /* call sv_2bool */
3261 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
3262 else if(!SvOK(sv)) {
3265 else if(SvPOK(sv)) {
3266 svb = SvPVXtrue(sv);
3268 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
3269 svb = (SvIOK(sv) && SvIVX(sv) != 0)
3270 || (SvNOK(sv) && SvNVX(sv) != 0.0);
3274 goto restart; /* call sv_2bool_nomg */
3284 RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
3286 if (SvNOK(sv) && !SvPOK(sv))
3287 return SvNVX(sv) != 0.0;
3289 return SvTRUE_common(sv, 0);
3293 =for apidoc sv_utf8_upgrade
3294 =for apidoc_item sv_utf8_upgrade_flags
3295 =for apidoc_item sv_utf8_upgrade_flags_grow
3296 =for apidoc_item sv_utf8_upgrade_nomg
3298 These convert the PV of an SV to its UTF-8-encoded form.
3299 The SV is forced to string form if it is not already.
3300 They always set the C<SvUTF8> flag to avoid future validity checks even if the
3301 whole string is the same in UTF-8 as not.
3302 They return the number of bytes in the converted string
3304 The forms differ in just two ways. The main difference is whether or not they
3305 perform 'get magic' on C<sv>. C<sv_utf8_upgrade_nomg> skips 'get magic';
3306 C<sv_utf8_upgrade> performs it; and C<sv_utf8_upgrade_flags> and
3307 C<sv_utf8_upgrade_flags_grow> either perform it (if the C<SV_GMAGIC> bit is set
3308 in C<flags>) or don't (if that bit is cleared).
3310 The other difference is that C<sv_utf8_upgrade_flags_grow> has an additional
3311 parameter, C<extra>, which allows the caller to specify an amount of space to
3312 be reserved as spare beyond what is needed for the actual conversion. This is
3313 used when the caller knows it will soon be needing yet more space, and it is
3314 more efficient to request space from the system in a single call.
3315 This form is otherwise identical to C<sv_utf8_upgrade_flags>.
3317 These are not a general purpose byte encoding to Unicode interface: use the
3318 Encode extension for that.
3320 The C<SV_FORCE_UTF8_UPGRADE> flag is now ignored.
3322 =for apidoc Amnh||SV_GMAGIC|
3323 =for apidoc Amnh||SV_FORCE_UTF8_UPGRADE|
3327 If the routine itself changes the string, it adds a trailing C<NUL>. Such a
3328 C<NUL> isn't guaranteed due to having other routines do the work in some input
3329 cases, or if the input is already flagged as being in utf8.
3334 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3336 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3338 if (sv == &PL_sv_undef)
3340 if (!SvPOK_nog(sv)) {
3342 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3343 (void) sv_2pv_flags(sv,&len, flags);
3345 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3349 (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3353 /* SVt_REGEXP's shouldn't be upgraded to UTF8 - they're already
3354 * compiled and individual nodes will remain non-utf8 even if the
3355 * stringified version of the pattern gets upgraded. Whether the
3356 * PVX of a REGEXP should be grown or we should just croak, I don't
3358 if (SvUTF8(sv) || isREGEXP(sv)) {
3359 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3364 S_sv_uncow(aTHX_ sv, 0);
3367 if (SvCUR(sv) == 0) {
3368 if (extra) SvGROW(sv, extra + 1); /* Make sure is room for a trailing
3370 } else { /* Assume Latin-1/EBCDIC */
3371 /* This function could be much more efficient if we
3372 * had a FLAG in SVs to signal if there are any variant
3373 * chars in the PV. Given that there isn't such a flag
3374 * make the loop as fast as possible. */
3375 U8 * s = (U8 *) SvPVX_const(sv);
3378 if (is_utf8_invariant_string_loc(s, SvCUR(sv), (const U8 **) &t)) {
3380 /* utf8 conversion not needed because all are invariants. Mark
3381 * as UTF-8 even if no variant - saves scanning loop */
3383 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3387 /* Here, there is at least one variant (t points to the first one), so
3388 * the string should be converted to utf8. Everything from 's' to
3389 * 't - 1' will occupy only 1 byte each on output.
3391 * Note that the incoming SV may not have a trailing '\0', as certain
3392 * code in pp_formline can send us partially built SVs.
3394 * There are two main ways to convert. One is to create a new string
3395 * and go through the input starting from the beginning, appending each
3396 * converted value onto the new string as we go along. Going this
3397 * route, it's probably best to initially allocate enough space in the
3398 * string rather than possibly running out of space and having to
3399 * reallocate and then copy what we've done so far. Since everything
3400 * from 's' to 't - 1' is invariant, the destination can be initialized
3401 * with these using a fast memory copy. To be sure to allocate enough
3402 * space, one could use the worst case scenario, where every remaining
3403 * byte expands to two under UTF-8, or one could parse it and count
3404 * exactly how many do expand.
3406 * The other way is to unconditionally parse the remainder of the
3407 * string to figure out exactly how big the expanded string will be,
3408 * growing if needed. Then start at the end of the string and place
3409 * the character there at the end of the unfilled space in the expanded
3410 * one, working backwards until reaching 't'.
3412 * The problem with assuming the worst case scenario is that for very
3413 * long strings, we could allocate much more memory than actually
3414 * needed, which can create performance problems. If we have to parse
3415 * anyway, the second method is the winner as it may avoid an extra
3416 * copy. The code used to use the first method under some
3417 * circumstances, but now that there is faster variant counting on
3418 * ASCII platforms, the second method is used exclusively, eliminating
3419 * some code that no longer has to be maintained. */
3422 /* Count the total number of variants there are. We can start
3423 * just beyond the first one, which is known to be at 't' */
3424 const Size_t invariant_length = t - s;
3425 U8 * e = (U8 *) SvEND(sv);
3427 /* The length of the left overs, plus 1. */
3428 const Size_t remaining_length_p1 = e - t;
3430 /* We expand by 1 for the variant at 't' and one for each remaining
3431 * variant (we start looking at 't+1') */
3432 Size_t expansion = 1 + variant_under_utf8_count(t + 1, e);
3434 /* +1 = trailing NUL */
3435 Size_t need = SvCUR(sv) + expansion + extra + 1;
3438 /* Grow if needed */
3439 if (SvLEN(sv) < need) {
3440 t = invariant_length + (U8*) SvGROW(sv, need);
3441 e = t + remaining_length_p1;
3443 SvCUR_set(sv, invariant_length + remaining_length_p1 + expansion);
3445 /* Set the NUL at the end */
3446 d = (U8 *) SvEND(sv);
3449 /* Having decremented d, it points to the position to put the
3450 * very last byte of the expanded string. Go backwards through
3451 * the string, copying and expanding as we go, stopping when we
3452 * get to the part that is invariant the rest of the way down */
3456 if (NATIVE_BYTE_IS_INVARIANT(*e)) {
3459 *d-- = UTF8_EIGHT_BIT_LO(*e);
3460 *d-- = UTF8_EIGHT_BIT_HI(*e);
3465 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3466 /* Update pos. We do it at the end rather than during
3467 * the upgrade, to avoid slowing down the common case
3468 * (upgrade without pos).
3469 * pos can be stored as either bytes or characters. Since
3470 * this was previously a byte string we can just turn off
3471 * the bytes flag. */
3472 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3474 mg->mg_flags &= ~MGf_BYTES;
3476 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3477 magic_setutf8(sv,mg); /* clear UTF8 cache */
3487 =for apidoc sv_utf8_downgrade
3488 =for apidoc_item sv_utf8_downgrade_flags
3489 =for apidoc_item sv_utf8_downgrade_nomg
3491 These attempt to convert the PV of an SV from characters to bytes. If the PV
3492 contains a character that cannot fit in a byte, this conversion will fail; in
3493 this case, C<FALSE> is returned if C<fail_ok> is true; otherwise they croak.
3495 They are not a general purpose Unicode to byte encoding interface:
3496 use the C<Encode> extension for that.
3498 They differ only in that:
3500 C<sv_utf8_downgrade> processes 'get' magic on C<sv>.
3502 C<sv_utf8_downgrade_nomg> does not.
3504 C<sv_utf8_downgrade_flags> has an additional C<flags> parameter in which you can specify
3505 C<SV_GMAGIC> to process 'get' magic, or leave it cleared to not process 'get' magic.
3511 Perl_sv_utf8_downgrade_flags(pTHX_ SV *const sv, const bool fail_ok, const U32 flags)
3513 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE_FLAGS;
3515 if (SvPOKp(sv) && SvUTF8(sv)) {
3519 U32 mg_flags = flags & SV_GMAGIC;
3522 S_sv_uncow(aTHX_ sv, 0);
3524 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3526 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3527 if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
3528 mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
3529 mg_flags|SV_CONST_RETURN);
3530 mg_flags = 0; /* sv_pos_b2u does get magic */
3532 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3533 magic_setutf8(sv,mg); /* clear UTF8 cache */
3536 s = (U8 *) SvPV_flags(sv, len, mg_flags);
3538 if (!utf8_to_bytes(s, &len)) {
3543 Perl_croak(aTHX_ "Wide character in %s",
3546 Perl_croak(aTHX_ "Wide character");
3557 =for apidoc sv_utf8_encode
3559 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3560 flag off so that it looks like octets again.
3566 Perl_sv_utf8_encode(pTHX_ SV *const sv)
3568 PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3570 if (SvREADONLY(sv)) {
3571 sv_force_normal_flags(sv, 0);
3573 (void) sv_utf8_upgrade(sv);
3578 =for apidoc sv_utf8_decode
3580 If the PV of the SV is an octet sequence in Perl's extended UTF-8
3581 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3582 so that it looks like a character. If the PV contains only single-byte
3583 characters, the C<SvUTF8> flag stays off.
3584 Scans PV for validity and returns FALSE if the PV is invalid UTF-8.
3590 Perl_sv_utf8_decode(pTHX_ SV *const sv)
3592 PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3595 const U8 *start, *c, *first_variant;
3597 /* The octets may have got themselves encoded - get them back as
3600 if (!sv_utf8_downgrade(sv, TRUE))
3603 /* it is actually just a matter of turning the utf8 flag on, but
3604 * we want to make sure everything inside is valid utf8 first.
3606 c = start = (const U8 *) SvPVX_const(sv);
3607 if (! is_utf8_invariant_string_loc(c, SvCUR(sv), &first_variant)) {
3608 if (!is_utf8_string(first_variant, SvCUR(sv) - (first_variant -c)))
3612 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3613 /* XXX Is this dead code? XS_utf8_decode calls SvSETMAGIC
3614 after this, clearing pos. Does anything on CPAN
3616 /* adjust pos to the start of a UTF8 char sequence */
3617 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3619 I32 pos = mg->mg_len;
3621 for (c = start + pos; c > start; c--) {
3622 if (UTF8_IS_START(*c))
3625 mg->mg_len = c - start;
3628 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3629 magic_setutf8(sv,mg); /* clear UTF8 cache */
3636 =for apidoc sv_setsv
3637 =for apidoc_item sv_setsv_flags
3638 =for apidoc_item sv_setsv_mg
3639 =for apidoc_item sv_setsv_nomg
3641 These copy the contents of the source SV C<ssv> into the destination SV C<dsv>.
3642 C<ssv> may be destroyed if it is mortal, so don't use these functions if
3643 the source SV needs to be reused.
3644 Loosely speaking, they perform a copy-by-value, obliterating any previous
3645 content of the destination.
3647 They differ only in that:
3649 C<sv_setsv> calls 'get' magic on C<ssv>, but skips 'set' magic on C<dsv>.
3651 C<sv_setsv_mg> calls both 'get' magic on C<ssv> and 'set' magic on C<dsv>.
3653 C<sv_setsv_nomg> skips all magic.
3655 C<sv_setsv_flags> has a C<flags> parameter which you can use to specify any
3656 combination of magic handling, and also you can specify C<SV_NOSTEAL> so that
3657 the buffers of temps will not be stolen.
3659 You probably want to instead use one of the assortment of wrappers, such as
3660 C<L</SvSetSV>>, C<L</SvSetSV_nosteal>>, C<L</SvSetMagicSV>> and
3661 C<L</SvSetMagicSV_nosteal>>.
3663 C<sv_setsv_flags> is the primary function for copying scalars, and most other
3664 copy-ish functions and macros use it underneath.
3666 =for apidoc Amnh||SV_NOSTEAL
3672 S_glob_assign_glob(pTHX_ SV *const dsv, SV *const ssv, const int dtype)
3674 I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3675 HV *old_stash = NULL;
3677 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3679 if (dtype != SVt_PVGV && !isGV_with_GP(dsv)) {
3680 const char * const name = GvNAME(ssv);
3681 const STRLEN len = GvNAMELEN(ssv);
3683 if (dtype >= SVt_PV) {
3689 SvUPGRADE(dsv, SVt_PVGV);
3690 (void)SvOK_off(dsv);
3691 isGV_with_GP_on(dsv);
3693 GvSTASH(dsv) = GvSTASH(ssv);
3695 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dsv)), dsv);
3696 gv_name_set(MUTABLE_GV(dsv), name, len,
3697 GV_ADD | (GvNAMEUTF8(ssv) ? SVf_UTF8 : 0 ));
3698 SvFAKE_on(dsv); /* can coerce to non-glob */
3701 if(GvGP(MUTABLE_GV(ssv))) {
3702 /* If source has method cache entry, clear it */
3704 SvREFCNT_dec(GvCV(ssv));
3705 GvCV_set(ssv, NULL);
3708 /* If source has a real method, then a method is
3711 GvCV((const GV *)ssv) && GvSTASH(dsv) && HvENAME(GvSTASH(dsv))
3717 /* If dest already had a real method, that's a change as well */
3719 !mro_changes && GvGP(MUTABLE_GV(dsv)) && GvCVu((const GV *)dsv)
3720 && GvSTASH(dsv) && HvENAME(GvSTASH(dsv))
3725 /* We don't need to check the name of the destination if it was not a
3726 glob to begin with. */
3727 if(dtype == SVt_PVGV) {
3728 const char * const name = GvNAME((const GV *)dsv);
3729 const STRLEN len = GvNAMELEN(dsv);
3730 if(memEQs(name, len, "ISA")
3731 /* The stash may have been detached from the symbol table, so
3733 && GvSTASH(dsv) && HvENAME(GvSTASH(dsv))
3737 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3738 || (len == 1 && name[0] == ':')) {
3741 /* Set aside the old stash, so we can reset isa caches on
3743 if((old_stash = GvHV(dsv)))
3744 /* Make sure we do not lose it early. */
3745 SvREFCNT_inc_simple_void_NN(
3746 sv_2mortal((SV *)old_stash)
3751 SvREFCNT_inc_simple_void_NN(sv_2mortal(dsv));
3754 /* freeing dsv's GP might free ssv (e.g. *x = $x),
3755 * so temporarily protect it */
3757 SAVEFREESV(SvREFCNT_inc_simple_NN(ssv));
3758 gp_free(MUTABLE_GV(dsv));
3759 GvINTRO_off(dsv); /* one-shot flag */
3760 GvGP_set(dsv, gp_ref(GvGP(ssv)));
3765 if (GvIMPORTED(dsv) != GVf_IMPORTED
3766 && CopSTASH_ne(PL_curcop, GvSTASH(dsv)))
3771 if(mro_changes == 2) {
3772 if (GvAV((const GV *)ssv)) {
3774 SV * const sref = (SV *)GvAV((const GV *)dsv);
3775 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3776 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3777 AV * const ary = newAV_alloc_x(2);
3778 av_push_simple(ary, mg->mg_obj); /* takes the refcount */
3779 av_push_simple(ary, SvREFCNT_inc_simple_NN(dsv));
3780 mg->mg_obj = (SV *)ary;
3782 av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dsv));
3785 else sv_magic(sref, dsv, PERL_MAGIC_isa, NULL, 0);
3787 mro_isa_changed_in(GvSTASH(dsv));
3789 else if(mro_changes == 3) {
3790 HV * const stash = GvHV(dsv);
3791 if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3797 else if(mro_changes) mro_method_changed_in(GvSTASH(dsv));
3798 if (GvIO(dsv) && dtype == SVt_PVGV) {
3799 DEBUG_o(Perl_deb(aTHX_
3800 "glob_assign_glob clearing PL_stashcache\n"));
3801 /* It's a cache. It will rebuild itself quite happily.
3802 It's a lot of effort to work out exactly which key (or keys)
3803 might be invalidated by the creation of the this file handle.
3805 hv_clear(PL_stashcache);
3811 Perl_gv_setref(pTHX_ SV *const dsv, SV *const ssv)
3813 SV * const sref = SvRV(ssv);
3815 const int intro = GvINTRO(dsv);
3818 const U32 stype = SvTYPE(sref);
3820 PERL_ARGS_ASSERT_GV_SETREF;
3823 GvINTRO_off(dsv); /* one-shot flag */
3824 GvLINE(dsv) = CopLINE(PL_curcop);
3825 GvEGV(dsv) = MUTABLE_GV(dsv);
3830 location = (SV **) &(GvGP(dsv)->gp_cv); /* XXX bypassing GvCV_set */
3831 import_flag = GVf_IMPORTED_CV;
3834 location = (SV **) &GvHV(dsv);
3835 import_flag = GVf_IMPORTED_HV;
3838 location = (SV **) &GvAV(dsv);
3839 import_flag = GVf_IMPORTED_AV;
3842 location = (SV **) &GvIOp(dsv);
3845 location = (SV **) &GvFORM(dsv);
3848 location = &GvSV(dsv);
3849 import_flag = GVf_IMPORTED_SV;
3852 if (stype == SVt_PVCV) {
3853 /*if (GvCVGEN(dsv) && (GvCV(dsv) != (const CV *)sref || GvCVGEN(dsv))) {*/
3855 SvREFCNT_dec(GvCV(dsv));
3856 GvCV_set(dsv, NULL);
3857 GvCVGEN(dsv) = 0; /* Switch off cacheness. */
3860 /* SAVEt_GVSLOT takes more room on the savestack and has more
3861 overhead in leave_scope than SAVEt_GENERIC_SV. But for CVs
3862 leave_scope needs access to the GV so it can reset method
3863 caches. We must use SAVEt_GVSLOT whenever the type is
3864 SVt_PVCV, even if the stash is anonymous, as the stash may
3865 gain a name somehow before leave_scope. */
3866 if (stype == SVt_PVCV) {
3867 /* There is no save_pushptrptrptr. Creating it for this
3868 one call site would be overkill. So inline the ss add
3872 SS_ADD_PTR(location);
3873 SS_ADD_PTR(SvREFCNT_inc(*location));
3874 SS_ADD_UV(SAVEt_GVSLOT);
3877 else SAVEGENERICSV(*location);
3880 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dsv))) {
3881 CV* const cv = MUTABLE_CV(*location);
3883 if (!GvCVGEN((const GV *)dsv) &&
3884 (CvROOT(cv) || CvXSUB(cv)) &&
3885 /* redundant check that avoids creating the extra SV
3886 most of the time: */
3887 (CvCONST(cv) || (ckWARN(WARN_REDEFINE) && !intro)))
3889 SV * const new_const_sv =
3890 CvCONST((const CV *)sref)
3891 ? cv_const_sv((const CV *)sref)
3893 HV * const stash = GvSTASH((const GV *)dsv);
3894 report_redefined_cv(
3897 ? Perl_newSVpvf(aTHX_
3898 "%" HEKf "::%" HEKf,
3899 HEKfARG(HvNAME_HEK(stash)),
3900 HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv))))
3901 : Perl_newSVpvf(aTHX_
3903 HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv))))
3906 CvCONST((const CV *)sref) ? &new_const_sv : NULL
3910 cv_ckproto_len_flags(cv, (const GV *)dsv,
3911 SvPOK(sref) ? CvPROTO(sref) : NULL,
3912 SvPOK(sref) ? CvPROTOLEN(sref) : 0,
3913 SvPOK(sref) ? SvUTF8(sref) : 0);
3915 GvCVGEN(dsv) = 0; /* Switch off cacheness. */
3917 if(GvSTASH(dsv)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3918 if (intro && GvREFCNT(dsv) > 1) {
3919 /* temporary remove extra savestack's ref */
3921 gv_method_changed(dsv);
3924 else gv_method_changed(dsv);
3927 *location = SvREFCNT_inc_simple_NN(sref);
3928 if (import_flag && !(GvFLAGS(dsv) & import_flag)
3929 && CopSTASH_ne(PL_curcop, GvSTASH(dsv))) {
3930 GvFLAGS(dsv) |= import_flag;
3933 if (stype == SVt_PVHV) {
3934 const char * const name = GvNAME((GV*)dsv);
3935 const STRLEN len = GvNAMELEN(dsv);
3938 (len > 1 && name[len-2] == ':' && name[len-1] == ':')
3939 || (len == 1 && name[0] == ':')
3941 && (!dref || HvENAME_get(dref))
3944 (HV *)sref, (HV *)dref,
3950 stype == SVt_PVAV && sref != dref
3951 && memEQs(GvNAME((GV*)dsv), GvNAMELEN((GV*)dsv), "ISA")
3952 /* The stash may have been detached from the symbol table, so
3953 check its name before doing anything. */
3954 && GvSTASH(dsv) && HvENAME(GvSTASH(dsv))
3957 MAGIC * const omg = dref && SvSMAGICAL(dref)
3958 ? mg_find(dref, PERL_MAGIC_isa)
3960 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3961 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3962 AV * const ary = newAV_alloc_xz(4);
3963 av_push_simple(ary, mg->mg_obj); /* takes the refcount */
3964 mg->mg_obj = (SV *)ary;
3967 if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
3968 SV **svp = AvARRAY((AV *)omg->mg_obj);
3969 I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
3973 SvREFCNT_inc_simple_NN(*svp++)
3979 SvREFCNT_inc_simple_NN(omg->mg_obj)
3983 av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dsv));
3989 sref, omg ? omg->mg_obj : dsv, PERL_MAGIC_isa, NULL, 0
3991 for (i = 0; i <= AvFILL(sref); ++i) {
3992 SV **elem = av_fetch ((AV*)sref, i, 0);
3995 *elem, sref, PERL_MAGIC_isaelem, NULL, i
3999 mg = mg_find(sref, PERL_MAGIC_isa);
4001 /* Since the *ISA assignment could have affected more than
4002 one stash, don't call mro_isa_changed_in directly, but let
4003 magic_clearisa do it for us, as it already has the logic for
4004 dealing with globs vs arrays of globs. */
4006 Perl_magic_clearisa(aTHX_ NULL, mg);
4008 else if (stype == SVt_PVIO) {
4009 DEBUG_o(Perl_deb(aTHX_ "gv_setref clearing PL_stashcache\n"));
4010 /* It's a cache. It will rebuild itself quite happily.
4011 It's a lot of effort to work out exactly which key (or keys)
4012 might be invalidated by the creation of the this file handle.
4014 hv_clear(PL_stashcache);
4018 if (!intro) SvREFCNT_dec(dref);
4027 #ifdef PERL_DEBUG_READONLY_COW
4028 # include <sys/mman.h>
4030 # ifndef PERL_MEMORY_DEBUG_HEADER_SIZE
4031 # define PERL_MEMORY_DEBUG_HEADER_SIZE 0
4035 Perl_sv_buf_to_ro(pTHX_ SV *sv)
4037 struct perl_memory_debug_header * const header =
4038 (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4039 const MEM_SIZE len = header->size;
4040 PERL_ARGS_ASSERT_SV_BUF_TO_RO;
4041 # ifdef PERL_TRACK_MEMPOOL
4042 if (!header->readonly) header->readonly = 1;
4044 if (mprotect(header, len, PROT_READ))
4045 Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
4046 header, len, errno);
4050 S_sv_buf_to_rw(pTHX_ SV *sv)
4052 struct perl_memory_debug_header * const header =
4053 (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4054 const MEM_SIZE len = header->size;
4055 PERL_ARGS_ASSERT_SV_BUF_TO_RW;
4056 if (mprotect(header, len, PROT_READ|PROT_WRITE))
4057 Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
4058 header, len, errno);
4059 # ifdef PERL_TRACK_MEMPOOL
4060 header->readonly = 0;
4065 # define sv_buf_to_ro(sv) NOOP
4066 # define sv_buf_to_rw(sv) NOOP
4070 Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags)
4075 unsigned int both_type;
4077 PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
4079 if (UNLIKELY( ssv == dsv ))
4082 if (UNLIKELY( !ssv ))
4085 stype = SvTYPE(ssv);
4086 dtype = SvTYPE(dsv);
4087 both_type = (stype | dtype);
4089 /* with these values, we can check that both SVs are NULL/IV (and not
4090 * freed) just by testing the or'ed types */
4091 STATIC_ASSERT_STMT(SVt_NULL == 0);
4092 STATIC_ASSERT_STMT(SVt_IV == 1);
4093 if (both_type <= 1) {
4094 /* both src and dst are UNDEF/IV/RV, so we can do a lot of
4100 /* minimal subset of SV_CHECK_THINKFIRST_COW_DROP(dsv) */
4101 if (SvREADONLY(dsv))
4102 Perl_croak_no_modify();
4105 sv_unref_flags(dsv, 0);
4110 assert(!SvGMAGICAL(ssv));
4111 assert(!SvGMAGICAL(dsv));
4113 sflags = SvFLAGS(ssv);
4114 if (sflags & (SVf_IOK|SVf_ROK)) {
4115 SET_SVANY_FOR_BODYLESS_IV(dsv);
4116 new_dflags = SVt_IV;
4118 if (sflags & SVf_ROK) {
4119 dsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(ssv));
4120 new_dflags |= SVf_ROK;
4123 /* both src and dst are <= SVt_IV, so sv_any points to the
4124 * head; so access the head directly
4126 assert( &(ssv->sv_u.svu_iv)
4127 == &(((XPVIV*) SvANY(ssv))->xiv_iv));
4128 assert( &(dsv->sv_u.svu_iv)
4129 == &(((XPVIV*) SvANY(dsv))->xiv_iv));
4130 dsv->sv_u.svu_iv = ssv->sv_u.svu_iv;
4131 new_dflags |= (SVf_IOK|SVp_IOK|(sflags & SVf_IVisUV));
4135 new_dflags = dtype; /* turn off everything except the type */
4137 SvFLAGS(dsv) = new_dflags;
4138 SvREFCNT_dec(old_rv);
4143 if (UNLIKELY(both_type == SVTYPEMASK)) {
4144 if (SvIS_FREED(dsv)) {
4145 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
4146 " to a freed scalar %p", SVfARG(ssv), (void *)dsv);
4148 if (SvIS_FREED(ssv)) {
4149 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
4150 (void*)ssv, (void*)dsv);
4156 SV_CHECK_THINKFIRST_COW_DROP(dsv);
4157 dtype = SvTYPE(dsv); /* THINKFIRST may have changed type */
4159 /* There's a lot of redundancy below but we're going for speed here */
4164 if (LIKELY( dtype != SVt_PVGV && dtype != SVt_PVLV )) {
4165 (void)SvOK_off(dsv);
4173 /* For performance, we inline promoting to type SVt_IV. */
4174 /* We're starting from SVt_NULL, so provided that define is
4175 * actual 0, we don't have to unset any SV type flags
4176 * to promote to SVt_IV. */
4177 STATIC_ASSERT_STMT(SVt_NULL == 0);
4178 SET_SVANY_FOR_BODYLESS_IV(dsv);
4179 SvFLAGS(dsv) |= SVt_IV;
4183 sv_upgrade(dsv, SVt_PVIV);
4187 goto end_of_first_switch;
4189 (void)SvIOK_only(dsv);
4190 SvIV_set(dsv, SvIVX(ssv));
4193 /* SvTAINTED can only be true if the SV has taint magic, which in
4194 turn means that the SV type is PVMG (or greater). This is the
4195 case statement for SVt_IV, so this cannot be true (whatever gcov
4197 assert(!SvTAINTED(ssv));
4202 if (dtype < SVt_PV && dtype != SVt_IV)
4203 sv_upgrade(dsv, SVt_IV);
4207 if (LIKELY( SvNOK(ssv) )) {
4211 sv_upgrade(dsv, SVt_NV);
4215 sv_upgrade(dsv, SVt_PVNV);
4219 goto end_of_first_switch;
4221 SvNV_set(dsv, SvNVX(ssv));
4222 (void)SvNOK_only(dsv);
4223 /* SvTAINTED can only be true if the SV has taint magic, which in
4224 turn means that the SV type is PVMG (or greater). This is the
4225 case statement for SVt_NV, so this cannot be true (whatever gcov
4227 assert(!SvTAINTED(ssv));
4234 sv_upgrade(dsv, SVt_PV);
4237 if (dtype < SVt_PVIV)
4238 sv_upgrade(dsv, SVt_PVIV);
4241 if (dtype < SVt_PVNV)
4242 sv_upgrade(dsv, SVt_PVNV);
4246 invlist_clone(ssv, dsv);
4250 const char * const type = sv_reftype(ssv,0);
4252 /* diag_listed_as: Bizarre copy of %s */
4253 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4255 Perl_croak(aTHX_ "Bizarre copy of %s", type);
4257 NOT_REACHED; /* NOTREACHED */
4261 if (dtype < SVt_REGEXP)
4262 sv_upgrade(dsv, SVt_REGEXP);
4268 if (SvGMAGICAL(ssv) && (flags & SV_GMAGIC)) {
4270 if (SvTYPE(ssv) != stype)
4271 stype = SvTYPE(ssv);
4273 if (isGV_with_GP(ssv) && dtype <= SVt_PVLV) {
4274 glob_assign_glob(dsv, ssv, dtype);
4277 if (stype == SVt_PVLV)
4279 if (isREGEXP(ssv)) goto upgregexp;
4280 SvUPGRADE(dsv, SVt_PVNV);
4283 SvUPGRADE(dsv, (svtype)stype);
4285 end_of_first_switch:
4287 /* dsv may have been upgraded. */
4288 dtype = SvTYPE(dsv);
4289 sflags = SvFLAGS(ssv);
4291 if (UNLIKELY( dtype == SVt_PVCV )) {
4292 /* Assigning to a subroutine sets the prototype. */
4295 const char *const ptr = SvPV_const(ssv, len);
4297 SvGROW(dsv, len + 1);
4298 Copy(ptr, SvPVX(dsv), len + 1, char);
4299 SvCUR_set(dsv, len);
4301 SvFLAGS(dsv) |= sflags & SVf_UTF8;
4302 CvAUTOLOAD_off(dsv);
4307 else if (UNLIKELY(dtype == SVt_PVAV || dtype == SVt_PVHV
4308 || dtype == SVt_PVFM))
4310 const char * const type = sv_reftype(dsv,0);
4312 /* diag_listed_as: Cannot copy to %s */
4313 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4315 Perl_croak(aTHX_ "Cannot copy to %s", type);
4316 } else if (sflags & SVf_ROK) {
4317 if (isGV_with_GP(dsv)
4318 && SvTYPE(SvRV(ssv)) == SVt_PVGV && isGV_with_GP(SvRV(ssv))) {
4321 if (GvIMPORTED(dsv) != GVf_IMPORTED
4322 && CopSTASH_ne(PL_curcop, GvSTASH(dsv)))
4329 glob_assign_glob(dsv, ssv, dtype);
4333 if (dtype >= SVt_PV) {
4334 if (isGV_with_GP(dsv)) {
4335 gv_setref(dsv, ssv);
4338 if (SvPVX_const(dsv)) {
4344 (void)SvOK_off(dsv);
4345 SvRV_set(dsv, SvREFCNT_inc(SvRV(ssv)));
4346 SvFLAGS(dsv) |= sflags & SVf_ROK;
4347 assert(!(sflags & SVp_NOK));
4348 assert(!(sflags & SVp_IOK));
4349 assert(!(sflags & SVf_NOK));
4350 assert(!(sflags & SVf_IOK));
4352 else if (isGV_with_GP(dsv)) {
4353 if (!(sflags & SVf_OK)) {
4354 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4355 "Undefined value assigned to typeglob");
4358 GV *gv = gv_fetchsv_nomg(ssv, GV_ADD, SVt_PVGV);
4359 if (dsv != (const SV *)gv) {
4360 const char * const name = GvNAME((const GV *)dsv);
4361 const STRLEN len = GvNAMELEN(dsv);
4362 HV *old_stash = NULL;
4363 bool reset_isa = FALSE;
4364 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4365 || (len == 1 && name[0] == ':')) {
4366 /* Set aside the old stash, so we can reset isa caches
4367 on its subclasses. */
4368 if((old_stash = GvHV(dsv))) {
4369 /* Make sure we do not lose it early. */
4370 SvREFCNT_inc_simple_void_NN(
4371 sv_2mortal((SV *)old_stash)
4378 SvREFCNT_inc_simple_void_NN(sv_2mortal(dsv));
4379 gp_free(MUTABLE_GV(dsv));
4381 GvGP_set(dsv, gp_ref(GvGP(gv)));
4384 HV * const stash = GvHV(dsv);
4386 old_stash ? (HV *)HvENAME_get(old_stash) : stash
4396 else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4397 && (stype == SVt_REGEXP || isREGEXP(ssv))) {
4398 reg_temp_copy((REGEXP*)dsv, (REGEXP*)ssv);
4400 else if (sflags & SVp_POK) {
4401 const STRLEN cur = SvCUR(ssv);
4402 const STRLEN len = SvLEN(ssv);
4405 * We have three basic ways to copy the string:
4411 * Which we choose is based on various factors. The following
4412 * things are listed in order of speed, fastest to slowest:
4414 * - Copying a short string
4415 * - Copy-on-write bookkeeping
4417 * - Copying a long string
4419 * We swipe the string (steal the string buffer) if the SV on the
4420 * rhs is about to be freed anyway (TEMP and refcnt==1). This is a
4421 * big win on long strings. It should be a win on short strings if
4422 * SvPVX_const(dsv) has to be allocated. If not, it should not
4423 * slow things down, as SvPVX_const(ssv) would have been freed
4426 * We also steal the buffer from a PADTMP (operator target) if it
4427 * is ‘long enough’. For short strings, a swipe does not help
4428 * here, as it causes more malloc calls the next time the target
4429 * is used. Benchmarks show that even if SvPVX_const(dsv) has to
4430 * be allocated it is still not worth swiping PADTMPs for short
4431 * strings, as the savings here are small.
4433 * If swiping is not an option, then we see whether it is
4434 * worth using copy-on-write. If the lhs already has a buf-
4435 * fer big enough and the string is short, we skip it and fall back
4436 * to method 3, since memcpy is faster for short strings than the
4437 * later bookkeeping overhead that copy-on-write entails.
4439 * If the rhs is not a copy-on-write string yet, then we also
4440 * consider whether the buffer is too large relative to the string
4441 * it holds. Some operations such as readline allocate a large
4442 * buffer in the expectation of reusing it. But turning such into
4443 * a COW buffer is counter-productive because it increases memory
4444 * usage by making readline allocate a new large buffer the sec-
4445 * ond time round. So, if the buffer is too large, again, we use
4448 * Finally, if there is no buffer on the left, or the buffer is too
4449 * small, then we use copy-on-write and make both SVs share the
4454 /* Whichever path we take through the next code, we want this true,
4455 and doing it now facilitates the COW check. */
4456 (void)SvPOK_only(dsv);
4460 /* slated for free anyway (and not COW)? */
4461 (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
4462 /* or a swipable TARG */
4464 (SVs_PADTMP|SVf_READONLY|SVf_PROTECT|SVf_IsCOW))
4466 /* whose buffer is worth stealing */
4467 && CHECK_COWBUF_THRESHOLD(cur,len)
4470 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4471 (!(flags & SV_NOSTEAL)) &&
4472 /* and we're allowed to steal temps */
4473 SvREFCNT(ssv) == 1 && /* and no other references to it? */
4474 len) /* and really is a string */
4475 { /* Passes the swipe test. */
4476 if (SvPVX_const(dsv)) /* we know that dtype >= SVt_PV */
4478 SvPV_set(dsv, SvPVX_mutable(ssv));
4479 SvLEN_set(dsv, SvLEN(ssv));
4480 SvCUR_set(dsv, SvCUR(ssv));
4483 (void)SvOK_off(ssv); /* NOTE: nukes most SvFLAGS on ssv */
4484 SvPV_set(ssv, NULL);
4489 /* We must check for SvIsCOW_static() even without
4490 * SV_COW_SHARED_HASH_KEYS being set or else we'll break SvIsBOOL()
4492 else if (SvIsCOW_static(ssv)) {
4493 if (SvPVX_const(dsv)) { /* we know that dtype >= SVt_PV */
4496 SvPV_set(dsv, SvPVX(ssv));
4498 SvCUR_set(dsv, cur);
4499 SvFLAGS(dsv) |= (SVf_IsCOW|SVppv_STATIC);
4501 else if (flags & SV_COW_SHARED_HASH_KEYS
4503 #ifdef PERL_COPY_ON_WRITE
4506 ( (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dsv) < cur+1)
4507 /* If this is a regular (non-hek) COW, only so
4508 many COW "copies" are possible. */
4509 && CowREFCNT(ssv) != SV_COW_REFCNT_MAX ))
4510 : ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4511 && !(SvFLAGS(dsv) & SVf_BREAK)
4512 && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len
4513 && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dsv) < cur+1)
4517 && !(SvFLAGS(dsv) & SVf_BREAK)
4520 /* Either it's a shared hash key, or it's suitable for
4524 PerlIO_printf(Perl_debug_log, "Copy on write: ssv --> dsv\n");
4530 if (!(sflags & SVf_IsCOW)) {
4535 if (SvPVX_const(dsv)) { /* we know that dtype >= SVt_PV */
4541 if (sflags & SVf_IsCOW) {
4545 SvPV_set(dsv, SvPVX_mutable(ssv));
4550 /* SvIsCOW_shared_hash */
4551 DEBUG_C(PerlIO_printf(Perl_debug_log,
4552 "Copy on write: Sharing hash\n"));
4554 assert (SvTYPE(dsv) >= SVt_PV);
4556 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv)))));
4558 SvLEN_set(dsv, len);
4559 SvCUR_set(dsv, cur);
4562 /* Failed the swipe test, and we cannot do copy-on-write either.
4563 Have to copy the string. */
4564 SvGROW(dsv, cur + 1); /* inlined from sv_setpvn */
4565 Move(SvPVX_const(ssv),SvPVX(dsv),cur,char);
4566 SvCUR_set(dsv, cur);
4569 if (sflags & SVp_NOK) {
4570 SvNV_set(dsv, SvNVX(ssv));
4571 if ((sflags & SVf_NOK) && !(sflags & SVf_POK)) {
4572 /* Source was SVf_NOK|SVp_NOK|SVp_POK but not SVf_POK, meaning
4573 a value set as floating point and later stringified, where
4574 the value happens to be one of the few that we know aren't
4575 affected by the numeric locale, hence we can cache the
4576 stringification. Currently that's +Inf, -Inf and NaN, but
4577 conceivably we might extend this to -9 .. +9 (excluding -0).
4578 So mark destination the same: */
4579 SvFLAGS(dsv) &= ~SVf_POK;
4582 if (sflags & SVp_IOK) {
4583 SvIV_set(dsv, SvIVX(ssv));
4584 if (sflags & SVf_IVisUV)
4586 if ((sflags & SVf_IOK) && !(sflags & SVf_POK)) {
4587 /* Source was SVf_IOK|SVp_IOK|SVp_POK but not SVf_POK, meaning
4588 a value set as an integer and later stringified. So mark
4589 destination the same: */
4590 SvFLAGS(dsv) &= ~SVf_POK;
4593 SvFLAGS(dsv) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4595 const MAGIC * const smg = SvVSTRING_mg(ssv);
4597 sv_magic(dsv, NULL, PERL_MAGIC_vstring,
4598 smg->mg_ptr, smg->mg_len);
4603 else if (sflags & (SVp_IOK|SVp_NOK)) {
4604 (void)SvOK_off(dsv);
4605 SvFLAGS(dsv) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4606 if (sflags & SVp_IOK) {
4607 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4608 SvIV_set(dsv, SvIVX(ssv));
4610 if (sflags & SVp_NOK) {
4611 SvNV_set(dsv, SvNVX(ssv));
4615 if (isGV_with_GP(ssv)) {
4616 gv_efullname3(dsv, MUTABLE_GV(ssv), "*");
4619 (void)SvOK_off(dsv);
4627 =for apidoc sv_set_undef
4629 Equivalent to C<sv_setsv(sv, &PL_sv_undef)>, but more efficient.
4630 Doesn't handle set magic.
4632 The perl equivalent is C<$sv = undef;>. Note that it doesn't free any string
4633 buffer, unlike C<undef $sv>.
4635 Introduced in perl 5.25.12.
4641 Perl_sv_set_undef(pTHX_ SV *sv)
4643 U32 type = SvTYPE(sv);
4645 PERL_ARGS_ASSERT_SV_SET_UNDEF;
4647 /* shortcut, NULL, IV, RV */
4649 if (type <= SVt_IV) {
4650 assert(!SvGMAGICAL(sv));
4651 if (SvREADONLY(sv)) {
4652 /* does undeffing PL_sv_undef count as modifying a read-only
4653 * variable? Some XS code does this */
4654 if (sv == &PL_sv_undef)
4656 Perl_croak_no_modify();
4661 sv_unref_flags(sv, 0);
4664 SvFLAGS(sv) = type; /* quickly turn off all flags */
4665 SvREFCNT_dec_NN(rv);
4669 SvFLAGS(sv) = type; /* quickly turn off all flags */
4674 Perl_croak(aTHX_ "panic: attempt to undefine a freed scalar %p",
4677 SV_CHECK_THINKFIRST_COW_DROP(sv);
4679 if (isGV_with_GP(sv))
4680 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4681 "Undefined value assigned to typeglob");
4687 =for apidoc sv_set_true
4689 Equivalent to C<sv_setsv(sv, &PL_sv_yes)>, but may be made more
4690 efficient in the future. Doesn't handle set magic.
4692 The perl equivalent is C<$sv = !0;>.
4694 Introduced in perl 5.35.11.
4700 Perl_sv_set_true(pTHX_ SV *sv)
4702 PERL_ARGS_ASSERT_SV_SET_TRUE;
4703 sv_setsv(sv, &PL_sv_yes);
4707 =for apidoc sv_set_false
4709 Equivalent to C<sv_setsv(sv, &PL_sv_no)>, but may be made more
4710 efficient in the future. Doesn't handle set magic.
4712 The perl equivalent is C<$sv = !1;>.
4714 Introduced in perl 5.35.11.
4720 Perl_sv_set_false(pTHX_ SV *sv)
4722 PERL_ARGS_ASSERT_SV_SET_FALSE;
4723 sv_setsv(sv, &PL_sv_no);
4727 =for apidoc sv_set_bool
4729 Equivalent to C<sv_setsv(sv, bool_val ? &Pl_sv_yes : &PL_sv_no)>, but
4730 may be made more efficient in the future. Doesn't handle set magic.
4732 The perl equivalent is C<$sv = !!$expr;>.
4734 Introduced in perl 5.35.11.
4740 Perl_sv_set_bool(pTHX_ SV *sv, const bool bool_val)
4742 PERL_ARGS_ASSERT_SV_SET_BOOL;
4743 sv_setsv(sv, bool_val ? &PL_sv_yes : &PL_sv_no);
4748 Perl_sv_setsv_mg(pTHX_ SV *const dsv, SV *const ssv)
4750 PERL_ARGS_ASSERT_SV_SETSV_MG;
4757 # define SVt_COW SVt_PV
4759 Perl_sv_setsv_cow(pTHX_ SV *dsv, SV *ssv)
4761 STRLEN cur = SvCUR(ssv);
4762 STRLEN len = SvLEN(ssv);
4764 U32 new_flags = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
4765 #if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_COPY_ON_WRITE)
4766 const bool already = cBOOL(SvIsCOW(ssv));
4769 PERL_ARGS_ASSERT_SV_SETSV_COW;
4772 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4773 (void*)ssv, (void*)dsv);
4780 if (SvTHINKFIRST(dsv))
4781 sv_force_normal_flags(dsv, SV_COW_DROP_PV);
4782 else if (SvPVX_const(dsv))
4783 Safefree(SvPVX_mutable(dsv));
4787 SvUPGRADE(dsv, SVt_COW);
4789 assert (SvPOK(ssv));
4790 assert (SvPOKp(ssv));
4793 if (SvIsCOW_shared_hash(ssv)) {
4794 /* source is a COW shared hash key. */
4795 DEBUG_C(PerlIO_printf(Perl_debug_log,
4796 "Fast copy on write: Sharing hash\n"));
4797 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv))));
4800 else if (SvIsCOW_static(ssv)) {
4801 /* source is static constant; preserve this */
4802 new_pv = SvPVX(ssv);
4803 new_flags |= SVppv_STATIC;
4806 assert(SvCUR(ssv)+1 < SvLEN(ssv));
4807 assert(CowREFCNT(ssv) < SV_COW_REFCNT_MAX);
4809 assert ((SvFLAGS(ssv) & CAN_COW_MASK) == CAN_COW_FLAGS);
4810 SvUPGRADE(ssv, SVt_COW);
4812 DEBUG_C(PerlIO_printf(Perl_debug_log,
4813 "Fast copy on write: Converting ssv to COW\n"));
4816 # ifdef PERL_DEBUG_READONLY_COW
4817 if (already) sv_buf_to_rw(ssv);
4820 new_pv = SvPVX_mutable(ssv);
4824 SvPV_set(dsv, new_pv);
4825 SvFLAGS(dsv) = new_flags;
4828 SvLEN_set(dsv, len);
4829 SvCUR_set(dsv, cur);
4839 =for apidoc sv_setpv_bufsize
4841 Sets the SV to be a string of cur bytes length, with at least
4842 len bytes available. Ensures that there is a null byte at SvEND.
4843 Returns a char * pointer to the SvPV buffer.
4849 Perl_sv_setpv_bufsize(pTHX_ SV *const sv, const STRLEN cur, const STRLEN len)
4853 PERL_ARGS_ASSERT_SV_SETPV_BUFSIZE;
4855 SV_CHECK_THINKFIRST_COW_DROP(sv);
4856 SvUPGRADE(sv, SVt_PV);
4857 pv = SvGROW(sv, len + 1);
4860 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4863 if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4868 =for apidoc sv_setpv
4869 =for apidoc_item sv_setpv_mg
4870 =for apidoc_item sv_setpvn
4871 =for apidoc_item sv_setpvn_fresh
4872 =for apidoc_item sv_setpvn_mg
4873 =for apidoc_item |void|sv_setpvs|SV* sv|"literal string"
4874 =for apidoc_item |void|sv_setpvs_mg|SV* sv|"literal string"
4876 These copy a string into the SV C<sv>, making sure it is C<L</SvPOK_only>>.
4878 In the C<pvs> forms, the string must be a C literal string, enclosed in double
4881 In the C<pvn> forms, the first byte of the string is pointed to by C<ptr>, and
4882 C<len> indicates the number of bytes to be copied, potentially including
4883 embedded C<NUL> characters.
4885 In the plain C<pv> forms, C<ptr> points to a NUL-terminated C string. That is,
4886 it points to the first byte of the string, and the copy proceeds up through the
4887 first enountered C<NUL> byte.
4889 In the forms that take a C<ptr> argument, if it is NULL, the SV will become
4892 The UTF-8 flag is not changed by these functions. A terminating NUL byte is
4893 guaranteed in the result.
4895 The C<_mg> forms handle 'set' magic; the other forms skip all magic.
4897 C<sv_setpvn_fresh> is a cut-down alternative to C<sv_setpvn>, intended ONLY
4898 to be used with a fresh sv that has been upgraded to a SVt_PV, SVt_PVIV,
4899 SVt_PVNV, or SVt_PVMG.
4905 Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4909 PERL_ARGS_ASSERT_SV_SETPVN;
4911 SV_CHECK_THINKFIRST_COW_DROP(sv);
4912 if (isGV_with_GP(sv))
4913 Perl_croak_no_modify();
4919 /* len is STRLEN which is unsigned, need to copy to signed */
4922 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
4925 SvUPGRADE(sv, SVt_PV);
4927 dptr = SvGROW(sv, len + 1);
4928 Move(ptr,dptr,len,char);
4931 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4933 if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4937 Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4939 PERL_ARGS_ASSERT_SV_SETPVN_MG;
4941 sv_setpvn(sv,ptr,len);
4946 Perl_sv_setpvn_fresh(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4950 PERL_ARGS_ASSERT_SV_SETPVN_FRESH;
4951 assert(SvTYPE(sv) >= SVt_PV && SvTYPE(sv) <= SVt_PVMG);
4952 assert(!SvTHINKFIRST(sv));
4953 assert(!isGV_with_GP(sv));
4957 /* len is STRLEN which is unsigned, need to copy to signed */
4959 Perl_croak(aTHX_ "panic: sv_setpvn_fresh called with negative strlen %"
4962 dptr = sv_grow_fresh(sv, len + 1);
4963 Move(ptr,dptr,len,char);
4972 Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
4976 PERL_ARGS_ASSERT_SV_SETPV;
4978 SV_CHECK_THINKFIRST_COW_DROP(sv);
4984 SvUPGRADE(sv, SVt_PV);
4986 SvGROW(sv, len + 1);
4987 Move(ptr,SvPVX(sv),len+1,char);
4989 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4991 if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4995 Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
4997 PERL_ARGS_ASSERT_SV_SETPV_MG;
5004 Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
5006 PERL_ARGS_ASSERT_SV_SETHEK;
5012 if (HEK_LEN(hek) == HEf_SVKEY) {
5013 sv_setsv(sv, *(SV**)HEK_KEY(hek));
5016 const int flags = HEK_FLAGS(hek);
5017 if (flags & HVhek_WASUTF8) {
5018 STRLEN utf8_len = HEK_LEN(hek);
5019 char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
5020 sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
5023 } else if (flags & HVhek_NOTSHARED) {
5024 sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
5027 else SvUTF8_off(sv);
5031 SV_CHECK_THINKFIRST_COW_DROP(sv);
5032 SvUPGRADE(sv, SVt_PV);
5034 SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
5035 SvCUR_set(sv, HEK_LEN(hek));
5041 else SvUTF8_off(sv);
5049 =for apidoc sv_usepvn
5050 =for apidoc_item sv_usepvn_flags
5051 =for apidoc_item sv_usepvn_mg
5053 These tell an SV to use C<ptr> for its string value. Normally SVs have
5054 their string stored inside the SV, but these tell the SV to use an
5055 external string instead.
5057 C<ptr> should point to memory that was allocated
5058 by L</C<Newx>>. It must be
5059 the start of a C<Newx>-ed block of memory, and not a pointer to the
5060 middle of it (beware of L<C<OOK>|perlguts/Offsets> and copy-on-write),
5061 and not be from a non-C<Newx> memory allocator like C<malloc>. The
5062 string length, C<len>, must be supplied. By default this function
5063 will L</C<Renew>> (i.e. realloc, move) the memory pointed to by C<ptr>,
5064 so that the pointer should not be freed or used by the programmer after giving
5065 it to C<sv_usepvn>, and neither should any pointers from "behind" that pointer
5066 (I<e.g.>, S<C<ptr> + 1>) be used.
5068 In the C<sv_usepvn_flags> form, if S<C<flags & SV_SMAGIC>> is true,
5069 C<SvSETMAGIC> is called before returning.
5070 And if S<C<flags & SV_HAS_TRAILING_NUL>> is true, then C<ptr[len]> must be
5071 C<NUL>, and the realloc will be skipped (I<i.e.>, the buffer is actually at
5072 least 1 byte longer than C<len>, and already meets the requirements for storing
5075 C<sv_usepvn> is merely C<sv_usepvn_flags> with C<flags> set to 0, so 'set'
5078 C<sv_usepvn_mg> is merely C<sv_usepvn_flags> with C<flags> set to C<SV_SMAGIC>,
5079 so 'set' magic is performed.
5081 =for apidoc Amnh||SV_SMAGIC
5082 =for apidoc Amnh||SV_HAS_TRAILING_NUL
5088 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
5092 PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
5094 SV_CHECK_THINKFIRST_COW_DROP(sv);
5095 SvUPGRADE(sv, SVt_PV);
5098 if (flags & SV_SMAGIC)
5102 if (SvPVX_const(sv))
5106 if (flags & SV_HAS_TRAILING_NUL)
5107 assert(ptr[len] == '\0');
5110 allocate = (flags & SV_HAS_TRAILING_NUL)
5112 #ifdef Perl_safesysmalloc_size
5115 PERL_STRLEN_ROUNDUP(len + 1);
5117 if (flags & SV_HAS_TRAILING_NUL) {
5118 /* It's long enough - do nothing.
5119 Specifically Perl_newCONSTSUB is relying on this. */
5122 /* Force a move to shake out bugs in callers. */
5123 char *new_ptr = (char*)safemalloc(allocate);
5124 Copy(ptr, new_ptr, len, char);
5125 PoisonFree(ptr,len,char);
5129 ptr = (char*) saferealloc (ptr, allocate);
5132 #ifdef Perl_safesysmalloc_size
5133 SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
5135 SvLEN_set(sv, allocate);
5139 if (!(flags & SV_HAS_TRAILING_NUL)) {
5142 (void)SvPOK_only_UTF8(sv); /* validate pointer */
5144 if (flags & SV_SMAGIC)
5150 S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
5152 assert(SvIsCOW(sv));
5155 const char * const pvx = SvPVX_const(sv);
5156 const STRLEN len = SvLEN(sv);
5157 const STRLEN cur = SvCUR(sv);
5158 const bool was_shared_hek = SvIsCOW_shared_hash(sv);
5162 PerlIO_printf(Perl_debug_log,
5163 "Copy on write: Force normal %ld\n",
5169 # ifdef PERL_COPY_ON_WRITE
5171 /* Must do this first, since the CowREFCNT uses SvPVX and
5172 we need to write to CowREFCNT, or de-RO the whole buffer if we are
5173 the only owner left of the buffer. */
5174 sv_buf_to_rw(sv); /* NOOP if RO-ing not supported */
5176 U8 cowrefcnt = CowREFCNT(sv);
5177 if(cowrefcnt != 0) {
5179 CowREFCNT(sv) = cowrefcnt;
5184 /* Else we are the only owner of the buffer. */
5189 /* This SV doesn't own the buffer, so need to Newx() a new one: */
5194 if (flags & SV_COW_DROP_PV) {
5195 /* OK, so we don't need to copy our buffer. */
5198 SvGROW(sv, cur + 1);
5199 Move(pvx,SvPVX(sv),cur,char);
5203 if (was_shared_hek) {
5204 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5212 const char * const pvx = SvPVX_const(sv);
5213 const STRLEN len = SvCUR(sv);
5217 if (flags & SV_COW_DROP_PV) {
5218 /* OK, so we don't need to copy our buffer. */
5221 SvGROW(sv, len + 1);
5222 Move(pvx,SvPVX(sv),len,char);
5225 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5232 =for apidoc sv_force_normal_flags
5234 Undo various types of fakery on an SV, where fakery means
5235 "more than" a string: if the PV is a shared string, make
5236 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5237 an C<xpvmg>; if we're a copy-on-write scalar, this is the on-write time when
5238 we do the copy, and is also used locally; if this is a
5239 vstring, drop the vstring magic. If C<SV_COW_DROP_PV> is set
5240 then a copy-on-write scalar drops its PV buffer (if any) and becomes
5241 C<SvPOK_off> rather than making a copy. (Used where this
5242 scalar is about to be set to some other value.) In addition,
5243 the C<flags> parameter gets passed to C<sv_unref_flags()>
5244 when unreffing. C<sv_force_normal> calls this function
5245 with flags set to 0.
5247 This function is expected to be used to signal to perl that this SV is
5248 about to be written to, and any extra book-keeping needs to be taken care
5249 of. Hence, it croaks on read-only values.
5251 =for apidoc Amnh||SV_COW_DROP_PV
5257 Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
5259 PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
5262 Perl_croak_no_modify();
5263 else if (SvIsCOW(sv) && LIKELY(SvTYPE(sv) != SVt_PVHV))
5264 S_sv_uncow(aTHX_ sv, flags);
5266 sv_unref_flags(sv, flags);
5267 else if (SvFAKE(sv) && isGV_with_GP(sv))
5268 sv_unglob(sv, flags);
5269 else if (SvFAKE(sv) && isREGEXP(sv)) {
5270 /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
5271 to sv_unglob. We only need it here, so inline it. */
5272 const bool islv = SvTYPE(sv) == SVt_PVLV;
5273 const svtype new_type =
5274 islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
5275 SV *const temp = newSV_type(new_type);
5276 regexp *old_rx_body;
5278 if (new_type == SVt_PVMG) {
5279 SvMAGIC_set(temp, SvMAGIC(sv));
5280 SvMAGIC_set(sv, NULL);
5281 SvSTASH_set(temp, SvSTASH(sv));
5282 SvSTASH_set(sv, NULL);
5285 SvCUR_set(temp, SvCUR(sv));
5286 /* Remember that SvPVX is in the head, not the body. */
5287 assert(ReANY((REGEXP *)sv)->mother_re);
5290 /* LV-as-regex has sv->sv_any pointing to an XPVLV body,
5291 * whose xpvlenu_rx field points to the regex body */
5292 XPV *xpv = (XPV*)(SvANY(sv));
5293 old_rx_body = xpv->xpv_len_u.xpvlenu_rx;
5294 xpv->xpv_len_u.xpvlenu_rx = NULL;
5297 old_rx_body = ReANY((REGEXP *)sv);
5299 /* Their buffer is already owned by someone else. */
5300 if (flags & SV_COW_DROP_PV) {
5301 /* SvLEN is already 0. For SVt_REGEXP, we have a brand new
5302 zeroed body. For SVt_PVLV, we zeroed it above (len field
5303 a union with xpvlenu_rx) */
5304 assert(!SvLEN(islv ? sv : temp));
5305 sv->sv_u.svu_pv = 0;
5308 sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
5309 SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
5313 /* Now swap the rest of the bodies. */
5317 SvFLAGS(sv) &= ~SVTYPEMASK;
5318 SvFLAGS(sv) |= new_type;
5319 SvANY(sv) = SvANY(temp);
5322 SvFLAGS(temp) &= ~(SVTYPEMASK);
5323 SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
5324 SvANY(temp) = old_rx_body;
5326 /* temp is now rebuilt as a correctly structured SVt_REGEXP, so this
5327 * will trigger a call to sv_clear() which will correctly free the
5329 SvREFCNT_dec_NN(temp);
5331 else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
5337 Efficient removal of characters from the beginning of the string buffer.
5338 C<SvPOK(sv)>, or at least C<SvPOKp(sv)>, must be true and C<ptr> must be a
5339 pointer to somewhere inside the string buffer. C<ptr> becomes the first
5340 character of the adjusted string. Uses the C<OOK> hack. On return, only
5341 C<SvPOK(sv)> and C<SvPOKp(sv)> among the C<OK> flags will be true.
5343 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
5344 refer to the same chunk of data.
5346 The unfortunate similarity of this function's name to that of Perl's C<chop>
5347 operator is strictly coincidental. This function works from the left;
5348 C<chop> works from the right.
5354 Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
5365 PERL_ARGS_ASSERT_SV_CHOP;
5367 if (!ptr || !SvPOKp(sv))
5369 delta = ptr - SvPVX_const(sv);
5371 /* Nothing to do. */
5374 max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
5375 if (delta > max_delta)
5376 Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
5377 ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
5378 /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
5379 SV_CHECK_THINKFIRST(sv);
5380 SvPOK_only_UTF8(sv);
5383 if (!SvLEN(sv)) { /* make copy of shared string */
5384 const char *pvx = SvPVX_const(sv);
5385 const STRLEN len = SvCUR(sv);
5386 SvGROW(sv, len + 1);
5387 Move(pvx,SvPVX(sv),len,char);
5393 SvOOK_offset(sv, old_delta);
5395 SvLEN_set(sv, SvLEN(sv) - delta);
5396 SvCUR_set(sv, SvCUR(sv) - delta);
5397 SvPV_set(sv, SvPVX(sv) + delta);
5399 p = (U8 *)SvPVX_const(sv);
5402 /* how many bytes were evacuated? we will fill them with sentinel
5403 bytes, except for the part holding the new offset of course. */
5406 evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
5408 assert(evacn <= delta + old_delta);
5412 /* This sets 'delta' to the accumulated value of all deltas so far */
5416 /* If 'delta' fits in a byte, store it just prior to the new beginning of
5417 * the string; otherwise store a 0 byte there and store 'delta' just prior
5418 * to that, using as many bytes as a STRLEN occupies. Thus it overwrites a
5419 * portion of the chopped part of the string */
5420 if (delta < 0x100) {
5424 p -= sizeof(STRLEN);
5425 Copy((U8*)&delta, p, sizeof(STRLEN), U8);
5429 /* Fill the preceding buffer with sentinals to verify that no-one is
5439 =for apidoc sv_catpvn
5440 =for apidoc_item sv_catpvn_flags
5441 =for apidoc_item sv_catpvn_mg
5442 =for apidoc_item sv_catpvn_nomg
5444 These concatenate the C<len> bytes of the string beginning at C<ptr> onto the
5445 end of the string which is in C<dsv>. The caller must make sure C<ptr>
5446 contains at least C<len> bytes.
5448 For all but C<sv_catpvn_flags>, the string appended is assumed to be valid
5449 UTF-8 if the SV has the UTF-8 status set, and a string of bytes otherwise.
5451 They differ in that:
5453 C<sv_catpvn_mg> performs both 'get' and 'set' magic on C<dsv>.
5455 C<sv_catpvn> performs only 'get' magic.
5457 C<sv_catpvn_nomg> skips all magic.
5459 C<sv_catpvn_flags> has an extra C<flags> parameter which allows you to specify
5460 any combination of magic handling (using C<SV_GMAGIC> and/or C<SV_SMAGIC>) and
5461 to also override the UTF-8 handling. By supplying the C<SV_CATBYTES> flag, the
5462 appended string is interpreted as plain bytes; by supplying instead the
5463 C<SV_CATUTF8> flag, it will be interpreted as UTF-8, and the C<dsv> will be
5464 upgraded to UTF-8 if necessary.
5466 C<sv_catpvn>, C<sv_catpvn_mg>, and C<sv_catpvn_nomg> are implemented
5467 in terms of C<sv_catpvn_flags>.
5469 =for apidoc Amnh||SV_CATUTF8
5470 =for apidoc Amnh||SV_CATBYTES
5476 Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
5479 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5481 PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5482 assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5484 if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
5485 if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
5486 sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5489 else SvGROW(dsv, dlen + slen + 3);
5491 sstr = SvPVX_const(dsv);
5492 Move(sstr, SvPVX(dsv) + dlen, slen, char);
5493 SvCUR_set(dsv, SvCUR(dsv) + slen);
5496 /* We inline bytes_to_utf8, to avoid an extra malloc. */
5497 const char * const send = sstr + slen;
5500 /* Something this code does not account for, which I think is
5501 impossible; it would require the same pv to be treated as
5502 bytes *and* utf8, which would indicate a bug elsewhere. */
5503 assert(sstr != dstr);
5505 SvGROW(dsv, dlen + slen * 2 + 3);
5506 d = (U8 *)SvPVX(dsv) + dlen;
5508 while (sstr < send) {
5509 append_utf8_from_native_byte(*sstr, &d);
5512 SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5515 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
5517 if (flags & SV_SMAGIC)
5522 =for apidoc sv_catsv
5523 =for apidoc_item sv_catsv_flags
5524 =for apidoc_item sv_catsv_mg
5525 =for apidoc_item sv_catsv_nomg
5527 These concatenate the string from SV C<sstr> onto the end of the string in SV
5528 C<dsv>. If C<sstr> is null, these are no-ops; otherwise only C<dsv> is
5531 They differ only in what magic they perform:
5533 C<sv_catsv_mg> performs 'get' magic on both SVs before the copy, and 'set' magic
5534 on C<dsv> afterwards.
5536 C<sv_catsv> performs just 'get' magic, on both SVs.
5538 C<sv_catsv_nomg> skips all magic.
5540 C<sv_catsv_flags> has an extra C<flags> parameter which allows you to use
5541 C<SV_GMAGIC> and/or C<SV_SMAGIC> to specify any combination of magic handling
5542 (although either both or neither SV will have 'get' magic applied to it.)
5544 C<sv_catsv>, C<sv_catsv_mg>, and C<sv_catsv_nomg> are implemented
5545 in terms of C<sv_catsv_flags>.
5550 Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const sstr, const I32 flags)
5552 PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5556 const char *spv = SvPV_flags_const(sstr, slen, flags);
5557 if (flags & SV_GMAGIC)
5559 sv_catpvn_flags(dsv, spv, slen,
5560 DO_UTF8(sstr) ? SV_CATUTF8 : SV_CATBYTES);
5561 if (flags & SV_SMAGIC)
5567 =for apidoc sv_catpv
5568 =for apidoc_item sv_catpv_flags
5569 =for apidoc_item sv_catpv_mg
5570 =for apidoc_item sv_catpv_nomg
5572 These concatenate the C<NUL>-terminated string C<sstr> onto the end of the
5573 string which is in the SV.
5574 If the SV has the UTF-8 status set, then the bytes appended should be
5577 They differ only in how they handle magic:
5579 C<sv_catpv_mg> performs both 'get' and 'set' magic.
5581 C<sv_catpv> performs only 'get' magic.
5583 C<sv_catpv_nomg> skips all magic.
5585 C<sv_catpv_flags> has an extra C<flags> parameter which allows you to specify
5586 any combination of magic handling (using C<SV_GMAGIC> and/or C<SV_SMAGIC>), and
5587 to also override the UTF-8 handling. By supplying the C<SV_CATUTF8> flag, the
5588 appended string is forced to be interpreted as UTF-8; by supplying instead the
5589 C<SV_CATBYTES> flag, it will be interpreted as just bytes. Either the SV or
5590 the string appended will be upgraded to UTF-8 if necessary.
5596 Perl_sv_catpv(pTHX_ SV *const dsv, const char *sstr)
5602 PERL_ARGS_ASSERT_SV_CATPV;
5606 junk = SvPV_force(dsv, tlen);
5608 SvGROW(dsv, tlen + len + 1);
5610 sstr = SvPVX_const(dsv);
5611 Move(sstr,SvPVX(dsv)+tlen,len+1,char);
5612 SvCUR_set(dsv, SvCUR(dsv) + len);
5613 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
5618 Perl_sv_catpv_flags(pTHX_ SV *dsv, const char *sstr, const I32 flags)
5620 PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5621 sv_catpvn_flags(dsv, sstr, strlen(sstr), flags);
5625 Perl_sv_catpv_mg(pTHX_ SV *const dsv, const char *const sstr)
5627 PERL_ARGS_ASSERT_SV_CATPV_MG;
5636 Creates a new SV. A non-zero C<len> parameter indicates the number of
5637 bytes of preallocated string space the SV should have. An extra byte for a
5638 trailing C<NUL> is also reserved. (C<SvPOK> is not set for the SV even if string
5639 space is allocated.) The reference count for the new SV is set to 1.
5641 In 5.9.3, C<newSV()> replaces the older C<NEWSV()> API, and drops the first
5642 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5643 This aid has been superseded by a new build option, C<PERL_MEM_LOG> (see
5644 L<perlhacktips/PERL_MEM_LOG>). The older API is still there for use in XS
5645 modules supporting older perls.
5651 Perl_newSV(pTHX_ const STRLEN len)
5658 sv = newSV_type(SVt_PV);
5659 sv_grow_fresh(sv, len + 1);
5664 =for apidoc sv_magicext
5666 Adds magic to an SV, upgrading it if necessary. Applies the
5667 supplied C<vtable> and returns a pointer to the magic added.