This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Sort perlapi, perlintern better
[perl5.git] / sv.c
1 /*    sv.c
2  *
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
5  *    and others
6  *
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.
9  *
10  */
11
12 /*
13  * 'I wonder what the Entish is for "yes" and "no",' he thought.
14  *                                                      --Pippin
15  *
16  *     [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
17  */
18
19 /*
20  *
21  *
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
27  * in the pp*.c files.
28  */
29
30 #include "EXTERN.h"
31 #define PERL_IN_SV_C
32 #include "perl.h"
33 #include "regcomp.h"
34 #ifdef __VMS
35 # include <rms.h>
36 #endif
37
38 #ifdef __Lynx__
39 /* Missing proto on LynxOS */
40   char *gconvert(double, int, int,  char *);
41 #endif
42
43 #ifdef USE_QUADMATH
44 #  define SNPRINTF_G(nv, buffer, size, ndig) \
45     quadmath_snprintf(buffer, size, "%.*Qg", (int)ndig, (NV)(nv))
46 #else
47 #  define SNPRINTF_G(nv, buffer, size, ndig) \
48     PERL_UNUSED_RESULT(Gconvert((NV)(nv), (int)ndig, 0, buffer))
49 #endif
50
51 #ifndef SV_COW_THRESHOLD
52 #    define SV_COW_THRESHOLD                    0   /* COW iff len > K */
53 #endif
54 #ifndef SV_COWBUF_THRESHOLD
55 #    define SV_COWBUF_THRESHOLD                 1250 /* COW iff len > K */
56 #endif
57 #ifndef SV_COW_MAX_WASTE_THRESHOLD
58 #    define SV_COW_MAX_WASTE_THRESHOLD          80   /* COW iff (len - cur) < K */
59 #endif
60 #ifndef SV_COWBUF_WASTE_THRESHOLD
61 #    define SV_COWBUF_WASTE_THRESHOLD           80   /* COW iff (len - cur) < K */
62 #endif
63 #ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD
64 #    define SV_COW_MAX_WASTE_FACTOR_THRESHOLD   2    /* COW iff len < (cur * K) */
65 #endif
66 #ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD
67 #    define SV_COWBUF_WASTE_FACTOR_THRESHOLD    2    /* COW iff len < (cur * K) */
68 #endif
69 /* Work around compiler warnings about unsigned >= THRESHOLD when thres-
70    hold is 0. */
71 #if SV_COW_THRESHOLD
72 # define GE_COW_THRESHOLD(cur) ((cur) >= SV_COW_THRESHOLD)
73 #else
74 # define GE_COW_THRESHOLD(cur) 1
75 #endif
76 #if SV_COWBUF_THRESHOLD
77 # define GE_COWBUF_THRESHOLD(cur) ((cur) >= SV_COWBUF_THRESHOLD)
78 #else
79 # define GE_COWBUF_THRESHOLD(cur) 1
80 #endif
81 #if SV_COW_MAX_WASTE_THRESHOLD
82 # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COW_MAX_WASTE_THRESHOLD)
83 #else
84 # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) 1
85 #endif
86 #if SV_COWBUF_WASTE_THRESHOLD
87 # define GE_COWBUF_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COWBUF_WASTE_THRESHOLD)
88 #else
89 # define GE_COWBUF_WASTE_THRESHOLD(cur,len) 1
90 #endif
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))
93 #else
94 # define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) 1
95 #endif
96 #if SV_COWBUF_WASTE_FACTOR_THRESHOLD
97 # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COWBUF_WASTE_FACTOR_THRESHOLD * (cur))
98 #else
99 # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) 1
100 #endif
101
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)) \
106 )
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)) \
111 )
112
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
117  * --jhi
118  */
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]);} \
123                               } STMT_END
124 #else
125 #   define ASSERT_UTF8_CACHE(cache) NOOP
126 #endif
127
128 static const char S_destroy[] = "DESTROY";
129 #define S_destroy_len (sizeof(S_destroy)-1)
130
131 /* ============================================================================
132
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.
138
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.
144
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.
150
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.
154
155 The following global variables are associated with arenas:
156
157  PL_sv_arenaroot     pointer to list of SV arenas
158  PL_sv_root          pointer to list of free SV structures
159
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
163
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.
168
169 The SV arena serves the secondary purpose of allowing still-live SVs
170 to be located and destroyed during final cleanup.
171
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.
177
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.
181
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]):
187
188     sv_report_used() / do_report_used()
189                         dump all remaining SVs (debugging aid)
190
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()
199                         below.
200
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.
210
211 =head2 Arena allocator API Summary
212
213 Private API to rest of sv.c
214
215     new_SV(),  del_SV(),
216
217     new_XPVNV(), del_body()
218     etc
219
220 Public API:
221
222     sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
223
224 =cut
225
226  * ========================================================================= */
227
228 /*
229  * "A time to plant, and a time to uproot what was planted..."
230  */
231
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); \
235     } STMT_END
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))
239 #else
240 #  define FREE_SV_DEBUG_FILE(sv)
241 #  define DEBUG_SV_SERIAL(sv)   NOOP
242 #endif
243
244 /* Mark an SV head as unused, and add to free list.
245  *
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. */
250
251 #define plant_SV(p) \
252     STMT_START {                                        \
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);                          \
257         POISON_SV_HEAD(p);                              \
258         SvFLAGS(p) = SVTYPEMASK;                        \
259         if (!(old_flags & SVf_BREAK)) {         \
260             SvARENA_CHAIN_SET(p, PL_sv_root);   \
261             PL_sv_root = (p);                           \
262         }                                               \
263         --PL_sv_count;                                  \
264     } STMT_END
265
266
267 /* make some more SVs by adding another arena */
268
269 SV*
270 Perl_more_sv(pTHX)
271 {
272     SV* sv;
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);
276     uproot_SV(sv);
277     return sv;
278 }
279
280 /* del_SV(): return an empty SV head to the free list */
281
282 #ifdef DEBUGGING
283
284 #define del_SV(p) \
285     STMT_START {                                        \
286         if (DEBUG_D_TEST)                               \
287             del_sv(p);                                  \
288         else                                            \
289             plant_SV(p);                                \
290     } STMT_END
291
292 STATIC void
293 S_del_sv(pTHX_ SV *p)
294 {
295     PERL_ARGS_ASSERT_DEL_SV;
296
297     if (DEBUG_D_TEST) {
298         SV* sva;
299         bool ok = 0;
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) {
304                 ok = 1;
305                 break;
306             }
307         }
308         if (!ok) {
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);
312             return;
313         }
314     }
315     plant_SV(p);
316 }
317
318 #else /* ! DEBUGGING */
319
320 #define del_SV(p)   plant_SV(p)
321
322 #endif /* DEBUGGING */
323
324
325 /*
326 =for apidoc_section $SV
327
328 =for apidoc sv_add_arena
329
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.
332
333 =cut
334 */
335
336 static void
337 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
338 {
339     SV *const sva = MUTABLE_SV(ptr);
340     SV* sv;
341     SV* svend;
342
343     PERL_ARGS_ASSERT_SV_ADD_ARENA;
344
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 */
349
350     PL_sv_arenaroot = sva;
351     PL_sv_root = sva + 1;
352
353     svend = &sva[SvREFCNT(sva) - 1];
354     sv = sva + 1;
355     while (sv < svend) {
356         SvARENA_CHAIN_SET(sv, (sv + 1));
357 #ifdef DEBUGGING
358         SvREFCNT(sv) = 0;
359 #endif
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;
363         sv++;
364     }
365     SvARENA_CHAIN_SET(sv, 0);
366 #ifdef DEBUGGING
367     SvREFCNT(sv) = 0;
368 #endif
369     SvFLAGS(sv) = SVTYPEMASK;
370 }
371
372 /* visit(): call the named function for each non-free SV in the arenas
373  * whose flags field matches the flags/mask args. */
374
375 STATIC I32
376 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
377 {
378     SV* sva;
379     I32 visited = 0;
380
381     PERL_ARGS_ASSERT_VISIT;
382
383     for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
384         const SV * const svend = &sva[SvREFCNT(sva)];
385         SV* sv;
386         for (sv = sva + 1; sv < svend; ++sv) {
387             if (SvTYPE(sv) != (svtype)SVTYPEMASK
388                     && (sv->sv_flags & mask) == flags
389                     && SvREFCNT(sv))
390             {
391                 (*f)(aTHX_ sv);
392                 ++visited;
393             }
394         }
395     }
396     return visited;
397 }
398
399 #ifdef DEBUGGING
400
401 /* called by sv_report_used() for each live SV */
402
403 static void
404 do_report_used(pTHX_ SV *const sv)
405 {
406     if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
407         PerlIO_printf(Perl_debug_log, "****\n");
408         sv_dump(sv);
409     }
410 }
411 #endif
412
413 /*
414 =for apidoc sv_report_used
415
416 Dump the contents of all SVs not yet freed (debugging aid).
417
418 =cut
419 */
420
421 void
422 Perl_sv_report_used(pTHX)
423 {
424 #ifdef DEBUGGING
425     visit(do_report_used, 0, 0);
426 #else
427     PERL_UNUSED_CONTEXT;
428 #endif
429 }
430
431 /* called by sv_clean_objs() for each live SV */
432
433 static void
434 do_clean_objs(pTHX_ SV *const ref)
435 {
436     assert (SvROK(ref));
437     {
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);
443                 SvWEAKREF_off(ref);
444                 SvRV_set(ref, NULL);
445             } else {
446                 SvROK_off(ref);
447                 SvRV_set(ref, NULL);
448                 SvREFCNT_dec_NN(target);
449             }
450         }
451     }
452 }
453
454
455 /* clear any slots in a GV which hold objects - except IO;
456  * called by sv_clean_objs() for each live GV */
457
458 static void
459 do_clean_named_objs(pTHX_ SV *const sv)
460 {
461     SV *obj;
462     assert(SvTYPE(sv) == SVt_PVGV);
463     assert(isGV_with_GP(sv));
464     if (!GvGP(sv))
465         return;
466
467     /* freeing GP entries may indirectly free the current GV;
468      * hold onto it while we mess with the GP slots */
469     SvREFCNT_inc(sv);
470
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)));
474         GvSV(sv) = NULL;
475         SvREFCNT_dec_NN(obj);
476     }
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)));
480         GvAV(sv) = NULL;
481         SvREFCNT_dec_NN(obj);
482     }
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)));
486         GvHV(sv) = NULL;
487         SvREFCNT_dec_NN(obj);
488     }
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)));
492         GvCV_set(sv, NULL);
493         SvREFCNT_dec_NN(obj);
494     }
495     SvREFCNT_dec_NN(sv); /* undo the inc above */
496 }
497
498 /* clear any IO slots in a GV which hold objects (except stderr, defout);
499  * called by sv_clean_objs() for each live GV */
500
501 static void
502 do_clean_named_io_objs(pTHX_ SV *const sv)
503 {
504     SV *obj;
505     assert(SvTYPE(sv) == SVt_PVGV);
506     assert(isGV_with_GP(sv));
507     if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
508         return;
509
510     SvREFCNT_inc(sv);
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)));
514         GvIOp(sv) = NULL;
515         SvREFCNT_dec_NN(obj);
516     }
517     SvREFCNT_dec_NN(sv); /* undo the inc above */
518 }
519
520 /* Void wrapper to pass to visit() */
521 static void
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))
525         return;
526     (void)curse(sv, 0);
527 }
528
529 /*
530 =for apidoc sv_clean_objs
531
532 Attempt to destroy all objects not yet freed.
533
534 =cut
535 */
536
537 void
538 Perl_sv_clean_objs(pTHX)
539 {
540     GV *olddef, *olderr;
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;
561 }
562
563 /* called by sv_clean_all() for each live SV */
564
565 static void
566 do_clean_all(pTHX_ SV *const sv)
567 {
568     if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
569         /* don't clean pid table and strtab */
570         return;
571     }
572     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%" UVxf "\n", PTR2UV(sv)) ));
573     SvFLAGS(sv) |= SVf_BREAK;
574     SvREFCNT_dec_NN(sv);
575 }
576
577 /*
578 =for apidoc sv_clean_all
579
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.
583
584 =cut
585 */
586
587 I32
588 Perl_sv_clean_all(pTHX)
589 {
590     I32 cleaned;
591     PL_in_clean_all = TRUE;
592     cleaned = visit(do_clean_all, 0,0);
593     return cleaned;
594 }
595
596 /*
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.
603
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.
610 */
611 struct arena_desc {
612     char       *arena;          /* the raw storage, allocated aligned */
613     size_t      size;           /* its size ~4k typ */
614     svtype      utype;          /* bodytype stored in arena */
615 };
616
617 struct arena_set;
618
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.  */
622
623 #define ARENAS_PER_SET  ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
624                           - 2 * sizeof(int)) / sizeof (struct arena_desc))
625
626 struct arena_set {
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];
631 };
632
633 /*
634 =for apidoc sv_free_arenas
635
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.
638
639 =cut
640
641 */
642 void
643 Perl_sv_free_arenas(pTHX)
644 {
645     SV* sva;
646     SV* svanext;
647     unsigned int i;
648
649     /* Free arenas here, but be careful about fake ones.  (We assume
650        contiguity of the fake ones with the corresponding real ones.) */
651
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));
656
657         if (!SvFAKE(sva))
658             Safefree(sva);
659     }
660
661     {
662         struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
663
664         while (aroot) {
665             struct arena_set *current = aroot;
666             i = aroot->curr;
667             while (i--) {
668                 assert(aroot->set[i].arena);
669                 Safefree(aroot->set[i].arena);
670             }
671             aroot = aroot->next;
672             Safefree(current);
673         }
674     }
675     PL_body_arenas = 0;
676
677     i = PERL_ARENA_ROOTS_SIZE;
678     while (i--)
679         PL_body_roots[i] = 0;
680
681     PL_sv_arenaroot = 0;
682     PL_sv_root = 0;
683 }
684
685 /*
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().
690
691   There are 4 kinds of arenas:
692
693   1. SV-head arenas, which are discussed and handled above
694   2. regular body arenas
695   3. arenas for reduced-size bodies
696   4. Hash-Entry arenas
697
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)
705
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.
712
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
716 SV detection.
717
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".
723
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.
729
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.)
737
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.)
748
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.
753
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.
759
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.
764
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.
767
768 For each sv-type, struct body_details bodies_by_type[] carries
769 parameters which control these aspects of SV handling:
770
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.
774
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.
778
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.
783
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.
790
791 */
792
793 /* return a thing to the free list */
794
795 #define del_body(thing, root)                           \
796     STMT_START {                                        \
797         void ** const thing_copy = (void **)thing;      \
798         *thing_copy = *root;                            \
799         *root = (void*)thing_copy;                      \
800     } STMT_END
801
802
803 void *
804 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
805                   const size_t arena_size)
806 {
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;
810     unsigned int curr;
811     char *start;
812     const char *end;
813     const size_t good_arena_size = Perl_malloc_good_size(arena_size);
814 #if defined(DEBUGGING)
815     static bool done_sanity_check;
816
817     if (!done_sanity_check) {
818         unsigned int i = SVt_LAST;
819
820         done_sanity_check = TRUE;
821
822         while (i--)
823             assert (bodies_by_type[i].type == i);
824     }
825 #endif
826
827     assert(arena_size);
828
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;
835         aroot = newroot;
836         PL_body_arenas = (void *) newroot;
837         DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
838     }
839
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);
844
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));
850
851     start = (char *) adesc->arena;
852
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;
856
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 "
861                           "size %d ct %d\n",
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));
865 #else
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));
871 #endif
872     *root = (void *)start;
873
874     while (1) {
875         /* Where the next body would start:  */
876         char * const next = start + body_size;
877
878         if (next >= end) {
879             /* This is the last body:  */
880             assert(next == end);
881
882             *(void **)start = 0;
883             return *root;
884         }
885
886         *(void**) start = (void *)next;
887         start = next;
888     }
889 }
890
891 /*
892 =for apidoc sv_upgrade
893
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
899 C<L</svtype>>.
900
901 =cut
902 */
903
904 void
905 Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
906 {
907     void*       old_body;
908     void*       new_body;
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;
913     SV *referent = NULL;
914
915     PERL_ARGS_ASSERT_SV_UPGRADE;
916
917     if (old_type == new_type)
918         return;
919
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)
924
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.  */
928
929     if (new_type > SVt_PVMG && SvIsCOW(sv)) {
930         sv_force_normal_flags(sv, 0);
931     }
932
933     old_body = SvANY(sv);
934
935     /* Copying structures onto other structures that have been neatly zeroed
936        has a subtle gotcha. Consider XPVMG
937
938        +------+------+------+------+------+-------+-------+
939        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
940        +------+------+------+------+------+-------+-------+
941        0      4      8     12     16     20      24      28
942
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:
945
946        +------+------+------+------+------+-------+-------+------+
947        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
948        +------+------+------+------+------+-------+-------+------+
949        0      4      8     12     16     20      24      28     32
950
951        so what happens if you allocate memory for this structure:
952
953        +------+------+------+------+------+-------+-------+------+------+...
954        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
955        +------+------+------+------+------+-------+-------+------+------+...
956        0      4      8     12     16     20      24      28     32     36
957
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.
962        Bugs ensue.
963
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)
969
970        So we are careful and work out the size of used parts of all the
971        structures.  */
972
973     switch (old_type) {
974     case SVt_NULL:
975         break;
976     case SVt_IV:
977         if (SvROK(sv)) {
978             referent = SvRV(sv);
979             old_type_details = &fake_rv;
980             if (new_type == SVt_NV)
981                 new_type = SVt_PVNV;
982         } else {
983             if (new_type < SVt_PVIV) {
984                 new_type = (new_type == SVt_NV)
985                     ? SVt_PVNV : SVt_PVIV;
986             }
987         }
988         break;
989     case SVt_NV:
990         if (new_type < SVt_PVNV) {
991             new_type = SVt_PVNV;
992         }
993         break;
994     case SVt_PV:
995         assert(new_type > SVt_PV);
996         STATIC_ASSERT_STMT(SVt_IV < SVt_PV);
997         STATIC_ASSERT_STMT(SVt_NV < SVt_PV);
998         break;
999     case SVt_PVIV:
1000         break;
1001     case SVt_PVNV:
1002         break;
1003     case SVt_PVMG:
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);
1008         break;
1009     default:
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);
1013     }
1014
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);
1018
1019     new_type_details = bodies_by_type + new_type;
1020
1021     SvFLAGS(sv) &= ~SVTYPEMASK;
1022     SvFLAGS(sv) |= new_type;
1023
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);
1027     switch (new_type) {
1028     case SVt_IV:
1029         assert(old_type == SVt_NULL);
1030         SET_SVANY_FOR_BODYLESS_IV(sv);
1031         SvIV_set(sv, 0);
1032         return;
1033     case SVt_NV:
1034         assert(old_type == SVt_NULL);
1035 #if NVSIZE <= IVSIZE
1036         SET_SVANY_FOR_BODYLESS_NV(sv);
1037 #else
1038         SvANY(sv) = new_XNV();
1039 #endif
1040         SvNV_set(sv, 0);
1041         return;
1042     case SVt_PVHV:
1043     case SVt_PVAV:
1044         assert(new_type_details->body_size);
1045
1046 #ifndef PURIFY
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));
1053 #else
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);
1057 #endif
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
1063                 };
1064
1065             AvREAL_only(sv);
1066         } else {
1067             *((XPVHV*) SvANY(sv)) = (XPVHV) {
1068                 .xmg_stash = NULL, .xmg_u = {.xmg_magic = NULL},
1069                 .xhv_keys = 0,
1070                 /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
1071                 .xhv_max = PERL_HASH_DEFAULT_HvMAX
1072                 };
1073
1074             assert(!SvOK(sv));
1075             SvOK_off(sv);
1076 #ifndef NODEFAULT_SHAREKEYS
1077             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
1078 #endif
1079         }
1080
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.
1084         */
1085         if (old_type == SVt_IV) {
1086             assert(!SvROK(sv));
1087         } else if (old_type >= SVt_PV) {
1088             assert(SvPVX_const(sv) == 0);
1089         }
1090
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);
1094         } else {
1095             sv->sv_u.svu_array = NULL; /* or svu_hash  */
1096         }
1097         break;
1098
1099     case SVt_PVIV:
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));
1103         assert(!SvNOK(sv));
1104         /* FALLTHROUGH */
1105     case SVt_PVIO:
1106     case SVt_PVFM:
1107     case SVt_PVGV:
1108     case SVt_PVCV:
1109     case SVt_PVLV:
1110     case SVt_INVLIST:
1111     case SVt_REGEXP:
1112     case SVt_PVMG:
1113     case SVt_PVNV:
1114     case SVt_PV:
1115
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..  */
1119 #ifndef PURIFY
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;
1125         } else
1126 #endif
1127         {
1128             new_body = new_NOARENAZ(new_type_details);
1129         }
1130         SvANY(sv) = new_body;
1131
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;
1137
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;
1143             }
1144             assert (length >= 0);
1145
1146             Copy((char *)old_body + offset, (char *)new_body + offset, length,
1147                  char);
1148         }
1149
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
1155          * for 0.0  */
1156         if (old_type_details->zero_nv && !new_type_details->zero_nv
1157             && !isGV_with_GP(sv))
1158             SvNV_set(sv, 0);
1159 #endif
1160
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);
1164
1165             SvOBJECT_on(io);
1166             /* Clear the stashcache because a new IO could overrule a package
1167                name */
1168             DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
1169             hv_clear(PL_stashcache);
1170
1171             SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1172             IoPAGE_LEN(sv) = 60;
1173         }
1174         if (old_type < SVt_PV) {
1175             /* referent will be NULL unless the old type was SVt_IV emulating
1176                SVt_RV */
1177             sv->sv_u.svu_rv = referent;
1178         }
1179         break;
1180     default:
1181         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1182                    (unsigned long)new_type);
1183     }
1184
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) {
1188 #ifdef PURIFY
1189         safefree(old_body);
1190 #else
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]);
1197 #endif
1198     }
1199 }
1200
1201 struct xpvhv_aux*
1202 Perl_hv_auxalloc(pTHX_ HV *hv) {
1203     const struct body_details *old_type_details = bodies_by_type + SVt_PVHV;
1204     void *old_body;
1205     void *new_body;
1206
1207     PERL_ARGS_ASSERT_HV_AUXALLOC;
1208     assert(SvTYPE(hv) == SVt_PVHV);
1209     assert(!SvOOK(hv));
1210
1211 #ifdef PURIFY
1212     new_body = new_NOARENAZ(&fake_hv_with_aux);
1213 #else
1214     new_body_from_arena(new_body, HVAUX_ARENA_ROOT_IX, fake_hv_with_aux);
1215 #endif
1216
1217     old_body = SvANY(hv);
1218
1219     Copy((char *)old_body + old_type_details->offset,
1220          (char *)new_body + fake_hv_with_aux.offset,
1221          old_type_details->copy,
1222          char);
1223
1224 #ifdef PURIFY
1225     safefree(old_body);
1226 #else
1227     assert(old_type_details->arena);
1228     del_body((void*)((char*)old_body + old_type_details->offset),
1229              &PL_body_roots[SVt_PVHV]);
1230 #endif
1231
1232     SvANY(hv) = (XPVHV *) new_body;
1233     SvOOK_on(hv);
1234     return HvAUX(hv);
1235 }
1236
1237 /*
1238 =for apidoc sv_backoff
1239
1240 Remove any string offset.  You should normally use the C<SvOOK_off> macro
1241 wrapper instead.
1242
1243 =cut
1244 */
1245
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
1248 */
1249
1250 void
1251 Perl_sv_backoff(SV *const sv)
1252 {
1253     STRLEN delta;
1254     const char * const s = SvPVX_const(sv);
1255
1256     PERL_ARGS_ASSERT_SV_BACKOFF;
1257
1258     assert(SvOOK(sv));
1259     assert(SvTYPE(sv) != SVt_PVHV);
1260     assert(SvTYPE(sv) != SVt_PVAV);
1261
1262     SvOOK_offset(sv, delta);
1263
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);
1268     return;
1269 }
1270
1271
1272 /* forward declaration */
1273 static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
1274
1275
1276 /*
1277 =for apidoc sv_grow
1278
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.
1282
1283 =cut
1284 */
1285
1286
1287 char *
1288 Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
1289 {
1290     char *s;
1291
1292     PERL_ARGS_ASSERT_SV_GROW;
1293
1294     if (SvROK(sv))
1295         sv_unref(sv);
1296     if (SvTYPE(sv) < SVt_PV) {
1297         sv_upgrade(sv, SVt_PV);
1298         s = SvPVX_mutable(sv);
1299     }
1300     else if (SvOOK(sv)) {       /* pv is offset? */
1301         sv_backoff(sv);
1302         s = SvPVX_mutable(sv);
1303         if (newlen > SvLEN(sv))
1304             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1305     }
1306     else
1307     {
1308         if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0);
1309         s = SvPVX_mutable(sv);
1310     }
1311
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.
1317      *
1318      * Only increment if the allocation isn't MEM_SIZE_MAX,
1319      * otherwise it will wrap to 0.
1320      */
1321     if ( newlen != MEM_SIZE_MAX )
1322         newlen++;
1323 #endif
1324
1325 #if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size)
1326 #define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1327 #endif
1328
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)
1333             newlen = minlen;
1334 #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1335
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 */
1338         if (SvLEN(sv)) {
1339             STRLEN rounded = PERL_STRLEN_ROUNDUP(newlen);
1340             if (rounded > newlen)
1341                 newlen = rounded;
1342         }
1343 #endif
1344         if (SvLEN(sv) && s) {
1345             s = (char*)saferealloc(s, newlen);
1346         }
1347         else {
1348             s = (char*)safemalloc(newlen);
1349             if (SvPVX_const(sv) && SvCUR(sv)) {
1350                 Move(SvPVX_const(sv), s, SvCUR(sv), char);
1351             }
1352         }
1353         SvPV_set(sv, s);
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
1357            needed.  */
1358         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1359 #else
1360         SvLEN_set(sv, newlen);
1361 #endif
1362     }
1363     return s;
1364 }
1365
1366 /*
1367 =for apidoc sv_grow_fresh
1368
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.
1373
1374 =cut
1375 */
1376
1377
1378 char *
1379 Perl_sv_grow_fresh(pTHX_ SV *const sv, STRLEN newlen)
1380 {
1381     char *s;
1382
1383     PERL_ARGS_ASSERT_SV_GROW_FRESH;
1384
1385     assert(SvTYPE(sv) >= SVt_PV && SvTYPE(sv) <= SVt_PVMG);
1386     assert(!SvROK(sv));
1387     assert(!SvOOK(sv));
1388     assert(!SvIsCOW(sv));
1389     assert(!SvLEN(sv));
1390     assert(!SvCUR(sv));
1391
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.
1397      *
1398      * Only increment if the allocation isn't MEM_SIZE_MAX,
1399      * otherwise it will wrap to 0.
1400      */
1401     if ( newlen != MEM_SIZE_MAX )
1402         newlen++;
1403 #endif
1404
1405     /* 10 is a longstanding, hardcoded minimum length in sv_grow. */
1406     /* Just doing the same here for consistency. */
1407     if (newlen < 10)
1408         newlen = 10;
1409
1410     s = (char*)safemalloc(newlen);
1411     SvPV_set(sv, s);
1412
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);
1416     return s;
1417 }
1418
1419 /*
1420 =for apidoc sv_setiv
1421 =for apidoc_item sv_setiv_mg
1422
1423 These copy an integer into the given SV, upgrading first if necessary.
1424
1425 They differ only in that C<sv_setiv_mg> handles 'set' magic; C<sv_setiv> does
1426 not.
1427
1428 =cut
1429 */
1430
1431 void
1432 Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
1433 {
1434     PERL_ARGS_ASSERT_SV_SETIV;
1435
1436     SV_CHECK_THINKFIRST_COW_DROP(sv);
1437     switch (SvTYPE(sv)) {
1438     case SVt_NULL:
1439     case SVt_NV:
1440         sv_upgrade(sv, SVt_IV);
1441         break;
1442     case SVt_PV:
1443         sv_upgrade(sv, SVt_PVIV);
1444         break;
1445
1446     case SVt_PVGV:
1447         if (!isGV_with_GP(sv))
1448             break;
1449         /* FALLTHROUGH */
1450     case SVt_PVAV:
1451     case SVt_PVHV:
1452     case SVt_PVCV:
1453     case SVt_PVFM:
1454     case SVt_PVIO:
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),
1457                    OP_DESC(PL_op));
1458         NOT_REACHED; /* NOTREACHED */
1459         break;
1460     default: NOOP;
1461     }
1462     (void)SvIOK_only(sv);                       /* validate number */
1463     SvIV_set(sv, i);
1464     SvTAINT(sv);
1465 }
1466
1467 void
1468 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1469 {
1470     PERL_ARGS_ASSERT_SV_SETIV_MG;
1471
1472     sv_setiv(sv,i);
1473     SvSETMAGIC(sv);
1474 }
1475
1476 /*
1477 =for apidoc sv_setuv
1478 =for apidoc_item sv_setuv_mg
1479
1480 These copy an unsigned integer into the given SV, upgrading first if necessary.
1481
1482
1483 They differ only in that C<sv_setuv_mg> handles 'set' magic; C<sv_setuv> does
1484 not.
1485
1486 =cut
1487 */
1488
1489 void
1490 Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1491 {
1492     PERL_ARGS_ASSERT_SV_SETUV;
1493
1494     /* With the if statement to ensure that integers are stored as IVs whenever
1495        possible:
1496        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1497
1498        without
1499        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1500
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 :-)
1504     */
1505     if (u <= (UV)IV_MAX) {
1506        sv_setiv(sv, (IV)u);
1507        return;
1508     }
1509     sv_setiv(sv, 0);
1510     SvIsUV_on(sv);
1511     SvUV_set(sv, u);
1512 }
1513
1514 void
1515 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1516 {
1517     PERL_ARGS_ASSERT_SV_SETUV_MG;
1518
1519     sv_setuv(sv,u);
1520     SvSETMAGIC(sv);
1521 }
1522
1523 /*
1524 =for apidoc sv_setnv
1525 =for apidoc_item sv_setnv_mg
1526
1527 These copy a double into the given SV, upgrading first if necessary.
1528
1529 They differ only in that C<sv_setnv_mg> handles 'set' magic; C<sv_setnv> does
1530 not.
1531
1532 =cut
1533 */
1534
1535 void
1536 Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1537 {
1538     PERL_ARGS_ASSERT_SV_SETNV;
1539
1540     SV_CHECK_THINKFIRST_COW_DROP(sv);
1541     switch (SvTYPE(sv)) {
1542     case SVt_NULL:
1543     case SVt_IV:
1544         sv_upgrade(sv, SVt_NV);
1545         break;
1546     case SVt_PV:
1547     case SVt_PVIV:
1548         sv_upgrade(sv, SVt_PVNV);
1549         break;
1550
1551     case SVt_PVGV:
1552         if (!isGV_with_GP(sv))
1553             break;
1554         /* FALLTHROUGH */
1555     case SVt_PVAV:
1556     case SVt_PVHV:
1557     case SVt_PVCV:
1558     case SVt_PVFM:
1559     case SVt_PVIO:
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),
1562                    OP_DESC(PL_op));
1563         NOT_REACHED; /* NOTREACHED */
1564         break;
1565     default: NOOP;
1566     }
1567     SvNV_set(sv, num);
1568     (void)SvNOK_only(sv);                       /* validate number */
1569     SvTAINT(sv);
1570 }
1571
1572 void
1573 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1574 {
1575     PERL_ARGS_ASSERT_SV_SETNV_MG;
1576
1577     sv_setnv(sv,num);
1578     SvSETMAGIC(sv);
1579 }
1580
1581 /*
1582 =for apidoc sv_setrv_noinc
1583 =for apidoc_item sv_setrv_noinc_mg
1584
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.
1588
1589 C<sv_setrv_noinc_mg> will invoke 'set' magic on the SV; C<sv_setrv_noinc> will
1590 not.
1591
1592 =cut
1593 */
1594
1595 void
1596 Perl_sv_setrv_noinc(pTHX_ SV *const sv, SV *const ref)
1597 {
1598     PERL_ARGS_ASSERT_SV_SETRV_NOINC;
1599
1600     SV_CHECK_THINKFIRST_COW_DROP(sv);
1601     prepare_SV_for_RV(sv);
1602
1603     SvOK_off(sv);
1604     SvRV_set(sv, ref);
1605     SvROK_on(sv);
1606 }
1607
1608 void
1609 Perl_sv_setrv_noinc_mg(pTHX_ SV *const sv, SV *const ref)
1610 {
1611     PERL_ARGS_ASSERT_SV_SETRV_NOINC_MG;
1612
1613     sv_setrv_noinc(sv, ref);
1614     SvSETMAGIC(sv);
1615 }
1616
1617 /*
1618 =for apidoc sv_setrv_inc
1619 =for apidoc_item sv_setrv_inc_mg
1620
1621 As C<sv_setrv_noinc> but increments the reference count of I<ref>.
1622
1623 C<sv_setrv_inc_mg> will invoke 'set' magic on the SV; C<sv_setrv_inc> will
1624 not.
1625
1626 =cut
1627 */
1628
1629 void
1630 Perl_sv_setrv_inc(pTHX_ SV *const sv, SV *const ref)
1631 {
1632     PERL_ARGS_ASSERT_SV_SETRV_INC;
1633
1634     sv_setrv_noinc(sv, SvREFCNT_inc_simple_NN(ref));
1635 }
1636
1637 void
1638 Perl_sv_setrv_inc_mg(pTHX_ SV *const sv, SV *const ref)
1639 {
1640     PERL_ARGS_ASSERT_SV_SETRV_INC_MG;
1641
1642     sv_setrv_noinc(sv, SvREFCNT_inc_simple_NN(ref));
1643     SvSETMAGIC(sv);
1644 }
1645
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.
1650  */
1651
1652 STATIC const char *
1653 S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1654     const char *pv;
1655
1656      PERL_ARGS_ASSERT_SV_DISPLAY;
1657
1658      if (DO_UTF8(sv)) {
1659           SV *dsv = newSVpvs_flags("", SVs_TEMP);
1660           pv = sv_uni_display(dsv, sv, 32, UNI_DISPLAY_ISPRINT);
1661      } else {
1662           char *d = tmpbuf;
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 */
1666
1667           const char *s = SvPVX_const(sv);
1668           const char * const end = s + SvCUR(sv);
1669           for ( ; s < end && d < limit; s++ ) {
1670                int ch = (U8) *s;
1671                if (! isASCII(ch) && !isPRINT_LC(ch)) {
1672                     *d++ = 'M';
1673                     *d++ = '-';
1674
1675                     /* Map to ASCII "equivalent" of Latin1 */
1676                     ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1677                }
1678                if (ch == '\n') {
1679                     *d++ = '\\';
1680                     *d++ = 'n';
1681                }
1682                else if (ch == '\r') {
1683                     *d++ = '\\';
1684                     *d++ = 'r';
1685                }
1686                else if (ch == '\f') {
1687                     *d++ = '\\';
1688                     *d++ = 'f';
1689                }
1690                else if (ch == '\\') {
1691                     *d++ = '\\';
1692                     *d++ = '\\';
1693                }
1694                else if (ch == '\0') {
1695                     *d++ = '\\';
1696                     *d++ = '0';
1697                }
1698                else if (isPRINT_LC(ch))
1699                     *d++ = ch;
1700                else {
1701                     *d++ = '^';
1702                     *d++ = toCTRL(ch);
1703                }
1704           }
1705           if (s < end) {
1706                *d++ = '.';
1707                *d++ = '.';
1708                *d++ = '.';
1709           }
1710           *d = '\0';
1711           pv = tmpbuf;
1712     }
1713
1714     return pv;
1715 }
1716
1717 /* Print an "isn't numeric" warning, using a cleaned-up,
1718  * printable version of the offending string
1719  */
1720
1721 STATIC void
1722 S_not_a_number(pTHX_ SV *const sv)
1723 {
1724      char tmpbuf[64];
1725      const char *pv;
1726
1727      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1728
1729      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1730
1731     if (PL_op)
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,
1735                     OP_DESC(PL_op));
1736     else
1737         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1738                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1739                     "Argument \"%s\" isn't numeric", pv);
1740 }
1741
1742 STATIC void
1743 S_not_incrementable(pTHX_ SV *const sv) {
1744      char tmpbuf[64];
1745      const char *pv;
1746
1747      PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1748
1749      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1750
1751      Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1752                  "Argument \"%s\" treated as 0 in increment (++)", pv);
1753 }
1754
1755 /*
1756 =for apidoc looks_like_number
1757
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
1761 ignored.
1762
1763 =cut
1764 */
1765
1766 I32
1767 Perl_looks_like_number(pTHX_ SV *const sv)
1768 {
1769     const char *sbegin;
1770     STRLEN len;
1771     int numtype;
1772
1773     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1774
1775     if (SvPOK(sv) || SvPOKp(sv)) {
1776         sbegin = SvPV_nomg_const(sv, len);
1777     }
1778     else
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;
1782 }
1783
1784 STATIC bool
1785 S_glob_2number(pTHX_ GV * const gv)
1786 {
1787     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1788
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))
1792     {
1793         SV *const buffer = sv_newmortal();
1794         gv_efullname3(buffer, gv, "*");
1795         not_a_number(buffer);
1796     }
1797     /* We just want something true to return, so that S_sv_2iuv_common
1798         can tail call us and return true.  */
1799     return TRUE;
1800 }
1801
1802 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1803    until proven guilty, assume that things are not that bad... */
1804
1805 /*
1806    NV_PRESERVES_UV:
1807
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
1823       acceptable (still))
1824
1825
1826    flags are used:
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
1831
1832    so
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).
1837
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.
1841
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;
1847
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.
1853
1854    * making IV and NV equal status should make maths accurate on 64 bit
1855      platforms
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
1865
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    ####################################################################
1871
1872    Your mileage will vary depending your CPU's relative fp to integer
1873    performance ratio.
1874 */
1875
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
1882
1883 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1884
1885 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1886 STATIC int
1887 S_sv_2iuv_non_preserve(pTHX_ SV *const sv
1888 #  ifdef DEBUGGING
1889                        , I32 numtype
1890 #  endif
1891                        )
1892 {
1893     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1894     PERL_UNUSED_CONTEXT;
1895
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);
1899         (void)SvNOK_on(sv);
1900         SvIV_set(sv, IV_MIN);
1901         return IS_NUMBER_UNDERFLOW_IV;
1902     }
1903     if (SvNVX(sv) > (NV)UV_MAX) {
1904         (void)SvIOKp_on(sv);
1905         (void)SvNOK_on(sv);
1906         SvIsUV_on(sv);
1907         SvUV_set(sv, UV_MAX);
1908         return IS_NUMBER_OVERFLOW_UV;
1909     }
1910     (void)SvIOKp_on(sv);
1911     (void)SvNOK_on(sv);
1912     /* Can't use strtol etc to convert this string.  (See truth table in
1913        sv_2iv  */
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 */
1918         } else {
1919             /* Integer is imprecise. NOK, IOKp */
1920         }
1921         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1922     }
1923     SvIsUV_on(sv);
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.
1929                NOK, IOKp */
1930             return IS_NUMBER_OVERFLOW_UV;
1931         }
1932         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1933     } else {
1934         /* Integer is imprecise. NOK, IOKp */
1935     }
1936     return IS_NUMBER_OVERFLOW_IV;
1937 }
1938 #endif /* !NV_PRESERVES_UV*/
1939
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). */
1942 static void
1943 S_sv_setnv(pTHX_ SV* sv, int numtype)
1944 {
1945     bool pok = cBOOL(SvPOK(sv));
1946     bool nok = FALSE;
1947 #ifdef NV_INF
1948     if ((numtype & IS_NUMBER_INFINITY)) {
1949         SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
1950         nok = TRUE;
1951     } else
1952 #endif
1953 #ifdef NV_NAN
1954     if ((numtype & IS_NUMBER_NAN)) {
1955         SvNV_set(sv, NV_NAN);
1956         nok = TRUE;
1957     } else
1958 #endif
1959     if (pok) {
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. */
1963     }
1964     if (nok) {
1965         SvNOK_only(sv); /* No IV or UV please, this is pure infnan. */
1966         if (pok)
1967             SvPOK_on(sv); /* PV is okay, though. */
1968     }
1969 }
1970
1971 STATIC bool
1972 S_sv_2iuv_common(pTHX_ SV *const sv)
1973 {
1974     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
1975
1976     if (SvNOKp(sv)) {
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 */
1982
1983         if (SvTYPE(sv) == SVt_NV)
1984             sv_upgrade(sv, SVt_PVNV);
1985
1986     got_nv:
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
1991            cases go to UV */
1992 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1993         if (Perl_isnan(SvNVX(sv))) {
1994             SvUV_set(sv, 0);
1995             SvIsUV_on(sv);
1996             return FALSE;
1997         }
1998 #endif
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 */
2009 #endif
2010                 ) {
2011                 if (SvNOK(sv))
2012                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2013                 else {
2014                     /* scalar has trailing garbage, eg "42a" */
2015                 }
2016                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2017                                       "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (precise)\n",
2018                                       PTR2UV(sv),
2019                                       SvNVX(sv),
2020                                       SvIVX(sv)));
2021
2022             } else {
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",
2029                                       PTR2UV(sv),
2030                                       SvNVX(sv),
2031                                       SvIVX(sv)));
2032             }
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 */
2041         }
2042         else {
2043             SvUV_set(sv, U_V(SvNVX(sv)));
2044             if (
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 */
2053 #endif
2054                 && SvNOK(sv)
2055                 )
2056                 SvIOK_on(sv);
2057             SvIsUV_on(sv);
2058             DEBUG_c(PerlIO_printf(Perl_debug_log,
2059                                   "0x%" UVxf " 2iv(%" UVuf " => %" IVdf ") (as unsigned)\n",
2060                                   PTR2UV(sv),
2061                                   SvUVX(sv),
2062                                   SvUVX(sv)));
2063         }
2064     }
2065     else if (SvPOKp(sv)) {
2066         UV value;
2067         int numtype;
2068         const char *s = SvPVX_const(sv);
2069         const STRLEN cur = SvCUR(sv);
2070
2071         /* short-cut for a single digit string like "1" */
2072
2073         if (cur == 1) {
2074             char c = *s;
2075             if (isDIGIT(c)) {
2076                 if (SvTYPE(sv) < SVt_PVIV)
2077                     sv_upgrade(sv, SVt_PVIV);
2078                 (void)SvIOK_on(sv);
2079                 SvIV_set(sv, (IV)(c - '0'));
2080                 return FALSE;
2081             }
2082         }
2083
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).
2091
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.
2095          */
2096
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);
2103             (void)SvIOK_on(sv);
2104         } else if (SvTYPE(sv) < SVt_PVNV)
2105             sv_upgrade(sv, SVt_PVNV);
2106
2107         if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
2108             if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING)))
2109                 not_a_number(sv);
2110             S_sv_setnv(aTHX_ sv, numtype);
2111             goto got_nv;        /* Fill IV/UV slot and set IOKp */
2112         }
2113
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
2120                         | IS_NUMBER_NOT_INT
2121 #endif
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);
2125
2126             if (!(numtype & IS_NUMBER_NEG)) {
2127                 /* positive */;
2128                 if (value <= (UV)IV_MAX) {
2129                     SvIV_set(sv, (IV)value);
2130                 } else {
2131                     /* it didn't overflow, and it was positive. */
2132                     SvUV_set(sv, value);
2133                     SvIsUV_on(sv);
2134                 }
2135             } else {
2136                 /* 2s complement assumption  */
2137                 if (value <= (UV)IV_MIN) {
2138                     SvIV_set(sv, value == (UV)IV_MIN
2139                                     ? IV_MIN : -(IV)value);
2140                 } else {
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);
2145                     SvNOK_on(sv);
2146                     SvIOK_off(sv);
2147                     SvIOKp_on(sv);
2148                     SvNV_set(sv, -(NV)value);
2149                     SvIV_set(sv, IV_MIN);
2150                 }
2151             }
2152         }
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.  */
2156
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);
2161
2162             if (! numtype && ckWARN(WARN_NUMERIC))
2163                 not_a_number(sv);
2164
2165             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" NVgf ")\n",
2166                                   PTR2UV(sv), SvNVX(sv)));
2167
2168 #ifdef NV_PRESERVES_UV
2169             SvNOKp_on(sv);
2170             if (numtype)
2171                 SvNOK_on(sv);
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
2178                    Atof.  */
2179                 SvNOK_on(sv);
2180                 assert (SvIOKp(sv));
2181             } else {
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);
2186                     SvNOK_on(sv);
2187                     SvIV_set(sv, I_V(SvNVX(sv)));
2188                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2189                         SvIOK_on(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) <=
2195                                        (UV)IV_MAX);
2196                 } else {
2197                     /* IN_UV NOT_INT
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.  */
2205 #  ifdef DEBUGGING
2206                     sv_2iuv_non_preserve (sv, numtype);
2207 #  else
2208                     sv_2iuv_non_preserve (sv);
2209 #  endif
2210                 }
2211             }
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:  */
2216         if (!numtype)
2217             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2218 #endif /* NV_PRESERVES_UV */
2219         }
2220     }
2221     else {
2222         if (isGV_with_GP(sv))
2223             return glob_2number(MUTABLE_GV(sv));
2224
2225         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2226                 report_uninit(sv);
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.  */
2231         return TRUE;
2232     }
2233     return FALSE;
2234 }
2235
2236 /*
2237 =for apidoc sv_2iv_flags
2238
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.
2242
2243 =cut
2244 */
2245
2246 IV
2247 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2248 {
2249     PERL_ARGS_ASSERT_SV_2IV_FLAGS;
2250
2251     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2252          && SvTYPE(sv) != SVt_PVFM);
2253
2254     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2255         mg_get(sv);
2256
2257     if (SvROK(sv)) {
2258         if (SvAMAGIC(sv)) {
2259             SV * tmpstr;
2260             if (flags & SV_SKIP_OVERLOAD)
2261                 return 0;
2262             tmpstr = AMG_CALLunary(sv, numer_amg);
2263             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2264                 return SvIV(tmpstr);
2265             }
2266         }
2267         return PTR2IV(SvRV(sv));
2268     }
2269
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.
2276
2277            Regexps have no SvIVX and SvNVX fields.
2278         */
2279         assert(SvPOKp(sv));
2280         {
2281             UV value;
2282             const char * const ptr =
2283                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2284             const int numtype
2285                 = grok_number(ptr, SvCUR(sv), &value);
2286
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)
2292                         return -(IV)value;
2293                 } else {
2294                     if (value < (UV)IV_MAX)
2295                         return (IV)value;
2296                 }
2297             }
2298
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. */
2304             }
2305
2306             if (!numtype) {
2307                 if (ckWARN(WARN_NUMERIC))
2308                     not_a_number(sv);
2309             }
2310             return I_V(Atof(ptr));
2311         }
2312     }
2313
2314     if (SvTHINKFIRST(sv)) {
2315         if (SvREADONLY(sv) && !SvOK(sv)) {
2316             if (ckWARN(WARN_UNINITIALIZED))
2317                 report_uninit(sv);
2318             return 0;
2319         }
2320     }
2321
2322     if (!SvIOKp(sv)) {
2323         if (S_sv_2iuv_common(aTHX_ sv))
2324             return 0;
2325     }
2326
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);
2330 }
2331
2332 /*
2333 =for apidoc sv_2uv_flags
2334
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.
2338
2339 =for apidoc Amnh||SV_GMAGIC
2340
2341 =cut
2342 */
2343
2344 UV
2345 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2346 {
2347     PERL_ARGS_ASSERT_SV_2UV_FLAGS;
2348
2349     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2350         mg_get(sv);
2351
2352     if (SvROK(sv)) {
2353         if (SvAMAGIC(sv)) {
2354             SV *tmpstr;
2355             if (flags & SV_SKIP_OVERLOAD)
2356                 return 0;
2357             tmpstr = AMG_CALLunary(sv, numer_amg);
2358             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2359                 return SvUV(tmpstr);
2360             }
2361         }
2362         return PTR2UV(SvRV(sv));
2363     }
2364
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. */
2369         assert(SvPOKp(sv));
2370         {
2371             UV value;
2372             const char * const ptr =
2373                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2374             const int numtype
2375                 = grok_number(ptr, SvCUR(sv), &value);
2376
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))
2381                     return value;
2382             }
2383
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. */
2389             }
2390
2391             if (!numtype) {
2392                 if (ckWARN(WARN_NUMERIC))
2393                     not_a_number(sv);
2394             }
2395             return U_V(Atof(ptr));
2396         }
2397     }
2398
2399     if (SvTHINKFIRST(sv)) {
2400         if (SvREADONLY(sv) && !SvOK(sv)) {
2401             if (ckWARN(WARN_UNINITIALIZED))
2402                 report_uninit(sv);
2403             return 0;
2404         }
2405     }
2406
2407     if (!SvIOKp(sv)) {
2408         if (S_sv_2iuv_common(aTHX_ sv))
2409             return 0;
2410     }
2411
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);
2415 }
2416
2417 /*
2418 =for apidoc sv_2nv_flags
2419
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.
2423
2424 =cut
2425 */
2426
2427 NV
2428 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2429 {
2430     PERL_ARGS_ASSERT_SV_2NV_FLAGS;
2431
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.  */
2438         const char *ptr;
2439         if (flags & SV_GMAGIC)
2440             mg_get(sv);
2441         if (SvNOKp(sv))
2442             return SvNVX(sv);
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))
2447                 not_a_number(sv);
2448             return Atof(ptr);
2449         }
2450         if (SvIOKp(sv)) {
2451             if (SvIsUV(sv))
2452                 return (NV)SvUVX(sv);
2453             else
2454                 return (NV)SvIVX(sv);
2455         }
2456         if (SvROK(sv)) {
2457             goto return_rok;
2458         }
2459         assert(SvTYPE(sv) >= SVt_PVMG);
2460         /* This falls through to the report_uninit near the end of the
2461            function. */
2462     } else if (SvTHINKFIRST(sv)) {
2463         if (SvROK(sv)) {
2464         return_rok:
2465             if (SvAMAGIC(sv)) {
2466                 SV *tmpstr;
2467                 if (flags & SV_SKIP_OVERLOAD)
2468                     return 0;
2469                 tmpstr = AMG_CALLunary(sv, numer_amg);
2470                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2471                     return SvNV(tmpstr);
2472                 }
2473             }
2474             return PTR2NV(SvRV(sv));
2475         }
2476         if (SvREADONLY(sv) && !SvOK(sv)) {
2477             if (ckWARN(WARN_UNINITIALIZED))
2478                 report_uninit(sv);
2479             return 0.0;
2480         }
2481     }
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);
2486         DEBUG_c({
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();
2493         });
2494         CLANG_DIAG_RESTORE_STMT;
2495
2496     }
2497     else if (SvTYPE(sv) < SVt_PVNV)
2498         sv_upgrade(sv, SVt_PVNV);
2499     if (SvNOKp(sv)) {
2500         return SvNVX(sv);
2501     }
2502     if (SvIOKp(sv)) {
2503         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2504 #ifdef NV_PRESERVES_UV
2505         if (SvIOK(sv))
2506             SvNOK_on(sv);
2507         else
2508             SvNOKp_on(sv);
2509 #else
2510         /* Only set the public NV OK flag if this NV preserves the IV  */
2511         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2512         if (SvIOK(sv) &&
2513             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2514                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2515             SvNOK_on(sv);
2516         else
2517             SvNOKp_on(sv);
2518 #endif
2519     }
2520     else if (SvPOKp(sv)) {
2521         UV value;
2522         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2523         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2524             not_a_number(sv);
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);
2530         } else {
2531             S_sv_setnv(aTHX_ sv, numtype);
2532         }
2533         if (numtype)
2534             SvNOK_on(sv);
2535         else
2536             SvNOKp_on(sv);
2537 #else
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 ==
2544            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.  */
2550             SvNOK_on(sv);
2551         } else {
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.  */
2556             } else {
2557                 SvNOKp_on(sv);
2558                 SvIOKp_on(sv);
2559
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 ==
2563                      * (UV)IV_MIN */
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);
2568                 } else {
2569                     SvUV_set(sv, value);
2570                     SvIsUV_on(sv);
2571                 }
2572
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 */
2579                 } else {
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)) {
2584                             SvNOK_on(sv);
2585                         } else {
2586                             /* It had no "." so it must be integer.  */
2587                         }
2588                         SvIOK_on(sv);
2589                     } else {
2590                         /* between IV_MAX and NV(UV_MAX).
2591                            Could be slightly > UV_MAX */
2592
2593                         if (numtype & IS_NUMBER_NOT_INT) {
2594                             /* UV and NV both imprecise.  */
2595                         } else {
2596                             const UV nv_as_uv = U_V(nv);
2597
2598                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2599                                 SvNOK_on(sv);
2600                             }
2601                             SvIOK_on(sv);
2602                         }
2603                     }
2604                 }
2605             }
2606         }
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:  */
2611         if (!numtype)
2612             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2613 #endif /* NV_PRESERVES_UV */
2614     }
2615     else {
2616         if (isGV_with_GP(sv)) {
2617             glob_2number(MUTABLE_GV(sv));
2618             return 0.0;
2619         }
2620
2621         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2622             report_uninit(sv);
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.  */
2627         return 0.0;
2628     }
2629     CLANG_DIAG_IGNORE_STMT(-Wthread-safety);
2630     DEBUG_c({
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();
2636     });
2637     CLANG_DIAG_RESTORE_STMT;
2638     return SvNVX(sv);
2639 }
2640
2641 /*
2642 =for apidoc sv_2num
2643
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
2646 get-magic already.
2647
2648 =cut
2649 */
2650
2651 SV *
2652 Perl_sv_2num(pTHX_ SV *const sv)
2653 {
2654     PERL_ARGS_ASSERT_SV_2NUM;
2655
2656     if (!SvROK(sv))
2657         return sv;
2658     if (SvAMAGIC(sv)) {
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);
2663     }
2664     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2665 }
2666
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".
2670  *
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 {
2675     char arr[200];
2676     U16 dummy;
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',
2692     '9', '8', '9', '9'
2693 }};
2694
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
2697  * end of it.
2698  *
2699  * We assume that buf is at least TYPE_CHARS(UV) long.
2700  */
2701
2702 PERL_STATIC_INLINE char *
2703 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2704 {
2705     char *ptr = buf + TYPE_CHARS(UV);
2706     char * const ebuf = ptr;
2707     int sign;
2708     U16 *word_ptr, *word_table;
2709
2710     PERL_ARGS_ASSERT_UIV_2BUF;
2711
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;
2717
2718     if (UNLIKELY(is_uv))
2719         sign = 0;
2720     else if (iv >= 0) {
2721         uv = iv;
2722         sign = 0;
2723     } else {
2724         /* Using 0- here to silence bogus warning from MS VC */
2725         uv = (UV) (0 - (UV) iv);
2726         sign = 1;
2727     }
2728
2729     while (uv > 99) {
2730         *--word_ptr = word_table[uv % 100];
2731         uv /= 100;
2732     }
2733     ptr = (char*)word_ptr;
2734
2735     if (uv < 10)
2736         *--ptr = (char)uv + '0';
2737     else {
2738         *--word_ptr = word_table[uv];
2739         ptr = (char*)word_ptr;
2740     }
2741
2742     if (sign)
2743         *--ptr = '-';
2744
2745     *peob = ebuf;
2746     return ptr;
2747 }
2748
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.
2754  *
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. */
2758 STATIC size_t
2759 S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char plus) {
2760     char* s = buffer;
2761     assert(maxlen >= 4);
2762     if (Perl_isinf(nv)) {
2763         if (nv < 0) {
2764             if (maxlen < 5) /* "-Inf\0"  */
2765                 return 0;
2766             *s++ = '-';
2767         } else if (plus) {
2768             *s++ = '+';
2769         }
2770         *s++ = 'I';
2771         *s++ = 'n';
2772         *s++ = 'f';
2773     }
2774     else if (Perl_isnan(nv)) {
2775         *s++ = 'N';
2776         *s++ = 'a';
2777         *s++ = 'N';
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.*/
2783     }
2784     else {
2785       return 0;
2786     }
2787     assert((s == buffer + 3) || (s == buffer + 4));
2788     *s = 0;
2789     return s - buffer;
2790 }
2791
2792 /*
2793 =for apidoc      sv_2pv
2794 =for apidoc_item sv_2pv_flags
2795
2796 These implement the various forms of the L<perlapi/C<SvPV>> macros.
2797 The macros are the preferred interface.
2798
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.
2801
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
2804 C<SV_GMAGIC>.
2805
2806 =for apidoc Amnh||SV_GMAGIC
2807
2808 =cut
2809 */
2810
2811 char *
2812 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const U32 flags)
2813 {
2814     char *s;
2815
2816     PERL_ARGS_ASSERT_SV_2PV_FLAGS;
2817
2818     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2819          && SvTYPE(sv) != SVt_PVFM);
2820     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2821         mg_get(sv);
2822     if (SvROK(sv)) {
2823         if (SvAMAGIC(sv)) {
2824             SV *tmpstr;
2825             if (flags & SV_SKIP_OVERLOAD)
2826                 return NULL;
2827             tmpstr = AMG_CALLunary(sv, string_amg);
2828             TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2829             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2830                 /* Unwrap this:  */
2831                 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2832                  */
2833
2834                 char *pv;
2835                 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2836                     if (flags & SV_CONST_RETURN) {
2837                         pv = (char *) SvPVX_const(tmpstr);
2838                     } else {
2839                         pv = (flags & SV_MUTABLE_RETURN)
2840                             ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2841                     }
2842                     if (lp)
2843                         *lp = SvCUR(tmpstr);
2844                 } else {
2845                     pv = sv_2pv_flags(tmpstr, lp, flags);
2846                 }
2847                 if (SvUTF8(tmpstr))
2848                     SvUTF8_on(sv);
2849                 else
2850                     SvUTF8_off(sv);
2851                 return pv;
2852             }
2853         }
2854         {
2855             STRLEN len;
2856             char *retval;
2857             char *buffer;
2858             SV *const referent = SvRV(sv);
2859
2860             if (!referent) {
2861                 len = 7;
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);
2867
2868                 assert(re);
2869
2870                 /* If the regex is UTF-8 we want the containing scalar to
2871                    have an UTF-8 flag too */
2872                 if (RX_UTF8(re))
2873                     SvUTF8_on(sv);
2874                 else
2875                     SvUTF8_off(sv);
2876
2877                 if (lp)
2878                     *lp = RX_WRAPLEN(re);
2879
2880                 return RX_WRAPPED(re);
2881             } else {
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;
2888
2889                 if (SvOBJECT(referent)) {
2890                     const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2891
2892                     if (name) {
2893                         stashname = HEK_KEY(name);
2894                         stashnamelen = HEK_LEN(name);
2895
2896                         if (HEK_UTF8(name)) {
2897                             SvUTF8_on(sv);
2898                         } else {
2899                             SvUTF8_off(sv);
2900                         }
2901                     } else {
2902                         stashname = "__ANON__";
2903                         stashnamelen = 8;
2904                     }
2905                     len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2906                         + 2 * sizeof(UV) + 2 /* )\0 */;
2907                 } else {
2908                     len = typelen + 3 /* (0x */
2909                         + 2 * sizeof(UV) + 2 /* )\0 */;
2910                 }
2911
2912                 Newx(buffer, len, char);
2913                 buffer_end = retval = buffer + len;
2914
2915                 /* Working backwards  */
2916                 *--retval = '\0';
2917                 *--retval = ')';
2918                 do {
2919                     *--retval = PL_hexdigit[addr & 15];
2920                 } while (addr >>= 4);
2921                 *--retval = 'x';
2922                 *--retval = '0';
2923                 *--retval = '(';
2924
2925                 retval -= typelen;
2926                 memcpy(retval, typestring, typelen);
2927
2928                 if (stashname) {
2929                     *--retval = '=';
2930                     retval -= stashnamelen;
2931                     memcpy(retval, stashname, stashnamelen);
2932                 }
2933                 /* retval may not necessarily have reached the start of the
2934                    buffer here.  */
2935                 assert (retval >= buffer);
2936
2937                 len = buffer_end - retval - 1; /* -1 for that \0  */
2938             }
2939             if (lp)
2940                 *lp = len;
2941             SAVEFREEPV(buffer);
2942             return retval;
2943         }
2944     }
2945
2946     if (SvPOKp(sv)) {
2947         if (lp)
2948             *lp = SvCUR(sv);
2949         if (flags & SV_MUTABLE_RETURN)
2950             return SvPVX_mutable(sv);
2951         if (flags & SV_CONST_RETURN)
2952             return (char *)SvPVX_const(sv);
2953         return SvPVX(sv);
2954     }
2955
2956     if (SvIOK(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 */
2962         union {
2963             char arr[TYPE_CHARS(UV)];
2964             U16 dummy;
2965         } buf;
2966         char *ebuf, *ptr;
2967         STRLEN len;
2968
2969         if (SvTYPE(sv) < SVt_PVIV)
2970             sv_upgrade(sv, SVt_PVIV);
2971         ptr = uiv_2buf(buf.arr, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2972         len = ebuf - ptr;
2973         /* inlined from sv_setpvn */
2974         s = SvGROW_mutable(sv, len + 1);
2975         Move(ptr, s, len, char);
2976         s += len;
2977         *s = '\0';
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. */
2993         SvPOKp_on(sv);
2994     }
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))
3001 #endif
3002         ) {
3003             s = SvGROW_mutable(sv, 2);
3004             *s++ = '0';
3005             *s = '\0';
3006         } else {
3007             STRLEN len;
3008             STRLEN size = 5; /* "-Inf\0" */
3009
3010             s = SvGROW_mutable(sv, size);
3011             len = S_infnan_2pv(SvNVX(sv), s, size, 0);
3012             if (len > 0) {
3013                 s += len;
3014                 SvPOKp_on(sv);
3015             }
3016             else {
3017                 /* some Xenix systems wipe out errno here */
3018                 dSAVE_ERRNO;
3019
3020                 size =
3021                     1 + /* sign */
3022                     1 + /* "." */
3023                     NV_DIG +
3024                     1 + /* "e" */
3025                     1 + /* sign */
3026                     5 + /* exponent digits */
3027                     1 + /* \0 */
3028                     2; /* paranoia */
3029
3030                 s = SvGROW_mutable(sv, size);
3031 #ifndef USE_LOCALE_NUMERIC
3032                 SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3033
3034                 SvPOKp_on(sv);
3035 #else
3036                 {
3037                     bool local_radix;
3038                     DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3039                     STORE_LC_NUMERIC_SET_TO_NEEDED();
3040
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);
3045                     }
3046
3047                     SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3048
3049                     /* If the radix character is UTF-8, and actually is in the
3050                      * output, turn on the UTF-8 flag for the scalar */
3051                     if (   local_radix
3052                         && SvUTF8(PL_numeric_radix_sv)
3053                         && instr(s, SvPVX_const(PL_numeric_radix_sv)))
3054                     {
3055                         SvUTF8_on(sv);
3056                     }
3057
3058                     RESTORE_LC_NUMERIC();
3059                 }
3060
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 */
3065 #endif
3066                 RESTORE_ERRNO;
3067             }
3068             while (*s) s++;
3069         }
3070     }
3071     else if (isGV_with_GP(sv)) {
3072         GV *const gv = MUTABLE_GV(sv);
3073         SV *const buffer = sv_newmortal();
3074
3075         gv_efullname3(buffer, gv, "*");
3076
3077         assert(SvPOK(buffer));
3078         if (SvUTF8(buffer))
3079             SvUTF8_on(sv);
3080         else
3081             SvUTF8_off(sv);
3082         if (lp)
3083             *lp = SvCUR(buffer);
3084         return SvPVX(buffer);
3085     }
3086     else {
3087         if (lp)
3088             *lp = 0;
3089         if (flags & SV_UNDEF_RETURNS_NULL)
3090             return NULL;
3091         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3092             report_uninit(sv);
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);
3096         return (char *)"";
3097     }
3098
3099     {
3100         const STRLEN len = s - SvPVX_const(sv);
3101         if (lp)
3102             *lp = len;
3103         SvCUR_set(sv, len);
3104     }
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);
3111     return SvPVX(sv);
3112 }
3113
3114 /*
3115 =for apidoc sv_copypv
3116 =for apidoc_item sv_copypv_flags
3117 =for apidoc_item sv_copypv_nomg
3118
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.
3125
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).
3130
3131 =cut
3132 */
3133
3134 void
3135 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3136 {
3137     STRLEN len;
3138     const char *s;
3139
3140     PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3141
3142     s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC));
3143     sv_setpvn(dsv,s,len);
3144     if (SvUTF8(ssv))
3145         SvUTF8_on(dsv);
3146     else
3147         SvUTF8_off(dsv);
3148 }
3149
3150 /*
3151 =for apidoc      sv_2pvbyte
3152 =for apidoc_item sv_2pvbyte_flags
3153
3154 These implement the various forms of the L<perlapi/C<SvPVbyte>> macros.
3155 The macros are the preferred interface.
3156
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,
3160 they croak.
3161
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
3164 C<SV_GMAGIC>.
3165
3166 =for apidoc Amnh||SV_GMAGIC
3167
3168 =cut
3169 */
3170
3171 char *
3172 Perl_sv_2pvbyte_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags)
3173 {
3174     PERL_ARGS_ASSERT_SV_2PVBYTE_FLAGS;
3175
3176     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
3177         mg_get(sv);
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);
3182         sv = sv2;
3183     }
3184     sv_utf8_downgrade_nomg(sv,0);
3185     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3186 }
3187
3188 /*
3189 =for apidoc      sv_2pvutf8
3190 =for apidoc_item sv_2pvutf8_flags
3191
3192 These implement the various forms of the L<perlapi/C<SvPVutf8>> macros.
3193 The macros are the preferred interface.
3194
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
3197 as a side-effect.
3198
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
3201 C<SV_GMAGIC>.
3202
3203 =cut
3204 */
3205
3206 char *
3207 Perl_sv_2pvutf8_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags)
3208 {
3209     PERL_ARGS_ASSERT_SV_2PVUTF8_FLAGS;
3210
3211     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
3212         mg_get(sv);
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);
3217         sv = sv2;
3218     }
3219     sv_utf8_upgrade_nomg(sv);
3220     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3221 }
3222
3223
3224 /*
3225 =for apidoc sv_2bool
3226
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.
3230
3231 =for apidoc sv_2bool_flags
3232
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.
3236
3237
3238 =cut
3239 */
3240
3241 bool
3242 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
3243 {
3244     PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3245
3246     restart:
3247     if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3248
3249     if (!SvOK(sv))
3250         return 0;
3251     if (SvROK(sv)) {
3252         if (SvAMAGIC(sv)) {
3253             SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3254             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
3255                 bool svb;
3256                 sv = tmpsv;
3257                 if(SvGMAGICAL(sv)) {
3258                     flags = SV_GMAGIC;
3259                     goto restart; /* call sv_2bool */
3260                 }
3261                 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
3262                 else if(!SvOK(sv)) {
3263                     svb = 0;
3264                 }
3265                 else if(SvPOK(sv)) {
3266                     svb = SvPVXtrue(sv);
3267                 }
3268                 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
3269                     svb = (SvIOK(sv) && SvIVX(sv) != 0)
3270                         || (SvNOK(sv) && SvNVX(sv) != 0.0);
3271                 }
3272                 else {
3273                     flags = 0;
3274                     goto restart; /* call sv_2bool_nomg */
3275                 }
3276                 return cBOOL(svb);
3277             }
3278         }
3279         assert(SvRV(sv));
3280         return TRUE;
3281     }
3282     if (isREGEXP(sv))
3283         return
3284           RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
3285
3286     if (SvNOK(sv) && !SvPOK(sv))
3287         return SvNVX(sv) != 0.0;
3288
3289     return SvTRUE_common(sv, 0);
3290 }
3291
3292 /*
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
3297
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
3303
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).
3309
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>.
3316
3317 These are not a general purpose byte encoding to Unicode interface: use the
3318 Encode extension for that.
3319
3320 The C<SV_FORCE_UTF8_UPGRADE> flag is now ignored.
3321
3322 =for apidoc Amnh||SV_GMAGIC|
3323 =for apidoc Amnh||SV_FORCE_UTF8_UPGRADE|
3324
3325 =cut
3326
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.
3330
3331 */
3332
3333 STRLEN
3334 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3335 {
3336     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3337
3338     if (sv == &PL_sv_undef)
3339         return 0;
3340     if (!SvPOK_nog(sv)) {
3341         STRLEN len = 0;
3342         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3343             (void) sv_2pv_flags(sv,&len, flags);
3344             if (SvUTF8(sv)) {
3345                 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3346                 return len;
3347             }
3348         } else {
3349             (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3350         }
3351     }
3352
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
3357      * know - DAPM */
3358     if (SvUTF8(sv) || isREGEXP(sv)) {
3359         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3360         return SvCUR(sv);
3361     }
3362
3363     if (SvIsCOW(sv)) {
3364         S_sv_uncow(aTHX_ sv, 0);
3365     }
3366
3367     if (SvCUR(sv) == 0) {
3368         if (extra) SvGROW(sv, extra + 1); /* Make sure is room for a trailing
3369                                              byte */
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);
3376         U8 *t = s;
3377
3378         if (is_utf8_invariant_string_loc(s, SvCUR(sv), (const U8 **) &t)) {
3379
3380             /* utf8 conversion not needed because all are invariants.  Mark
3381              * as UTF-8 even if no variant - saves scanning loop */
3382             SvUTF8_on(sv);
3383             if (extra) SvGROW(sv, SvCUR(sv) + extra);
3384             return SvCUR(sv);
3385         }
3386
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.
3390          *
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.
3393          *
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.
3405          *
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'.
3411          *
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. */
3420
3421         {
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);
3426
3427             /* The length of the left overs, plus 1. */
3428             const Size_t remaining_length_p1 = e - t;
3429
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);
3433
3434             /* +1 = trailing NUL */
3435             Size_t need = SvCUR(sv) + expansion + extra + 1;
3436             U8 * d;
3437
3438             /* Grow if needed */
3439             if (SvLEN(sv) < need) {
3440                 t = invariant_length + (U8*) SvGROW(sv, need);
3441                 e = t + remaining_length_p1;
3442             }
3443             SvCUR_set(sv, invariant_length + remaining_length_p1 + expansion);
3444
3445             /* Set the NUL at the end */
3446             d = (U8 *) SvEND(sv);
3447             *d-- = '\0';
3448
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 */
3453
3454             e--;
3455             while (e >= t) {
3456                 if (NATIVE_BYTE_IS_INVARIANT(*e)) {
3457                     *d-- = *e;
3458                 } else {
3459                     *d-- = UTF8_EIGHT_BIT_LO(*e);
3460                     *d-- = UTF8_EIGHT_BIT_HI(*e);
3461                 }
3462                 e--;
3463             }
3464
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);
3473                 if (mg) {
3474                     mg->mg_flags &= ~MGf_BYTES;
3475                 }
3476                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3477                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3478             }
3479         }
3480     }
3481
3482     SvUTF8_on(sv);
3483     return SvCUR(sv);
3484 }
3485
3486 /*
3487 =for apidoc sv_utf8_downgrade
3488 =for apidoc_item sv_utf8_downgrade_flags
3489 =for apidoc_item sv_utf8_downgrade_nomg
3490
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.
3494
3495 They are not a general purpose Unicode to byte encoding interface:
3496 use the C<Encode> extension for that.
3497
3498 They differ only in that:
3499
3500 C<sv_utf8_downgrade> processes 'get' magic on C<sv>.
3501
3502 C<sv_utf8_downgrade_nomg> does not.
3503
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.
3506
3507 =cut
3508 */
3509
3510 bool
3511 Perl_sv_utf8_downgrade_flags(pTHX_ SV *const sv, const bool fail_ok, const U32 flags)
3512 {
3513     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE_FLAGS;
3514
3515     if (SvPOKp(sv) && SvUTF8(sv)) {
3516         if (SvCUR(sv)) {
3517             U8 *s;
3518             STRLEN len;
3519             U32 mg_flags = flags & SV_GMAGIC;
3520
3521             if (SvIsCOW(sv)) {
3522                 S_sv_uncow(aTHX_ sv, 0);
3523             }
3524             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3525                 /* update pos */
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 */
3531                 }
3532                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3533                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3534
3535             }
3536             s = (U8 *) SvPV_flags(sv, len, mg_flags);
3537
3538             if (!utf8_to_bytes(s, &len)) {
3539                 if (fail_ok)
3540                     return FALSE;
3541                 else {
3542                     if (PL_op)
3543                         Perl_croak(aTHX_ "Wide character in %s",
3544                                    OP_DESC(PL_op));
3545                     else
3546                         Perl_croak(aTHX_ "Wide character");
3547                 }
3548             }
3549             SvCUR_set(sv, len);
3550         }
3551     }
3552     SvUTF8_off(sv);
3553     return TRUE;
3554 }
3555
3556 /*
3557 =for apidoc sv_utf8_encode
3558
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.
3561
3562 =cut
3563 */
3564
3565 void
3566 Perl_sv_utf8_encode(pTHX_ SV *const sv)
3567 {
3568     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3569
3570     if (SvREADONLY(sv)) {
3571         sv_force_normal_flags(sv, 0);
3572     }
3573     (void) sv_utf8_upgrade(sv);
3574     SvUTF8_off(sv);
3575 }
3576
3577 /*
3578 =for apidoc sv_utf8_decode
3579
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.
3585
3586 =cut
3587 */
3588
3589 bool
3590 Perl_sv_utf8_decode(pTHX_ SV *const sv)
3591 {
3592     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3593
3594     if (SvPOKp(sv)) {
3595         const U8 *start, *c, *first_variant;
3596
3597         /* The octets may have got themselves encoded - get them back as
3598          * bytes
3599          */
3600         if (!sv_utf8_downgrade(sv, TRUE))
3601             return FALSE;
3602
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.
3605          */
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)))
3609                 return FALSE;
3610             SvUTF8_on(sv);
3611         }
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
3615                    need this? */
3616             /* adjust pos to the start of a UTF8 char sequence */
3617             MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3618             if (mg) {
3619                 I32 pos = mg->mg_len;
3620                 if (pos > 0) {
3621                     for (c = start + pos; c > start; c--) {
3622                         if (UTF8_IS_START(*c))
3623                             break;
3624                     }
3625                     mg->mg_len  = c - start;
3626                 }
3627             }
3628             if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3629                 magic_setutf8(sv,mg); /* clear UTF8 cache */
3630         }
3631     }
3632     return TRUE;
3633 }
3634
3635 /*
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
3640
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.
3646
3647 They differ only in that:
3648
3649 C<sv_setsv> calls 'get' magic on C<ssv>, but skips 'set' magic on C<dsv>.
3650
3651 C<sv_setsv_mg> calls both 'get' magic on C<ssv> and 'set' magic on C<dsv>.
3652
3653 C<sv_setsv_nomg> skips all magic.
3654
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.
3658
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>>.
3662
3663 C<sv_setsv_flags> is the primary function for copying scalars, and most other
3664 copy-ish functions and macros use it underneath.
3665
3666 =for apidoc Amnh||SV_NOSTEAL
3667
3668 =cut
3669 */
3670
3671 static void
3672 S_glob_assign_glob(pTHX_ SV *const dsv, SV *const ssv, const int dtype)
3673 {
3674     I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3675     HV *old_stash = NULL;
3676
3677     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3678
3679     if (dtype != SVt_PVGV && !isGV_with_GP(dsv)) {
3680         const char * const name = GvNAME(ssv);
3681         const STRLEN len = GvNAMELEN(ssv);
3682         {
3683             if (dtype >= SVt_PV) {
3684                 SvPV_free(dsv);
3685                 SvPV_set(dsv, 0);
3686                 SvLEN_set(dsv, 0);
3687                 SvCUR_set(dsv, 0);
3688             }
3689             SvUPGRADE(dsv, SVt_PVGV);
3690             (void)SvOK_off(dsv);
3691             isGV_with_GP_on(dsv);
3692         }
3693         GvSTASH(dsv) = GvSTASH(ssv);
3694         if (GvSTASH(dsv))
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 */
3699     }
3700
3701     if(GvGP(MUTABLE_GV(ssv))) {
3702         /* If source has method cache entry, clear it */
3703         if(GvCVGEN(ssv)) {
3704             SvREFCNT_dec(GvCV(ssv));
3705             GvCV_set(ssv, NULL);
3706             GvCVGEN(ssv) = 0;
3707         }
3708         /* If source has a real method, then a method is
3709            going to change */
3710         else if(
3711          GvCV((const GV *)ssv) && GvSTASH(dsv) && HvENAME(GvSTASH(dsv))
3712         ) {
3713             mro_changes = 1;
3714         }
3715     }
3716
3717     /* If dest already had a real method, that's a change as well */
3718     if(
3719         !mro_changes && GvGP(MUTABLE_GV(dsv)) && GvCVu((const GV *)dsv)
3720      && GvSTASH(dsv) && HvENAME(GvSTASH(dsv))
3721     ) {
3722         mro_changes = 1;
3723     }
3724
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
3732             check its name. */
3733          && GvSTASH(dsv) && HvENAME(GvSTASH(dsv))
3734         )
3735             mro_changes = 2;
3736         else {
3737             if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3738              || (len == 1 && name[0] == ':')) {
3739                 mro_changes = 3;
3740
3741                 /* Set aside the old stash, so we can reset isa caches on
3742                    its subclasses. */
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)
3747                     );
3748             }
3749         }
3750
3751         SvREFCNT_inc_simple_void_NN(sv_2mortal(dsv));
3752     }
3753
3754     /* freeing dsv's GP might free ssv (e.g. *x = $x),
3755      * so temporarily protect it */
3756     ENTER;
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)));
3761     LEAVE;
3762
3763     if (SvTAINTED(ssv))
3764         SvTAINT(dsv);
3765     if (GvIMPORTED(dsv) != GVf_IMPORTED
3766         && CopSTASH_ne(PL_curcop, GvSTASH(dsv)))
3767         {
3768             GvIMPORTED_on(dsv);
3769         }
3770     GvMULTI_on(dsv);
3771     if(mro_changes == 2) {
3772       if (GvAV((const GV *)ssv)) {
3773         MAGIC *mg;
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;
3781             } else {
3782                 av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dsv));
3783             }
3784         }
3785         else sv_magic(sref, dsv, PERL_MAGIC_isa, NULL, 0);
3786       }
3787       mro_isa_changed_in(GvSTASH(dsv));
3788     }
3789     else if(mro_changes == 3) {
3790         HV * const stash = GvHV(dsv);
3791         if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3792             mro_package_moved(
3793                 stash, old_stash,
3794                 (GV *)dsv, 0
3795             );
3796     }
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.
3804          */
3805         hv_clear(PL_stashcache);
3806     }
3807     return;
3808 }
3809
3810 void
3811 Perl_gv_setref(pTHX_ SV *const dsv, SV *const ssv)
3812 {
3813     SV * const sref = SvRV(ssv);
3814     SV *dref;
3815     const int intro = GvINTRO(dsv);
3816     SV **location;
3817     U8 import_flag = 0;
3818     const U32 stype = SvTYPE(sref);
3819
3820     PERL_ARGS_ASSERT_GV_SETREF;
3821
3822     if (intro) {
3823         GvINTRO_off(dsv);       /* one-shot flag */
3824         GvLINE(dsv) = CopLINE(PL_curcop);
3825         GvEGV(dsv) = MUTABLE_GV(dsv);
3826     }
3827     GvMULTI_on(dsv);
3828     switch (stype) {
3829     case SVt_PVCV:
3830         location = (SV **) &(GvGP(dsv)->gp_cv); /* XXX bypassing GvCV_set */
3831         import_flag = GVf_IMPORTED_CV;
3832         goto common;
3833     case SVt_PVHV:
3834         location = (SV **) &GvHV(dsv);
3835         import_flag = GVf_IMPORTED_HV;
3836         goto common;
3837     case SVt_PVAV:
3838         location = (SV **) &GvAV(dsv);
3839         import_flag = GVf_IMPORTED_AV;
3840         goto common;
3841     case SVt_PVIO:
3842         location = (SV **) &GvIOp(dsv);
3843         goto common;
3844     case SVt_PVFM:
3845         location = (SV **) &GvFORM(dsv);
3846         goto common;
3847     default:
3848         location = &GvSV(dsv);
3849         import_flag = GVf_IMPORTED_SV;
3850     common:
3851         if (intro) {
3852             if (stype == SVt_PVCV) {
3853                 /*if (GvCVGEN(dsv) && (GvCV(dsv) != (const CV *)sref || GvCVGEN(dsv))) {*/
3854                 if (GvCVGEN(dsv)) {
3855                     SvREFCNT_dec(GvCV(dsv));
3856                     GvCV_set(dsv, NULL);
3857                     GvCVGEN(dsv) = 0; /* Switch off cacheness. */
3858                 }
3859             }
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
3869                    routines here. */
3870                 dSS_ADD;
3871                 SS_ADD_PTR(dsv);
3872                 SS_ADD_PTR(location);
3873                 SS_ADD_PTR(SvREFCNT_inc(*location));
3874                 SS_ADD_UV(SAVEt_GVSLOT);
3875                 SS_ADD_END(4);
3876             }
3877             else SAVEGENERICSV(*location);
3878         }
3879         dref = *location;
3880         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dsv))) {
3881             CV* const cv = MUTABLE_CV(*location);
3882             if (cv) {
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)))
3888                     {
3889                         SV * const new_const_sv =
3890                             CvCONST((const CV *)sref)
3891                                  ? cv_const_sv((const CV *)sref)
3892                                  : NULL;
3893                         HV * const stash = GvSTASH((const GV *)dsv);
3894                         report_redefined_cv(
3895                            sv_2mortal(
3896                              stash
3897                                ? Perl_newSVpvf(aTHX_
3898                                     "%" HEKf "::%" HEKf,
3899                                     HEKfARG(HvNAME_HEK(stash)),
3900                                     HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv))))
3901                                : Perl_newSVpvf(aTHX_
3902                                     "%" HEKf,
3903                                     HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv))))
3904                            ),
3905                            cv,
3906                            CvCONST((const CV *)sref) ? &new_const_sv : NULL
3907                         );
3908                     }
3909                 if (!intro)
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);
3914             }
3915             GvCVGEN(dsv) = 0; /* Switch off cacheness. */
3916             GvASSUMECV_on(dsv);
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 */
3920                     --GvREFCNT(dsv);
3921                     gv_method_changed(dsv);
3922                     ++GvREFCNT(dsv);
3923                 }
3924                 else gv_method_changed(dsv);
3925             }
3926         }
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;
3931         }
3932
3933         if (stype == SVt_PVHV) {
3934             const char * const name = GvNAME((GV*)dsv);
3935             const STRLEN len = GvNAMELEN(dsv);
3936             if (
3937                 (
3938                    (len > 1 && name[len-2] == ':' && name[len-1] == ':')
3939                 || (len == 1 && name[0] == ':')
3940                 )
3941              && (!dref || HvENAME_get(dref))
3942             ) {
3943                 mro_package_moved(
3944                     (HV *)sref, (HV *)dref,
3945                     (GV *)dsv, 0
3946                 );
3947             }
3948         }
3949         else if (
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))
3955         ) {
3956             MAGIC *mg;
3957             MAGIC * const omg = dref && SvSMAGICAL(dref)
3958                                  ? mg_find(dref, PERL_MAGIC_isa)
3959                                  : NULL;
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;
3965                 }
3966                 if (omg) {
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;
3970                         while (items--)
3971                             av_push(
3972                              (AV *)mg->mg_obj,
3973                              SvREFCNT_inc_simple_NN(*svp++)
3974                             );
3975                     }
3976                     else
3977                         av_push(
3978                          (AV *)mg->mg_obj,
3979                          SvREFCNT_inc_simple_NN(omg->mg_obj)
3980                         );
3981                 }
3982                 else
3983                     av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dsv));
3984             }
3985             else
3986             {
3987                 SSize_t i;
3988                 sv_magic(
3989                  sref, omg ? omg->mg_obj : dsv, PERL_MAGIC_isa, NULL, 0
3990                 );
3991                 for (i = 0; i <= AvFILL(sref); ++i) {
3992                     SV **elem = av_fetch ((AV*)sref, i, 0);
3993                     if (elem) {
3994                         sv_magic(
3995                           *elem, sref, PERL_MAGIC_isaelem, NULL, i
3996                         );
3997                     }
3998                 }
3999                 mg = mg_find(sref, PERL_MAGIC_isa);
4000             }
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. */
4005             assert(mg);
4006             Perl_magic_clearisa(aTHX_ NULL, mg);
4007         }
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.
4013             */
4014             hv_clear(PL_stashcache);
4015         }
4016         break;
4017     }
4018     if (!intro) SvREFCNT_dec(dref);
4019     if (SvTAINTED(ssv))
4020         SvTAINT(dsv);
4021     return;
4022 }
4023
4024
4025
4026
4027 #ifdef PERL_DEBUG_READONLY_COW
4028 # include <sys/mman.h>
4029
4030 # ifndef PERL_MEMORY_DEBUG_HEADER_SIZE
4031 #  define PERL_MEMORY_DEBUG_HEADER_SIZE 0
4032 # endif
4033
4034 void
4035 Perl_sv_buf_to_ro(pTHX_ SV *sv)
4036 {
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;
4043 # endif
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);
4047 }
4048
4049 static void
4050 S_sv_buf_to_rw(pTHX_ SV *sv)
4051 {
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;
4061 # endif
4062 }
4063
4064 #else
4065 # define sv_buf_to_ro(sv)       NOOP
4066 # define sv_buf_to_rw(sv)       NOOP
4067 #endif
4068
4069 void
4070 Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags)
4071 {
4072     U32 sflags;
4073     int dtype;
4074     svtype stype;
4075     unsigned int both_type;
4076
4077     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
4078
4079     if (UNLIKELY( ssv == dsv ))
4080         return;
4081
4082     if (UNLIKELY( !ssv ))
4083         ssv = &PL_sv_undef;
4084
4085     stype = SvTYPE(ssv);
4086     dtype = SvTYPE(dsv);
4087     both_type = (stype | dtype);
4088
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
4095          * special-casing */
4096         U32 sflags;
4097         U32 new_dflags;
4098         SV *old_rv = NULL;
4099
4100         /* minimal subset of SV_CHECK_THINKFIRST_COW_DROP(dsv) */
4101         if (SvREADONLY(dsv))
4102             Perl_croak_no_modify();
4103         if (SvROK(dsv)) {
4104             if (SvWEAKREF(dsv))
4105                 sv_unref_flags(dsv, 0);
4106             else
4107                 old_rv = SvRV(dsv);
4108         }
4109
4110         assert(!SvGMAGICAL(ssv));
4111         assert(!SvGMAGICAL(dsv));
4112
4113         sflags = SvFLAGS(ssv);
4114         if (sflags & (SVf_IOK|SVf_ROK)) {
4115             SET_SVANY_FOR_BODYLESS_IV(dsv);
4116             new_dflags = SVt_IV;
4117
4118             if (sflags & SVf_ROK) {
4119                 dsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(ssv));
4120                 new_dflags |= SVf_ROK;
4121             }
4122             else {
4123                 /* both src and dst are <= SVt_IV, so sv_any points to the
4124                  * head; so access the head directly
4125                  */
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));
4132             }
4133         }
4134         else {
4135             new_dflags = dtype; /* turn off everything except the type */
4136         }
4137         SvFLAGS(dsv) = new_dflags;
4138         SvREFCNT_dec(old_rv);
4139
4140         return;
4141     }
4142
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);
4147         }
4148         if (SvIS_FREED(ssv)) {
4149             Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
4150                        (void*)ssv, (void*)dsv);
4151         }
4152     }
4153
4154
4155
4156     SV_CHECK_THINKFIRST_COW_DROP(dsv);
4157     dtype = SvTYPE(dsv); /* THINKFIRST may have changed type */
4158
4159     /* There's a lot of redundancy below but we're going for speed here */
4160
4161     switch (stype) {
4162     case SVt_NULL:
4163       undef_sstr:
4164         if (LIKELY( dtype != SVt_PVGV && dtype != SVt_PVLV )) {
4165             (void)SvOK_off(dsv);
4166             return;
4167         }
4168         break;
4169     case SVt_IV:
4170         if (SvIOK(ssv)) {
4171             switch (dtype) {
4172             case SVt_NULL:
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;
4180                 break;
4181             case SVt_NV:
4182             case SVt_PV:
4183                 sv_upgrade(dsv, SVt_PVIV);
4184                 break;
4185             case SVt_PVGV:
4186             case SVt_PVLV:
4187                 goto end_of_first_switch;
4188             }
4189             (void)SvIOK_only(dsv);
4190             SvIV_set(dsv,  SvIVX(ssv));
4191             if (SvIsUV(ssv))
4192                 SvIsUV_on(dsv);
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
4196                may say).  */
4197             assert(!SvTAINTED(ssv));
4198             return;
4199         }
4200         if (!SvROK(ssv))
4201             goto undef_sstr;
4202         if (dtype < SVt_PV && dtype != SVt_IV)
4203             sv_upgrade(dsv, SVt_IV);
4204         break;
4205
4206     case SVt_NV:
4207         if (LIKELY( SvNOK(ssv) )) {
4208             switch (dtype) {
4209             case SVt_NULL:
4210             case SVt_IV:
4211                 sv_upgrade(dsv, SVt_NV);
4212                 break;
4213             case SVt_PV:
4214             case SVt_PVIV:
4215                 sv_upgrade(dsv, SVt_PVNV);
4216                 break;
4217             case SVt_PVGV:
4218             case SVt_PVLV:
4219                 goto end_of_first_switch;
4220             }
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
4226                may say).  */
4227             assert(!SvTAINTED(ssv));
4228             return;
4229         }
4230         goto undef_sstr;
4231
4232     case SVt_PV:
4233         if (dtype < SVt_PV)
4234             sv_upgrade(dsv, SVt_PV);
4235         break;
4236     case SVt_PVIV:
4237         if (dtype < SVt_PVIV)
4238             sv_upgrade(dsv, SVt_PVIV);
4239         break;
4240     case SVt_PVNV:
4241         if (dtype < SVt_PVNV)
4242             sv_upgrade(dsv, SVt_PVNV);
4243         break;
4244
4245     case SVt_INVLIST:
4246         invlist_clone(ssv, dsv);
4247         break;
4248     default:
4249         {
4250         const char * const type = sv_reftype(ssv,0);
4251         if (PL_op)
4252             /* diag_listed_as: Bizarre copy of %s */
4253             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4254         else
4255             Perl_croak(aTHX_ "Bizarre copy of %s", type);
4256         }
4257         NOT_REACHED; /* NOTREACHED */
4258
4259     case SVt_REGEXP:
4260       upgregexp:
4261         if (dtype < SVt_REGEXP)
4262             sv_upgrade(dsv, SVt_REGEXP);
4263         break;
4264
4265     case SVt_PVLV:
4266     case SVt_PVGV:
4267     case SVt_PVMG:
4268         if (SvGMAGICAL(ssv) && (flags & SV_GMAGIC)) {
4269             mg_get(ssv);
4270             if (SvTYPE(ssv) != stype)
4271                 stype = SvTYPE(ssv);
4272         }
4273         if (isGV_with_GP(ssv) && dtype <= SVt_PVLV) {
4274                     glob_assign_glob(dsv, ssv, dtype);
4275                     return;
4276         }
4277         if (stype == SVt_PVLV)
4278         {
4279             if (isREGEXP(ssv)) goto upgregexp;
4280             SvUPGRADE(dsv, SVt_PVNV);
4281         }
4282         else
4283             SvUPGRADE(dsv, (svtype)stype);
4284     }
4285  end_of_first_switch:
4286
4287     /* dsv may have been upgraded.  */
4288     dtype = SvTYPE(dsv);
4289     sflags = SvFLAGS(ssv);
4290
4291     if (UNLIKELY( dtype == SVt_PVCV )) {
4292         /* Assigning to a subroutine sets the prototype.  */
4293         if (SvOK(ssv)) {
4294             STRLEN len;
4295             const char *const ptr = SvPV_const(ssv, len);
4296
4297             SvGROW(dsv, len + 1);
4298             Copy(ptr, SvPVX(dsv), len + 1, char);
4299             SvCUR_set(dsv, len);
4300             SvPOK_only(dsv);
4301             SvFLAGS(dsv) |= sflags & SVf_UTF8;
4302             CvAUTOLOAD_off(dsv);
4303         } else {
4304             SvOK_off(dsv);
4305         }
4306     }
4307     else if (UNLIKELY(dtype == SVt_PVAV || dtype == SVt_PVHV
4308              || dtype == SVt_PVFM))
4309     {
4310         const char * const type = sv_reftype(dsv,0);
4311         if (PL_op)
4312             /* diag_listed_as: Cannot copy to %s */
4313             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4314         else
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))) {
4319             ssv = SvRV(ssv);
4320             if (ssv == dsv) {
4321                 if (GvIMPORTED(dsv) != GVf_IMPORTED
4322                     && CopSTASH_ne(PL_curcop, GvSTASH(dsv)))
4323                 {
4324                     GvIMPORTED_on(dsv);
4325                 }
4326                 GvMULTI_on(dsv);
4327                 return;
4328             }
4329             glob_assign_glob(dsv, ssv, dtype);
4330             return;
4331         }
4332
4333         if (dtype >= SVt_PV) {
4334             if (isGV_with_GP(dsv)) {
4335                 gv_setref(dsv, ssv);
4336                 return;
4337             }
4338             if (SvPVX_const(dsv)) {
4339                 SvPV_free(dsv);
4340                 SvLEN_set(dsv, 0);
4341                 SvCUR_set(dsv, 0);
4342             }
4343         }
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));
4351     }
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");
4356         }
4357         else {
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)
4372                         );
4373                     }
4374                     reset_isa = TRUE;
4375                 }
4376
4377                 if (GvGP(dsv)) {
4378                     SvREFCNT_inc_simple_void_NN(sv_2mortal(dsv));
4379                     gp_free(MUTABLE_GV(dsv));
4380                 }
4381                 GvGP_set(dsv, gp_ref(GvGP(gv)));
4382
4383                 if (reset_isa) {
4384                     HV * const stash = GvHV(dsv);
4385                     if(
4386                         old_stash ? (HV *)HvENAME_get(old_stash) : stash
4387                     )
4388                         mro_package_moved(
4389                          stash, old_stash,
4390                          (GV *)dsv, 0
4391                         );
4392                 }
4393             }
4394         }
4395     }
4396     else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4397           && (stype == SVt_REGEXP || isREGEXP(ssv))) {
4398         reg_temp_copy((REGEXP*)dsv, (REGEXP*)ssv);
4399     }
4400     else if (sflags & SVp_POK) {
4401         const STRLEN cur = SvCUR(ssv);
4402         const STRLEN len = SvLEN(ssv);
4403
4404         /*
4405          * We have three basic ways to copy the string:
4406          *
4407          *  1. Swipe
4408          *  2. Copy-on-write
4409          *  3. Actual copy
4410          *
4411          * Which we choose is based on various factors.  The following
4412          * things are listed in order of speed, fastest to slowest:
4413          *  - Swipe
4414          *  - Copying a short string
4415          *  - Copy-on-write bookkeeping
4416          *  - malloc
4417          *  - Copying a long string
4418          *
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
4424          * soon anyway.
4425          *
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.
4432          *
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.
4438
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
4446          * method 3 (copy).
4447          *
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
4450          * string buffer.
4451          *
4452          */
4453
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);
4457
4458         if (
4459                  (              /* Either ... */
4460                                 /* slated for free anyway (and not COW)? */
4461                     (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
4462                                 /* or a swipable TARG */
4463                  || ((sflags &
4464                            (SVs_PADTMP|SVf_READONLY|SVf_PROTECT|SVf_IsCOW))
4465                        == SVs_PADTMP
4466                                 /* whose buffer is worth stealing */
4467                      && CHECK_COWBUF_THRESHOLD(cur,len)
4468                     )
4469                  ) &&
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 */
4477                 SvPV_free(dsv);
4478             SvPV_set(dsv, SvPVX_mutable(ssv));
4479             SvLEN_set(dsv, SvLEN(ssv));
4480             SvCUR_set(dsv, SvCUR(ssv));
4481
4482             SvTEMP_off(dsv);
4483             (void)SvOK_off(ssv);        /* NOTE: nukes most SvFLAGS on ssv */
4484             SvPV_set(ssv, NULL);
4485             SvLEN_set(ssv, 0);
4486             SvCUR_set(ssv, 0);
4487             SvTEMP_off(ssv);
4488         }
4489         /* We must check for SvIsCOW_static() even without
4490          * SV_COW_SHARED_HASH_KEYS being set or else we'll break SvIsBOOL()
4491          */
4492         else if (SvIsCOW_static(ssv)) {
4493             if (SvPVX_const(dsv)) {     /* we know that dtype >= SVt_PV */
4494                 SvPV_free(dsv);
4495             }
4496             SvPV_set(dsv, SvPVX(ssv));
4497             SvLEN_set(dsv, 0);
4498             SvCUR_set(dsv, cur);
4499             SvFLAGS(dsv) |= (SVf_IsCOW|SVppv_STATIC);
4500         }
4501         else if (flags & SV_COW_SHARED_HASH_KEYS
4502               &&
4503 #ifdef PERL_COPY_ON_WRITE
4504                  (sflags & SVf_IsCOW
4505                    ? (!len ||
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)
4514                     ))
4515 #else
4516                  sflags & SVf_IsCOW
4517               && !(SvFLAGS(dsv) & SVf_BREAK)
4518 #endif
4519             ) {
4520             /* Either it's a shared hash key, or it's suitable for
4521                copy-on-write.  */
4522 #ifdef DEBUGGING
4523             if (DEBUG_C_TEST) {
4524                 PerlIO_printf(Perl_debug_log, "Copy on write: ssv --> dsv\n");
4525                 sv_dump(ssv);
4526                 sv_dump(dsv);
4527             }
4528 #endif
4529 #ifdef PERL_ANY_COW
4530             if (!(sflags & SVf_IsCOW)) {
4531                     SvIsCOW_on(ssv);
4532                     CowREFCNT(ssv) = 0;
4533             }
4534 #endif
4535             if (SvPVX_const(dsv)) {     /* we know that dtype >= SVt_PV */
4536                 SvPV_free(dsv);
4537             }
4538
4539 #ifdef PERL_ANY_COW
4540             if (len) {
4541                     if (sflags & SVf_IsCOW) {
4542                         sv_buf_to_rw(ssv);
4543                     }
4544                     CowREFCNT(ssv)++;
4545                     SvPV_set(dsv, SvPVX_mutable(ssv));
4546                     sv_buf_to_ro(ssv);
4547             } else
4548 #endif
4549             {
4550                     /* SvIsCOW_shared_hash */
4551                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4552                                           "Copy on write: Sharing hash\n"));
4553
4554                     assert (SvTYPE(dsv) >= SVt_PV);
4555                     SvPV_set(dsv,
4556                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv)))));
4557             }
4558             SvLEN_set(dsv, len);
4559             SvCUR_set(dsv, cur);
4560             SvIsCOW_on(dsv);
4561         } else {
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);
4567             *SvEND(dsv) = '\0';
4568         }
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;
4580             }
4581         }
4582         if (sflags & SVp_IOK) {
4583             SvIV_set(dsv, SvIVX(ssv));
4584             if (sflags & SVf_IVisUV)
4585                 SvIsUV_on(dsv);
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;
4591             }
4592         }
4593         SvFLAGS(dsv) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4594         {
4595             const MAGIC * const smg = SvVSTRING_mg(ssv);
4596             if (smg) {
4597                 sv_magic(dsv, NULL, PERL_MAGIC_vstring,
4598                          smg->mg_ptr, smg->mg_len);
4599                 SvRMAGICAL_on(dsv);
4600             }
4601         }
4602     }
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));
4609         }
4610         if (sflags & SVp_NOK) {
4611             SvNV_set(dsv, SvNVX(ssv));
4612         }
4613     }
4614     else {
4615         if (isGV_with_GP(ssv)) {
4616             gv_efullname3(dsv, MUTABLE_GV(ssv), "*");
4617         }
4618         else
4619             (void)SvOK_off(dsv);
4620     }
4621     if (SvTAINTED(ssv))
4622         SvTAINT(dsv);
4623 }
4624
4625
4626 /*
4627 =for apidoc sv_set_undef
4628
4629 Equivalent to C<sv_setsv(sv, &PL_sv_undef)>, but more efficient.
4630 Doesn't handle set magic.
4631
4632 The perl equivalent is C<$sv = undef;>. Note that it doesn't free any string
4633 buffer, unlike C<undef $sv>.
4634
4635 Introduced in perl 5.25.12.
4636
4637 =cut
4638 */
4639
4640 void
4641 Perl_sv_set_undef(pTHX_ SV *sv)
4642 {
4643     U32 type = SvTYPE(sv);
4644
4645     PERL_ARGS_ASSERT_SV_SET_UNDEF;
4646
4647     /* shortcut, NULL, IV, RV */
4648
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)
4655                 return;
4656             Perl_croak_no_modify();
4657         }
4658
4659         if (SvROK(sv)) {
4660             if (SvWEAKREF(sv))
4661                 sv_unref_flags(sv, 0);
4662             else {
4663                 SV *rv = SvRV(sv);
4664                 SvFLAGS(sv) = type; /* quickly turn off all flags */
4665                 SvREFCNT_dec_NN(rv);
4666                 return;
4667             }
4668         }
4669         SvFLAGS(sv) = type; /* quickly turn off all flags */
4670         return;
4671     }
4672
4673     if (SvIS_FREED(sv))
4674         Perl_croak(aTHX_ "panic: attempt to undefine a freed scalar %p",
4675             (void *)sv);
4676
4677     SV_CHECK_THINKFIRST_COW_DROP(sv);
4678
4679     if (isGV_with_GP(sv))
4680         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4681                        "Undefined value assigned to typeglob");
4682     else
4683         SvOK_off(sv);
4684 }
4685
4686 /*
4687 =for apidoc sv_set_true
4688
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.
4691
4692 The perl equivalent is C<$sv = !0;>.
4693
4694 Introduced in perl 5.35.11.
4695
4696 =cut
4697 */
4698
4699 void
4700 Perl_sv_set_true(pTHX_ SV *sv)
4701 {
4702     PERL_ARGS_ASSERT_SV_SET_TRUE;
4703     sv_setsv(sv, &PL_sv_yes);
4704 }
4705
4706 /*
4707 =for apidoc sv_set_false
4708
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.
4711
4712 The perl equivalent is C<$sv = !1;>.
4713
4714 Introduced in perl 5.35.11.
4715
4716 =cut
4717 */
4718
4719 void
4720 Perl_sv_set_false(pTHX_ SV *sv)
4721 {
4722     PERL_ARGS_ASSERT_SV_SET_FALSE;
4723     sv_setsv(sv, &PL_sv_no);
4724 }
4725
4726 /*
4727 =for apidoc sv_set_bool
4728
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.
4731
4732 The perl equivalent is C<$sv = !!$expr;>.
4733
4734 Introduced in perl 5.35.11.
4735
4736 =cut
4737 */
4738
4739 void
4740 Perl_sv_set_bool(pTHX_ SV *sv, const bool bool_val)
4741 {
4742     PERL_ARGS_ASSERT_SV_SET_BOOL;
4743     sv_setsv(sv, bool_val ? &PL_sv_yes : &PL_sv_no);
4744 }
4745
4746
4747 void
4748 Perl_sv_setsv_mg(pTHX_ SV *const dsv, SV *const ssv)
4749 {
4750     PERL_ARGS_ASSERT_SV_SETSV_MG;
4751
4752     sv_setsv(dsv,ssv);
4753     SvSETMAGIC(dsv);
4754 }
4755
4756 #ifdef PERL_ANY_COW
4757 #  define SVt_COW SVt_PV
4758 SV *
4759 Perl_sv_setsv_cow(pTHX_ SV *dsv, SV *ssv)
4760 {
4761     STRLEN cur = SvCUR(ssv);
4762     STRLEN len = SvLEN(ssv);
4763     char *new_pv;
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));
4767 #endif
4768
4769     PERL_ARGS_ASSERT_SV_SETSV_COW;
4770 #ifdef DEBUGGING
4771     if (DEBUG_C_TEST) {
4772         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4773                       (void*)ssv, (void*)dsv);
4774         sv_dump(ssv);
4775         if (dsv)
4776                     sv_dump(dsv);
4777     }
4778 #endif
4779     if (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));
4784     }
4785     else
4786         new_SV(dsv);
4787     SvUPGRADE(dsv, SVt_COW);
4788
4789     assert (SvPOK(ssv));
4790     assert (SvPOKp(ssv));
4791
4792     if (SvIsCOW(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))));
4798             goto common_exit;
4799         }
4800         else if (SvIsCOW_static(ssv)) {
4801             /* source is static constant; preserve this */
4802             new_pv = SvPVX(ssv);
4803             new_flags |= SVppv_STATIC;
4804             goto common_exit;
4805         }
4806         assert(SvCUR(ssv)+1 < SvLEN(ssv));
4807         assert(CowREFCNT(ssv) < SV_COW_REFCNT_MAX);
4808     } else {
4809         assert ((SvFLAGS(ssv) & CAN_COW_MASK) == CAN_COW_FLAGS);
4810         SvUPGRADE(ssv, SVt_COW);
4811         SvIsCOW_on(ssv);
4812         DEBUG_C(PerlIO_printf(Perl_debug_log,
4813                               "Fast copy on write: Converting ssv to COW\n"));
4814         CowREFCNT(ssv) = 0;
4815     }
4816 #  ifdef PERL_DEBUG_READONLY_COW
4817     if (already) sv_buf_to_rw(ssv);
4818 #  endif
4819     CowREFCNT(ssv)++;
4820     new_pv = SvPVX_mutable(ssv);
4821     sv_buf_to_ro(ssv);
4822
4823   common_exit:
4824     SvPV_set(dsv, new_pv);
4825     SvFLAGS(dsv) = new_flags;
4826     if (SvUTF8(ssv))
4827         SvUTF8_on(dsv);
4828     SvLEN_set(dsv, len);
4829     SvCUR_set(dsv, cur);
4830 #ifdef DEBUGGING
4831     if (DEBUG_C_TEST)
4832                 sv_dump(dsv);
4833 #endif
4834     return dsv;
4835 }
4836 #endif
4837
4838 /*
4839 =for apidoc sv_setpv_bufsize
4840
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.
4844
4845 =cut
4846 */
4847
4848 char *
4849 Perl_sv_setpv_bufsize(pTHX_ SV *const sv, const STRLEN cur, const STRLEN len)
4850 {
4851     char *pv;
4852
4853     PERL_ARGS_ASSERT_SV_SETPV_BUFSIZE;
4854
4855     SV_CHECK_THINKFIRST_COW_DROP(sv);
4856     SvUPGRADE(sv, SVt_PV);
4857     pv = SvGROW(sv, len + 1);
4858     SvCUR_set(sv, cur);
4859     *(SvEND(sv))= '\0';
4860     (void)SvPOK_only_UTF8(sv);                /* validate pointer */
4861
4862     SvTAINT(sv);
4863     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4864     return pv;
4865 }
4866
4867 /*
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"
4875
4876 These copy a string into the SV C<sv>, making sure it is C<L</SvPOK_only>>.
4877
4878 In the C<pvs> forms, the string must be a C literal string, enclosed in double
4879 quotes.
4880
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.
4884
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.
4888
4889 In the forms that take a C<ptr> argument, if it is NULL, the SV will become
4890 undefined.
4891
4892 The UTF-8 flag is not changed by these functions.  A terminating NUL byte is
4893 guaranteed in the result.
4894
4895 The C<_mg> forms handle 'set' magic; the other forms skip all magic.
4896
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.
4900
4901 =cut
4902 */
4903
4904 void
4905 Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4906 {
4907     char *dptr;
4908
4909     PERL_ARGS_ASSERT_SV_SETPVN;
4910
4911     SV_CHECK_THINKFIRST_COW_DROP(sv);
4912     if (isGV_with_GP(sv))
4913         Perl_croak_no_modify();
4914     if (!ptr) {
4915         (void)SvOK_off(sv);
4916         return;
4917     }
4918     else {
4919         /* len is STRLEN which is unsigned, need to copy to signed */
4920         const IV iv = len;
4921         if (iv < 0)
4922             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
4923                        IVdf, iv);
4924     }
4925     SvUPGRADE(sv, SVt_PV);
4926
4927     dptr = SvGROW(sv, len + 1);
4928     Move(ptr,dptr,len,char);
4929     dptr[len] = '\0';
4930     SvCUR_set(sv, len);
4931     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4932     SvTAINT(sv);
4933     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4934 }
4935
4936 void
4937 Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4938 {
4939     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4940
4941     sv_setpvn(sv,ptr,len);
4942     SvSETMAGIC(sv);
4943 }
4944
4945 void
4946 Perl_sv_setpvn_fresh(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4947 {
4948     char *dptr;
4949
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));
4954
4955     if (ptr) {
4956         const IV iv = len;
4957         /* len is STRLEN which is unsigned, need to copy to signed */
4958         if (iv < 0)
4959             Perl_croak(aTHX_ "panic: sv_setpvn_fresh called with negative strlen %"
4960                        IVdf, iv);
4961
4962         dptr = sv_grow_fresh(sv, len + 1);
4963         Move(ptr,dptr,len,char);
4964         dptr[len] = '\0';
4965         SvCUR_set(sv, len);
4966         SvPOK_on(sv);
4967         SvTAINT(sv);
4968     }
4969 }
4970
4971 void
4972 Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
4973 {
4974     STRLEN len;
4975
4976     PERL_ARGS_ASSERT_SV_SETPV;
4977
4978     SV_CHECK_THINKFIRST_COW_DROP(sv);
4979     if (!ptr) {
4980         (void)SvOK_off(sv);
4981         return;
4982     }
4983     len = strlen(ptr);
4984     SvUPGRADE(sv, SVt_PV);
4985
4986     SvGROW(sv, len + 1);
4987     Move(ptr,SvPVX(sv),len+1,char);
4988     SvCUR_set(sv, len);
4989     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4990     SvTAINT(sv);
4991     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4992 }
4993
4994 void
4995 Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
4996 {
4997     PERL_ARGS_ASSERT_SV_SETPV_MG;
4998
4999     sv_setpv(sv,ptr);
5000     SvSETMAGIC(sv);
5001 }
5002
5003 void
5004 Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
5005 {
5006     PERL_ARGS_ASSERT_SV_SETHEK;
5007
5008     if (!hek) {
5009         return;
5010     }
5011
5012     if (HEK_LEN(hek) == HEf_SVKEY) {
5013         sv_setsv(sv, *(SV**)HEK_KEY(hek));
5014         return;
5015     } else {
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);
5021             SvUTF8_on(sv);
5022             return;
5023         } else if (flags & HVhek_NOTSHARED) {
5024             sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
5025             if (HEK_UTF8(hek))
5026                 SvUTF8_on(sv);
5027             else SvUTF8_off(sv);
5028             return;
5029         }
5030         {
5031             SV_CHECK_THINKFIRST_COW_DROP(sv);
5032             SvUPGRADE(sv, SVt_PV);
5033             SvPV_free(sv);
5034             SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
5035             SvCUR_set(sv, HEK_LEN(hek));
5036             SvLEN_set(sv, 0);
5037             SvIsCOW_on(sv);
5038             SvPOK_on(sv);
5039             if (HEK_UTF8(hek))
5040                 SvUTF8_on(sv);
5041             else SvUTF8_off(sv);
5042             return;
5043         }
5044     }
5045 }
5046
5047
5048 /*
5049 =for apidoc      sv_usepvn
5050 =for apidoc_item sv_usepvn_flags
5051 =for apidoc_item sv_usepvn_mg
5052
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.
5056
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.
5067
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
5073 in C<SvPVX>).
5074
5075 C<sv_usepvn> is merely C<sv_usepvn_flags> with C<flags> set to 0, so 'set'
5076 magic is skipped.
5077
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.
5080
5081 =for apidoc Amnh||SV_SMAGIC
5082 =for apidoc Amnh||SV_HAS_TRAILING_NUL
5083
5084 =cut
5085 */
5086
5087 void
5088 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
5089 {
5090     STRLEN allocate;
5091
5092     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
5093
5094     SV_CHECK_THINKFIRST_COW_DROP(sv);
5095     SvUPGRADE(sv, SVt_PV);
5096     if (!ptr) {
5097         (void)SvOK_off(sv);
5098         if (flags & SV_SMAGIC)
5099             SvSETMAGIC(sv);
5100         return;
5101     }
5102     if (SvPVX_const(sv))
5103         SvPV_free(sv);
5104
5105 #ifdef DEBUGGING
5106     if (flags & SV_HAS_TRAILING_NUL)
5107         assert(ptr[len] == '\0');
5108 #endif
5109
5110     allocate = (flags & SV_HAS_TRAILING_NUL)
5111         ? len + 1 :
5112 #ifdef Perl_safesysmalloc_size
5113         len + 1;
5114 #else
5115         PERL_STRLEN_ROUNDUP(len + 1);
5116 #endif
5117     if (flags & SV_HAS_TRAILING_NUL) {
5118         /* It's long enough - do nothing.
5119            Specifically Perl_newCONSTSUB is relying on this.  */
5120     } else {
5121 #ifdef DEBUGGING
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);
5126         Safefree(ptr);
5127         ptr = new_ptr;
5128 #else
5129         ptr = (char*) saferealloc (ptr, allocate);
5130 #endif
5131     }
5132 #ifdef Perl_safesysmalloc_size
5133     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
5134 #else
5135     SvLEN_set(sv, allocate);
5136 #endif
5137     SvCUR_set(sv, len);
5138     SvPV_set(sv, ptr);
5139     if (!(flags & SV_HAS_TRAILING_NUL)) {
5140         ptr[len] = '\0';
5141     }
5142     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5143     SvTAINT(sv);
5144     if (flags & SV_SMAGIC)
5145         SvSETMAGIC(sv);
5146 }
5147
5148
5149 static void
5150 S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
5151 {
5152     assert(SvIsCOW(sv));
5153     {
5154 #ifdef PERL_ANY_COW
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);
5159
5160 #ifdef DEBUGGING
5161         if (DEBUG_C_TEST) {
5162                 PerlIO_printf(Perl_debug_log,
5163                               "Copy on write: Force normal %ld\n",
5164                               (long) flags);
5165                 sv_dump(sv);
5166         }
5167 #endif
5168         SvIsCOW_off(sv);
5169 # ifdef PERL_COPY_ON_WRITE
5170         if (len) {
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 */
5175             {
5176                 U8 cowrefcnt = CowREFCNT(sv);
5177                 if(cowrefcnt != 0) {
5178                     cowrefcnt--;
5179                     CowREFCNT(sv) = cowrefcnt;
5180                     sv_buf_to_ro(sv);
5181                     goto copy_over;
5182                 }
5183             }
5184             /* Else we are the only owner of the buffer. */
5185         }
5186         else
5187 # endif
5188         {
5189             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
5190             copy_over:
5191             SvPV_set(sv, NULL);
5192             SvCUR_set(sv, 0);
5193             SvLEN_set(sv, 0);
5194             if (flags & SV_COW_DROP_PV) {
5195                 /* OK, so we don't need to copy our buffer.  */
5196                 SvPOK_off(sv);
5197             } else {
5198                 SvGROW(sv, cur + 1);
5199                 Move(pvx,SvPVX(sv),cur,char);
5200                 SvCUR_set(sv, cur);
5201                 *SvEND(sv) = '\0';
5202             }
5203             if (was_shared_hek) {
5204                         unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5205             }
5206 #ifdef DEBUGGING
5207             if (DEBUG_C_TEST)
5208                 sv_dump(sv);
5209 #endif
5210         }
5211 #else
5212             const char * const pvx = SvPVX_const(sv);
5213             const STRLEN len = SvCUR(sv);
5214             SvIsCOW_off(sv);
5215             SvPV_set(sv, NULL);
5216             SvLEN_set(sv, 0);
5217             if (flags & SV_COW_DROP_PV) {
5218                 /* OK, so we don't need to copy our buffer.  */
5219                 SvPOK_off(sv);
5220             } else {
5221                 SvGROW(sv, len + 1);
5222                 Move(pvx,SvPVX(sv),len,char);
5223                 *SvEND(sv) = '\0';
5224             }
5225             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5226 #endif
5227     }
5228 }
5229
5230
5231 /*
5232 =for apidoc sv_force_normal_flags
5233
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.
5246
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.
5250
5251 =for apidoc Amnh||SV_COW_DROP_PV
5252
5253 =cut
5254 */
5255
5256 void
5257 Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
5258 {
5259     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
5260
5261     if (SvREADONLY(sv))
5262         Perl_croak_no_modify();
5263     else if (SvIsCOW(sv) && LIKELY(SvTYPE(sv) != SVt_PVHV))
5264         S_sv_uncow(aTHX_ sv, flags);
5265     if (SvROK(sv))
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;
5277
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);
5283         }
5284         if (!islv)
5285             SvCUR_set(temp, SvCUR(sv));
5286         /* Remember that SvPVX is in the head, not the body. */
5287         assert(ReANY((REGEXP *)sv)->mother_re);
5288
5289         if (islv) {
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;
5295         }
5296         else
5297             old_rx_body = ReANY((REGEXP *)sv);
5298
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;
5306         }
5307         else {
5308             sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
5309             SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
5310             SvPOK_on(sv);
5311         }
5312
5313         /* Now swap the rest of the bodies. */
5314
5315         SvFAKE_off(sv);
5316         if (!islv) {
5317             SvFLAGS(sv) &= ~SVTYPEMASK;
5318             SvFLAGS(sv) |= new_type;
5319             SvANY(sv) = SvANY(temp);
5320         }
5321
5322         SvFLAGS(temp) &= ~(SVTYPEMASK);
5323         SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
5324         SvANY(temp) = old_rx_body;
5325
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
5328          * body. */
5329         SvREFCNT_dec_NN(temp);
5330     }
5331     else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
5332 }
5333
5334 /*
5335 =for apidoc sv_chop
5336
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.
5342
5343 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
5344 refer to the same chunk of data.
5345
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.
5349
5350 =cut
5351 */
5352
5353 void
5354 Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
5355 {
5356     STRLEN delta;
5357     STRLEN old_delta;
5358     U8 *p;
5359 #ifdef DEBUGGING
5360     const U8 *evacp;
5361     STRLEN evacn;
5362 #endif
5363     STRLEN max_delta;
5364
5365     PERL_ARGS_ASSERT_SV_CHOP;
5366
5367     if (!ptr || !SvPOKp(sv))
5368         return;
5369     delta = ptr - SvPVX_const(sv);
5370     if (!delta) {
5371         /* Nothing to do.  */
5372         return;
5373     }
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);
5381
5382     if (!SvOOK(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);
5388             *SvEND(sv) = '\0';
5389         }
5390         SvOOK_on(sv);
5391         old_delta = 0;
5392     } else {
5393         SvOOK_offset(sv, old_delta);
5394     }
5395     SvLEN_set(sv, SvLEN(sv) - delta);
5396     SvCUR_set(sv, SvCUR(sv) - delta);
5397     SvPV_set(sv, SvPVX(sv) + delta);
5398
5399     p = (U8 *)SvPVX_const(sv);
5400
5401 #ifdef DEBUGGING
5402     /* how many bytes were evacuated?  we will fill them with sentinel
5403        bytes, except for the part holding the new offset of course. */
5404     evacn = delta;
5405     if (old_delta)
5406         evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
5407     assert(evacn);
5408     assert(evacn <= delta + old_delta);
5409     evacp = p - evacn;
5410 #endif
5411
5412     /* This sets 'delta' to the accumulated value of all deltas so far */
5413     delta += old_delta;
5414     assert(delta);
5415
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) {
5421         *--p = (U8) delta;
5422     } else {
5423         *--p = 0;
5424         p -= sizeof(STRLEN);
5425         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
5426     }
5427
5428 #ifdef DEBUGGING
5429     /* Fill the preceding buffer with sentinals to verify that no-one is
5430        using it.  */
5431     while (p > evacp) {
5432         --p;
5433         *p = (U8)PTR2UV(p);
5434     }
5435 #endif
5436 }
5437
5438 /*
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
5443
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.
5447
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.
5450
5451 They differ in that:
5452
5453 C<sv_catpvn_mg> performs both 'get' and 'set' magic on C<dsv>.
5454
5455 C<sv_catpvn> performs only 'get' magic.
5456
5457 C<sv_catpvn_nomg> skips all magic.
5458
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.
5465
5466 C<sv_catpvn>, C<sv_catpvn_mg>, and C<sv_catpvn_nomg> are implemented
5467 in terms of C<sv_catpvn_flags>.
5468
5469 =for apidoc Amnh||SV_CATUTF8
5470 =for apidoc Amnh||SV_CATBYTES
5471
5472 =cut
5473 */
5474
5475 void
5476 Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
5477 {
5478     STRLEN dlen;
5479     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5480
5481     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5482     assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5483
5484     if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
5485       if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
5486          sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5487          dlen = SvCUR(dsv);
5488       }
5489       else SvGROW(dsv, dlen + slen + 3);
5490       if (sstr == dstr)
5491         sstr = SvPVX_const(dsv);
5492       Move(sstr, SvPVX(dsv) + dlen, slen, char);
5493       SvCUR_set(dsv, SvCUR(dsv) + slen);
5494     }
5495     else {
5496         /* We inline bytes_to_utf8, to avoid an extra malloc. */
5497         const char * const send = sstr + slen;
5498         U8 *d;
5499
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);
5504
5505         SvGROW(dsv, dlen + slen * 2 + 3);
5506         d = (U8 *)SvPVX(dsv) + dlen;
5507
5508         while (sstr < send) {
5509             append_utf8_from_native_byte(*sstr, &d);
5510             sstr++;
5511         }
5512         SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5513     }
5514     *SvEND(dsv) = '\0';
5515     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
5516     SvTAINT(dsv);
5517     if (flags & SV_SMAGIC)
5518         SvSETMAGIC(dsv);
5519 }
5520
5521 /*
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
5526
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
5529 modified.
5530
5531 They differ only in what magic they perform:
5532
5533 C<sv_catsv_mg> performs 'get' magic on both SVs before the copy, and 'set' magic
5534 on C<dsv> afterwards.
5535
5536 C<sv_catsv> performs just 'get' magic, on both SVs.
5537
5538 C<sv_catsv_nomg> skips all magic.
5539
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.)
5543
5544 C<sv_catsv>, C<sv_catsv_mg>, and C<sv_catsv_nomg> are implemented
5545 in terms of C<sv_catsv_flags>.
5546
5547 =cut */
5548
5549 void
5550 Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const sstr, const I32 flags)
5551 {
5552     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5553
5554     if (sstr) {
5555         STRLEN slen;
5556         const char *spv = SvPV_flags_const(sstr, slen, flags);
5557         if (flags & SV_GMAGIC)
5558                 SvGETMAGIC(dsv);
5559         sv_catpvn_flags(dsv, spv, slen,
5560                             DO_UTF8(sstr) ? SV_CATUTF8 : SV_CATBYTES);
5561         if (flags & SV_SMAGIC)
5562                 SvSETMAGIC(dsv);
5563     }
5564 }
5565
5566 /*
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
5571
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
5575 valid UTF-8.
5576
5577 They differ only in how they handle magic:
5578
5579 C<sv_catpv_mg> performs both 'get' and 'set' magic.
5580
5581 C<sv_catpv> performs only 'get' magic.
5582
5583 C<sv_catpv_nomg> skips all magic.
5584
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.
5591
5592 =cut
5593 */
5594
5595 void
5596 Perl_sv_catpv(pTHX_ SV *const dsv, const char *sstr)
5597 {
5598     STRLEN len;
5599     STRLEN tlen;
5600     char *junk;
5601
5602     PERL_ARGS_ASSERT_SV_CATPV;
5603
5604     if (!sstr)
5605         return;
5606     junk = SvPV_force(dsv, tlen);
5607     len = strlen(sstr);
5608     SvGROW(dsv, tlen + len + 1);
5609     if (sstr == junk)
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 */
5614     SvTAINT(dsv);
5615 }
5616
5617 void
5618 Perl_sv_catpv_flags(pTHX_ SV *dsv, const char *sstr, const I32 flags)
5619 {
5620     PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5621     sv_catpvn_flags(dsv, sstr, strlen(sstr), flags);
5622 }
5623
5624 void
5625 Perl_sv_catpv_mg(pTHX_ SV *const dsv, const char *const sstr)
5626 {
5627     PERL_ARGS_ASSERT_SV_CATPV_MG;
5628
5629     sv_catpv(dsv,sstr);
5630     SvSETMAGIC(dsv);
5631 }
5632
5633 /*
5634 =for apidoc newSV
5635
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.
5640
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.
5646
5647 =cut
5648 */
5649
5650 SV *
5651 Perl_newSV(pTHX_ const STRLEN len)
5652 {
5653     SV *sv;
5654
5655     if (!len)
5656         new_SV(sv);
5657     else {
5658         sv = newSV_type(SVt_PV);
5659         sv_grow_fresh(sv, len + 1);
5660     }
5661     return sv;
5662 }
5663 /*
5664 =for apidoc sv_magicext
5665
5666 Adds magic to an SV, upgrading it if necessary.  Applies the
5667 supplied C<vtable> and returns a pointer to the magic added.