This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Merge branch 'release-5.38.0' into blead
[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) {                   \
235             PerlMemShared_free((sv)->sv_debug_file); \
236             sv->sv_debug_file = NULL;                \
237         }                                            \
238     } STMT_END
239 #  define DEBUG_SV_SERIAL(sv)                                               \
240     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) del_SV\n",    \
241             PTR2UV(sv), (long)(sv)->sv_debug_serial))
242 #else
243 #  define FREE_SV_DEBUG_FILE(sv)
244 #  define DEBUG_SV_SERIAL(sv)   NOOP
245 #endif
246
247 /* Mark an SV head as unused, and add to free list.
248  *
249  * If SVf_BREAK is set, skip adding it to the free list, as this SV had
250  * its refcount artificially decremented during global destruction, so
251  * there may be dangling pointers to it. The last thing we want in that
252  * case is for it to be reused. */
253
254 #define plant_SV(p) \
255     STMT_START {                                        \
256         const U32 old_flags = SvFLAGS(p);                       \
257         MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__);  \
258         DEBUG_SV_SERIAL(p);                             \
259         FREE_SV_DEBUG_FILE(p);                          \
260         POISON_SV_HEAD(p);                              \
261         SvFLAGS(p) = SVTYPEMASK;                        \
262         if (!(old_flags & SVf_BREAK)) {         \
263             SvARENA_CHAIN_SET(p, PL_sv_root);   \
264             PL_sv_root = (p);                           \
265         }                                               \
266         --PL_sv_count;                                  \
267     } STMT_END
268
269
270 /* make some more SVs by adding another arena */
271
272 SV*
273 Perl_more_sv(pTHX)
274 {
275     SV* sv;
276     char *chunk;                /* must use New here to match call to */
277     Newx(chunk,PERL_ARENA_SIZE,char);  /* Safefree() in sv_free_arenas() */
278     sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
279     uproot_SV(sv);
280     return sv;
281 }
282
283 /* del_SV(): return an empty SV head to the free list */
284
285 #ifdef DEBUGGING
286
287 #define del_SV(p) \
288     STMT_START {                                        \
289         if (DEBUG_D_TEST)                               \
290             del_sv(p);                                  \
291         else                                            \
292             plant_SV(p);                                \
293     } STMT_END
294
295 STATIC void
296 S_del_sv(pTHX_ SV *p)
297 {
298     PERL_ARGS_ASSERT_DEL_SV;
299
300     if (DEBUG_D_TEST) {
301         SV* sva;
302         bool ok = 0;
303         for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
304             const SV * const sv = sva + 1;
305             const SV * const svend = &sva[SvREFCNT(sva)];
306             if (p >= sv && p < svend) {
307                 ok = 1;
308                 break;
309             }
310         }
311         if (!ok) {
312             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
313                              "Attempt to free non-arena SV: 0x%" UVxf
314                              pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
315             return;
316         }
317     }
318     plant_SV(p);
319 }
320
321 #else /* ! DEBUGGING */
322
323 #define del_SV(p)   plant_SV(p)
324
325 #endif /* DEBUGGING */
326
327
328 /*
329 =for apidoc_section $SV
330
331 =for apidoc sv_add_arena
332
333 Given a chunk of memory, link it to the head of the list of arenas,
334 and split it into a list of free SVs.
335
336 =cut
337 */
338
339 static void
340 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
341 {
342     SV *const sva = MUTABLE_SV(ptr);
343     SV* sv;
344     SV* svend;
345
346     PERL_ARGS_ASSERT_SV_ADD_ARENA;
347
348     /* The first SV in an arena isn't an SV. */
349     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
350     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
351     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
352
353     PL_sv_arenaroot = sva;
354     PL_sv_root = sva + 1;
355
356     svend = &sva[SvREFCNT(sva) - 1];
357     sv = sva + 1;
358     while (sv < svend) {
359         SvARENA_CHAIN_SET(sv, (sv + 1));
360 #ifdef DEBUGGING
361         SvREFCNT(sv) = 0;
362 #endif
363         /* Must always set typemask because it's always checked in on cleanup
364            when the arenas are walked looking for objects.  */
365         SvFLAGS(sv) = SVTYPEMASK;
366         sv++;
367     }
368     SvARENA_CHAIN_SET(sv, 0);
369 #ifdef DEBUGGING
370     SvREFCNT(sv) = 0;
371 #endif
372     SvFLAGS(sv) = SVTYPEMASK;
373 }
374
375 /* visit(): call the named function for each non-free SV in the arenas
376  * whose flags field matches the flags/mask args. */
377
378 STATIC I32
379 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
380 {
381     SV* sva;
382     I32 visited = 0;
383
384     PERL_ARGS_ASSERT_VISIT;
385
386     for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
387         const SV * const svend = &sva[SvREFCNT(sva)];
388         SV* sv;
389         for (sv = sva + 1; sv < svend; ++sv) {
390             if (!SvIS_FREED(sv)
391                     && (sv->sv_flags & mask) == flags
392                     && SvREFCNT(sv))
393             {
394                 (*f)(aTHX_ sv);
395                 ++visited;
396             }
397         }
398     }
399     return visited;
400 }
401
402 #ifdef DEBUGGING
403
404 /* called by sv_report_used() for each live SV */
405
406 static void
407 do_report_used(pTHX_ SV *const sv)
408 {
409     if (!SvIS_FREED(sv)) {
410         PerlIO_printf(Perl_debug_log, "****\n");
411         sv_dump(sv);
412     }
413 }
414 #endif
415
416 /*
417 =for apidoc sv_report_used
418
419 Dump the contents of all SVs not yet freed (debugging aid).
420
421 =cut
422 */
423
424 void
425 Perl_sv_report_used(pTHX)
426 {
427 #ifdef DEBUGGING
428     visit(do_report_used, 0, 0);
429 #else
430     PERL_UNUSED_CONTEXT;
431 #endif
432 }
433
434 /* called by sv_clean_objs() for each live SV */
435
436 static void
437 do_clean_objs(pTHX_ SV *const ref)
438 {
439     assert (SvROK(ref));
440     {
441         SV * const target = SvRV(ref);
442         if (SvOBJECT(target)) {
443             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
444             if (SvWEAKREF(ref)) {
445                 sv_del_backref(target, ref);
446                 SvWEAKREF_off(ref);
447                 SvRV_set(ref, NULL);
448             } else {
449                 SvROK_off(ref);
450                 SvRV_set(ref, NULL);
451                 SvREFCNT_dec_NN(target);
452             }
453         }
454     }
455 }
456
457
458 /* clear any slots in a GV which hold objects - except IO;
459  * called by sv_clean_objs() for each live GV */
460
461 static void
462 do_clean_named_objs(pTHX_ SV *const sv)
463 {
464     SV *obj;
465     assert(SvTYPE(sv) == SVt_PVGV);
466     assert(isGV_with_GP(sv));
467     if (!GvGP(sv))
468         return;
469
470     /* freeing GP entries may indirectly free the current GV;
471      * hold onto it while we mess with the GP slots */
472     SvREFCNT_inc(sv);
473
474     if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
475         DEBUG_D((PerlIO_printf(Perl_debug_log,
476                 "Cleaning named glob SV object:\n "), sv_dump(obj)));
477         GvSV(sv) = NULL;
478         SvREFCNT_dec_NN(obj);
479     }
480     if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
481         DEBUG_D((PerlIO_printf(Perl_debug_log,
482                 "Cleaning named glob AV object:\n "), sv_dump(obj)));
483         GvAV(sv) = NULL;
484         SvREFCNT_dec_NN(obj);
485     }
486     if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
487         DEBUG_D((PerlIO_printf(Perl_debug_log,
488                 "Cleaning named glob HV object:\n "), sv_dump(obj)));
489         GvHV(sv) = NULL;
490         SvREFCNT_dec_NN(obj);
491     }
492     if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
493         DEBUG_D((PerlIO_printf(Perl_debug_log,
494                 "Cleaning named glob CV object:\n "), sv_dump(obj)));
495         GvCV_set(sv, NULL);
496         SvREFCNT_dec_NN(obj);
497     }
498     SvREFCNT_dec_NN(sv); /* undo the inc above */
499 }
500
501 /* clear any IO slots in a GV which hold objects (except stderr, defout);
502  * called by sv_clean_objs() for each live GV */
503
504 static void
505 do_clean_named_io_objs(pTHX_ SV *const sv)
506 {
507     SV *obj;
508     assert(SvTYPE(sv) == SVt_PVGV);
509     assert(isGV_with_GP(sv));
510     if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
511         return;
512
513     SvREFCNT_inc(sv);
514     if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
515         DEBUG_D((PerlIO_printf(Perl_debug_log,
516                 "Cleaning named glob IO object:\n "), sv_dump(obj)));
517         GvIOp(sv) = NULL;
518         SvREFCNT_dec_NN(obj);
519     }
520     SvREFCNT_dec_NN(sv); /* undo the inc above */
521 }
522
523 /* Void wrapper to pass to visit() */
524 static void
525 do_curse(pTHX_ SV * const sv) {
526     if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
527      || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
528         return;
529     (void)curse(sv, 0);
530 }
531
532 /*
533 =for apidoc sv_clean_objs
534
535 Attempt to destroy all objects not yet freed.
536
537 =cut
538 */
539
540 void
541 Perl_sv_clean_objs(pTHX)
542 {
543     GV *olddef, *olderr;
544     PL_in_clean_objs = TRUE;
545     visit(do_clean_objs, SVf_ROK, SVf_ROK);
546     /* Some barnacles may yet remain, clinging to typeglobs.
547      * Run the non-IO destructors first: they may want to output
548      * error messages, close files etc */
549     visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
550     visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
551     /* And if there are some very tenacious barnacles clinging to arrays,
552        closures, or what have you.... */
553     visit(do_curse, SVs_OBJECT, SVs_OBJECT);
554     olddef = PL_defoutgv;
555     PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
556     if (olddef && isGV_with_GP(olddef))
557         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
558     olderr = PL_stderrgv;
559     PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
560     if (olderr && isGV_with_GP(olderr))
561         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
562     SvREFCNT_dec(olddef);
563     PL_in_clean_objs = FALSE;
564 }
565
566 /* called by sv_clean_all() for each live SV */
567
568 static void
569 do_clean_all(pTHX_ SV *const sv)
570 {
571     if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
572         /* don't clean pid table and strtab */
573         return;
574     }
575     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%" UVxf "\n", PTR2UV(sv)) ));
576     SvFLAGS(sv) |= SVf_BREAK;
577     SvREFCNT_dec_NN(sv);
578 }
579
580 /*
581 =for apidoc sv_clean_all
582
583 Decrement the refcnt of each remaining SV, possibly triggering a
584 cleanup.  This function may have to be called multiple times to free
585 SVs which are in complex self-referential hierarchies.
586
587 =cut
588 */
589
590 I32
591 Perl_sv_clean_all(pTHX)
592 {
593     I32 cleaned;
594     PL_in_clean_all = TRUE;
595     cleaned = visit(do_clean_all, 0,0);
596     return cleaned;
597 }
598
599 /*
600   ARENASETS: a meta-arena implementation which separates arena-info
601   into struct arena_set, which contains an array of struct
602   arena_descs, each holding info for a single arena.  By separating
603   the meta-info from the arena, we recover the 1st slot, formerly
604   borrowed for list management.  The arena_set is about the size of an
605   arena, avoiding the needless malloc overhead of a naive linked-list.
606
607   The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
608   memory in the last arena-set (1/2 on average).  In trade, we get
609   back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
610   smaller types).  The recovery of the wasted space allows use of
611   small arenas for large, rare body types, by changing array* fields
612   in body_details_by_type[] below.
613 */
614 struct arena_desc {
615     char       *arena;          /* the raw storage, allocated aligned */
616     size_t      size;           /* its size ~4k typ */
617     svtype      utype;          /* bodytype stored in arena */
618 };
619
620 struct arena_set;
621
622 /* Get the maximum number of elements in set[] such that struct arena_set
623    will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
624    therefore likely to be 1 aligned memory page.  */
625
626 #define ARENAS_PER_SET  ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
627                           - 2 * sizeof(int)) / sizeof (struct arena_desc))
628
629 struct arena_set {
630     struct arena_set* next;
631     unsigned int   set_size;    /* ie ARENAS_PER_SET */
632     unsigned int   curr;        /* index of next available arena-desc */
633     struct arena_desc set[ARENAS_PER_SET];
634 };
635
636 /*
637 =for apidoc sv_free_arenas
638
639 Deallocate the memory used by all arenas.  Note that all the individual SV
640 heads and bodies within the arenas must already have been freed.
641
642 =cut
643
644 */
645 void
646 Perl_sv_free_arenas(pTHX)
647 {
648     SV* sva;
649     SV* svanext;
650     unsigned int i;
651
652     /* Free arenas here, but be careful about fake ones.  (We assume
653        contiguity of the fake ones with the corresponding real ones.) */
654
655     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
656         svanext = MUTABLE_SV(SvANY(sva));
657         while (svanext && SvFAKE(svanext))
658             svanext = MUTABLE_SV(SvANY(svanext));
659
660         if (!SvFAKE(sva))
661             Safefree(sva);
662     }
663
664     {
665         struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
666
667         while (aroot) {
668             struct arena_set *current = aroot;
669             i = aroot->curr;
670             while (i--) {
671                 assert(aroot->set[i].arena);
672                 Safefree(aroot->set[i].arena);
673             }
674             aroot = aroot->next;
675             Safefree(current);
676         }
677     }
678     PL_body_arenas = 0;
679
680     i = PERL_ARENA_ROOTS_SIZE;
681     while (i--)
682         PL_body_roots[i] = 0;
683
684     PL_sv_arenaroot = 0;
685     PL_sv_root = 0;
686 }
687
688 /*
689   Historically, here were mid-level routines that manage the
690   allocation of bodies out of the various arenas. Some of these
691   routines and related definitions remain here, but others were
692   moved into sv_inline.h to facilitate inlining of newSV_type().
693
694   There are 4 kinds of arenas:
695
696   1. SV-head arenas, which are discussed and handled above
697   2. regular body arenas
698   3. arenas for reduced-size bodies
699   4. Hash-Entry arenas
700
701   Arena types 2 & 3 are chained by body-type off an array of
702   arena-root pointers, which is indexed by svtype.  Some of the
703   larger/less used body types are malloced singly, since a large
704   unused block of them is wasteful.  Also, several svtypes don't have
705   bodies; the data fits into the sv-head itself.  The arena-root
706   pointer thus has a few unused root-pointers (which may be hijacked
707   later for arena type 4)
708
709   3 differs from 2 as an optimization; some body types have several
710   unused fields in the front of the structure (which are kept in-place
711   for consistency).  These bodies can be allocated in smaller chunks,
712   because the leading fields arent accessed.  Pointers to such bodies
713   are decremented to point at the unused 'ghost' memory, knowing that
714   the pointers are used with offsets to the real memory.
715
716 Allocation of SV-bodies is similar to SV-heads, differing as follows;
717 the allocation mechanism is used for many body types, so is somewhat
718 more complicated, it uses arena-sets, and has no need for still-live
719 SV detection.
720
721 At the outermost level, (new|del)_X*V macros return bodies of the
722 appropriate type.  These macros call either (new|del)_body_type or
723 (new|del)_body_allocated macro pairs, depending on specifics of the
724 type.  Most body types use the former pair, the latter pair is used to
725 allocate body types with "ghost fields".
726
727 "ghost fields" are fields that are unused in certain types, and
728 consequently don't need to actually exist.  They are declared because
729 they're part of a "base type", which allows use of functions as
730 methods.  The simplest examples are AVs and HVs, 2 aggregate types
731 which don't use the fields which support SCALAR semantics.
732
733 For these types, the arenas are carved up into appropriately sized
734 chunks, we thus avoid wasted memory for those unaccessed members.
735 When bodies are allocated, we adjust the pointer back in memory by the
736 size of the part not allocated, so it's as if we allocated the full
737 structure.  (But things will all go boom if you write to the part that
738 is "not there", because you'll be overwriting the last members of the
739 preceding structure in memory.)
740
741 We calculate the correction using the STRUCT_OFFSET macro on the first
742 member present.  If the allocated structure is smaller (no initial NV
743 actually allocated) then the net effect is to subtract the size of the NV
744 from the pointer, to return a new pointer as if an initial NV were actually
745 allocated.  (We were using structures named *_allocated for this, but
746 this turned out to be a subtle bug, because a structure without an NV
747 could have a lower alignment constraint, but the compiler is allowed to
748 optimised accesses based on the alignment constraint of the actual pointer
749 to the full structure, for example, using a single 64 bit load instruction
750 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
751
752 This is the same trick as was used for NV and IV bodies.  Ironically it
753 doesn't need to be used for NV bodies any more, because NV is now at
754 the start of the structure.  IV bodies, and also in some builds NV bodies,
755 don't need it either, because they are no longer allocated.
756
757 In turn, the new_body_* allocators call S_new_body(), which invokes
758 new_body_from_arena macro, which takes a lock, and takes a body off the
759 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
760 necessary to refresh an empty list.  Then the lock is released, and
761 the body is returned.
762
763 Perl_more_bodies allocates a new arena, and carves it up into an array of N
764 bodies, which it strings into a linked list.  It looks up arena-size
765 and body-size from the body_details table described below, thus
766 supporting the multiple body-types.
767
768 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
769 the (new|del)_X*V macros are mapped directly to malloc/free.
770
771 For each sv-type, struct body_details bodies_by_type[] carries
772 parameters which control these aspects of SV handling:
773
774 Arena_size determines whether arenas are used for this body type, and if
775 so, how big they are.  PURIFY or PERL_ARENA_SIZE=0 set this field to
776 zero, forcing individual mallocs and frees.
777
778 Body_size determines how big a body is, and therefore how many fit into
779 each arena.  Offset carries the body-pointer adjustment needed for
780 "ghost fields", and is used in *_allocated macros.
781
782 But its main purpose is to parameterize info needed in
783 Perl_sv_upgrade().  The info here dramatically simplifies the function
784 vs the implementation in 5.8.8, making it table-driven.  All fields
785 are used for this, except for arena_size.
786
787 For the sv-types that have no bodies, arenas are not used, so those
788 PL_body_roots[sv_type] are unused, and can be overloaded.  In
789 something of a special case, SVt_NULL is borrowed for HE arenas;
790 PL_body_roots[HE_ARENA_ROOT_IX=SVt_NULL] is filled by S_more_he, but the
791 bodies_by_type[SVt_NULL] slot is not used, as the table is not
792 available in hv.c. Similarly SVt_IV is re-used for HVAUX_ARENA_ROOT_IX.
793
794 */
795
796 /* return a thing to the free list */
797
798 #define del_body(thing, root)                           \
799     STMT_START {                                        \
800         void ** const thing_copy = (void **)thing;      \
801         *thing_copy = *root;                            \
802         *root = (void*)thing_copy;                      \
803     } STMT_END
804
805
806 void *
807 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
808                   const size_t arena_size)
809 {
810     void ** const root = &PL_body_roots[sv_type];
811     struct arena_desc *adesc;
812     struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
813     unsigned int curr;
814     char *start;
815     const char *end;
816     const size_t good_arena_size = Perl_malloc_good_size(arena_size);
817 #if defined(DEBUGGING)
818     static bool done_sanity_check;
819
820     if (!done_sanity_check) {
821         unsigned int i = SVt_LAST;
822
823         done_sanity_check = TRUE;
824
825         while (i--)
826             assert (bodies_by_type[i].type == i);
827     }
828 #endif
829
830     assert(arena_size);
831
832     /* may need new arena-set to hold new arena */
833     if (!aroot || aroot->curr >= aroot->set_size) {
834         struct arena_set *newroot;
835         Newxz(newroot, 1, struct arena_set);
836         newroot->set_size = ARENAS_PER_SET;
837         newroot->next = aroot;
838         aroot = newroot;
839         PL_body_arenas = (void *) newroot;
840         DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
841     }
842
843     /* ok, now have arena-set with at least 1 empty/available arena-desc */
844     curr = aroot->curr++;
845     adesc = &(aroot->set[curr]);
846     assert(!adesc->arena);
847
848     Newx(adesc->arena, good_arena_size, char);
849     adesc->size = good_arena_size;
850     adesc->utype = sv_type;
851     DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %" UVuf "\n",
852                           curr, (void*)adesc->arena, (UV)good_arena_size));
853
854     start = (char *) adesc->arena;
855
856     /* Get the address of the byte after the end of the last body we can fit.
857        Remember, this is integer division:  */
858     end = start + good_arena_size / body_size * body_size;
859
860     /* computed count doesn't reflect the 1st slot reservation */
861 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
862     DEBUG_m(PerlIO_printf(Perl_debug_log,
863                           "arena %p end %p arena-size %d (from %d) type %d "
864                           "size %d ct %d\n",
865                           (void*)start, (void*)end, (int)good_arena_size,
866                           (int)arena_size, sv_type, (int)body_size,
867                           (int)good_arena_size / (int)body_size));
868 #else
869     DEBUG_m(PerlIO_printf(Perl_debug_log,
870                           "arena %p end %p arena-size %d type %d size %d ct %d\n",
871                           (void*)start, (void*)end,
872                           (int)arena_size, sv_type, (int)body_size,
873                           (int)good_arena_size / (int)body_size));
874 #endif
875     *root = (void *)start;
876
877     while (1) {
878         /* Where the next body would start:  */
879         char * const next = start + body_size;
880
881         if (next >= end) {
882             /* This is the last body:  */
883             assert(next == end);
884
885             *(void **)start = 0;
886             return *root;
887         }
888
889         *(void**) start = (void *)next;
890         start = next;
891     }
892 }
893
894 /*
895 =for apidoc sv_upgrade
896
897 Upgrade an SV to a more complex form.  Generally adds a new body type to the
898 SV, then copies across as much information as possible from the old body.
899 It croaks if the SV is already in a more complex form than requested.  You
900 generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
901 before calling C<sv_upgrade>, and hence does not croak.  See also
902 C<L</svtype>>.
903
904 =cut
905 */
906
907 void
908 Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
909 {
910     void*       old_body;
911     void*       new_body;
912     const svtype old_type = SvTYPE(sv);
913     const struct body_details *new_type_details;
914     const struct body_details *old_type_details
915         = bodies_by_type + old_type;
916     SV *referent = NULL;
917
918     PERL_ARGS_ASSERT_SV_UPGRADE;
919
920     if (old_type == new_type)
921         return;
922
923     /* This clause was purposefully added ahead of the early return above to
924        the shared string hackery for (sort {$a <=> $b} keys %hash), with the
925        inference by Nick I-S that it would fix other troublesome cases. See
926        changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
927
928        Given that shared hash key scalars are no longer PVIV, but PV, there is
929        no longer need to unshare so as to free up the IVX slot for its proper
930        purpose. So it's safe to move the early return earlier.  */
931
932     if (new_type > SVt_PVMG && SvIsCOW(sv)) {
933         sv_force_normal_flags(sv, 0);
934     }
935
936     old_body = SvANY(sv);
937
938     /* Copying structures onto other structures that have been neatly zeroed
939        has a subtle gotcha. Consider XPVMG
940
941        +------+------+------+------+------+-------+-------+
942        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
943        +------+------+------+------+------+-------+-------+
944        0      4      8     12     16     20      24      28
945
946        where NVs are aligned to 8 bytes, so that sizeof that structure is
947        actually 32 bytes long, with 4 bytes of padding at the end:
948
949        +------+------+------+------+------+-------+-------+------+
950        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
951        +------+------+------+------+------+-------+-------+------+
952        0      4      8     12     16     20      24      28     32
953
954        so what happens if you allocate memory for this structure:
955
956        +------+------+------+------+------+-------+-------+------+------+...
957        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
958        +------+------+------+------+------+-------+-------+------+------+...
959        0      4      8     12     16     20      24      28     32     36
960
961        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
962        expect, because you copy the area marked ??? onto GP. Now, ??? may have
963        started out as zero once, but it's quite possible that it isn't. So now,
964        rather than a nicely zeroed GP, you have it pointing somewhere random.
965        Bugs ensue.
966
967        (In fact, GP ends up pointing at a previous GP structure, because the
968        principle cause of the padding in XPVMG getting garbage is a copy of
969        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
970        this happens to be moot because XPVGV has been re-ordered, with GP
971        no longer after STASH)
972
973        So we are careful and work out the size of used parts of all the
974        structures.  */
975
976     switch (old_type) {
977     case SVt_NULL:
978         break;
979     case SVt_IV:
980         if (SvROK(sv)) {
981             referent = SvRV(sv);
982             old_type_details = &fake_rv;
983             if (new_type == SVt_NV)
984                 new_type = SVt_PVNV;
985         } else {
986             if (new_type < SVt_PVIV) {
987                 new_type = (new_type == SVt_NV)
988                     ? SVt_PVNV : SVt_PVIV;
989             }
990         }
991         break;
992     case SVt_NV:
993         if (new_type < SVt_PVNV) {
994             new_type = SVt_PVNV;
995         }
996         break;
997     case SVt_PV:
998         assert(new_type > SVt_PV);
999         STATIC_ASSERT_STMT(SVt_IV < SVt_PV);
1000         STATIC_ASSERT_STMT(SVt_NV < SVt_PV);
1001         break;
1002     case SVt_PVIV:
1003         break;
1004     case SVt_PVNV:
1005         break;
1006     case SVt_PVMG:
1007         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1008            there's no way that it can be safely upgraded, because perl.c
1009            expects to Safefree(SvANY(PL_mess_sv))  */
1010         assert(sv != PL_mess_sv);
1011         break;
1012     default:
1013         if (UNLIKELY(old_type_details->cant_upgrade))
1014             Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1015                        sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1016     }
1017
1018     if (UNLIKELY(old_type > new_type))
1019         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1020                 (int)old_type, (int)new_type);
1021
1022     new_type_details = bodies_by_type + new_type;
1023
1024     SvFLAGS(sv) &= ~SVTYPEMASK;
1025     SvFLAGS(sv) |= new_type;
1026
1027     /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1028        the return statements above will have triggered.  */
1029     assert (new_type != SVt_NULL);
1030     switch (new_type) {
1031     case SVt_IV:
1032         assert(old_type == SVt_NULL);
1033         SET_SVANY_FOR_BODYLESS_IV(sv);
1034         SvIV_set(sv, 0);
1035         return;
1036     case SVt_NV:
1037         assert(old_type == SVt_NULL);
1038 #if NVSIZE <= IVSIZE
1039         SET_SVANY_FOR_BODYLESS_NV(sv);
1040 #else
1041         SvANY(sv) = new_XNV();
1042 #endif
1043         SvNV_set(sv, 0);
1044         return;
1045     case SVt_PVHV:
1046     case SVt_PVAV:
1047     case SVt_PVOBJ:
1048         assert(new_type_details->body_size);
1049
1050 #ifndef PURIFY
1051         assert(new_type_details->arena);
1052         assert(new_type_details->arena_size);
1053         /* This points to the start of the allocated area.  */
1054         new_body = S_new_body(aTHX_ new_type);
1055         /* xpvav and xpvhv have no offset, so no need to adjust new_body */
1056         assert(!(new_type_details->offset));
1057 #else
1058         /* We always allocated the full length item with PURIFY. To do this
1059            we fake things so that arena is false for all 16 types..  */
1060         new_body = new_NOARENAZ(new_type_details);
1061 #endif
1062         SvANY(sv) = new_body;
1063         switch(new_type) {
1064         case SVt_PVAV:
1065             {
1066                 XPVAV pvav = {
1067                     .xmg_stash = NULL,
1068                     .xmg_u = {.xmg_magic = NULL},
1069                     .xav_fill = -1, .xav_max = -1, .xav_alloc = 0
1070                 };
1071                 *((XPVAV*) SvANY(sv)) = pvav;
1072             }
1073
1074             AvREAL_only(sv);
1075             break;
1076         case SVt_PVHV:
1077             {
1078                 XPVHV pvhv = {
1079                     .xmg_stash = NULL,
1080                     .xmg_u = {.xmg_magic = NULL},
1081                     .xhv_keys = 0,
1082                     /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
1083                     .xhv_max = PERL_HASH_DEFAULT_HvMAX
1084                 };
1085                 *((XPVHV*) SvANY(sv)) = pvhv;
1086             }
1087
1088             assert(!SvOK(sv));
1089             SvOK_off(sv);
1090 #ifndef NODEFAULT_SHAREKEYS
1091             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
1092 #endif
1093             break;
1094         case SVt_PVOBJ:
1095             {
1096                 XPVOBJ pvo = {
1097                     .xmg_stash = NULL, .xmg_u = {.xmg_magic = NULL},
1098                     .xobject_maxfield = -1,
1099                     .xobject_iter_sv_at = 0,
1100                     .xobject_fields = NULL,
1101                 };
1102                 *((XPVOBJ*) SvANY(sv)) = pvo;
1103             }
1104             break;
1105         default:
1106             NOT_REACHED;
1107         }
1108
1109         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1110            The target created by newSVrv also is, and it can have magic.
1111            However, it never has SvPVX set.
1112         */
1113         if (old_type == SVt_IV) {
1114             assert(!SvROK(sv));
1115         } else if (old_type >= SVt_PV) {
1116             assert(SvPVX_const(sv) == 0);
1117         }
1118
1119         if (old_type >= SVt_PVMG) {
1120             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1121             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1122         } else {
1123             sv->sv_u.svu_array = NULL; /* or svu_hash  */
1124         }
1125         break;
1126
1127     case SVt_PVIV:
1128         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1129            no route from NV to PVIV, NOK can never be true  */
1130         assert(!SvNOKp(sv));
1131         assert(!SvNOK(sv));
1132         /* FALLTHROUGH */
1133     case SVt_PVIO:
1134     case SVt_PVFM:
1135     case SVt_PVGV:
1136     case SVt_PVCV:
1137     case SVt_PVLV:
1138     case SVt_INVLIST:
1139     case SVt_REGEXP:
1140     case SVt_PVMG:
1141     case SVt_PVNV:
1142     case SVt_PV:
1143
1144         assert(new_type_details->body_size);
1145         /* We always allocated the full length item with PURIFY. To do this
1146            we fake things so that arena is false for all 16 types..  */
1147 #ifndef PURIFY
1148         if(new_type_details->arena) {
1149             /* This points to the start of the allocated area.  */
1150             new_body = S_new_body(aTHX_ new_type);
1151             Zero(new_body, new_type_details->body_size, char);
1152             new_body = ((char *)new_body) - new_type_details->offset;
1153         } else
1154 #endif
1155         {
1156             new_body = new_NOARENAZ(new_type_details);
1157         }
1158         SvANY(sv) = new_body;
1159
1160         if (old_type_details->copy) {
1161             /* There is now the potential for an upgrade from something without
1162                an offset (PVNV or PVMG) to something with one (PVCV, PVFM)  */
1163             int offset = old_type_details->offset;
1164             int length = old_type_details->copy;
1165
1166             if (new_type_details->offset > old_type_details->offset) {
1167                 const int difference
1168                     = new_type_details->offset - old_type_details->offset;
1169                 offset += difference;
1170                 length -= difference;
1171             }
1172             assert (length >= 0);
1173
1174             Copy((char *)old_body + offset, (char *)new_body + offset, length,
1175                  char);
1176         }
1177
1178 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1179         /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1180          * correct 0.0 for us.  Otherwise, if the old body didn't have an
1181          * NV slot, but the new one does, then we need to initialise the
1182          * freshly created NV slot with whatever the correct bit pattern is
1183          * for 0.0  */
1184         if (old_type_details->zero_nv && !new_type_details->zero_nv
1185             && !isGV_with_GP(sv))
1186             SvNV_set(sv, 0);
1187 #endif
1188
1189         if (UNLIKELY(new_type == SVt_PVIO)) {
1190             IO * const io = MUTABLE_IO(sv);
1191             GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1192
1193             SvOBJECT_on(io);
1194             /* Clear the stashcache because a new IO could overrule a package
1195                name */
1196             DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
1197             hv_clear(PL_stashcache);
1198
1199             SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1200             IoPAGE_LEN(sv) = 60;
1201         }
1202         if (old_type < SVt_PV) {
1203             /* referent will be NULL unless the old type was SVt_IV emulating
1204                SVt_RV */
1205             sv->sv_u.svu_rv = referent;
1206         }
1207         break;
1208     default:
1209         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1210                    (unsigned long)new_type);
1211     }
1212
1213     /* if this is zero, this is a body-less SVt_NULL, SVt_IV/SVt_RV,
1214        and sometimes SVt_NV */
1215     if (old_type_details->body_size) {
1216 #ifdef PURIFY
1217         safefree(old_body);
1218 #else
1219         /* Note that there is an assumption that all bodies of types that
1220            can be upgraded came from arenas. Only the more complex non-
1221            upgradable types are allowed to be directly malloc()ed.  */
1222         assert(old_type_details->arena);
1223         del_body((void*)((char*)old_body + old_type_details->offset),
1224                  &PL_body_roots[old_type]);
1225 #endif
1226     }
1227 }
1228
1229 struct xpvhv_aux*
1230 Perl_hv_auxalloc(pTHX_ HV *hv) {
1231     const struct body_details *old_type_details = bodies_by_type + SVt_PVHV;
1232     void *old_body;
1233     void *new_body;
1234
1235     PERL_ARGS_ASSERT_HV_AUXALLOC;
1236     assert(SvTYPE(hv) == SVt_PVHV);
1237     assert(!HvHasAUX(hv));
1238
1239 #ifdef PURIFY
1240     new_body = new_NOARENAZ(&fake_hv_with_aux);
1241 #else
1242     new_body_from_arena(new_body, HVAUX_ARENA_ROOT_IX, fake_hv_with_aux);
1243 #endif
1244
1245     old_body = SvANY(hv);
1246
1247     Copy((char *)old_body + old_type_details->offset,
1248          (char *)new_body + fake_hv_with_aux.offset,
1249          old_type_details->copy,
1250          char);
1251
1252 #ifdef PURIFY
1253     safefree(old_body);
1254 #else
1255     assert(old_type_details->arena);
1256     del_body((void*)((char*)old_body + old_type_details->offset),
1257              &PL_body_roots[SVt_PVHV]);
1258 #endif
1259
1260     SvANY(hv) = (XPVHV *) new_body;
1261     SvFLAGS(hv) |= SVphv_HasAUX;
1262     return HvAUX(hv);
1263 }
1264
1265 /*
1266 =for apidoc sv_backoff
1267
1268 Remove any string offset.  You should normally use the C<SvOOK_off> macro
1269 wrapper instead.
1270
1271 =cut
1272 */
1273
1274 /* prior to 5.000 stable, this function returned the new OOK-less SvFLAGS
1275    prior to 5.23.4 this function always returned 0
1276 */
1277
1278 void
1279 Perl_sv_backoff(SV *const sv)
1280 {
1281     STRLEN delta;
1282     const char * const s = SvPVX_const(sv);
1283
1284     PERL_ARGS_ASSERT_SV_BACKOFF;
1285
1286     assert(SvOOK(sv));
1287     assert(SvTYPE(sv) != SVt_PVHV);
1288     assert(SvTYPE(sv) != SVt_PVAV);
1289
1290     SvOOK_offset(sv, delta);
1291
1292     SvLEN_set(sv, SvLEN(sv) + delta);
1293     SvPV_set(sv, SvPVX(sv) - delta);
1294     SvFLAGS(sv) &= ~SVf_OOK;
1295     Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1296     return;
1297 }
1298
1299
1300 /* forward declaration */
1301 static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
1302
1303
1304 /*
1305 =for apidoc sv_grow
1306
1307 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1308 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1309 Use the C<SvGROW> wrapper instead.
1310
1311 =cut
1312 */
1313
1314
1315 char *
1316 Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
1317 {
1318     char *s;
1319
1320     PERL_ARGS_ASSERT_SV_GROW;
1321
1322     if (SvROK(sv))
1323         sv_unref(sv);
1324     if (SvTYPE(sv) < SVt_PV) {
1325         sv_upgrade(sv, SVt_PV);
1326         s = SvPVX_mutable(sv);
1327     }
1328     else if (SvOOK(sv)) {       /* pv is offset? */
1329         sv_backoff(sv);
1330         s = SvPVX_mutable(sv);
1331         if (newlen > SvLEN(sv))
1332             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1333     }
1334     else
1335     {
1336         if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0);
1337         s = SvPVX_mutable(sv);
1338     }
1339
1340 #ifdef PERL_COPY_ON_WRITE
1341     /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1342      * to store the COW count. So in general, allocate one more byte than
1343      * asked for, to make it likely this byte is always spare: and thus
1344      * make more strings COW-able.
1345      *
1346      * Only increment if the allocation isn't MEM_SIZE_MAX,
1347      * otherwise it will wrap to 0.
1348      */
1349     if ( newlen != MEM_SIZE_MAX )
1350         newlen++;
1351 #endif
1352
1353 #if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size)
1354 #define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1355 #endif
1356
1357     if (newlen > SvLEN(sv)) {           /* need more room? */
1358         STRLEN minlen = SvCUR(sv);
1359         minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + PERL_STRLEN_NEW_MIN;
1360         if (newlen < minlen)
1361             newlen = minlen;
1362 #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1363
1364         /* Don't round up on the first allocation, as odds are pretty good that
1365          * the initial request is accurate as to what is really needed */
1366         if (SvLEN(sv)) {
1367             STRLEN rounded = PERL_STRLEN_ROUNDUP(newlen);
1368             if (rounded > newlen)
1369                 newlen = rounded;
1370         }
1371 #endif
1372         if (SvLEN(sv) && s) {
1373             s = (char*)saferealloc(s, newlen);
1374         }
1375         else {
1376             s = (char*)safemalloc(newlen);
1377             if (SvPVX_const(sv) && SvCUR(sv)) {
1378                 Move(SvPVX_const(sv), s, SvCUR(sv), char);
1379             }
1380         }
1381         SvPV_set(sv, s);
1382 #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1383         /* Do this here, do it once, do it right, and then we will never get
1384            called back into sv_grow() unless there really is some growing
1385            needed.  */
1386         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1387 #else
1388         SvLEN_set(sv, newlen);
1389 #endif
1390     }
1391     return s;
1392 }
1393
1394 /*
1395 =for apidoc sv_grow_fresh
1396
1397 A cut-down version of sv_grow intended only for when sv is a freshly-minted
1398 SVt_PV, SVt_PVIV, SVt_PVNV, or SVt_PVMG. i.e. sv has the default flags, has
1399 never been any other type, and does not have an existing string. Basically,
1400 just assigns a char buffer and returns a pointer to it.
1401
1402 =cut
1403 */
1404
1405
1406 char *
1407 Perl_sv_grow_fresh(pTHX_ SV *const sv, STRLEN newlen)
1408 {
1409     char *s;
1410
1411     PERL_ARGS_ASSERT_SV_GROW_FRESH;
1412
1413     assert(SvTYPE(sv) >= SVt_PV && SvTYPE(sv) <= SVt_PVMG);
1414     assert(!SvROK(sv));
1415     assert(!SvOOK(sv));
1416     assert(!SvIsCOW(sv));
1417     assert(!SvLEN(sv));
1418     assert(!SvCUR(sv));
1419
1420 #ifdef PERL_COPY_ON_WRITE
1421     /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1422      * to store the COW count. So in general, allocate one more byte than
1423      * asked for, to make it likely this byte is always spare: and thus
1424      * make more strings COW-able.
1425      *
1426      * Only increment if the allocation isn't MEM_SIZE_MAX,
1427      * otherwise it will wrap to 0.
1428      */
1429     if ( newlen != MEM_SIZE_MAX )
1430         newlen++;
1431 #endif
1432
1433     if (newlen < PERL_STRLEN_NEW_MIN)
1434         newlen = PERL_STRLEN_NEW_MIN;
1435
1436     s = (char*)safemalloc(newlen);
1437     SvPV_set(sv, s);
1438
1439     /* No PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC here, since many strings */
1440     /* will never be grown once set. Let the real sv_grow worry about that. */
1441     SvLEN_set(sv, newlen);
1442     return s;
1443 }
1444
1445 /*
1446 =for apidoc sv_setiv
1447 =for apidoc_item sv_setiv_mg
1448
1449 These copy an integer into the given SV, upgrading first if necessary.
1450
1451 They differ only in that C<sv_setiv_mg> handles 'set' magic; C<sv_setiv> does
1452 not.
1453
1454 =cut
1455 */
1456
1457 void
1458 Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
1459 {
1460     PERL_ARGS_ASSERT_SV_SETIV;
1461
1462     SV_CHECK_THINKFIRST_COW_DROP(sv);
1463     switch (SvTYPE(sv)) {
1464 #if NVSIZE <= IVSIZE
1465     case SVt_NULL:
1466     case SVt_NV:
1467         SET_SVANY_FOR_BODYLESS_IV(sv);
1468         SvFLAGS(sv) &= ~SVTYPEMASK;
1469         SvFLAGS(sv) |= SVt_IV;
1470         break;
1471 #else
1472     case SVt_NULL:
1473         SET_SVANY_FOR_BODYLESS_IV(sv);
1474         SvFLAGS(sv) &= ~SVTYPEMASK;
1475         SvFLAGS(sv) |= SVt_IV;
1476         break;
1477     case SVt_NV:
1478         sv_upgrade(sv, SVt_IV);
1479         break;
1480 #endif
1481     case SVt_PV:
1482         sv_upgrade(sv, SVt_PVIV);
1483         break;
1484
1485     case SVt_PVGV:
1486         if (!isGV_with_GP(sv))
1487             break;
1488         /* FALLTHROUGH */
1489     case SVt_PVAV:
1490     case SVt_PVHV:
1491     case SVt_PVCV:
1492     case SVt_PVFM:
1493     case SVt_PVIO:
1494         /* diag_listed_as: Can't coerce %s to %s in %s */
1495         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1496                    OP_DESC(PL_op));
1497         NOT_REACHED; /* NOTREACHED */
1498         break;
1499     default: NOOP;
1500     }
1501     (void)SvIOK_only(sv);                       /* validate number */
1502     SvIV_set(sv, i);
1503     SvTAINT(sv);
1504 }
1505
1506 void
1507 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1508 {
1509     PERL_ARGS_ASSERT_SV_SETIV_MG;
1510
1511     sv_setiv(sv,i);
1512     SvSETMAGIC(sv);
1513 }
1514
1515 /*
1516 =for apidoc sv_setuv
1517 =for apidoc_item sv_setuv_mg
1518
1519 These copy an unsigned integer into the given SV, upgrading first if necessary.
1520
1521
1522 They differ only in that C<sv_setuv_mg> handles 'set' magic; C<sv_setuv> does
1523 not.
1524
1525 =cut
1526 */
1527
1528 void
1529 Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1530 {
1531     PERL_ARGS_ASSERT_SV_SETUV;
1532
1533     /* With the if statement to ensure that integers are stored as IVs whenever
1534        possible:
1535        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1536
1537        without
1538        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1539
1540        If you wish to remove the following if statement, so that this routine
1541        (and its callers) always return UVs, please benchmark to see what the
1542        effect is. Modern CPUs may be different. Or may not :-)
1543     */
1544     if (u <= (UV)IV_MAX) {
1545        sv_setiv(sv, (IV)u);
1546        return;
1547     }
1548     sv_setiv(sv, 0);
1549     SvIsUV_on(sv);
1550     SvUV_set(sv, u);
1551 }
1552
1553 void
1554 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1555 {
1556     PERL_ARGS_ASSERT_SV_SETUV_MG;
1557
1558     sv_setuv(sv,u);
1559     SvSETMAGIC(sv);
1560 }
1561
1562 /*
1563 =for apidoc sv_setnv
1564 =for apidoc_item sv_setnv_mg
1565
1566 These copy a double into the given SV, upgrading first if necessary.
1567
1568 They differ only in that C<sv_setnv_mg> handles 'set' magic; C<sv_setnv> does
1569 not.
1570
1571 =cut
1572 */
1573
1574 void
1575 Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1576 {
1577     PERL_ARGS_ASSERT_SV_SETNV;
1578
1579     SV_CHECK_THINKFIRST_COW_DROP(sv);
1580     switch (SvTYPE(sv)) {
1581     case SVt_NULL:
1582     case SVt_IV:
1583 #if NVSIZE <= IVSIZE
1584         SET_SVANY_FOR_BODYLESS_NV(sv);
1585         SvFLAGS(sv) &= ~SVTYPEMASK;
1586         SvFLAGS(sv) |= SVt_NV;
1587         break;
1588 #else
1589         sv_upgrade(sv, SVt_NV);
1590         break;
1591 #endif
1592     case SVt_PV:
1593     case SVt_PVIV:
1594         sv_upgrade(sv, SVt_PVNV);
1595         break;
1596
1597     case SVt_PVGV:
1598         if (!isGV_with_GP(sv))
1599             break;
1600         /* FALLTHROUGH */
1601     case SVt_PVAV:
1602     case SVt_PVHV:
1603     case SVt_PVCV:
1604     case SVt_PVFM:
1605     case SVt_PVIO:
1606         /* diag_listed_as: Can't coerce %s to %s in %s */
1607         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1608                    OP_DESC(PL_op));
1609         NOT_REACHED; /* NOTREACHED */
1610         break;
1611     default: NOOP;
1612     }
1613     SvNV_set(sv, num);
1614     (void)SvNOK_only(sv);                       /* validate number */
1615     SvTAINT(sv);
1616 }
1617
1618 void
1619 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1620 {
1621     PERL_ARGS_ASSERT_SV_SETNV_MG;
1622
1623     sv_setnv(sv,num);
1624     SvSETMAGIC(sv);
1625 }
1626
1627 /*
1628 =for apidoc sv_setrv_noinc
1629 =for apidoc_item sv_setrv_noinc_mg
1630
1631 Copies an SV pointer into the given SV as an SV reference, upgrading it if
1632 necessary. After this, C<SvRV(sv)> is equal to I<ref>. This does not adjust
1633 the reference count of I<ref>. The reference I<ref> must not be NULL.
1634
1635 C<sv_setrv_noinc_mg> will invoke 'set' magic on the SV; C<sv_setrv_noinc> will
1636 not.
1637
1638 =cut
1639 */
1640
1641 void
1642 Perl_sv_setrv_noinc(pTHX_ SV *const sv, SV *const ref)
1643 {
1644     PERL_ARGS_ASSERT_SV_SETRV_NOINC;
1645
1646     SV_CHECK_THINKFIRST_COW_DROP(sv);
1647     prepare_SV_for_RV(sv);
1648
1649     SvOK_off(sv);
1650     SvRV_set(sv, ref);
1651     SvROK_on(sv);
1652 }
1653
1654 void
1655 Perl_sv_setrv_noinc_mg(pTHX_ SV *const sv, SV *const ref)
1656 {
1657     PERL_ARGS_ASSERT_SV_SETRV_NOINC_MG;
1658
1659     sv_setrv_noinc(sv, ref);
1660     SvSETMAGIC(sv);
1661 }
1662
1663 /*
1664 =for apidoc sv_setrv_inc
1665 =for apidoc_item sv_setrv_inc_mg
1666
1667 As C<sv_setrv_noinc> but increments the reference count of I<ref>.
1668
1669 C<sv_setrv_inc_mg> will invoke 'set' magic on the SV; C<sv_setrv_inc> will
1670 not.
1671
1672 =cut
1673 */
1674
1675 void
1676 Perl_sv_setrv_inc(pTHX_ SV *const sv, SV *const ref)
1677 {
1678     PERL_ARGS_ASSERT_SV_SETRV_INC;
1679
1680     sv_setrv_noinc(sv, SvREFCNT_inc_simple_NN(ref));
1681 }
1682
1683 void
1684 Perl_sv_setrv_inc_mg(pTHX_ SV *const sv, SV *const ref)
1685 {
1686     PERL_ARGS_ASSERT_SV_SETRV_INC_MG;
1687
1688     sv_setrv_noinc(sv, SvREFCNT_inc_simple_NN(ref));
1689     SvSETMAGIC(sv);
1690 }
1691
1692 /* Return a cleaned-up, printable version of sv, for non-numeric, or
1693  * not incrementable warning display.
1694  * Originally part of S_not_a_number().
1695  * The return value may be != tmpbuf.
1696  */
1697
1698 STATIC const char *
1699 S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1700     const char *pv;
1701
1702      PERL_ARGS_ASSERT_SV_DISPLAY;
1703
1704      if (DO_UTF8(sv)) {
1705           SV *dsv = newSVpvs_flags("", SVs_TEMP);
1706           pv = sv_uni_display(dsv, sv, 32, UNI_DISPLAY_ISPRINT);
1707      } else {
1708           char *d = tmpbuf;
1709           const char * const limit = tmpbuf + tmpbuf_size - 8;
1710           /* each *s can expand to 4 chars + "...\0",
1711              i.e. need room for 8 chars */
1712
1713           const char *s = SvPVX_const(sv);
1714           const char * const end = s + SvCUR(sv);
1715           for ( ; s < end && d < limit; s++ ) {
1716                int ch = (U8) *s;
1717                if (! isASCII(ch) && !isPRINT_LC(ch)) {
1718                     *d++ = 'M';
1719                     *d++ = '-';
1720
1721                     /* Map to ASCII "equivalent" of Latin1 */
1722                     ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1723                }
1724                if (ch == '\n') {
1725                     *d++ = '\\';
1726                     *d++ = 'n';
1727                }
1728                else if (ch == '\r') {
1729                     *d++ = '\\';
1730                     *d++ = 'r';
1731                }
1732                else if (ch == '\f') {
1733                     *d++ = '\\';
1734                     *d++ = 'f';
1735                }
1736                else if (ch == '\\') {
1737                     *d++ = '\\';
1738                     *d++ = '\\';
1739                }
1740                else if (ch == '\0') {
1741                     *d++ = '\\';
1742                     *d++ = '0';
1743                }
1744                else if (isPRINT_LC(ch))
1745                     *d++ = ch;
1746                else {
1747                     *d++ = '^';
1748                     *d++ = toCTRL(ch);
1749                }
1750           }
1751           if (s < end) {
1752                *d++ = '.';
1753                *d++ = '.';
1754                *d++ = '.';
1755           }
1756           *d = '\0';
1757           pv = tmpbuf;
1758     }
1759
1760     return pv;
1761 }
1762
1763 /* Print an "isn't numeric" warning, using a cleaned-up,
1764  * printable version of the offending string
1765  */
1766
1767 STATIC void
1768 S_not_a_number(pTHX_ SV *const sv)
1769 {
1770      char tmpbuf[64];
1771      const char *pv;
1772
1773      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1774
1775      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1776
1777     if (PL_op)
1778         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1779                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1780                     "Argument \"%s\" isn't numeric in %s", pv,
1781                     OP_DESC(PL_op));
1782     else
1783         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1784                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1785                     "Argument \"%s\" isn't numeric", pv);
1786 }
1787
1788 STATIC void
1789 S_not_incrementable(pTHX_ SV *const sv) {
1790      char tmpbuf[64];
1791      const char *pv;
1792
1793      PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1794
1795      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1796
1797      Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1798                  "Argument \"%s\" treated as 0 in increment (++)", pv);
1799 }
1800
1801 /*
1802 =for apidoc looks_like_number
1803
1804 Test if the content of an SV looks like a number (or is a number).
1805 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1806 non-numeric warning), even if your C<atof()> doesn't grok them.  Get-magic is
1807 ignored.
1808
1809 =cut
1810 */
1811
1812 I32
1813 Perl_looks_like_number(pTHX_ SV *const sv)
1814 {
1815     const char *sbegin;
1816     STRLEN len;
1817     int numtype;
1818
1819     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1820
1821     if (SvPOK(sv) || SvPOKp(sv)) {
1822         sbegin = SvPV_nomg_const(sv, len);
1823     }
1824     else
1825         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1826     numtype = grok_number(sbegin, len, NULL);
1827     return ((numtype & IS_NUMBER_TRAILING)) ? 0 : numtype;
1828 }
1829
1830 STATIC bool
1831 S_glob_2number(pTHX_ GV * const gv)
1832 {
1833     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1834
1835     /* We know that all GVs stringify to something that is not-a-number,
1836         so no need to test that.  */
1837     if (ckWARN(WARN_NUMERIC))
1838     {
1839         SV *const buffer = sv_newmortal();
1840         gv_efullname3(buffer, gv, "*");
1841         not_a_number(buffer);
1842     }
1843     /* We just want something true to return, so that S_sv_2iuv_common
1844         can tail call us and return true.  */
1845     return TRUE;
1846 }
1847
1848 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1849    until proven guilty, assume that things are not that bad... */
1850
1851 /*
1852    NV_PRESERVES_UV:
1853
1854    As 64 bit platforms often have an NV that doesn't preserve all bits of
1855    an IV (an assumption perl has been based on to date) it becomes necessary
1856    to remove the assumption that the NV always carries enough precision to
1857    recreate the IV whenever needed, and that the NV is the canonical form.
1858    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1859    precision as a side effect of conversion (which would lead to insanity
1860    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1861    1) to distinguish between IV/UV/NV slots that have a valid conversion cached
1862       where precision was lost, and IV/UV/NV slots that have a valid conversion
1863       which has lost no precision
1864    2) to ensure that if a numeric conversion to one form is requested that
1865       would lose precision, the precise conversion (or differently
1866       imprecise conversion) is also performed and cached, to prevent
1867       requests for different numeric formats on the same SV causing
1868       lossy conversion chains. (lossless conversion chains are perfectly
1869       acceptable (still))
1870
1871
1872    flags are used:
1873    SvIOKp is true if the IV slot contains a valid value
1874    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1875    SvNOKp is true if the NV slot contains a valid value
1876    SvNOK  is true only if the NV value is accurate
1877
1878    so
1879    while converting from PV to NV, check to see if converting that NV to an
1880    IV(or UV) would lose accuracy over a direct conversion from PV to
1881    IV(or UV). If it would, cache both conversions, return NV, but mark
1882    SV as IOK NOKp (ie not NOK).
1883
1884    While converting from PV to IV, check to see if converting that IV to an
1885    NV would lose accuracy over a direct conversion from PV to NV. If it
1886    would, cache both conversions, flag similarly.
1887
1888    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1889    correctly because if IV & NV were set NV *always* overruled.
1890    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1891    changes - now IV and NV together means that the two are interchangeable:
1892    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1893
1894    The benefit of this is that operations such as pp_add know that if
1895    SvIOK is true for both left and right operands, then integer addition
1896    can be used instead of floating point (for cases where the result won't
1897    overflow). Before, floating point was always used, which could lead to
1898    loss of precision compared with integer addition.
1899
1900    * making IV and NV equal status should make maths accurate on 64 bit
1901      platforms
1902    * may speed up maths somewhat if pp_add and friends start to use
1903      integers when possible instead of fp. (Hopefully the overhead in
1904      looking for SvIOK and checking for overflow will not outweigh the
1905      fp to integer speedup)
1906    * will slow down integer operations (callers of SvIV) on "inaccurate"
1907      values, as the change from SvIOK to SvIOKp will cause a call into
1908      sv_2iv each time rather than a macro access direct to the IV slot
1909    * should speed up number->string conversion on integers as IV is
1910      favoured when IV and NV are equally accurate
1911
1912    ####################################################################
1913    You had better be using SvIOK_notUV if you want an IV for arithmetic:
1914    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1915    On the other hand, SvUOK is true iff UV.
1916    ####################################################################
1917
1918    Your mileage will vary depending your CPU's relative fp to integer
1919    performance ratio.
1920 */
1921
1922 #ifndef NV_PRESERVES_UV
1923 #  define IS_NUMBER_UNDERFLOW_IV 1
1924 #  define IS_NUMBER_UNDERFLOW_UV 2
1925 #  define IS_NUMBER_IV_AND_UV    2
1926 #  define IS_NUMBER_OVERFLOW_IV  4
1927 #  define IS_NUMBER_OVERFLOW_UV  5
1928
1929 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1930
1931 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1932 STATIC int
1933 S_sv_2iuv_non_preserve(pTHX_ SV *const sv
1934 #  ifdef DEBUGGING
1935                        , I32 numtype
1936 #  endif
1937                        )
1938 {
1939     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1940     PERL_UNUSED_CONTEXT;
1941
1942     DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%" UVxf " NV=%" NVgf " inttype=%" UVXf "\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
1943     if (SvNVX(sv) < (NV)IV_MIN) {
1944         (void)SvIOKp_on(sv);
1945         (void)SvNOK_on(sv);
1946         SvIV_set(sv, IV_MIN);
1947         return IS_NUMBER_UNDERFLOW_IV;
1948     }
1949     if (SvNVX(sv) > (NV)UV_MAX) {
1950         (void)SvIOKp_on(sv);
1951         (void)SvNOK_on(sv);
1952         SvIsUV_on(sv);
1953         SvUV_set(sv, UV_MAX);
1954         return IS_NUMBER_OVERFLOW_UV;
1955     }
1956     (void)SvIOKp_on(sv);
1957     (void)SvNOK_on(sv);
1958     /* Can't use strtol etc to convert this string.  (See truth table in
1959        sv_2iv  */
1960     if (SvNVX(sv) < IV_MAX_P1) {
1961         SvIV_set(sv, I_V(SvNVX(sv)));
1962         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1963             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1964         } else {
1965             /* Integer is imprecise. NOK, IOKp */
1966         }
1967         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1968     }
1969     SvIsUV_on(sv);
1970     SvUV_set(sv, U_V(SvNVX(sv)));
1971     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1972         if (SvUVX(sv) == UV_MAX) {
1973             /* As we know that NVs don't preserve UVs, UV_MAX cannot
1974                possibly be preserved by NV. Hence, it must be overflow.
1975                NOK, IOKp */
1976             return IS_NUMBER_OVERFLOW_UV;
1977         }
1978         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1979     } else {
1980         /* Integer is imprecise. NOK, IOKp */
1981     }
1982     return IS_NUMBER_OVERFLOW_IV;
1983 }
1984 #endif /* !NV_PRESERVES_UV*/
1985
1986 /* If numtype is infnan, set the NV of the sv accordingly.
1987  * If numtype is anything else, try setting the NV using Atof(PV). */
1988 static void
1989 S_sv_setnv(pTHX_ SV* sv, int numtype)
1990 {
1991     bool pok = cBOOL(SvPOK(sv));
1992     bool nok = FALSE;
1993 #ifdef NV_INF
1994     if ((numtype & IS_NUMBER_INFINITY)) {
1995         SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
1996         nok = TRUE;
1997     } else
1998 #endif
1999 #ifdef NV_NAN
2000     if ((numtype & IS_NUMBER_NAN)) {
2001         SvNV_set(sv, NV_NAN);
2002         nok = TRUE;
2003     } else
2004 #endif
2005     if (pok) {
2006         SvNV_set(sv, Atof(SvPVX_const(sv)));
2007         /* Purposefully no true nok here, since we don't want to blow
2008          * away the possible IOK/UV of an existing sv. */
2009     }
2010     if (nok) {
2011         SvNOK_only(sv); /* No IV or UV please, this is pure infnan. */
2012         if (pok)
2013             SvPOK_on(sv); /* PV is okay, though. */
2014     }
2015 }
2016
2017 STATIC bool
2018 S_sv_2iuv_common(pTHX_ SV *const sv)
2019 {
2020     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2021
2022     if (SvNOKp(sv)) {
2023         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2024          * without also getting a cached IV/UV from it at the same time
2025          * (ie PV->NV conversion should detect loss of accuracy and cache
2026          * IV or UV at same time to avoid this. */
2027         /* IV-over-UV optimisation - choose to cache IV if possible */
2028
2029         if (SvTYPE(sv) == SVt_NV)
2030             sv_upgrade(sv, SVt_PVNV);
2031
2032     got_nv:
2033         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2034         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2035            certainly cast into the IV range at IV_MAX, whereas the correct
2036            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2037            cases go to UV */
2038 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2039         if (Perl_isnan(SvNVX(sv))) {
2040             SvUV_set(sv, 0);
2041             SvIsUV_on(sv);
2042             return FALSE;
2043         }
2044 #endif
2045         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2046             SvIV_set(sv, I_V(SvNVX(sv)));
2047             if (SvNVX(sv) == (NV) SvIVX(sv)
2048 #ifndef NV_PRESERVES_UV
2049                 && SvIVX(sv) != IV_MIN /* avoid negating IV_MIN below */
2050                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2051                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2052                 /* Don't flag it as "accurately an integer" if the number
2053                    came from a (by definition imprecise) NV operation, and
2054                    we're outside the range of NV integer precision */
2055 #endif
2056                 ) {
2057                 if (SvNOK(sv))
2058                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2059                 else {
2060                     /* scalar has trailing garbage, eg "42a" */
2061                 }
2062                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2063                                       "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (precise)\n",
2064                                       PTR2UV(sv),
2065                                       SvNVX(sv),
2066                                       SvIVX(sv)));
2067
2068             } else {
2069                 /* IV not precise.  No need to convert from PV, as NV
2070                    conversion would already have cached IV if it detected
2071                    that PV->IV would be better than PV->NV->IV
2072                    flags already correct - don't set public IOK.  */
2073                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2074                                       "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (imprecise)\n",
2075                                       PTR2UV(sv),
2076                                       SvNVX(sv),
2077                                       SvIVX(sv)));
2078             }
2079             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2080                but the cast (NV)IV_MIN rounds to a the value less (more
2081                negative) than IV_MIN which happens to be equal to SvNVX ??
2082                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2083                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2084                (NV)UVX == NVX are both true, but the values differ. :-(
2085                Hopefully for 2s complement IV_MIN is something like
2086                0x8000000000000000 which will be exact. NWC */
2087         }
2088         else {
2089             SvUV_set(sv, U_V(SvNVX(sv)));
2090             if (
2091                 (SvNVX(sv) == (NV) SvUVX(sv))
2092 #ifndef  NV_PRESERVES_UV
2093                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2094                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2095                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2096                 /* Don't flag it as "accurately an integer" if the number
2097                    came from a (by definition imprecise) NV operation, and
2098                    we're outside the range of NV integer precision */
2099 #endif
2100                 && SvNOK(sv)
2101                 )
2102                 SvIOK_on(sv);
2103             SvIsUV_on(sv);
2104             DEBUG_c(PerlIO_printf(Perl_debug_log,
2105                                   "0x%" UVxf " 2iv(%" UVuf " => %" IVdf ") (as unsigned)\n",
2106                                   PTR2UV(sv),
2107                                   SvUVX(sv),
2108                                   SvUVX(sv)));
2109         }
2110     }
2111     else if (SvPOKp(sv)) {
2112         UV value;
2113         int numtype;
2114         const char *s = SvPVX_const(sv);
2115         const STRLEN cur = SvCUR(sv);
2116
2117         /* short-cut for a single digit string like "1" */
2118
2119         if (cur == 1) {
2120             char c = *s;
2121             if (isDIGIT(c)) {
2122                 if (SvTYPE(sv) < SVt_PVIV)
2123                     sv_upgrade(sv, SVt_PVIV);
2124                 (void)SvIOK_on(sv);
2125                 SvIV_set(sv, (IV)(c - '0'));
2126                 return FALSE;
2127             }
2128         }
2129
2130         numtype = grok_number(s, cur, &value);
2131         /* We want to avoid a possible problem when we cache an IV/ a UV which
2132            may be later translated to an NV, and the resulting NV is not
2133            the same as the direct translation of the initial string
2134            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2135            be careful to ensure that the value with the .456 is around if the
2136            NV value is requested in the future).
2137
2138            This means that if we cache such an IV/a UV, we need to cache the
2139            NV as well.  Moreover, we trade speed for space, and do not
2140            cache the NV if we are sure it's not needed.
2141          */
2142
2143         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2144         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2145              == IS_NUMBER_IN_UV) {
2146             /* It's definitely an integer, only upgrade to PVIV */
2147             if (SvTYPE(sv) < SVt_PVIV)
2148                 sv_upgrade(sv, SVt_PVIV);
2149             (void)SvIOK_on(sv);
2150         } else if (SvTYPE(sv) < SVt_PVNV)
2151             sv_upgrade(sv, SVt_PVNV);
2152
2153         if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
2154             if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING)))
2155                 not_a_number(sv);
2156             S_sv_setnv(aTHX_ sv, numtype);
2157             goto got_nv;        /* Fill IV/UV slot and set IOKp */
2158         }
2159
2160         /* If NVs preserve UVs then we only use the UV value if we know that
2161            we aren't going to call atof() below. If NVs don't preserve UVs
2162            then the value returned may have more precision than atof() will
2163            return, even though value isn't perfectly accurate.  */
2164         if ((numtype & (IS_NUMBER_IN_UV
2165 #ifdef NV_PRESERVES_UV
2166                         | IS_NUMBER_NOT_INT
2167 #endif
2168             )) == IS_NUMBER_IN_UV) {
2169             /* This won't turn off the public IOK flag if it was set above  */
2170             (void)SvIOKp_on(sv);
2171
2172             if (!(numtype & IS_NUMBER_NEG)) {
2173                 /* positive */;
2174                 if (value <= (UV)IV_MAX) {
2175                     SvIV_set(sv, (IV)value);
2176                 } else {
2177                     /* it didn't overflow, and it was positive. */
2178                     SvUV_set(sv, value);
2179                     SvIsUV_on(sv);
2180                 }
2181             } else {
2182                 /* 2s complement assumption  */
2183                 if (value <= (UV)IV_MIN) {
2184                     SvIV_set(sv, value == (UV)IV_MIN
2185                                     ? IV_MIN : -(IV)value);
2186                 } else {
2187                     /* Too negative for an IV.  This is a double upgrade, but
2188                        I'm assuming it will be rare.  */
2189                     if (SvTYPE(sv) < SVt_PVNV)
2190                         sv_upgrade(sv, SVt_PVNV);
2191                     SvNOK_on(sv);
2192                     SvIOK_off(sv);
2193                     SvIOKp_on(sv);
2194                     SvNV_set(sv, -(NV)value);
2195                     SvIV_set(sv, IV_MIN);
2196                 }
2197             }
2198         }
2199         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2200            will be in the previous block to set the IV slot, and the next
2201            block to set the NV slot.  So no else here.  */
2202
2203         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2204             != IS_NUMBER_IN_UV) {
2205             /* It wasn't an (integer that doesn't overflow the UV). */
2206             S_sv_setnv(aTHX_ sv, numtype);
2207
2208             if (! numtype && ckWARN(WARN_NUMERIC))
2209                 not_a_number(sv);
2210
2211             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" NVgf ")\n",
2212                                   PTR2UV(sv), SvNVX(sv)));
2213
2214 #ifdef NV_PRESERVES_UV
2215             SvNOKp_on(sv);
2216             if (numtype)
2217                 SvNOK_on(sv);
2218             goto got_nv;        /* Fill IV/UV slot and set IOKp, maybe IOK */
2219 #else /* NV_PRESERVES_UV */
2220             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2221                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2222                 /* The IV/UV slot will have been set from value returned by
2223                    grok_number above.  The NV slot has just been set using
2224                    Atof.  */
2225                 SvNOK_on(sv);
2226                 assert (SvIOKp(sv));
2227             } else {
2228                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2229                     U_V(Perl_fabs(SvNVX(sv)))) {
2230                     /* Small enough to preserve all bits. */
2231                     (void)SvIOKp_on(sv);
2232                     SvNOK_on(sv);
2233                     SvIV_set(sv, I_V(SvNVX(sv)));
2234                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2235                         SvIOK_on(sv);
2236                     /* There had been runtime checking for
2237                        "U_V(Perl_fabs(SvNVX(sv))) < (UV)IV_MAX" here to ensure
2238                        that this NV is in the preserved range, but this should
2239                        be always true if the following assertion is true: */
2240                     STATIC_ASSERT_STMT(((UV)1 << NV_PRESERVES_UV_BITS) <=
2241                                        (UV)IV_MAX);
2242                 } else {
2243                     /* IN_UV NOT_INT
2244                          0      0       already failed to read UV.
2245                          0      1       already failed to read UV.
2246                          1      0       you won't get here in this case. IV/UV
2247                                         slot set, public IOK, Atof() unneeded.
2248                          1      1       already read UV.
2249                        so there's no point in sv_2iuv_non_preserve() attempting
2250                        to use atol, strtol, strtoul etc.  */
2251 #  ifdef DEBUGGING
2252                     sv_2iuv_non_preserve (sv, numtype);
2253 #  else
2254                     sv_2iuv_non_preserve (sv);
2255 #  endif
2256                 }
2257             }
2258         /* It might be more code efficient to go through the entire logic above
2259            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2260            gets complex and potentially buggy, so more programmer efficient
2261            to do it this way, by turning off the public flags:  */
2262         if (!numtype)
2263             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2264 #endif /* NV_PRESERVES_UV */
2265         }
2266     }
2267     else {
2268         if (isGV_with_GP(sv))
2269             return glob_2number(MUTABLE_GV(sv));
2270
2271         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2272                 report_uninit(sv);
2273         if (SvTYPE(sv) < SVt_IV)
2274             /* Typically the caller expects that sv_any is not NULL now.  */
2275             sv_upgrade(sv, SVt_IV);
2276         /* Return 0 from the caller.  */
2277         return TRUE;
2278     }
2279     return FALSE;
2280 }
2281
2282 /*
2283 =for apidoc sv_2iv_flags
2284
2285 Return the integer value of an SV, doing any necessary string
2286 conversion.  If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2287 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2288
2289 =cut
2290 */
2291
2292 IV
2293 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2294 {
2295     PERL_ARGS_ASSERT_SV_2IV_FLAGS;
2296
2297     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2298          && SvTYPE(sv) != SVt_PVFM);
2299
2300     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2301         mg_get(sv);
2302
2303     if (SvROK(sv)) {
2304         if (SvAMAGIC(sv)) {
2305             SV * tmpstr;
2306             if (flags & SV_SKIP_OVERLOAD)
2307                 return 0;
2308             tmpstr = AMG_CALLunary(sv, numer_amg);
2309             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2310                 return SvIV(tmpstr);
2311             }
2312         }
2313         return PTR2IV(SvRV(sv));
2314     }
2315
2316     if (SvVALID(sv) || isREGEXP(sv)) {
2317         /* FBMs use the space for SvIVX and SvNVX for other purposes, so
2318            must not let them cache IVs.
2319            In practice they are extremely unlikely to actually get anywhere
2320            accessible by user Perl code - the only way that I'm aware of is when
2321            a constant subroutine which is used as the second argument to index.
2322
2323            Regexps have no SvIVX and SvNVX fields.
2324         */
2325         assert(SvPOKp(sv));
2326         {
2327             UV value;
2328             const char * const ptr =
2329                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2330             const int numtype
2331                 = grok_number(ptr, SvCUR(sv), &value);
2332
2333             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2334                 == IS_NUMBER_IN_UV) {
2335                 /* It's definitely an integer */
2336                 if (numtype & IS_NUMBER_NEG) {
2337                     if (value < (UV)IV_MIN)
2338                         return -(IV)value;
2339                 } else {
2340                     if (value < (UV)IV_MAX)
2341                         return (IV)value;
2342                 }
2343             }
2344
2345             /* Quite wrong but no good choices. */
2346             if ((numtype & IS_NUMBER_INFINITY)) {
2347                 return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX;
2348             } else if ((numtype & IS_NUMBER_NAN)) {
2349                 return 0; /* So wrong. */
2350             }
2351
2352             if (!numtype) {
2353                 if (ckWARN(WARN_NUMERIC))
2354                     not_a_number(sv);
2355             }
2356             return I_V(Atof(ptr));
2357         }
2358     }
2359
2360     if (SvTHINKFIRST(sv)) {
2361         if (SvREADONLY(sv) && !SvOK(sv)) {
2362             if (ckWARN(WARN_UNINITIALIZED))
2363                 report_uninit(sv);
2364             return 0;
2365         }
2366     }
2367
2368     if (!SvIOKp(sv)) {
2369         if (S_sv_2iuv_common(aTHX_ sv))
2370             return 0;
2371     }
2372
2373     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" IVdf ")\n",
2374         PTR2UV(sv),SvIVX(sv)));
2375     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2376 }
2377
2378 /*
2379 =for apidoc sv_2uv_flags
2380
2381 Return the unsigned integer value of an SV, doing any necessary string
2382 conversion.  If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2383 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2384
2385 =for apidoc Amnh||SV_GMAGIC
2386
2387 =cut
2388 */
2389
2390 UV
2391 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2392 {
2393     PERL_ARGS_ASSERT_SV_2UV_FLAGS;
2394
2395     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2396         mg_get(sv);
2397
2398     if (SvROK(sv)) {
2399         if (SvAMAGIC(sv)) {
2400             SV *tmpstr;
2401             if (flags & SV_SKIP_OVERLOAD)
2402                 return 0;
2403             tmpstr = AMG_CALLunary(sv, numer_amg);
2404             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2405                 return SvUV(tmpstr);
2406             }
2407         }
2408         return PTR2UV(SvRV(sv));
2409     }
2410
2411     if (SvVALID(sv) || isREGEXP(sv)) {
2412         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2413            the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2414            Regexps have no SvIVX and SvNVX fields. */
2415         assert(SvPOKp(sv));
2416         {
2417             UV value;
2418             const char * const ptr =
2419                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2420             const int numtype
2421                 = grok_number(ptr, SvCUR(sv), &value);
2422
2423             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2424                 == IS_NUMBER_IN_UV) {
2425                 /* It's definitely an integer */
2426                 if (!(numtype & IS_NUMBER_NEG))
2427                     return value;
2428             }
2429
2430             /* Quite wrong but no good choices. */
2431             if ((numtype & IS_NUMBER_INFINITY)) {
2432                 return UV_MAX; /* So wrong. */
2433             } else if ((numtype & IS_NUMBER_NAN)) {
2434                 return 0; /* So wrong. */
2435             }
2436
2437             if (!numtype) {
2438                 if (ckWARN(WARN_NUMERIC))
2439                     not_a_number(sv);
2440             }
2441             return U_V(Atof(ptr));
2442         }
2443     }
2444
2445     if (SvTHINKFIRST(sv)) {
2446         if (SvREADONLY(sv) && !SvOK(sv)) {
2447             if (ckWARN(WARN_UNINITIALIZED))
2448                 report_uninit(sv);
2449             return 0;
2450         }
2451     }
2452
2453     if (!SvIOKp(sv)) {
2454         if (S_sv_2iuv_common(aTHX_ sv))
2455             return 0;
2456     }
2457
2458     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2uv(%" UVuf ")\n",
2459                           PTR2UV(sv),SvUVX(sv)));
2460     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2461 }
2462
2463 /*
2464 =for apidoc sv_2nv_flags
2465
2466 Return the num value of an SV, doing any necessary string or integer
2467 conversion.  If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2468 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2469
2470 =cut
2471 */
2472
2473 NV
2474 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2475 {
2476     PERL_ARGS_ASSERT_SV_2NV_FLAGS;
2477
2478     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2479          && SvTYPE(sv) != SVt_PVFM);
2480     if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
2481         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2482            the same flag bit as SVf_IVisUV, so must not let them cache NVs.
2483            Regexps have no SvIVX and SvNVX fields.  */
2484         const char *ptr;
2485         if (flags & SV_GMAGIC)
2486             mg_get(sv);
2487         if (SvNOKp(sv))
2488             return SvNVX(sv);
2489         if (SvPOKp(sv) && !SvIOKp(sv)) {
2490             ptr = SvPVX_const(sv);
2491             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2492                 !grok_number(ptr, SvCUR(sv), NULL))
2493                 not_a_number(sv);
2494             return Atof(ptr);
2495         }
2496         if (SvIOKp(sv)) {
2497             if (SvIsUV(sv))
2498                 return (NV)SvUVX(sv);
2499             else
2500                 return (NV)SvIVX(sv);
2501         }
2502         if (SvROK(sv)) {
2503             goto return_rok;
2504         }
2505         assert(SvTYPE(sv) >= SVt_PVMG);
2506         /* This falls through to the report_uninit near the end of the
2507            function. */
2508     } else if (SvTHINKFIRST(sv)) {
2509         if (SvROK(sv)) {
2510         return_rok:
2511             if (SvAMAGIC(sv)) {
2512                 SV *tmpstr;
2513                 if (flags & SV_SKIP_OVERLOAD)
2514                     return 0;
2515                 tmpstr = AMG_CALLunary(sv, numer_amg);
2516                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2517                     return SvNV(tmpstr);
2518                 }
2519             }
2520             return PTR2NV(SvRV(sv));
2521         }
2522         if (SvREADONLY(sv) && !SvOK(sv)) {
2523             if (ckWARN(WARN_UNINITIALIZED))
2524                 report_uninit(sv);
2525             return 0.0;
2526         }
2527     }
2528     if (SvTYPE(sv) < SVt_NV) {
2529         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2530         sv_upgrade(sv, SVt_NV);
2531         CLANG_DIAG_IGNORE_STMT(-Wthread-safety);
2532         DEBUG_c({
2533             DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2534             STORE_LC_NUMERIC_SET_STANDARD();
2535             PerlIO_printf(Perl_debug_log,
2536                           "0x%" UVxf " num(%" NVgf ")\n",
2537                           PTR2UV(sv), SvNVX(sv));
2538             RESTORE_LC_NUMERIC();
2539         });
2540         CLANG_DIAG_RESTORE_STMT;
2541
2542     }
2543     else if (SvTYPE(sv) < SVt_PVNV)
2544         sv_upgrade(sv, SVt_PVNV);
2545     if (SvNOKp(sv)) {
2546         return SvNVX(sv);
2547     }
2548     if (SvIOKp(sv)) {
2549         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2550 #ifdef NV_PRESERVES_UV
2551         if (SvIOK(sv))
2552             SvNOK_on(sv);
2553         else
2554             SvNOKp_on(sv);
2555 #else
2556         /* Only set the public NV OK flag if this NV preserves the IV  */
2557         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2558         if (SvIOK(sv) &&
2559             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2560                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2561             SvNOK_on(sv);
2562         else
2563             SvNOKp_on(sv);
2564 #endif
2565     }
2566     else if (SvPOKp(sv)) {
2567         UV value;
2568         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2569         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2570             not_a_number(sv);
2571 #ifdef NV_PRESERVES_UV
2572         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2573             == IS_NUMBER_IN_UV) {
2574             /* It's definitely an integer */
2575             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2576         } else {
2577             S_sv_setnv(aTHX_ sv, numtype);
2578         }
2579         if (numtype)
2580             SvNOK_on(sv);
2581         else
2582             SvNOKp_on(sv);
2583 #else
2584         SvNV_set(sv, Atof(SvPVX_const(sv)));
2585         /* Only set the public NV OK flag if this NV preserves the value in
2586            the PV at least as well as an IV/UV would.
2587            Not sure how to do this 100% reliably. */
2588         /* if that shift count is out of range then Configure's test is
2589            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2590            UV_BITS */
2591         if (((UV)1 << NV_PRESERVES_UV_BITS) > U_V(Perl_fabs(SvNVX(sv)))) {
2592             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2593         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2594             /* Can't use strtol etc to convert this string, so don't try.
2595                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2596             SvNOK_on(sv);
2597         } else {
2598             /* value has been set.  It may not be precise.  */
2599             if ((numtype & IS_NUMBER_NEG) && (value >= (UV)IV_MIN)) {
2600                 /* 2s complement assumption for (UV)IV_MIN  */
2601                 SvNOK_on(sv); /* Integer is too negative.  */
2602             } else {
2603                 SvNOKp_on(sv);
2604                 SvIOKp_on(sv);
2605
2606                 if (numtype & IS_NUMBER_NEG) {
2607                     /* -IV_MIN is undefined, but we should never reach
2608                      * this point with both IS_NUMBER_NEG and value ==
2609                      * (UV)IV_MIN */
2610                     assert(value != (UV)IV_MIN);
2611                     SvIV_set(sv, -(IV)value);
2612                 } else if (value <= (UV)IV_MAX) {
2613                     SvIV_set(sv, (IV)value);
2614                 } else {
2615                     SvUV_set(sv, value);
2616                     SvIsUV_on(sv);
2617                 }
2618
2619                 if (numtype & IS_NUMBER_NOT_INT) {
2620                     /* I believe that even if the original PV had decimals,
2621                        they are lost beyond the limit of the FP precision.
2622                        However, neither is canonical, so both only get p
2623                        flags.  NWC, 2000/11/25 */
2624                     /* Both already have p flags, so do nothing */
2625                 } else {
2626                     const NV nv = SvNVX(sv);
2627                     /* XXX should this spot have NAN_COMPARE_BROKEN, too? */
2628                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2629                         if (SvIVX(sv) == I_V(nv)) {
2630                             SvNOK_on(sv);
2631                         } else {
2632                             /* It had no "." so it must be integer.  */
2633                         }
2634                         SvIOK_on(sv);
2635                     } else {
2636                         /* between IV_MAX and NV(UV_MAX).
2637                            Could be slightly > UV_MAX */
2638
2639                         if (numtype & IS_NUMBER_NOT_INT) {
2640                             /* UV and NV both imprecise.  */
2641                         } else {
2642                             const UV nv_as_uv = U_V(nv);
2643
2644                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2645                                 SvNOK_on(sv);
2646                             }
2647                             SvIOK_on(sv);
2648                         }
2649                     }
2650                 }
2651             }
2652         }
2653         /* It might be more code efficient to go through the entire logic above
2654            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2655            gets complex and potentially buggy, so more programmer efficient
2656            to do it this way, by turning off the public flags:  */
2657         if (!numtype)
2658             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2659 #endif /* NV_PRESERVES_UV */
2660     }
2661     else {
2662         if (isGV_with_GP(sv)) {
2663             glob_2number(MUTABLE_GV(sv));
2664             return 0.0;
2665         }
2666
2667         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2668             report_uninit(sv);
2669         assert (SvTYPE(sv) >= SVt_NV);
2670         /* Typically the caller expects that sv_any is not NULL now.  */
2671         /* XXX Ilya implies that this is a bug in callers that assume this
2672            and ideally should be fixed.  */
2673         return 0.0;
2674     }
2675     CLANG_DIAG_IGNORE_STMT(-Wthread-safety);
2676     DEBUG_c({
2677         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2678         STORE_LC_NUMERIC_SET_STANDARD();
2679         PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2nv(%" NVgf ")\n",
2680                       PTR2UV(sv), SvNVX(sv));
2681         RESTORE_LC_NUMERIC();
2682     });
2683     CLANG_DIAG_RESTORE_STMT;
2684     return SvNVX(sv);
2685 }
2686
2687 /*
2688 =for apidoc sv_2num
2689
2690 Return an SV with the numeric value of the source SV, doing any necessary
2691 reference or overload conversion.  The caller is expected to have handled
2692 get-magic already.
2693
2694 =cut
2695 */
2696
2697 SV *
2698 Perl_sv_2num(pTHX_ SV *const sv)
2699 {
2700     PERL_ARGS_ASSERT_SV_2NUM;
2701
2702     if (!SvROK(sv))
2703         return sv;
2704     if (SvAMAGIC(sv)) {
2705         SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2706         TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2707         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2708             return sv_2num(tmpsv);
2709     }
2710     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2711 }
2712
2713 /* int2str_table: lookup table containing string representations of all
2714  * two digit numbers. For example, int2str_table.arr[0] is "00" and
2715  * int2str_table.arr[12*2] is "12".
2716  *
2717  * We are going to read two bytes at a time, so we have to ensure that
2718  * the array is aligned to a 2 byte boundary. That's why it was made a
2719  * union with a dummy U16 member. */
2720 static const union {
2721     char arr[200];
2722     U16 dummy;
2723 } int2str_table = {{
2724     '0', '0', '0', '1', '0', '2', '0', '3', '0', '4', '0', '5', '0', '6',
2725     '0', '7', '0', '8', '0', '9', '1', '0', '1', '1', '1', '2', '1', '3',
2726     '1', '4', '1', '5', '1', '6', '1', '7', '1', '8', '1', '9', '2', '0',
2727     '2', '1', '2', '2', '2', '3', '2', '4', '2', '5', '2', '6', '2', '7',
2728     '2', '8', '2', '9', '3', '0', '3', '1', '3', '2', '3', '3', '3', '4',
2729     '3', '5', '3', '6', '3', '7', '3', '8', '3', '9', '4', '0', '4', '1',
2730     '4', '2', '4', '3', '4', '4', '4', '5', '4', '6', '4', '7', '4', '8',
2731     '4', '9', '5', '0', '5', '1', '5', '2', '5', '3', '5', '4', '5', '5',
2732     '5', '6', '5', '7', '5', '8', '5', '9', '6', '0', '6', '1', '6', '2',
2733     '6', '3', '6', '4', '6', '5', '6', '6', '6', '7', '6', '8', '6', '9',
2734     '7', '0', '7', '1', '7', '2', '7', '3', '7', '4', '7', '5', '7', '6',
2735     '7', '7', '7', '8', '7', '9', '8', '0', '8', '1', '8', '2', '8', '3',
2736     '8', '4', '8', '5', '8', '6', '8', '7', '8', '8', '8', '9', '9', '0',
2737     '9', '1', '9', '2', '9', '3', '9', '4', '9', '5', '9', '6', '9', '7',
2738     '9', '8', '9', '9'
2739 }};
2740
2741 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2742  * UV as a string towards the end of buf, and return pointers to start and
2743  * end of it.
2744  *
2745  * We assume that buf is at least TYPE_CHARS(UV) long.
2746  */
2747
2748 PERL_STATIC_INLINE char *
2749 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2750 {
2751     char *ptr = buf + TYPE_CHARS(UV);
2752     char * const ebuf = ptr;
2753     int sign;
2754     U16 *word_ptr, *word_table;
2755
2756     PERL_ARGS_ASSERT_UIV_2BUF;
2757
2758     /* ptr has to be properly aligned, because we will cast it to U16* */
2759     assert(PTR2nat(ptr) % 2 == 0);
2760     /* we are going to read/write two bytes at a time */
2761     word_ptr = (U16*)ptr;
2762     word_table = (U16*)int2str_table.arr;
2763
2764     if (UNLIKELY(is_uv))
2765         sign = 0;
2766     else if (iv >= 0) {
2767         uv = iv;
2768         sign = 0;
2769     } else {
2770         /* Using 0- here to silence bogus warning from MS VC */
2771         uv = (UV) (0 - (UV) iv);
2772         sign = 1;
2773     }
2774
2775     while (uv > 99) {
2776         *--word_ptr = word_table[uv % 100];
2777         uv /= 100;
2778     }
2779     ptr = (char*)word_ptr;
2780
2781     if (uv < 10)
2782         *--ptr = (char)uv + '0';
2783     else {
2784         *--word_ptr = word_table[uv];
2785         ptr = (char*)word_ptr;
2786     }
2787
2788     if (sign)
2789         *--ptr = '-';
2790
2791     *peob = ebuf;
2792     return ptr;
2793 }
2794
2795 /* Helper for sv_2pv_flags and sv_vcatpvfn_flags.  If the NV is an
2796  * infinity or a not-a-number, writes the appropriate strings to the
2797  * buffer, including a zero byte.  On success returns the written length,
2798  * excluding the zero byte, on failure (not an infinity, not a nan)
2799  * returns zero, assert-fails on maxlen being too short.
2800  *
2801  * XXX for "Inf", "-Inf", and "NaN", we could have three read-only
2802  * shared string constants we point to, instead of generating a new
2803  * string for each instance. */
2804 STATIC size_t
2805 S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char plus) {
2806     char* s = buffer;
2807     assert(maxlen >= 4);
2808     if (Perl_isinf(nv)) {
2809         if (nv < 0) {
2810             if (maxlen < 5) /* "-Inf\0"  */
2811                 return 0;
2812             *s++ = '-';
2813         } else if (plus) {
2814             *s++ = '+';
2815         }
2816         *s++ = 'I';
2817         *s++ = 'n';
2818         *s++ = 'f';
2819     }
2820     else if (Perl_isnan(nv)) {
2821         *s++ = 'N';
2822         *s++ = 'a';
2823         *s++ = 'N';
2824         /* XXX optionally output the payload mantissa bits as
2825          * "(unsigned)" (to match the nan("...") C99 function,
2826          * or maybe as "(0xhhh...)"  would make more sense...
2827          * provide a format string so that the user can decide?
2828          * NOTE: would affect the maxlen and assert() logic.*/
2829     }
2830     else {
2831       return 0;
2832     }
2833     assert((s == buffer + 3) || (s == buffer + 4));
2834     *s = 0;
2835     return s - buffer;
2836 }
2837
2838 /*
2839 =for apidoc      sv_2pv
2840 =for apidoc_item sv_2pv_flags
2841
2842 These implement the various forms of the L<perlapi/C<SvPV>> macros.
2843 The macros are the preferred interface.
2844
2845 These return a pointer to the string value of an SV (coercing it to a string if
2846 necessary), and set C<*lp> to its length in bytes.
2847
2848 The forms differ in that plain C<sv_2pvbyte> always processes 'get' magic; and
2849 C<sv_2pvbyte_flags> processes 'get' magic if and only if C<flags> contains
2850 C<SV_GMAGIC>.
2851
2852 =for apidoc Amnh||SV_GMAGIC
2853
2854 =cut
2855 */
2856
2857 char *
2858 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const U32 flags)
2859 {
2860     char *s;
2861     bool done_gmagic = FALSE;
2862
2863     PERL_ARGS_ASSERT_SV_2PV_FLAGS;
2864
2865     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2866          && SvTYPE(sv) != SVt_PVFM);
2867     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) {
2868         mg_get(sv);
2869         done_gmagic = TRUE;
2870     }
2871
2872     if (SvROK(sv)) {
2873         if (SvAMAGIC(sv)) {
2874             SV *tmpstr;
2875             SV *nsv= (SV *)sv;
2876             if (flags & SV_SKIP_OVERLOAD)
2877                 return NULL;
2878             if (done_gmagic)
2879                 nsv = sv_mortalcopy_flags(sv,0);
2880             tmpstr = AMG_CALLunary(nsv, string_amg);
2881             TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2882             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(nsv)))) {
2883                 /* Unwrap this:  */
2884                 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2885                  */
2886
2887                 char *pv;
2888                 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2889                     if (flags & SV_CONST_RETURN) {
2890                         pv = (char *) SvPVX_const(tmpstr);
2891                     } else {
2892                         pv = (flags & SV_MUTABLE_RETURN)
2893                             ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2894                     }
2895                     if (lp)
2896                         *lp = SvCUR(tmpstr);
2897                 } else {
2898                     pv = sv_2pv_flags(tmpstr, lp, flags);
2899                 }
2900                 if (SvUTF8(tmpstr))
2901                     SvUTF8_on(sv);
2902                 else
2903                     SvUTF8_off(sv);
2904                 return pv;
2905             }
2906         }
2907         {
2908             STRLEN len;
2909             char *retval;
2910             char *buffer;
2911             SV *const referent = SvRV(sv);
2912
2913             if (!referent) {
2914                 len = 7;
2915                 retval = buffer = savepvn("NULLREF", len);
2916             } else if (SvTYPE(referent) == SVt_REGEXP &&
2917                        (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
2918                         amagic_is_enabled(string_amg))) {
2919                 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2920
2921                 assert(re);
2922
2923                 /* If the regex is UTF-8 we want the containing scalar to
2924                    have an UTF-8 flag too */
2925                 if (RX_UTF8(re))
2926                     SvUTF8_on(sv);
2927                 else
2928                     SvUTF8_off(sv);
2929
2930                 if (lp)
2931                     *lp = RX_WRAPLEN(re);
2932
2933                 return RX_WRAPPED(re);
2934             } else {
2935                 const char *const typestring = sv_reftype(referent, 0);
2936                 const STRLEN typelen = strlen(typestring);
2937                 UV addr = PTR2UV(referent);
2938                 const char *stashname = NULL;
2939                 STRLEN stashnamelen = 0; /* hush, gcc */
2940                 const char *buffer_end;
2941
2942                 if (SvOBJECT(referent)) {
2943                     const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2944
2945                     if (name) {
2946                         stashname = HEK_KEY(name);
2947                         stashnamelen = HEK_LEN(name);
2948
2949                         if (HEK_UTF8(name)) {
2950                             SvUTF8_on(sv);
2951                         } else {
2952                             SvUTF8_off(sv);
2953                         }
2954                     } else {
2955                         stashname = "__ANON__";
2956                         stashnamelen = 8;
2957                     }
2958                     len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2959                         + 2 * sizeof(UV) + 2 /* )\0 */;
2960                 } else {
2961                     len = typelen + 3 /* (0x */
2962                         + 2 * sizeof(UV) + 2 /* )\0 */;
2963                 }
2964
2965                 Newx(buffer, len, char);
2966                 buffer_end = retval = buffer + len;
2967
2968                 /* Working backwards  */
2969                 *--retval = '\0';
2970                 *--retval = ')';
2971                 do {
2972                     *--retval = PL_hexdigit[addr & 15];
2973                 } while (addr >>= 4);
2974                 *--retval = 'x';
2975                 *--retval = '0';
2976                 *--retval = '(';
2977
2978                 retval -= typelen;
2979                 memcpy(retval, typestring, typelen);
2980
2981                 if (stashname) {
2982                     *--retval = '=';
2983                     retval -= stashnamelen;
2984                     memcpy(retval, stashname, stashnamelen);
2985                 }
2986                 /* retval may not necessarily have reached the start of the
2987                    buffer here.  */
2988                 assert (retval >= buffer);
2989
2990                 len = buffer_end - retval - 1; /* -1 for that \0  */
2991             }
2992             if (lp)
2993                 *lp = len;
2994             SAVEFREEPV(buffer);
2995             return retval;
2996         }
2997     }
2998
2999     if (SvPOKp(sv)) {
3000         if (lp)
3001             *lp = SvCUR(sv);
3002         if (flags & SV_MUTABLE_RETURN)
3003             return SvPVX_mutable(sv);
3004         if (flags & SV_CONST_RETURN)
3005             return (char *)SvPVX_const(sv);
3006         return SvPVX(sv);
3007     }
3008
3009     if (SvIOK(sv)) {
3010         /* I'm assuming that if both IV and NV are equally valid then
3011            converting the IV is going to be more efficient */
3012         const U32 isUIOK = SvIsUV(sv);
3013         /* The purpose of this union is to ensure that arr is aligned on
3014            a 2 byte boundary, because that is what uiv_2buf() requires */
3015         union {
3016             char arr[TYPE_CHARS(UV)];
3017             U16 dummy;
3018         } buf;
3019         char *ebuf, *ptr;
3020         STRLEN len;
3021
3022         if (SvTYPE(sv) < SVt_PVIV)
3023             sv_upgrade(sv, SVt_PVIV);
3024         ptr = uiv_2buf(buf.arr, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
3025         len = ebuf - ptr;
3026         /* inlined from sv_setpvn */
3027         s = SvGROW_mutable(sv, len + 1);
3028         Move(ptr, s, len, char);
3029         s += len;
3030         *s = '\0';
3031         /* We used to call SvPOK_on(). Whilst this is fine for (most) Perl code,
3032            it means that after this stringification is cached, there is no way
3033            to distinguish between values originally assigned as $a = 42; and
3034            $a = "42"; (or results of string operators vs numeric operators)
3035            where the value has subsequently been used in the other sense
3036            and had a value cached.
3037            This (somewhat) hack means that we retain the cached stringification,
3038            but don't set SVf_POK. Hence if a value is SVf_IOK|SVf_POK then it
3039            originated as "42", whereas if it's SVf_IOK then it originated as 42.
3040            (ignore SVp_IOK and SVp_POK)
3041            The SvPV macros are now updated to recognise this specific case
3042            (and that there isn't overloading or magic that could alter the
3043            cached value) and so return the cached value immediately without
3044            re-entering this function, getting back here to this block of code,
3045            and repeating the same conversion. */
3046         SvPOKp_on(sv);
3047     }
3048     else if (SvNOK(sv)) {
3049         if (SvTYPE(sv) < SVt_PVNV)
3050             sv_upgrade(sv, SVt_PVNV);
3051         if (SvNVX(sv) == 0.0
3052 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3053             && !Perl_isnan(SvNVX(sv))
3054 #endif
3055         ) {
3056             s = SvGROW_mutable(sv, 2);
3057             *s++ = '0';
3058             *s = '\0';
3059         } else {
3060             STRLEN len;
3061             STRLEN size = 5; /* "-Inf\0" */
3062
3063             s = SvGROW_mutable(sv, size);
3064             len = S_infnan_2pv(SvNVX(sv), s, size, 0);
3065             if (len > 0) {
3066                 s += len;
3067                 SvPOKp_on(sv);
3068             }
3069             else {
3070                 /* some Xenix systems wipe out errno here */
3071                 dSAVE_ERRNO;
3072
3073                 size =
3074                     1 + /* sign */
3075                     1 + /* "." */
3076                     NV_DIG +
3077                     1 + /* "e" */
3078                     1 + /* sign */
3079                     5 + /* exponent digits */
3080                     1 + /* \0 */
3081                     2; /* paranoia */
3082
3083                 s = SvGROW_mutable(sv, size);
3084 #ifndef USE_LOCALE_NUMERIC
3085                 SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3086
3087                 SvPOKp_on(sv);
3088 #else
3089                 {
3090                     bool local_radix;
3091                     DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3092                     STORE_LC_NUMERIC_SET_TO_NEEDED();
3093
3094                     local_radix = NOT_IN_NUMERIC_STANDARD_;
3095                     if (local_radix && SvCUR(PL_numeric_radix_sv) > 1) {
3096                         size += SvCUR(PL_numeric_radix_sv) - 1;
3097                         s = SvGROW_mutable(sv, size);
3098                     }
3099
3100                     SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3101
3102                     /* If the radix character is UTF-8, and actually is in the
3103                      * output, turn on the UTF-8 flag for the scalar */
3104                     if (   local_radix
3105                         && SvUTF8(PL_numeric_radix_sv)
3106                         && instr(s, SvPVX_const(PL_numeric_radix_sv)))
3107                     {
3108                         SvUTF8_on(sv);
3109                     }
3110
3111                     RESTORE_LC_NUMERIC();
3112                 }
3113
3114                 /* We don't call SvPOK_on(), because it may come to
3115                  * pass that the locale changes so that the
3116                  * stringification we just did is no longer correct.  We
3117                  * will have to re-stringify every time it is needed */
3118 #endif
3119                 RESTORE_ERRNO;
3120             }
3121             while (*s) s++;
3122         }
3123     }
3124     else if (isGV_with_GP(sv)) {
3125         GV *const gv = MUTABLE_GV(sv);
3126         SV *const buffer = sv_newmortal();
3127
3128         gv_efullname3(buffer, gv, "*");
3129
3130         assert(SvPOK(buffer));
3131         if (SvUTF8(buffer))
3132             SvUTF8_on(sv);
3133         else
3134             SvUTF8_off(sv);
3135         if (lp)
3136             *lp = SvCUR(buffer);
3137         return SvPVX(buffer);
3138     }
3139     else {
3140         if (lp)
3141             *lp = 0;
3142         if (flags & SV_UNDEF_RETURNS_NULL)
3143             return NULL;
3144         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3145             report_uninit(sv);
3146         /* Typically the caller expects that sv_any is not NULL now.  */
3147         if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
3148             sv_upgrade(sv, SVt_PV);
3149         return (char *)"";
3150     }
3151
3152     {
3153         const STRLEN len = s - SvPVX_const(sv);
3154         if (lp)
3155             *lp = len;
3156         SvCUR_set(sv, len);
3157     }
3158     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2pv(%s)\n",
3159                           PTR2UV(sv),SvPVX_const(sv)));
3160     if (flags & SV_CONST_RETURN)
3161         return (char *)SvPVX_const(sv);
3162     if (flags & SV_MUTABLE_RETURN)
3163         return SvPVX_mutable(sv);
3164     return SvPVX(sv);
3165 }
3166
3167 /*
3168 =for apidoc sv_copypv
3169 =for apidoc_item sv_copypv_flags
3170 =for apidoc_item sv_copypv_nomg
3171
3172 These copy a stringified representation of the source SV into the
3173 destination SV.  They automatically perform coercion of numeric values into
3174 strings.  Guaranteed to preserve the C<UTF8> flag even from overloaded objects.
3175 Similar in nature to C<sv_2pv[_flags]> but they operate directly on an SV
3176 instead of just the string.  Mostly they use L</C<sv_2pv_flags>> to
3177 do the work, except when that would lose the UTF-8'ness of the PV.
3178
3179 The three forms differ only in whether or not they perform 'get magic' on
3180 C<sv>.  C<sv_copypv_nomg> skips 'get magic'; C<sv_copypv> performs it; and
3181 C<sv_copypv_flags> either performs it (if the C<SV_GMAGIC> bit is set in
3182 C<flags>) or doesn't (if that bit is cleared).
3183
3184 =cut
3185 */
3186
3187 void
3188 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3189 {
3190     STRLEN len;
3191     const char *s;
3192
3193     PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3194
3195     s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC));
3196     sv_setpvn(dsv,s,len);
3197     if (SvUTF8(ssv))
3198         SvUTF8_on(dsv);
3199     else
3200         SvUTF8_off(dsv);
3201 }
3202
3203 /*
3204 =for apidoc      sv_2pvbyte
3205 =for apidoc_item sv_2pvbyte_flags
3206
3207 These implement the various forms of the L<perlapi/C<SvPVbyte>> macros.
3208 The macros are the preferred interface.
3209
3210 These return a pointer to the byte-encoded representation of the SV, and set
3211 C<*lp> to its length.  If the SV is marked as being encoded as UTF-8, it will
3212 be downgraded, if possible, to a byte string.  If the SV cannot be downgraded,
3213 they croak.
3214
3215 The forms differ in that plain C<sv_2pvbyte> always processes 'get' magic; and
3216 C<sv_2pvbyte_flags> processes 'get' magic if and only if C<flags> contains
3217 C<SV_GMAGIC>.
3218
3219 =for apidoc Amnh||SV_GMAGIC
3220
3221 =cut
3222 */
3223
3224 char *
3225 Perl_sv_2pvbyte_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags)
3226 {
3227     PERL_ARGS_ASSERT_SV_2PVBYTE_FLAGS;
3228
3229     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
3230         mg_get(sv);
3231     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3232      || isGV_with_GP(sv) || SvROK(sv)) {
3233         SV *sv2 = sv_newmortal();
3234         sv_copypv_nomg(sv2,sv);
3235         sv = sv2;
3236     }
3237     sv_utf8_downgrade_nomg(sv,0);
3238     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3239 }
3240
3241 /*
3242 =for apidoc      sv_2pvutf8
3243 =for apidoc_item sv_2pvutf8_flags
3244
3245 These implement the various forms of the L<perlapi/C<SvPVutf8>> macros.
3246 The macros are the preferred interface.
3247
3248 These return a pointer to the UTF-8-encoded representation of the SV, and set
3249 C<*lp> to its length in bytes.  They may cause the SV to be upgraded to UTF-8
3250 as a side-effect.
3251
3252 The forms differ in that plain C<sv_2pvutf8> always processes 'get' magic; and
3253 C<sv_2pvutf8_flags> processes 'get' magic if and only if C<flags> contains
3254 C<SV_GMAGIC>.
3255
3256 =cut
3257 */
3258
3259 char *
3260 Perl_sv_2pvutf8_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags)
3261 {
3262     PERL_ARGS_ASSERT_SV_2PVUTF8_FLAGS;
3263
3264     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
3265         mg_get(sv);
3266     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3267      || isGV_with_GP(sv) || SvROK(sv)) {
3268         SV *sv2 = sv_newmortal();
3269         sv_copypv_nomg(sv2,sv);
3270         sv = sv2;
3271     }
3272     sv_utf8_upgrade_nomg(sv);
3273     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3274 }
3275
3276
3277 /*
3278 =for apidoc sv_2bool
3279
3280 This macro is only used by C<sv_true()> or its macro equivalent, and only if
3281 the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>.
3282 It calls C<sv_2bool_flags> with the C<SV_GMAGIC> flag.
3283
3284 =for apidoc sv_2bool_flags
3285
3286 This function is only used by C<sv_true()> and friends,  and only if
3287 the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>.  If the flags
3288 contain C<SV_GMAGIC>, then it does an C<mg_get()> first.
3289
3290
3291 =cut
3292 */
3293
3294 bool
3295 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
3296 {
3297     PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3298
3299     restart:
3300     if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3301
3302     if (!SvOK(sv))
3303         return 0;
3304     if (SvROK(sv)) {
3305         if (SvAMAGIC(sv)) {
3306             SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3307             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
3308                 bool svb;
3309                 sv = tmpsv;
3310                 if(SvGMAGICAL(sv)) {
3311                     flags = SV_GMAGIC;
3312                     goto restart; /* call sv_2bool */
3313                 }
3314                 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
3315                 else if(!SvOK(sv)) {
3316                     svb = 0;
3317                 }
3318                 else if(SvPOK(sv)) {
3319                     svb = SvPVXtrue(sv);
3320                 }
3321                 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
3322                     svb = (SvIOK(sv) && SvIVX(sv) != 0)
3323                         || (SvNOK(sv) && SvNVX(sv) != 0.0);
3324                 }
3325                 else {
3326                     flags = 0;
3327                     goto restart; /* call sv_2bool_nomg */
3328                 }
3329                 return cBOOL(svb);
3330             }
3331         }
3332         assert(SvRV(sv));
3333         return TRUE;
3334     }
3335     if (isREGEXP(sv))
3336         return
3337           RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
3338
3339     if (SvNOK(sv) && !SvPOK(sv))
3340         return SvNVX(sv) != 0.0;
3341
3342     return SvTRUE_common(sv, 0);
3343 }
3344
3345 /*
3346 =for apidoc sv_utf8_upgrade
3347 =for apidoc_item sv_utf8_upgrade_flags
3348 =for apidoc_item sv_utf8_upgrade_flags_grow
3349 =for apidoc_item sv_utf8_upgrade_nomg
3350
3351 These convert the PV of an SV to its UTF-8-encoded form.
3352 The SV is forced to string form if it is not already.
3353 They always set the C<SvUTF8> flag to avoid future validity checks even if the
3354 whole string is the same in UTF-8 as not.
3355 They return the number of bytes in the converted string
3356
3357 The forms differ in just two ways.  The main difference is whether or not they
3358 perform 'get magic' on C<sv>.  C<sv_utf8_upgrade_nomg> skips 'get magic';
3359 C<sv_utf8_upgrade> performs it; and C<sv_utf8_upgrade_flags> and
3360 C<sv_utf8_upgrade_flags_grow> either perform it (if the C<SV_GMAGIC> bit is set
3361 in C<flags>) or don't (if that bit is cleared).
3362
3363 The other difference is that C<sv_utf8_upgrade_flags_grow> has an additional
3364 parameter, C<extra>, which allows the caller to specify an amount of space to
3365 be reserved as spare beyond what is needed for the actual conversion.  This is
3366 used when the caller knows it will soon be needing yet more space, and it is
3367 more efficient to request space from the system in a single call.
3368 This form is otherwise identical to C<sv_utf8_upgrade_flags>.
3369
3370 These are not a general purpose byte encoding to Unicode interface: use the
3371 Encode extension for that.
3372
3373 The C<SV_FORCE_UTF8_UPGRADE> flag is now ignored.
3374
3375 =for apidoc Amnh||SV_GMAGIC|
3376 =for apidoc Amnh||SV_FORCE_UTF8_UPGRADE|
3377
3378 =cut
3379
3380 If the routine itself changes the string, it adds a trailing C<NUL>.  Such a
3381 C<NUL> isn't guaranteed due to having other routines do the work in some input
3382 cases, or if the input is already flagged as being in utf8.
3383
3384 */
3385
3386 STRLEN
3387 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3388 {
3389     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3390
3391     if (sv == &PL_sv_undef)
3392         return 0;
3393     if (!SvPOK_nog(sv)) {
3394         STRLEN len = 0;
3395         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3396             (void) sv_2pv_flags(sv,&len, flags);
3397             if (SvUTF8(sv)) {
3398                 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3399                 return len;
3400             }
3401         } else {
3402             (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3403         }
3404     }
3405
3406     /* SVt_REGEXP's shouldn't be upgraded to UTF8 - they're already
3407      * compiled and individual nodes will remain non-utf8 even if the
3408      * stringified version of the pattern gets upgraded. Whether the
3409      * PVX of a REGEXP should be grown or we should just croak, I don't
3410      * know - DAPM */
3411     if (SvUTF8(sv) || isREGEXP(sv)) {
3412         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3413         return SvCUR(sv);
3414     }
3415
3416     if (SvIsCOW(sv)) {
3417         S_sv_uncow(aTHX_ sv, 0);
3418     }
3419
3420     if (SvCUR(sv) == 0) {
3421         if (extra) SvGROW(sv, extra + 1); /* Make sure is room for a trailing
3422                                              byte */
3423     } else { /* Assume Latin-1/EBCDIC */
3424         /* This function could be much more efficient if we
3425          * had a FLAG in SVs to signal if there are any variant
3426          * chars in the PV.  Given that there isn't such a flag
3427          * make the loop as fast as possible. */
3428         U8 * s = (U8 *) SvPVX_const(sv);
3429         U8 *t = s;
3430
3431         if (is_utf8_invariant_string_loc(s, SvCUR(sv), (const U8 **) &t)) {
3432
3433             /* utf8 conversion not needed because all are invariants.  Mark
3434              * as UTF-8 even if no variant - saves scanning loop */
3435             SvUTF8_on(sv);
3436             if (extra) SvGROW(sv, SvCUR(sv) + extra);
3437             return SvCUR(sv);
3438         }
3439
3440         /* Here, there is at least one variant (t points to the first one), so
3441          * the string should be converted to utf8.  Everything from 's' to
3442          * 't - 1' will occupy only 1 byte each on output.
3443          *
3444          * Note that the incoming SV may not have a trailing '\0', as certain
3445          * code in pp_formline can send us partially built SVs.
3446          *
3447          * There are two main ways to convert.  One is to create a new string
3448          * and go through the input starting from the beginning, appending each
3449          * converted value onto the new string as we go along.  Going this
3450          * route, it's probably best to initially allocate enough space in the
3451          * string rather than possibly running out of space and having to
3452          * reallocate and then copy what we've done so far.  Since everything
3453          * from 's' to 't - 1' is invariant, the destination can be initialized
3454          * with these using a fast memory copy.  To be sure to allocate enough
3455          * space, one could use the worst case scenario, where every remaining
3456          * byte expands to two under UTF-8, or one could parse it and count
3457          * exactly how many do expand.
3458          *
3459          * The other way is to unconditionally parse the remainder of the
3460          * string to figure out exactly how big the expanded string will be,
3461          * growing if needed.  Then start at the end of the string and place
3462          * the character there at the end of the unfilled space in the expanded
3463          * one, working backwards until reaching 't'.
3464          *
3465          * The problem with assuming the worst case scenario is that for very
3466          * long strings, we could allocate much more memory than actually
3467          * needed, which can create performance problems.  If we have to parse
3468          * anyway, the second method is the winner as it may avoid an extra
3469          * copy.  The code used to use the first method under some
3470          * circumstances, but now that there is faster variant counting on
3471          * ASCII platforms, the second method is used exclusively, eliminating
3472          * some code that no longer has to be maintained. */
3473
3474         {
3475             /* Count the total number of variants there are.  We can start
3476              * just beyond the first one, which is known to be at 't' */
3477             const Size_t invariant_length = t - s;
3478             U8 * e = (U8 *) SvEND(sv);
3479
3480             /* The length of the left overs, plus 1. */
3481             const Size_t remaining_length_p1 = e - t;
3482
3483             /* We expand by 1 for the variant at 't' and one for each remaining
3484              * variant (we start looking at 't+1') */
3485             Size_t expansion = 1 + variant_under_utf8_count(t + 1, e);
3486
3487             /* +1 = trailing NUL */
3488             Size_t need = SvCUR(sv) + expansion + extra + 1;
3489             U8 * d;
3490
3491             /* Grow if needed */
3492             if (SvLEN(sv) < need) {
3493                 t = invariant_length + (U8*) SvGROW(sv, need);
3494                 e = t + remaining_length_p1;
3495             }
3496             SvCUR_set(sv, invariant_length + remaining_length_p1 + expansion);
3497
3498             /* Set the NUL at the end */
3499             d = (U8 *) SvEND(sv);
3500             *d-- = '\0';
3501
3502             /* Having decremented d, it points to the position to put the
3503              * very last byte of the expanded string.  Go backwards through
3504              * the string, copying and expanding as we go, stopping when we
3505              * get to the part that is invariant the rest of the way down */
3506
3507             e--;
3508             while (e >= t) {
3509                 if (NATIVE_BYTE_IS_INVARIANT(*e)) {
3510                     *d-- = *e;
3511                 } else {
3512                     *d-- = UTF8_EIGHT_BIT_LO(*e);
3513                     *d-- = UTF8_EIGHT_BIT_HI(*e);
3514                 }
3515                 e--;
3516             }
3517
3518             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3519                 /* Update pos. We do it at the end rather than during
3520                  * the upgrade, to avoid slowing down the common case
3521                  * (upgrade without pos).
3522                  * pos can be stored as either bytes or characters.  Since
3523                  * this was previously a byte string we can just turn off
3524                  * the bytes flag. */
3525                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3526                 if (mg) {
3527                     mg->mg_flags &= ~MGf_BYTES;
3528                 }
3529                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3530                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3531             }
3532         }
3533     }
3534
3535     SvUTF8_on(sv);
3536     return SvCUR(sv);
3537 }
3538
3539 /*
3540 =for apidoc sv_utf8_downgrade
3541 =for apidoc_item sv_utf8_downgrade_flags
3542 =for apidoc_item sv_utf8_downgrade_nomg
3543
3544 These attempt to convert the PV of an SV from characters to bytes.  If the PV
3545 contains a character that cannot fit in a byte, this conversion will fail; in
3546 this case, C<FALSE> is returned if C<fail_ok> is true; otherwise they croak.
3547
3548 They are not a general purpose Unicode to byte encoding interface:
3549 use the C<Encode> extension for that.
3550
3551 They differ only in that:
3552
3553 C<sv_utf8_downgrade> processes 'get' magic on C<sv>.
3554
3555 C<sv_utf8_downgrade_nomg> does not.
3556
3557 C<sv_utf8_downgrade_flags> has an additional C<flags> parameter in which you can specify
3558 C<SV_GMAGIC> to process 'get' magic, or leave it cleared to not process 'get' magic.
3559
3560 =cut
3561 */
3562
3563 bool
3564 Perl_sv_utf8_downgrade_flags(pTHX_ SV *const sv, const bool fail_ok, const U32 flags)
3565 {
3566     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE_FLAGS;
3567
3568     if (SvPOKp(sv) && SvUTF8(sv)) {
3569         if (SvCUR(sv)) {
3570             U8 *s;
3571             STRLEN len;
3572             U32 mg_flags = flags & SV_GMAGIC;
3573
3574             if (SvIsCOW(sv)) {
3575                 S_sv_uncow(aTHX_ sv, 0);
3576             }
3577             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3578                 /* update pos */
3579                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3580                 if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
3581                         mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
3582                                                 mg_flags|SV_CONST_RETURN);
3583                         mg_flags = 0; /* sv_pos_b2u does get magic */
3584                 }
3585                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3586                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3587
3588             }
3589             s = (U8 *) SvPV_flags(sv, len, mg_flags);
3590
3591             if (!utf8_to_bytes(s, &len)) {
3592                 if (fail_ok)
3593                     return FALSE;
3594                 else {
3595                     if (PL_op)
3596                         Perl_croak(aTHX_ "Wide character in %s",
3597                                    OP_DESC(PL_op));
3598                     else
3599                         Perl_croak(aTHX_ "Wide character");
3600                 }
3601             }
3602             SvCUR_set(sv, len);
3603         }
3604     }
3605     SvUTF8_off(sv);
3606     return TRUE;
3607 }
3608
3609 /*
3610 =for apidoc sv_utf8_encode
3611
3612 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3613 flag off so that it looks like octets again.
3614
3615 =cut
3616 */
3617
3618 void
3619 Perl_sv_utf8_encode(pTHX_ SV *const sv)
3620 {
3621     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3622
3623     if (SvREADONLY(sv)) {
3624         sv_force_normal_flags(sv, 0);
3625     }
3626     (void) sv_utf8_upgrade(sv);
3627     SvUTF8_off(sv);
3628 }
3629
3630 /*
3631 =for apidoc sv_utf8_decode
3632
3633 If the PV of the SV is an octet sequence in Perl's extended UTF-8
3634 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3635 so that it looks like a character.  If the PV contains only single-byte
3636 characters, the C<SvUTF8> flag stays off.
3637 Scans PV for validity and returns FALSE if the PV is invalid UTF-8.
3638
3639 =cut
3640 */
3641
3642 bool
3643 Perl_sv_utf8_decode(pTHX_ SV *const sv)
3644 {
3645     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3646
3647     if (SvPOKp(sv)) {
3648         const U8 *start, *c, *first_variant;
3649
3650         /* The octets may have got themselves encoded - get them back as
3651          * bytes
3652          */
3653         if (!sv_utf8_downgrade(sv, TRUE))
3654             return FALSE;
3655
3656         /* it is actually just a matter of turning the utf8 flag on, but
3657          * we want to make sure everything inside is valid utf8 first.
3658          */
3659         c = start = (const U8 *) SvPVX_const(sv);
3660         if (! is_utf8_invariant_string_loc(c, SvCUR(sv), &first_variant)) {
3661             if (!is_utf8_string(first_variant, SvCUR(sv) - (first_variant -c)))
3662                 return FALSE;
3663             SvUTF8_on(sv);
3664         }
3665         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3666             /* XXX Is this dead code?  XS_utf8_decode calls SvSETMAGIC
3667                    after this, clearing pos.  Does anything on CPAN
3668                    need this? */
3669             /* adjust pos to the start of a UTF8 char sequence */
3670             MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3671             if (mg) {
3672                 I32 pos = mg->mg_len;
3673                 if (pos > 0) {
3674                     for (c = start + pos; c > start; c--) {
3675                         if (UTF8_IS_START(*c))
3676                             break;
3677                     }
3678                     mg->mg_len  = c - start;
3679                 }
3680             }
3681             if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3682                 magic_setutf8(sv,mg); /* clear UTF8 cache */
3683         }
3684     }
3685     return TRUE;
3686 }
3687
3688 /*
3689 =for apidoc sv_setsv
3690 =for apidoc_item sv_setsv_flags
3691 =for apidoc_item sv_setsv_mg
3692 =for apidoc_item sv_setsv_nomg
3693
3694 These copy the contents of the source SV C<ssv> into the destination SV C<dsv>.
3695 C<ssv> may be destroyed if it is mortal, so don't use these functions if
3696 the source SV needs to be reused.
3697 Loosely speaking, they perform a copy-by-value, obliterating any previous
3698 content of the destination.
3699
3700 They differ only in that:
3701
3702 C<sv_setsv> calls 'get' magic on C<ssv>, but skips 'set' magic on C<dsv>.
3703
3704 C<sv_setsv_mg> calls both 'get' magic on C<ssv> and 'set' magic on C<dsv>.
3705
3706 C<sv_setsv_nomg> skips all magic.
3707
3708 C<sv_setsv_flags> has a C<flags> parameter which you can use to specify any
3709 combination of magic handling, and also you can specify C<SV_NOSTEAL> so that
3710 the buffers of temps will not be stolen.
3711
3712 You probably want to instead use one of the assortment of wrappers, such as
3713 C<L</SvSetSV>>, C<L</SvSetSV_nosteal>>, C<L</SvSetMagicSV>> and
3714 C<L</SvSetMagicSV_nosteal>>.
3715
3716 C<sv_setsv_flags> is the primary function for copying scalars, and most other
3717 copy-ish functions and macros use it underneath.
3718
3719 =for apidoc Amnh||SV_NOSTEAL
3720
3721 =cut
3722 */
3723
3724 static void
3725 S_glob_assign_glob(pTHX_ SV *const dsv, SV *const ssv, const int dtype)
3726 {
3727     I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3728     HV *old_stash = NULL;
3729
3730     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3731
3732     if (dtype != SVt_PVGV && !isGV_with_GP(dsv)) {
3733         const char * const name = GvNAME(ssv);
3734         const STRLEN len = GvNAMELEN(ssv);
3735         {
3736             if (dtype >= SVt_PV) {
3737                 SvPV_free(dsv);
3738                 SvPV_set(dsv, 0);
3739                 SvLEN_set(dsv, 0);
3740                 SvCUR_set(dsv, 0);
3741             }
3742             SvUPGRADE(dsv, SVt_PVGV);
3743             (void)SvOK_off(dsv);
3744             isGV_with_GP_on(dsv);
3745         }
3746         GvSTASH(dsv) = GvSTASH(ssv);
3747         if (GvSTASH(dsv))
3748             Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dsv)), dsv);
3749         gv_name_set(MUTABLE_GV(dsv), name, len,
3750                         GV_ADD | (GvNAMEUTF8(ssv) ? SVf_UTF8 : 0 ));
3751         SvFAKE_on(dsv); /* can coerce to non-glob */
3752     }
3753
3754     if(GvGP(MUTABLE_GV(ssv))) {
3755         /* If source has method cache entry, clear it */
3756         if(GvCVGEN(ssv)) {
3757             SvREFCNT_dec(GvCV(ssv));
3758             GvCV_set(ssv, NULL);
3759             GvCVGEN(ssv) = 0;
3760         }
3761         /* If source has a real method, then a method is
3762            going to change */
3763         else if(
3764          GvCV((const GV *)ssv) && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
3765         ) {
3766             mro_changes = 1;
3767         }
3768     }
3769
3770     /* If dest already had a real method, that's a change as well */
3771     if(
3772         !mro_changes && GvGP(MUTABLE_GV(dsv)) && GvCVu((const GV *)dsv)
3773      && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
3774     ) {
3775         mro_changes = 1;
3776     }
3777
3778     /* We don't need to check the name of the destination if it was not a
3779        glob to begin with. */
3780     if(dtype == SVt_PVGV) {
3781         const char * const name = GvNAME((const GV *)dsv);
3782         const STRLEN len = GvNAMELEN(dsv);
3783         if(memEQs(name, len, "ISA")
3784          /* The stash may have been detached from the symbol table, so
3785             check its name. */
3786          && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
3787         )
3788             mro_changes = 2;
3789         else {
3790             if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3791              || (len == 1 && name[0] == ':')) {
3792                 mro_changes = 3;
3793
3794                 /* Set aside the old stash, so we can reset isa caches on
3795                    its subclasses. */
3796                 if((old_stash = GvHV(dsv)))
3797                     /* Make sure we do not lose it early. */
3798                     SvREFCNT_inc_simple_void_NN(
3799                      sv_2mortal((SV *)old_stash)
3800                     );
3801             }
3802         }
3803
3804         SvREFCNT_inc_simple_void_NN(sv_2mortal(dsv));
3805     }
3806
3807     /* freeing dsv's GP might free ssv (e.g. *x = $x),
3808      * so temporarily protect it */
3809     ENTER;
3810     SAVEFREESV(SvREFCNT_inc_simple_NN(ssv));
3811     gp_free(MUTABLE_GV(dsv));
3812     GvINTRO_off(dsv);           /* one-shot flag */
3813     GvGP_set(dsv, gp_ref(GvGP(ssv)));
3814     LEAVE;
3815
3816     if (SvTAINTED(ssv))
3817         SvTAINT(dsv);
3818     if (GvIMPORTED(dsv) != GVf_IMPORTED
3819         && CopSTASH_ne(PL_curcop, GvSTASH(dsv)))
3820         {
3821             GvIMPORTED_on(dsv);
3822         }
3823     GvMULTI_on(dsv);
3824     if(mro_changes == 2) {
3825       if (GvAV((const GV *)ssv)) {
3826         MAGIC *mg;
3827         SV * const sref = (SV *)GvAV((const GV *)dsv);
3828         if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3829             if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3830                 AV * const ary = newAV_alloc_x(2);
3831                 av_push_simple(ary, mg->mg_obj); /* takes the refcount */
3832                 av_push_simple(ary, SvREFCNT_inc_simple_NN(dsv));
3833                 mg->mg_obj = (SV *)ary;
3834             } else {
3835                 av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dsv));
3836             }
3837         }
3838         else sv_magic(sref, dsv, PERL_MAGIC_isa, NULL, 0);
3839       }
3840       mro_isa_changed_in(GvSTASH(dsv));
3841     }
3842     else if(mro_changes == 3) {
3843         HV * const stash = GvHV(dsv);
3844         if(old_stash ? HvHasENAME(old_stash) : cBOOL(stash))
3845             mro_package_moved(
3846                 stash, old_stash,
3847                 (GV *)dsv, 0
3848             );
3849     }
3850     else if(mro_changes) mro_method_changed_in(GvSTASH(dsv));
3851     if (GvIO(dsv) && dtype == SVt_PVGV) {
3852         DEBUG_o(Perl_deb(aTHX_
3853                         "glob_assign_glob clearing PL_stashcache\n"));
3854         /* It's a cache. It will rebuild itself quite happily.
3855            It's a lot of effort to work out exactly which key (or keys)
3856            might be invalidated by the creation of the this file handle.
3857          */
3858         hv_clear(PL_stashcache);
3859     }
3860     return;
3861 }
3862
3863 void
3864 Perl_gv_setref(pTHX_ SV *const dsv, SV *const ssv)
3865 {
3866     SV * const sref = SvRV(ssv);
3867     SV *dref;
3868     const int intro = GvINTRO(dsv);
3869     SV **location;
3870     U8 import_flag = 0;
3871     const U32 stype = SvTYPE(sref);
3872
3873     PERL_ARGS_ASSERT_GV_SETREF;
3874
3875     if (intro) {
3876         GvINTRO_off(dsv);       /* one-shot flag */
3877         GvLINE(dsv) = CopLINE(PL_curcop);
3878         GvEGV(dsv) = MUTABLE_GV(dsv);
3879     }
3880     GvMULTI_on(dsv);
3881     switch (stype) {
3882     case SVt_PVCV:
3883         location = (SV **) &(GvGP(dsv)->gp_cv); /* XXX bypassing GvCV_set */
3884         import_flag = GVf_IMPORTED_CV;
3885         goto common;
3886     case SVt_PVHV:
3887         location = (SV **) &GvHV(dsv);
3888         import_flag = GVf_IMPORTED_HV;
3889         goto common;
3890     case SVt_PVAV:
3891         location = (SV **) &GvAV(dsv);
3892         import_flag = GVf_IMPORTED_AV;
3893         goto common;
3894     case SVt_PVIO:
3895         location = (SV **) &GvIOp(dsv);
3896         goto common;
3897     case SVt_PVFM:
3898         location = (SV **) &GvFORM(dsv);
3899         goto common;
3900     default:
3901         location = &GvSV(dsv);
3902         import_flag = GVf_IMPORTED_SV;
3903     common:
3904         if (intro) {
3905             if (stype == SVt_PVCV) {
3906                 /*if (GvCVGEN(dsv) && (GvCV(dsv) != (const CV *)sref || GvCVGEN(dsv))) {*/
3907                 if (GvCVGEN(dsv)) {
3908                     SvREFCNT_dec(GvCV(dsv));
3909                     GvCV_set(dsv, NULL);
3910                     GvCVGEN(dsv) = 0; /* Switch off cacheness. */
3911                 }
3912             }
3913             /* SAVEt_GVSLOT takes more room on the savestack and has more
3914                overhead in leave_scope than SAVEt_GENERIC_SV.  But for CVs
3915                leave_scope needs access to the GV so it can reset method
3916                caches.  We must use SAVEt_GVSLOT whenever the type is
3917                SVt_PVCV, even if the stash is anonymous, as the stash may
3918                gain a name somehow before leave_scope. */
3919             if (stype == SVt_PVCV) {
3920                 /* There is no save_pushptrptrptr.  Creating it for this
3921                    one call site would be overkill.  So inline the ss add
3922                    routines here. */
3923                 dSS_ADD;
3924                 SS_ADD_PTR(dsv);
3925                 SS_ADD_PTR(location);
3926                 SS_ADD_PTR(SvREFCNT_inc(*location));
3927                 SS_ADD_UV(SAVEt_GVSLOT);
3928                 SS_ADD_END(4);
3929             }
3930             else SAVEGENERICSV(*location);
3931         }
3932         dref = *location;
3933         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dsv))) {
3934             CV* const cv = MUTABLE_CV(*location);
3935             if (cv) {
3936                 if (!GvCVGEN((const GV *)dsv) &&
3937                     (CvROOT(cv) || CvXSUB(cv)) &&
3938                     /* redundant check that avoids creating the extra SV
3939                        most of the time: */
3940                     (CvCONST(cv) || (ckWARN(WARN_REDEFINE) && !intro)))
3941                     {
3942                         SV * const new_const_sv =
3943                             CvCONST((const CV *)sref)
3944                                  ? cv_const_sv_or_av((const CV *)sref)
3945                                  : NULL;
3946                         HV * const stash = GvSTASH((const GV *)dsv);
3947                         report_redefined_cv(
3948                            sv_2mortal(
3949                              stash
3950                                ? Perl_newSVpvf(aTHX_
3951                                     "%" HEKf "::%" HEKf,
3952                                     HEKfARG(HvNAME_HEK(stash)),
3953                                     HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv))))
3954                                : Perl_newSVpvf(aTHX_
3955                                     "%" HEKf,
3956                                     HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv))))
3957                            ),
3958                            cv,
3959                            CvCONST((const CV *)sref) ? &new_const_sv : NULL
3960                         );
3961                     }
3962                 if (!intro)
3963                     cv_ckproto_len_flags(cv, (const GV *)dsv,
3964                                    SvPOK(sref) ? CvPROTO(sref) : NULL,
3965                                    SvPOK(sref) ? CvPROTOLEN(sref) : 0,
3966                                    SvPOK(sref) ? SvUTF8(sref) : 0);
3967             }
3968             GvCVGEN(dsv) = 0; /* Switch off cacheness. */
3969             GvASSUMECV_on(dsv);
3970             if(GvSTASH(dsv)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3971                 if (intro && GvREFCNT(dsv) > 1) {
3972                     /* temporary remove extra savestack's ref */
3973                     --GvREFCNT(dsv);
3974                     gv_method_changed(dsv);
3975                     ++GvREFCNT(dsv);
3976                 }
3977                 else gv_method_changed(dsv);
3978             }
3979         }
3980         *location = SvREFCNT_inc_simple_NN(sref);
3981         if (import_flag && !(GvFLAGS(dsv) & import_flag)
3982             && CopSTASH_ne(PL_curcop, GvSTASH(dsv))) {
3983             GvFLAGS(dsv) |= import_flag;
3984         }
3985
3986         if (stype == SVt_PVHV) {
3987             const char * const name = GvNAME((GV*)dsv);
3988             const STRLEN len = GvNAMELEN(dsv);
3989             if (
3990                 (
3991                    (len > 1 && name[len-2] == ':' && name[len-1] == ':')
3992                 || (len == 1 && name[0] == ':')
3993                 )
3994              && (!dref || HvHasENAME(dref))
3995             ) {
3996                 mro_package_moved(
3997                     (HV *)sref, (HV *)dref,
3998                     (GV *)dsv, 0
3999                 );
4000             }
4001         }
4002         else if (
4003             stype == SVt_PVAV && sref != dref
4004          && memEQs(GvNAME((GV*)dsv), GvNAMELEN((GV*)dsv), "ISA")
4005          /* The stash may have been detached from the symbol table, so
4006             check its name before doing anything. */
4007          && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
4008         ) {
4009             MAGIC *mg;
4010             MAGIC * const omg = dref && SvSMAGICAL(dref)
4011                                  ? mg_find(dref, PERL_MAGIC_isa)
4012                                  : NULL;
4013             if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
4014                 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
4015                     AV * const ary = newAV_alloc_xz(4);
4016                     av_push_simple(ary, mg->mg_obj); /* takes the refcount */
4017                     mg->mg_obj = (SV *)ary;
4018                 }
4019                 if (omg) {
4020                     if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
4021                         SV **svp = AvARRAY((AV *)omg->mg_obj);
4022                         I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
4023                         while (items--)
4024                             av_push(
4025                              (AV *)mg->mg_obj,
4026                              SvREFCNT_inc_simple_NN(*svp++)
4027                             );
4028                     }
4029                     else
4030                         av_push(
4031                          (AV *)mg->mg_obj,
4032                          SvREFCNT_inc_simple_NN(omg->mg_obj)
4033                         );
4034                 }
4035                 else
4036                     av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dsv));
4037             }
4038             else
4039             {
4040                 SSize_t i;
4041                 sv_magic(
4042                  sref, omg ? omg->mg_obj : dsv, PERL_MAGIC_isa, NULL, 0
4043                 );
4044                 for (i = 0; i <= AvFILL(sref); ++i) {
4045                     SV **elem = av_fetch ((AV*)sref, i, 0);
4046                     if (elem) {
4047                         sv_magic(
4048                           *elem, sref, PERL_MAGIC_isaelem, NULL, i
4049                         );
4050                     }
4051                 }
4052                 mg = mg_find(sref, PERL_MAGIC_isa);
4053             }
4054             /* Since the *ISA assignment could have affected more than
4055                one stash, don't call mro_isa_changed_in directly, but let
4056                magic_clearisa do it for us, as it already has the logic for
4057                dealing with globs vs arrays of globs. */
4058             assert(mg);
4059             Perl_magic_clearisa(aTHX_ NULL, mg);
4060         }
4061         else if (stype == SVt_PVIO) {
4062             DEBUG_o(Perl_deb(aTHX_ "gv_setref clearing PL_stashcache\n"));
4063             /* It's a cache. It will rebuild itself quite happily.
4064                It's a lot of effort to work out exactly which key (or keys)
4065                might be invalidated by the creation of the this file handle.
4066             */
4067             hv_clear(PL_stashcache);
4068         }
4069         break;
4070     }
4071     if (!intro) SvREFCNT_dec(dref);
4072     if (SvTAINTED(ssv))
4073         SvTAINT(dsv);
4074     return;
4075 }
4076
4077
4078
4079
4080 #ifdef PERL_DEBUG_READONLY_COW
4081 # include <sys/mman.h>
4082
4083 # ifndef PERL_MEMORY_DEBUG_HEADER_SIZE
4084 #  define PERL_MEMORY_DEBUG_HEADER_SIZE 0
4085 # endif
4086
4087 void
4088 Perl_sv_buf_to_ro(pTHX_ SV *sv)
4089 {
4090     struct perl_memory_debug_header * const header =
4091         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4092     const MEM_SIZE len = header->size;
4093     PERL_ARGS_ASSERT_SV_BUF_TO_RO;
4094 # ifdef PERL_TRACK_MEMPOOL
4095     if (!header->readonly) header->readonly = 1;
4096 # endif
4097     if (mprotect(header, len, PROT_READ))
4098         Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
4099                          header, len, errno);
4100 }
4101
4102 static void
4103 S_sv_buf_to_rw(pTHX_ SV *sv)
4104 {
4105     struct perl_memory_debug_header * const header =
4106         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4107     const MEM_SIZE len = header->size;
4108     PERL_ARGS_ASSERT_SV_BUF_TO_RW;
4109     if (mprotect(header, len, PROT_READ|PROT_WRITE))
4110         Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
4111                          header, len, errno);
4112 # ifdef PERL_TRACK_MEMPOOL
4113     header->readonly = 0;
4114 # endif
4115 }
4116
4117 #else
4118 # define sv_buf_to_ro(sv)       NOOP
4119 # define sv_buf_to_rw(sv)       NOOP
4120 #endif
4121
4122 void
4123 Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags)
4124 {
4125     U32 sflags;
4126     int dtype;
4127     svtype stype;
4128     unsigned int both_type;
4129
4130     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
4131
4132     if (UNLIKELY( ssv == dsv ))
4133         return;
4134
4135     if (UNLIKELY( !ssv ))
4136         ssv = &PL_sv_undef;
4137
4138     stype = SvTYPE(ssv);
4139     dtype = SvTYPE(dsv);
4140     both_type = (stype | dtype);
4141
4142     /* with these values, we can check that both SVs are NULL/IV (and not
4143      * freed) just by testing the or'ed types */
4144     STATIC_ASSERT_STMT(SVt_NULL == 0);
4145     STATIC_ASSERT_STMT(SVt_IV   == 1);
4146     STATIC_ASSERT_STMT(SVt_NV   == 2);
4147 #if NVSIZE <= IVSIZE
4148     if (both_type <= 2) {
4149 #else
4150     if (both_type <= 1) {
4151 #endif
4152         /* both src and dst are UNDEF/IV/RV - maybe NV depending on config,
4153          * so we can do a lot of special-casing */
4154         U32 sflags;
4155         U32 new_dflags;
4156         SV *old_rv = NULL;
4157
4158         /* minimal subset of SV_CHECK_THINKFIRST_COW_DROP(dsv) */
4159         if (SvREADONLY(dsv))
4160             Perl_croak_no_modify();
4161         if (SvROK(dsv)) {
4162             if (SvWEAKREF(dsv))
4163                 sv_unref_flags(dsv, 0);
4164             else
4165                 old_rv = SvRV(dsv);
4166             SvROK_off(dsv);
4167         }
4168
4169         assert(!SvGMAGICAL(ssv));
4170         assert(!SvGMAGICAL(dsv));
4171
4172         sflags = SvFLAGS(ssv);
4173         if (sflags & (SVf_IOK|SVf_ROK)) {
4174             SET_SVANY_FOR_BODYLESS_IV(dsv);
4175             new_dflags = SVt_IV;
4176
4177             if (sflags & SVf_ROK) {
4178                 dsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(ssv));
4179                 new_dflags |= SVf_ROK;
4180             }
4181             else {
4182                 /* both src and dst are <= SVt_IV, so sv_any points to the
4183                  * head; so access the head directly
4184                  */
4185                 assert(    &(ssv->sv_u.svu_iv)
4186                         == &(((XPVIV*) SvANY(ssv))->xiv_iv));
4187                 assert(    &(dsv->sv_u.svu_iv)
4188                         == &(((XPVIV*) SvANY(dsv))->xiv_iv));
4189                 dsv->sv_u.svu_iv = ssv->sv_u.svu_iv;
4190                 new_dflags |= (SVf_IOK|SVp_IOK|(sflags & SVf_IVisUV));
4191             }
4192         }
4193 #if NVSIZE <= IVSIZE
4194         else if (sflags & SVf_NOK) {
4195             SET_SVANY_FOR_BODYLESS_NV(dsv);
4196             new_dflags = (SVt_NV|SVf_NOK|SVp_NOK);
4197
4198             /* both src and dst are <= SVt_MV, so sv_any points to the
4199              * head; so access the head directly
4200              */
4201             assert(    &(ssv->sv_u.svu_nv)
4202                     == &(((XPVNV*) SvANY(ssv))->xnv_u.xnv_nv));
4203             assert(    &(dsv->sv_u.svu_nv)
4204                     == &(((XPVNV*) SvANY(dsv))->xnv_u.xnv_nv));
4205             dsv->sv_u.svu_nv = ssv->sv_u.svu_nv;
4206         }
4207 #endif
4208         else {
4209             new_dflags = dtype; /* turn off everything except the type */
4210         }
4211         /* Should preserve some dsv flags - at least SVs_TEMP, */
4212         /* so cannot just set SvFLAGS(dsv) = new_dflags        */
4213         /* First clear the flags that we do want to clobber    */
4214         (void)SvOK_off(dsv);
4215         SvFLAGS(dsv) &= ~SVTYPEMASK;
4216         /* Now set the new flags */
4217         SvFLAGS(dsv) |= new_dflags;
4218
4219         SvREFCNT_dec(old_rv);
4220         return;
4221     }
4222
4223     if (UNLIKELY(both_type == SVTYPEMASK)) {
4224         if (SvIS_FREED(dsv)) {
4225             Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
4226                        " to a freed scalar %p", SVfARG(ssv), (void *)dsv);
4227         }
4228         if (SvIS_FREED(ssv)) {
4229             Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
4230                        (void*)ssv, (void*)dsv);
4231         }
4232     }
4233
4234
4235
4236     SV_CHECK_THINKFIRST_COW_DROP(dsv);
4237     dtype = SvTYPE(dsv); /* THINKFIRST may have changed type */
4238
4239     /* There's a lot of redundancy below but we're going for speed here
4240      * Note: some of the cases below do return; rather than break; so the
4241      * if-elseif-else logic below this switch does not see all cases. */
4242
4243     switch (stype) {
4244     case SVt_NULL:
4245       undef_sstr:
4246         if (LIKELY( dtype != SVt_PVGV && dtype != SVt_PVLV )) {
4247             (void)SvOK_off(dsv);
4248             return;
4249         }
4250         break;
4251     case SVt_IV:
4252         if (SvIOK(ssv)) {
4253             switch (dtype) {
4254             case SVt_NULL:
4255                 /* For performance, we inline promoting to type SVt_IV. */
4256                 /* We're starting from SVt_NULL, so provided that define is
4257                  * actual 0, we don't have to unset any SV type flags
4258                  * to promote to SVt_IV. */
4259                 STATIC_ASSERT_STMT(SVt_NULL == 0);
4260                 SET_SVANY_FOR_BODYLESS_IV(dsv);
4261                 SvFLAGS(dsv) |= SVt_IV;
4262                 break;
4263             case SVt_NV:
4264             case SVt_PV:
4265                 sv_upgrade(dsv, SVt_PVIV);
4266                 break;
4267             case SVt_PVGV:
4268             case SVt_PVLV:
4269                 goto end_of_first_switch;
4270             }
4271             (void)SvIOK_only(dsv);
4272             SvIV_set(dsv,  SvIVX(ssv));
4273             if (SvIsUV(ssv))
4274                 SvIsUV_on(dsv);
4275             /* SvTAINTED can only be true if the SV has taint magic, which in
4276                turn means that the SV type is PVMG (or greater). This is the
4277                case statement for SVt_IV, so this cannot be true (whatever gcov
4278                may say).  */
4279             assert(!SvTAINTED(ssv));
4280             return;
4281         }
4282         if (!SvROK(ssv))
4283             goto undef_sstr;
4284         if (dtype < SVt_PV && dtype != SVt_IV)
4285             sv_upgrade(dsv, SVt_IV);
4286         break;
4287
4288     case SVt_NV:
4289         if (LIKELY( SvNOK(ssv) )) {
4290             switch (dtype) {
4291             case SVt_NULL:
4292             case SVt_IV:
4293                 sv_upgrade(dsv, SVt_NV);
4294                 break;
4295             case SVt_PV:
4296             case SVt_PVIV:
4297                 sv_upgrade(dsv, SVt_PVNV);
4298                 break;
4299             case SVt_PVGV:
4300             case SVt_PVLV:
4301                 goto end_of_first_switch;
4302             }
4303             SvNV_set(dsv, SvNVX(ssv));
4304             (void)SvNOK_only(dsv);
4305             /* SvTAINTED can only be true if the SV has taint magic, which in
4306                turn means that the SV type is PVMG (or greater). This is the
4307                case statement for SVt_NV, so this cannot be true (whatever gcov
4308                may say).  */
4309             assert(!SvTAINTED(ssv));
4310             return;
4311         }
4312         goto undef_sstr;
4313
4314     case SVt_PV:
4315         if (dtype < SVt_PV)
4316             sv_upgrade(dsv, SVt_PV);
4317         break;
4318     case SVt_PVIV:
4319         if (dtype < SVt_PVIV)
4320             sv_upgrade(dsv, SVt_PVIV);
4321         break;
4322     case SVt_PVNV:
4323         if (dtype < SVt_PVNV)
4324             sv_upgrade(dsv, SVt_PVNV);
4325         break;
4326
4327     case SVt_INVLIST:
4328         invlist_clone(ssv, dsv);
4329         return;
4330     default:
4331         {
4332         const char * const type = sv_reftype(ssv,0);
4333         if (PL_op)
4334             /* diag_listed_as: Bizarre copy of %s */
4335             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4336         else
4337             Perl_croak(aTHX_ "Bizarre copy of %s", type);
4338         }
4339         NOT_REACHED; /* NOTREACHED */
4340
4341     case SVt_REGEXP:
4342       upgregexp:
4343         if (dtype < SVt_REGEXP)
4344             sv_upgrade(dsv, SVt_REGEXP);
4345         break;
4346
4347     case SVt_PVLV:
4348     case SVt_PVGV:
4349     case SVt_PVMG:
4350         if (SvGMAGICAL(ssv) && (flags & SV_GMAGIC)) {
4351             mg_get(ssv);
4352             if (SvTYPE(ssv) != stype)
4353                 stype = SvTYPE(ssv);
4354         }
4355         if (isGV_with_GP(ssv) && dtype <= SVt_PVLV) {
4356                     glob_assign_glob(dsv, ssv, dtype);
4357                     return;
4358         }
4359         if (stype == SVt_PVLV)
4360         {
4361             if (isREGEXP(ssv)) goto upgregexp;
4362             SvUPGRADE(dsv, SVt_PVNV);
4363         }
4364         else
4365             SvUPGRADE(dsv, (svtype)stype);
4366     }
4367  end_of_first_switch:
4368
4369     /* dsv may have been upgraded.  */
4370     dtype = SvTYPE(dsv);
4371     sflags = SvFLAGS(ssv);
4372
4373     if (UNLIKELY( dtype == SVt_PVCV )) {
4374         /* Assigning to a subroutine sets the prototype.  */
4375         if (SvOK(ssv)) {
4376             STRLEN len;
4377             const char *const ptr = SvPV_const(ssv, len);
4378
4379             SvGROW(dsv, len + 1);
4380             Copy(ptr, SvPVX(dsv), len + 1, char);
4381             SvCUR_set(dsv, len);
4382             SvPOK_only(dsv);
4383             SvFLAGS(dsv) |= sflags & SVf_UTF8;
4384             CvAUTOLOAD_off(dsv);
4385         } else {
4386             SvOK_off(dsv);
4387         }
4388     }
4389     else if (UNLIKELY(dtype == SVt_PVAV || dtype == SVt_PVHV
4390              || dtype == SVt_PVFM))
4391     {
4392         const char * const type = sv_reftype(dsv,0);
4393         if (PL_op)
4394             /* diag_listed_as: Cannot copy to %s */
4395             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4396         else
4397             Perl_croak(aTHX_ "Cannot copy to %s", type);
4398     } else if (sflags & SVf_ROK) {
4399         if (isGV_with_GP(dsv)
4400             && SvTYPE(SvRV(ssv)) == SVt_PVGV && isGV_with_GP(SvRV(ssv))) {
4401             ssv = SvRV(ssv);
4402             if (ssv == dsv) {
4403                 if (GvIMPORTED(dsv) != GVf_IMPORTED
4404                     && CopSTASH_ne(PL_curcop, GvSTASH(dsv)))
4405                 {
4406                     GvIMPORTED_on(dsv);
4407                 }
4408                 GvMULTI_on(dsv);
4409                 return;
4410             }
4411             glob_assign_glob(dsv, ssv, dtype);
4412             return;
4413         }
4414
4415         if (dtype >= SVt_PV) {
4416             if (isGV_with_GP(dsv)) {
4417                 gv_setref(dsv, ssv);
4418                 return;
4419             }
4420             if (SvPVX_const(dsv)) {
4421                 SvPV_free(dsv);
4422                 SvLEN_set(dsv, 0);
4423                 SvCUR_set(dsv, 0);
4424             }
4425         }
4426         (void)SvOK_off(dsv);
4427         SvRV_set(dsv, SvREFCNT_inc(SvRV(ssv)));
4428         SvFLAGS(dsv) |= sflags & SVf_ROK;
4429         assert(!(sflags & SVp_NOK));
4430         assert(!(sflags & SVp_IOK));
4431         assert(!(sflags & SVf_NOK));
4432         assert(!(sflags & SVf_IOK));
4433     }
4434     else if (isGV_with_GP(dsv)) {
4435         if (!(sflags & SVf_OK)) {
4436             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4437                            "Undefined value assigned to typeglob");
4438         }
4439         else {
4440             GV *gv = gv_fetchsv_nomg(ssv, GV_ADD, SVt_PVGV);
4441             if (dsv != (const SV *)gv) {
4442                 const char * const name = GvNAME((const GV *)dsv);
4443                 const STRLEN len = GvNAMELEN(dsv);
4444                 HV *old_stash = NULL;
4445                 bool reset_isa = FALSE;
4446                 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4447                  || (len == 1 && name[0] == ':')) {
4448                     /* Set aside the old stash, so we can reset isa caches
4449                        on its subclasses. */
4450                     if((old_stash = GvHV(dsv))) {
4451                         /* Make sure we do not lose it early. */
4452                         SvREFCNT_inc_simple_void_NN(
4453                          sv_2mortal((SV *)old_stash)
4454                         );
4455                     }
4456                     reset_isa = TRUE;
4457                 }
4458
4459                 if (GvGP(dsv)) {
4460                     SvREFCNT_inc_simple_void_NN(sv_2mortal(dsv));
4461                     gp_free(MUTABLE_GV(dsv));
4462                 }
4463                 GvGP_set(dsv, gp_ref(GvGP(gv)));
4464
4465                 if (reset_isa) {
4466                     HV * const stash = GvHV(dsv);
4467                     if(
4468                         old_stash ? HvHasENAME(old_stash) : cBOOL(stash)
4469                     )
4470                         mro_package_moved(
4471                          stash, old_stash,
4472                          (GV *)dsv, 0
4473                         );
4474                 }
4475             }
4476         }
4477     }
4478     else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4479           && (stype == SVt_REGEXP || isREGEXP(ssv))) {
4480         reg_temp_copy((REGEXP*)dsv, (REGEXP*)ssv);
4481     }
4482     else if (sflags & SVp_POK) {
4483         const STRLEN cur = SvCUR(ssv);
4484         const STRLEN len = SvLEN(ssv);
4485
4486         /*
4487          * We have three basic ways to copy the string:
4488          *
4489          *  1. Swipe
4490          *  2. Copy-on-write
4491          *  3. Actual copy
4492          *
4493          * Which we choose is based on various factors.  The following
4494          * things are listed in order of speed, fastest to slowest:
4495          *  - Swipe
4496          *  - Copying a short string
4497          *  - Copy-on-write bookkeeping
4498          *  - malloc
4499          *  - Copying a long string
4500          *
4501          * We swipe the string (steal the string buffer) if the SV on the
4502          * rhs is about to be freed anyway (TEMP and refcnt==1).  This is a
4503          * big win on long strings.  It should be a win on short strings if
4504          * SvPVX_const(dsv) has to be allocated.  If not, it should not
4505          * slow things down, as SvPVX_const(ssv) would have been freed
4506          * soon anyway.
4507          *
4508          * We also steal the buffer from a PADTMP (operator target) if it
4509          * is â€˜long enough’.  For short strings, a swipe does not help
4510          * here, as it causes more malloc calls the next time the target
4511          * is used.  Benchmarks show that even if SvPVX_const(dsv) has to
4512          * be allocated it is still not worth swiping PADTMPs for short
4513          * strings, as the savings here are small.
4514          *
4515          * If swiping is not an option, then we see whether it is worth using
4516          * copy-on-write.  If the lhs already has a buffer big enough and the
4517          * string is short, we skip it and fall back to method 3, since memcpy
4518          * is faster for short strings than the later bookkeeping overhead that
4519          * copy-on-write entails.
4520
4521          * If the rhs is not a copy-on-write string yet, then we also
4522          * consider whether the buffer is too large relative to the string
4523          * it holds.  Some operations such as readline allocate a large
4524          * buffer in the expectation of reusing it.  But turning such into
4525          * a COW buffer is counter-productive because it increases memory
4526          * usage by making readline allocate a new large buffer the sec-
4527          * ond time round.  So, if the buffer is too large, again, we use
4528          * method 3 (copy).
4529          *
4530          * Finally, if there is no buffer on the left, or the buffer is too
4531          * small, then we use copy-on-write and make both SVs share the
4532          * string buffer.
4533          *
4534          */
4535
4536         /* Whichever path we take through the next code, we want this true,
4537            and doing it now facilitates the COW check.  */
4538         (void)SvPOK_only(dsv);
4539
4540         if (
4541                  (              /* Either ... */
4542                                 /* slated for free anyway (and not COW)? */
4543                     (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
4544                                 /* or a swipable TARG */
4545                  || ((sflags &
4546                            (SVs_PADTMP|SVf_READONLY|SVf_PROTECT|SVf_IsCOW))
4547                        == SVs_PADTMP
4548                                 /* whose buffer is worth stealing */
4549                      && CHECK_COWBUF_THRESHOLD(cur,len)
4550                     )
4551                  ) &&
4552                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4553                  (!(flags & SV_NOSTEAL)) &&
4554                                         /* and we're allowed to steal temps */
4555                  SvREFCNT(ssv) == 1 &&   /* and no other references to it? */
4556                  len)             /* and really is a string */
4557         {       /* Passes the swipe test.  */
4558             if (SvPVX_const(dsv))       /* we know that dtype >= SVt_PV */
4559                 SvPV_free(dsv);
4560             SvPV_set(dsv, SvPVX_mutable(ssv));
4561             SvLEN_set(dsv, SvLEN(ssv));
4562             SvCUR_set(dsv, SvCUR(ssv));
4563
4564             SvTEMP_off(dsv);
4565             (void)SvOK_off(ssv);        /* NOTE: nukes most SvFLAGS on ssv */
4566             SvPV_set(ssv, NULL);
4567             SvLEN_set(ssv, 0);
4568             SvCUR_set(ssv, 0);
4569             SvTEMP_off(ssv);
4570         }
4571         /* We must check for SvIsCOW_static() even without
4572          * SV_COW_SHARED_HASH_KEYS being set or else we'll break SvIsBOOL()
4573          */
4574         else if (SvIsCOW_static(ssv)) {
4575             if (SvPVX_const(dsv)) {     /* we know that dtype >= SVt_PV */
4576                 SvPV_free(dsv);
4577             }
4578             SvPV_set(dsv, SvPVX(ssv));
4579             SvLEN_set(dsv, 0);
4580             SvCUR_set(dsv, cur);
4581             SvFLAGS(dsv) |= (SVf_IsCOW|SVppv_STATIC);
4582         }
4583         else if (flags & SV_COW_SHARED_HASH_KEYS
4584               &&
4585 #ifdef PERL_COPY_ON_WRITE
4586                  (sflags & SVf_IsCOW
4587                    ? (!len ||
4588                        (  (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dsv) < cur+1)
4589                           /* If this is a regular (non-hek) COW, only so
4590                              many COW "copies" are possible. */
4591                        && CowREFCNT(ssv) != SV_COW_REFCNT_MAX  ))
4592                    : (  (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4593                      && !(SvFLAGS(dsv) & SVf_BREAK)
4594                      && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len
4595                      && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dsv) < cur+1)
4596                     ))
4597 #else
4598                  sflags & SVf_IsCOW
4599               && !(SvFLAGS(dsv) & SVf_BREAK)
4600 #endif
4601             ) {
4602             /* Either it's a shared hash key, or it's suitable for
4603                copy-on-write.  */
4604 #ifdef DEBUGGING
4605             if (DEBUG_C_TEST) {
4606                 PerlIO_printf(Perl_debug_log, "Copy on write: ssv --> dsv\n");
4607                 sv_dump(ssv);
4608                 sv_dump(dsv);
4609             }
4610 #endif
4611 #ifdef PERL_ANY_COW
4612             if (!(sflags & SVf_IsCOW)) {
4613                     SvIsCOW_on(ssv);
4614                     CowREFCNT(ssv) = 0;
4615             }
4616 #endif
4617             if (SvPVX_const(dsv)) {     /* we know that dtype >= SVt_PV */
4618                 SvPV_free(dsv);
4619             }
4620
4621 #ifdef PERL_ANY_COW
4622             if (len) {
4623                     if (sflags & SVf_IsCOW) {
4624                         sv_buf_to_rw(ssv);
4625                     }
4626                     CowREFCNT(ssv)++;
4627                     SvPV_set(dsv, SvPVX_mutable(ssv));
4628                     sv_buf_to_ro(ssv);
4629             } else
4630 #endif
4631             {
4632                     /* SvIsCOW_shared_hash */
4633                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4634                                           "Copy on write: Sharing hash\n"));
4635
4636                     assert (SvTYPE(dsv) >= SVt_PV);
4637                     SvPV_set(dsv,
4638                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv)))));
4639             }
4640             SvLEN_set(dsv, len);
4641             SvCUR_set(dsv, cur);
4642             SvIsCOW_on(dsv);
4643         } else {
4644             /* Failed the swipe test, and we cannot do copy-on-write either.
4645                Have to copy the string.  */
4646             SvGROW(dsv, cur + 1);       /* inlined from sv_setpvn */
4647             Move(SvPVX_const(ssv),SvPVX(dsv),cur,char);
4648             SvCUR_set(dsv, cur);
4649             *SvEND(dsv) = '\0';
4650         }
4651         if (sflags & SVp_NOK) {
4652             SvNV_set(dsv, SvNVX(ssv));
4653             if ((sflags & SVf_NOK) && !(sflags & SVf_POK)) {
4654                 /* Source was SVf_NOK|SVp_NOK|SVp_POK but not SVf_POK, meaning
4655                    a value set as floating point and later stringified, where
4656                   the value happens to be one of the few that we know aren't
4657                   affected by the numeric locale, hence we can cache the
4658                   stringification. Currently that's  +Inf, -Inf and NaN, but
4659                   conceivably we might extend this to -9 .. +9 (excluding -0).
4660                   So mark destination the same: */
4661                 SvFLAGS(dsv) &= ~SVf_POK;
4662             }
4663         }
4664         if (sflags & SVp_IOK) {
4665             SvIV_set(dsv, SvIVX(ssv));
4666             if (sflags & SVf_IVisUV)
4667                 SvIsUV_on(dsv);
4668             if ((sflags & SVf_IOK) && !(sflags & SVf_POK)) {
4669                 /* Source was SVf_IOK|SVp_IOK|SVp_POK but not SVf_POK, meaning
4670                    a value set as an integer and later stringified. So mark
4671                    destination the same: */
4672                 SvFLAGS(dsv) &= ~SVf_POK;
4673             }
4674         }
4675         SvFLAGS(dsv) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4676         {
4677             const MAGIC * const smg = SvVSTRING_mg(ssv);
4678             if (smg) {
4679                 sv_magic(dsv, NULL, PERL_MAGIC_vstring,
4680                          smg->mg_ptr, smg->mg_len);
4681                 SvRMAGICAL_on(dsv);
4682             }
4683         }
4684     }
4685     else if (sflags & (SVp_IOK|SVp_NOK)) {
4686         (void)SvOK_off(dsv);
4687         SvFLAGS(dsv) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4688         if (sflags & SVp_IOK) {
4689             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4690             SvIV_set(dsv, SvIVX(ssv));
4691         }
4692         if (sflags & SVp_NOK) {
4693             SvNV_set(dsv, SvNVX(ssv));
4694         }
4695     }
4696     else {
4697         if (isGV_with_GP(ssv)) {
4698             gv_efullname3(dsv, MUTABLE_GV(ssv), "*");
4699         }
4700         else
4701             (void)SvOK_off(dsv);
4702     }
4703     if (SvTAINTED(ssv))
4704         SvTAINT(dsv);
4705 }
4706
4707
4708 /*
4709 =for apidoc sv_set_undef
4710
4711 Equivalent to C<sv_setsv(sv, &PL_sv_undef)>, but more efficient.
4712 Doesn't handle set magic.
4713
4714 The perl equivalent is C<$sv = undef;>. Note that it doesn't free any string
4715 buffer, unlike C<undef $sv>.
4716
4717 Introduced in perl 5.25.12.
4718
4719 =cut
4720 */
4721
4722 void
4723 Perl_sv_set_undef(pTHX_ SV *sv)
4724 {
4725     U32 type = SvTYPE(sv);
4726
4727     PERL_ARGS_ASSERT_SV_SET_UNDEF;
4728
4729     /* shortcut, NULL, IV, RV */
4730
4731     if (type <= SVt_IV) {
4732         assert(!SvGMAGICAL(sv));
4733         if (SvREADONLY(sv)) {
4734             /* does undeffing PL_sv_undef count as modifying a read-only
4735              * variable? Some XS code does this */
4736             if (sv == &PL_sv_undef)
4737                 return;
4738             Perl_croak_no_modify();
4739         }
4740
4741         if (SvROK(sv)) {
4742             if (SvWEAKREF(sv))
4743                 sv_unref_flags(sv, 0);
4744             else {
4745                 SV *rv = SvRV(sv);
4746                 SvFLAGS(sv) = type; /* quickly turn off all flags */
4747                 SvREFCNT_dec_NN(rv);
4748                 return;
4749             }
4750         }
4751         SvFLAGS(sv) = type; /* quickly turn off all flags */
4752         return;
4753     }
4754
4755     if (SvIS_FREED(sv))
4756         Perl_croak(aTHX_ "panic: attempt to undefine a freed scalar %p",
4757             (void *)sv);
4758
4759     SV_CHECK_THINKFIRST_COW_DROP(sv);
4760
4761     if (isGV_with_GP(sv))
4762         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4763                        "Undefined value assigned to typeglob");
4764     else
4765         SvOK_off(sv);
4766 }
4767
4768 /*
4769 =for apidoc sv_set_true
4770
4771 Equivalent to C<sv_setsv(sv, &PL_sv_yes)>, but may be made more
4772 efficient in the future. Doesn't handle set magic.
4773
4774 The perl equivalent is C<$sv = !0;>.
4775
4776 Introduced in perl 5.35.11.
4777
4778 =cut
4779 */
4780
4781 void
4782 Perl_sv_set_true(pTHX_ SV *sv)
4783 {
4784     PERL_ARGS_ASSERT_SV_SET_TRUE;
4785     sv_setsv(sv, &PL_sv_yes);
4786 }
4787
4788 /*
4789 =for apidoc sv_set_false
4790
4791 Equivalent to C<sv_setsv(sv, &PL_sv_no)>, but may be made more
4792 efficient in the future. Doesn't handle set magic.
4793
4794 The perl equivalent is C<$sv = !1;>.
4795
4796 Introduced in perl 5.35.11.
4797
4798 =cut
4799 */
4800
4801 void
4802 Perl_sv_set_false(pTHX_ SV *sv)
4803 {
4804     PERL_ARGS_ASSERT_SV_SET_FALSE;
4805     sv_setsv(sv, &PL_sv_no);
4806 }
4807
4808 /*
4809 =for apidoc sv_set_bool
4810
4811 Equivalent to C<sv_setsv(sv, bool_val ? &Pl_sv_yes : &PL_sv_no)>, but
4812 may be made more efficient in the future. Doesn't handle set magic.
4813
4814 The perl equivalent is C<$sv = !!$expr;>.
4815
4816 Introduced in perl 5.35.11.
4817
4818 =cut
4819 */
4820
4821 void
4822 Perl_sv_set_bool(pTHX_ SV *sv, const bool bool_val)
4823 {
4824     PERL_ARGS_ASSERT_SV_SET_BOOL;
4825     sv_setsv(sv, bool_val ? &PL_sv_yes : &PL_sv_no);
4826 }
4827
4828
4829 void
4830 Perl_sv_setsv_mg(pTHX_ SV *const dsv, SV *const ssv)
4831 {
4832     PERL_ARGS_ASSERT_SV_SETSV_MG;
4833
4834     sv_setsv(dsv,ssv);
4835     SvSETMAGIC(dsv);
4836 }
4837
4838 #ifdef PERL_ANY_COW
4839 #  define SVt_COW SVt_PV
4840 SV *
4841 Perl_sv_setsv_cow(pTHX_ SV *dsv, SV *ssv)
4842 {
4843     STRLEN cur = SvCUR(ssv);
4844     STRLEN len = SvLEN(ssv);
4845     char *new_pv;
4846     U32 new_flags = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
4847 #if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_COPY_ON_WRITE)
4848     const bool already = cBOOL(SvIsCOW(ssv));
4849 #endif
4850
4851     PERL_ARGS_ASSERT_SV_SETSV_COW;
4852 #ifdef DEBUGGING
4853     if (DEBUG_C_TEST) {
4854         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4855                       (void*)ssv, (void*)dsv);
4856         sv_dump(ssv);
4857         if (dsv)
4858                     sv_dump(dsv);
4859     }
4860 #endif
4861     if (dsv) {
4862         if (SvTHINKFIRST(dsv))
4863             sv_force_normal_flags(dsv, SV_COW_DROP_PV);
4864         else if (SvPVX_const(dsv))
4865             Safefree(SvPVX_mutable(dsv));
4866         SvUPGRADE(dsv, SVt_COW);
4867     }
4868     else
4869         dsv = newSV_type(SVt_COW);
4870
4871     assert (SvPOK(ssv));
4872     assert (SvPOKp(ssv));
4873
4874     if (SvIsCOW(ssv)) {
4875         if (SvIsCOW_shared_hash(ssv)) {
4876             /* source is a COW shared hash key.  */
4877             DEBUG_C(PerlIO_printf(Perl_debug_log,
4878                                   "Fast copy on write: Sharing hash\n"));
4879             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv))));
4880             goto common_exit;
4881         }
4882         else if (SvIsCOW_static(ssv)) {
4883             /* source is static constant; preserve this */
4884             new_pv = SvPVX(ssv);
4885             new_flags |= SVppv_STATIC;
4886             goto common_exit;
4887         }
4888         assert(SvCUR(ssv)+1 < SvLEN(ssv));
4889         assert(CowREFCNT(ssv) < SV_COW_REFCNT_MAX);
4890     } else {
4891         assert ((SvFLAGS(ssv) & CAN_COW_MASK) == CAN_COW_FLAGS);
4892         SvUPGRADE(ssv, SVt_COW);
4893         SvIsCOW_on(ssv);
4894         DEBUG_C(PerlIO_printf(Perl_debug_log,
4895                               "Fast copy on write: Converting ssv to COW\n"));
4896         CowREFCNT(ssv) = 0;
4897     }
4898 #  ifdef PERL_DEBUG_READONLY_COW
4899     if (already) sv_buf_to_rw(ssv);
4900 #  endif
4901     CowREFCNT(ssv)++;
4902     new_pv = SvPVX_mutable(ssv);
4903     sv_buf_to_ro(ssv);
4904
4905   common_exit:
4906     SvPV_set(dsv, new_pv);
4907     SvFLAGS(dsv) = new_flags;
4908     if (SvUTF8(ssv))
4909         SvUTF8_on(dsv);
4910     SvLEN_set(dsv, len);
4911     SvCUR_set(dsv, cur);
4912 #ifdef DEBUGGING
4913     if (DEBUG_C_TEST)
4914                 sv_dump(dsv);
4915 #endif
4916     return dsv;
4917 }
4918 #endif
4919
4920 /*
4921 =for apidoc sv_setpv_bufsize
4922
4923 Sets the SV to be a string of cur bytes length, with at least
4924 len bytes available. Ensures that there is a null byte at SvEND.
4925 Returns a char * pointer to the SvPV buffer.
4926
4927 =cut
4928 */
4929
4930 char *
4931 Perl_sv_setpv_bufsize(pTHX_ SV *const sv, const STRLEN cur, const STRLEN len)
4932 {
4933     char *pv;
4934
4935     PERL_ARGS_ASSERT_SV_SETPV_BUFSIZE;
4936
4937     SV_CHECK_THINKFIRST_COW_DROP(sv);
4938     SvUPGRADE(sv, SVt_PV);
4939     pv = SvGROW(sv, len + 1);
4940     SvCUR_set(sv, cur);
4941     *(SvEND(sv))= '\0';
4942     (void)SvPOK_only_UTF8(sv);                /* validate pointer */
4943
4944     SvTAINT(sv);
4945     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4946     return pv;
4947 }
4948
4949 /*
4950 =for apidoc            sv_setpv
4951 =for apidoc_item       sv_setpv_mg
4952 =for apidoc_item       sv_setpvn
4953 =for apidoc_item       sv_setpvn_fresh
4954 =for apidoc_item       sv_setpvn_mg
4955 =for apidoc_item |void|sv_setpvs|SV* sv|"literal string"
4956 =for apidoc_item |void|sv_setpvs_mg|SV* sv|"literal string"
4957
4958 These copy a string into the SV C<sv>, making sure it is C<L</SvPOK_only>>.
4959
4960 In the C<pvs> forms, the string must be a C literal string, enclosed in double
4961 quotes.
4962
4963 In the C<pvn> forms, the first byte of the string is pointed to by C<ptr>, and
4964 C<len> indicates the number of bytes to be copied, potentially including
4965 embedded C<NUL> characters.
4966
4967 In the plain C<pv> forms, C<ptr> points to a NUL-terminated C string.  That is,
4968 it points to the first byte of the string, and the copy proceeds up through the
4969 first encountered C<NUL> byte.
4970
4971 In the forms that take a C<ptr> argument, if it is NULL, the SV will become
4972 undefined.
4973
4974 The UTF-8 flag is not changed by these functions.  A terminating NUL byte is
4975 guaranteed in the result.
4976
4977 The C<_mg> forms handle 'set' magic; the other forms skip all magic.
4978
4979 C<sv_setpvn_fresh> is a cut-down alternative to C<sv_setpvn>, intended ONLY
4980 to be used with a fresh sv that has been upgraded to a SVt_PV, SVt_PVIV,
4981 SVt_PVNV, or SVt_PVMG.
4982
4983 =cut
4984 */
4985
4986 void
4987 Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4988 {
4989     char *dptr;
4990
4991     PERL_ARGS_ASSERT_SV_SETPVN;
4992
4993     SV_CHECK_THINKFIRST_COW_DROP(sv);
4994     if (isGV_with_GP(sv))
4995         Perl_croak_no_modify();
4996     if (!ptr) {
4997         (void)SvOK_off(sv);
4998         return;
4999     }
5000     else {
5001         /* len is STRLEN which is unsigned, need to copy to signed */
5002         const IV iv = len;
5003         if (iv < 0)
5004             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
5005                        IVdf, iv);
5006     }
5007     SvUPGRADE(sv, SVt_PV);
5008
5009     dptr = SvGROW(sv, len + 1);
5010     Move(ptr,dptr,len,char);
5011     dptr[len] = '\0';
5012     SvCUR_set(sv, len);
5013     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5014     SvTAINT(sv);
5015     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
5016 }
5017
5018 void
5019 Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
5020 {
5021     PERL_ARGS_ASSERT_SV_SETPVN_MG;
5022
5023     sv_setpvn(sv,ptr,len);
5024     SvSETMAGIC(sv);
5025 }
5026
5027 void
5028 Perl_sv_setpvn_fresh(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
5029 {
5030     char *dptr;
5031
5032     PERL_ARGS_ASSERT_SV_SETPVN_FRESH;
5033     assert(SvTYPE(sv) >= SVt_PV && SvTYPE(sv) <= SVt_PVMG);
5034     assert(!SvTHINKFIRST(sv));
5035     assert(!isGV_with_GP(sv));
5036
5037     if (ptr) {
5038         const IV iv = len;
5039         /* len is STRLEN which is unsigned, need to copy to signed */
5040         if (iv < 0)
5041             Perl_croak(aTHX_ "panic: sv_setpvn_fresh called with negative strlen %"
5042                        IVdf, iv);
5043
5044         dptr = sv_grow_fresh(sv, len + 1);
5045         Move(ptr,dptr,len,char);
5046         dptr[len] = '\0';
5047         SvCUR_set(sv, len);
5048         SvPOK_on(sv);
5049         SvTAINT(sv);
5050     }
5051 }
5052
5053 void
5054 Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
5055 {
5056     STRLEN len;
5057
5058     PERL_ARGS_ASSERT_SV_SETPV;
5059
5060     SV_CHECK_THINKFIRST_COW_DROP(sv);
5061     if (!ptr) {
5062         (void)SvOK_off(sv);
5063         return;
5064     }
5065     len = strlen(ptr);
5066     SvUPGRADE(sv, SVt_PV);
5067
5068     SvGROW(sv, len + 1);
5069     Move(ptr,SvPVX(sv),len+1,char);
5070     SvCUR_set(sv, len);
5071     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5072     SvTAINT(sv);
5073     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
5074 }
5075
5076 void
5077 Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
5078 {
5079     PERL_ARGS_ASSERT_SV_SETPV_MG;
5080
5081     sv_setpv(sv,ptr);
5082     SvSETMAGIC(sv);
5083 }
5084
5085 void
5086 Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
5087 {
5088     PERL_ARGS_ASSERT_SV_SETHEK;
5089
5090     if (!hek) {
5091         return;
5092     }
5093
5094     if (HEK_LEN(hek) == HEf_SVKEY) {
5095         sv_setsv(sv, *(SV**)HEK_KEY(hek));
5096         return;
5097     } else {
5098         const int flags = HEK_FLAGS(hek);
5099         if (flags & HVhek_WASUTF8) {
5100             STRLEN utf8_len = HEK_LEN(hek);
5101             char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
5102             sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
5103             SvUTF8_on(sv);
5104             return;
5105         } else if (flags & HVhek_NOTSHARED) {
5106             sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
5107             if (HEK_UTF8(hek))
5108                 SvUTF8_on(sv);
5109             else SvUTF8_off(sv);
5110             return;
5111         }
5112         {
5113             SV_CHECK_THINKFIRST_COW_DROP(sv);
5114             SvUPGRADE(sv, SVt_PV);
5115             SvPV_free(sv);
5116             SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
5117             SvCUR_set(sv, HEK_LEN(hek));
5118             SvLEN_set(sv, 0);
5119             SvIsCOW_on(sv);
5120             SvPOK_on(sv);
5121             if (HEK_UTF8(hek))
5122                 SvUTF8_on(sv);
5123             else SvUTF8_off(sv);
5124             return;
5125         }
5126     }
5127 }
5128
5129
5130 /*
5131 =for apidoc      sv_usepvn
5132 =for apidoc_item sv_usepvn_flags
5133 =for apidoc_item sv_usepvn_mg
5134
5135 These tell an SV to use C<ptr> for its string value.  Normally SVs have
5136 their string stored inside the SV, but these tell the SV to use an
5137 external string instead.
5138
5139 C<ptr> should point to memory that was allocated
5140 by L</C<Newx>>.  It must be
5141 the start of a C<Newx>-ed block of memory, and not a pointer to the
5142 middle of it (beware of L<C<OOK>|perlguts/Offsets> and copy-on-write),
5143 and not be from a non-C<Newx> memory allocator like C<malloc>.  The
5144 string length, C<len>, must be supplied.  By default this function
5145 will L</C<Renew>> (i.e. realloc, move) the memory pointed to by C<ptr>,
5146 so that the pointer should not be freed or used by the programmer after giving
5147 it to C<sv_usepvn>, and neither should any pointers from "behind" that pointer
5148 (I<e.g.>, S<C<ptr> + 1>) be used.
5149
5150 In the C<sv_usepvn_flags> form, if S<C<flags & SV_SMAGIC>> is true,
5151 C<SvSETMAGIC> is called before returning.
5152 And if S<C<flags & SV_HAS_TRAILING_NUL>> is true, then C<ptr[len]> must be
5153 C<NUL>, and the realloc will be skipped (I<i.e.>, the buffer is actually at
5154 least 1 byte longer than C<len>, and already meets the requirements for storing
5155 in C<SvPVX>).
5156
5157 C<sv_usepvn> is merely C<sv_usepvn_flags> with C<flags> set to 0, so 'set'
5158 magic is skipped.
5159
5160 C<sv_usepvn_mg> is merely C<sv_usepvn_flags> with C<flags> set to C<SV_SMAGIC>,
5161 so 'set' magic is performed.
5162
5163 =for apidoc Amnh||SV_SMAGIC
5164 =for apidoc Amnh||SV_HAS_TRAILING_NUL
5165
5166 =cut
5167 */
5168
5169 void
5170 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
5171 {
5172     STRLEN allocate;
5173
5174     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
5175
5176     SV_CHECK_THINKFIRST_COW_DROP(sv);
5177     SvUPGRADE(sv, SVt_PV);
5178     if (!ptr) {
5179         (void)SvOK_off(sv);
5180         if (flags & SV_SMAGIC)
5181             SvSETMAGIC(sv);
5182         return;
5183     }
5184     if (SvPVX_const(sv))
5185         SvPV_free(sv);
5186
5187 #ifdef DEBUGGING
5188     if (flags & SV_HAS_TRAILING_NUL)
5189         assert(ptr[len] == '\0');
5190 #endif
5191
5192     allocate = (flags & SV_HAS_TRAILING_NUL)
5193         ? len + 1 :
5194 #ifdef Perl_safesysmalloc_size
5195         len + 1;
5196 #else
5197         PERL_STRLEN_ROUNDUP(len + 1);
5198 #endif
5199     if (flags & SV_HAS_TRAILING_NUL) {
5200         /* It's long enough - do nothing.
5201            Specifically Perl_newCONSTSUB is relying on this.  */
5202     } else {
5203 #ifdef DEBUGGING
5204         /* Force a move to shake out bugs in callers.  */
5205         char *new_ptr = (char*)safemalloc(allocate);
5206         Copy(ptr, new_ptr, len, char);
5207         PoisonFree(ptr,len,char);
5208         Safefree(ptr);
5209         ptr = new_ptr;
5210 #else
5211         ptr = (char*) saferealloc (ptr, allocate);
5212 #endif
5213     }
5214 #ifdef Perl_safesysmalloc_size
5215     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
5216 #else
5217     SvLEN_set(sv, allocate);
5218 #endif
5219     SvCUR_set(sv, len);
5220     SvPV_set(sv, ptr);
5221     if (!(flags & SV_HAS_TRAILING_NUL)) {
5222         ptr[len] = '\0';
5223     }
5224     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5225     SvTAINT(sv);
5226     if (flags & SV_SMAGIC)
5227         SvSETMAGIC(sv);
5228 }
5229
5230
5231 static void
5232 S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
5233 {
5234     assert(SvIsCOW(sv));
5235     {
5236 #ifdef PERL_ANY_COW
5237         const char * const pvx = SvPVX_const(sv);
5238         const STRLEN len = SvLEN(sv);
5239         const STRLEN cur = SvCUR(sv);
5240         const bool was_shared_hek = SvIsCOW_shared_hash(sv);
5241
5242 #ifdef DEBUGGING
5243         if (DEBUG_C_TEST) {
5244                 PerlIO_printf(Perl_debug_log,
5245                               "Copy on write: Force normal %ld\n",
5246                               (long) flags);
5247                 sv_dump(sv);
5248         }
5249 #endif
5250         SvIsCOW_off(sv);
5251 # ifdef PERL_COPY_ON_WRITE
5252         if (len) {
5253             /* Must do this first, since the CowREFCNT uses SvPVX and
5254             we need to write to CowREFCNT, or de-RO the whole buffer if we are
5255             the only owner left of the buffer. */
5256             sv_buf_to_rw(sv); /* NOOP if RO-ing not supported */
5257             {
5258                 U8 cowrefcnt = CowREFCNT(sv);
5259                 if(cowrefcnt != 0) {
5260                     cowrefcnt--;
5261                     CowREFCNT(sv) = cowrefcnt;
5262                     sv_buf_to_ro(sv);
5263                     goto copy_over;
5264                 }
5265             }
5266             /* Else we are the only owner of the buffer. */
5267         }
5268         else
5269 # endif
5270         {
5271             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
5272             copy_over:
5273             SvPV_set(sv, NULL);
5274             SvCUR_set(sv, 0);
5275             SvLEN_set(sv, 0);
5276             if (flags & SV_COW_DROP_PV) {
5277                 /* OK, so we don't need to copy our buffer.  */
5278                 SvPOK_off(sv);
5279             } else {
5280                 SvGROW(sv, cur + 1);
5281                 Move(pvx,SvPVX(sv),cur,char);
5282                 SvCUR_set(sv, cur);
5283                 *SvEND(sv) = '\0';
5284             }
5285             if (was_shared_hek) {
5286                         unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5287             }
5288 #ifdef DEBUGGING
5289             if (DEBUG_C_TEST)
5290                 sv_dump(sv);
5291 #endif
5292         }
5293 #else
5294             const char * const pvx = SvPVX_const(sv);
5295             const STRLEN len = SvCUR(sv);
5296             SvIsCOW_off(sv);
5297             SvPV_set(sv, NULL);
5298             SvLEN_set(sv, 0);
5299             if (flags & SV_COW_DROP_PV) {
5300                 /* OK, so we don't need to copy our buffer.  */
5301                 SvPOK_off(sv);
5302             } else {
5303                 SvGROW(sv, len + 1);
5304                 Move(pvx,SvPVX(sv),len,char);
5305                 *SvEND(sv) = '\0';
5306             }
5307             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5308 #endif
5309     }
5310 }
5311
5312
5313 /*
5314 =for apidoc sv_force_normal_flags
5315
5316 Undo various types of fakery on an SV, where fakery means
5317 "more than" a string: if the PV is a shared string, make
5318 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5319 an C<xpvmg>; if we're a copy-on-write scalar, this is the on-write time when
5320 we do the copy, and is also used locally; if this is a
5321 vstring, drop the vstring magic.  If C<SV_COW_DROP_PV> is set
5322 then a copy-on-write scalar drops its PV buffer (if any) and becomes
5323 C<SvPOK_off> rather than making a copy.  (Used where this
5324 scalar is about to be set to some other value.)  In addition,
5325 the C<flags> parameter gets passed to C<sv_unref_flags()>
5326 when unreffing.  C<sv_force_normal> calls this function
5327 with flags set to 0.
5328
5329 This function is expected to be used to signal to perl that this SV is
5330 about to be written to, and any extra book-keeping needs to be taken care
5331 of.  Hence, it croaks on read-only values.
5332
5333 =for apidoc Amnh||SV_COW_DROP_PV
5334
5335 =cut
5336 */
5337
5338 void
5339 Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
5340 {
5341     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
5342
5343     if (SvREADONLY(sv))
5344         Perl_croak_no_modify();
5345     else if (SvIsCOW(sv) && LIKELY(SvTYPE(sv) != SVt_PVHV))
5346         S_sv_uncow(aTHX_ sv, flags);
5347     if (SvROK(sv))
5348         sv_unref_flags(sv, flags);
5349     else if (SvFAKE(sv) && isGV_with_GP(sv))
5350         sv_unglob(sv, flags);
5351     else if (SvFAKE(sv) && isREGEXP(sv)) {
5352         /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
5353            to sv_unglob. We only need it here, so inline it.  */
5354         const bool islv = SvTYPE(sv) == SVt_PVLV;
5355         const svtype new_type =
5356           islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
5357         SV *const temp = newSV_type(new_type);
5358         regexp *old_rx_body;
5359
5360         if (new_type == SVt_PVMG) {
5361             SvMAGIC_set(temp, SvMAGIC(sv));
5362             SvMAGIC_set(sv, NULL);
5363             SvSTASH_set(temp, SvSTASH(sv));
5364             SvSTASH_set(sv, NULL);
5365         }
5366         if (!islv)
5367             SvCUR_set(temp, SvCUR(sv));
5368         /* Remember that SvPVX is in the head, not the body. */
5369         assert(ReANY((REGEXP *)sv)->mother_re);
5370
5371         if (islv) {
5372             /* LV-as-regex has sv->sv_any pointing to an XPVLV body,
5373              * whose xpvlenu_rx field points to the regex body */
5374             XPV *xpv = (XPV*)(SvANY(sv));
5375             old_rx_body = xpv->xpv_len_u.xpvlenu_rx;
5376             xpv->xpv_len_u.xpvlenu_rx = NULL;
5377         }
5378         else
5379             old_rx_body = ReANY((REGEXP *)sv);
5380
5381         /* Their buffer is already owned by someone else. */
5382         if (flags & SV_COW_DROP_PV) {
5383             /* SvLEN is already 0.  For SVt_REGEXP, we have a brand new
5384                zeroed body.  For SVt_PVLV, we zeroed it above (len field
5385                a union with xpvlenu_rx) */
5386             assert(!SvLEN(islv ? sv : temp));
5387             sv->sv_u.svu_pv = 0;
5388         }
5389         else {
5390             sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
5391             SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
5392             SvPOK_on(sv);
5393         }
5394
5395         /* Now swap the rest of the bodies. */
5396
5397         SvFAKE_off(sv);
5398         if (!islv) {
5399             SvFLAGS(sv) &= ~SVTYPEMASK;
5400             SvFLAGS(sv) |= new_type;
5401             SvANY(sv) = SvANY(temp);
5402         }
5403
5404         SvFLAGS(temp) &= ~(SVTYPEMASK);
5405         SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
5406         SvANY(temp) = old_rx_body;
5407
5408         /* temp is now rebuilt as a correctly structured SVt_REGEXP, so this
5409          * will trigger a call to sv_clear() which will correctly free the
5410          * body. */
5411         SvREFCNT_dec_NN(temp);
5412     }
5413     else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
5414 }
5415
5416 /*
5417 =for apidoc sv_chop
5418
5419 Efficient removal of characters from the beginning of the string buffer.
5420 C<SvPOK(sv)>, or at least C<SvPOKp(sv)>, must be true and C<ptr> must be a
5421 pointer to somewhere inside the string buffer.  C<ptr> becomes the first
5422 character of the adjusted string.  Uses the C<OOK> hack.  On return, only
5423 C<SvPOK(sv)> and C<SvPOKp(sv)> among the C<OK> flags will be true.
5424
5425 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
5426 refer to the same chunk of data.
5427
5428 The unfortunate similarity of this function's name to that of Perl's C<chop>
5429 operator is strictly coincidental.  This function works from the left;
5430 C<chop> works from the right.
5431
5432 =cut
5433 */
5434
5435 void
5436 Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
5437 {
5438     STRLEN delta;
5439     STRLEN old_delta;
5440     U8 *p;
5441 #ifdef DEBUGGING
5442     const U8 *evacp;
5443     STRLEN evacn;
5444 #endif
5445     STRLEN max_delta;
5446
5447     PERL_ARGS_ASSERT_SV_CHOP;
5448
5449     if (!ptr || !SvPOKp(sv))
5450         return;
5451     delta = ptr - SvPVX_const(sv);
5452     if (!delta) {
5453         /* Nothing to do.  */
5454         return;
5455     }
5456     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
5457     if (delta > max_delta)
5458         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
5459                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
5460     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
5461     SV_CHECK_THINKFIRST(sv);
5462     SvPOK_only_UTF8(sv);
5463
5464     if (!SvOOK(sv)) {
5465         if (!SvLEN(sv)) { /* make copy of shared string */
5466             const char *pvx = SvPVX_const(sv);
5467             const STRLEN len = SvCUR(sv);
5468             SvGROW(sv, len + 1);
5469             Move(pvx,SvPVX(sv),len,char);
5470             *SvEND(sv) = '\0';
5471         }
5472         SvOOK_on(sv);
5473         old_delta = 0;
5474     } else {
5475         SvOOK_offset(sv, old_delta);
5476     }
5477     SvLEN_set(sv, SvLEN(sv) - delta);
5478     SvCUR_set(sv, SvCUR(sv) - delta);
5479     SvPV_set(sv, SvPVX(sv) + delta);
5480
5481     p = (U8 *)SvPVX_const(sv);
5482
5483 #ifdef DEBUGGING
5484     /* how many bytes were evacuated?  we will fill them with sentinel
5485        bytes, except for the part holding the new offset of course. */
5486     evacn = delta;
5487     if (old_delta)
5488         evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
5489     assert(evacn);
5490     assert(evacn <= delta + old_delta);
5491     evacp = p - evacn;
5492 #endif
5493
5494     /* This sets 'delta' to the accumulated value of all deltas so far */
5495     delta += old_delta;
5496     assert(delta);
5497
5498     /* If 'delta' fits in a byte, store it just prior to the new beginning of
5499      * the string; otherwise store a 0 byte there and store 'delta' just prior
5500      * to that, using as many bytes as a STRLEN occupies.  Thus it overwrites a
5501      * portion of the chopped part of the string */
5502     if (delta < 0x100) {
5503         *--p = (U8) delta;
5504     } else {
5505         *--p = 0;
5506         p -= sizeof(STRLEN);
5507         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
5508     }
5509
5510 #ifdef DEBUGGING
5511     /* Fill the preceding buffer with sentinals to verify that no-one is
5512        using it.  */
5513     while (p > evacp) {
5514         --p;
5515         *p = (U8)PTR2UV(p);
5516     }
5517 #endif
5518 }
5519
5520 /*
5521 =for apidoc sv_catpvn
5522 =for apidoc_item sv_catpvn_flags
5523 =for apidoc_item sv_catpvn_mg
5524 =for apidoc_item sv_catpvn_nomg
5525
5526 These concatenate the C<len> bytes of the string beginning at C<ptr> onto the
5527 end of the string which is in C<dsv>.  The caller must make sure C<ptr>
5528 contains at least C<len> bytes.
5529
5530 For all but C<sv_catpvn_flags>, the string appended is assumed to be valid
5531 UTF-8 if the SV has the UTF-8 status set, and a string of bytes otherwise.
5532
5533 They differ in that:
5534
5535 C<sv_catpvn_mg> performs both 'get' and 'set' magic on C<dsv>.
5536
5537 C<sv_catpvn> performs only 'get' magic.
5538
5539 C<sv_catpvn_nomg> skips all magic.
5540
5541 C<sv_catpvn_flags> has an extra C<flags> parameter which allows you to specify
5542 any combination of magic handling (using C<SV_GMAGIC> and/or C<SV_SMAGIC>) and
5543 to also override the UTF-8 handling.  By supplying the C<SV_CATBYTES> flag, the
5544 appended string is interpreted as plain bytes; by supplying instead the
5545 C<SV_CATUTF8> flag, it will be interpreted as UTF-8, and the C<dsv> will be
5546 upgraded to UTF-8 if necessary.
5547
5548 C<sv_catpvn>, C<sv_catpvn_mg>, and C<sv_catpvn_nomg> are implemented
5549 in terms of C<sv_catpvn_flags>.
5550
5551 =for apidoc Amnh||SV_CATUTF8
5552 =for apidoc Amnh||SV_CATBYTES
5553
5554 =cut
5555 */
5556
5557 void
5558 Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
5559 {
5560     STRLEN dlen;
5561     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5562
5563     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5564     assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5565
5566     if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
5567       if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
5568          sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5569          dlen = SvCUR(dsv);
5570       }
5571       else SvGROW(dsv, dlen + slen + 3);
5572       if (sstr == dstr)
5573         sstr = SvPVX_const(dsv);
5574       Move(sstr, SvPVX(dsv) + dlen, slen, char);
5575       SvCUR_set(dsv, SvCUR(dsv) + slen);
5576     }
5577     else {
5578         /* We inline bytes_to_utf8, to avoid an extra malloc. */
5579         const char * const send = sstr + slen;
5580         U8 *d;
5581
5582         /* Something this code does not account for, which I think is
5583            impossible; it would require the same pv to be treated as
5584            bytes *and* utf8, which would indicate a bug elsewhere. */
5585         assert(sstr != dstr);
5586
5587         SvGROW(dsv, dlen + slen * 2 + 3);
5588         d = (U8 *)SvPVX(dsv) + dlen;
5589
5590         while (sstr < send) {
5591             append_utf8_from_native_byte(*sstr, &d);
5592             sstr++;
5593         }
5594         SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5595     }
5596     *SvEND(dsv) = '\0';
5597     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
5598     SvTAINT(dsv);
5599     if (flags & SV_SMAGIC)
5600         SvSETMAGIC(dsv);
5601 }
5602
5603 /*
5604 =for apidoc sv_catsv
5605 =for apidoc_item sv_catsv_flags
5606 =for apidoc_item sv_catsv_mg
5607 =for apidoc_item sv_catsv_nomg
5608
5609 These concatenate the string from SV C<sstr> onto the end of the string in SV
5610 C<dsv>.  If C<sstr> is null, these are no-ops; otherwise only C<dsv> is
5611 modified.
5612
5613 They differ only in what magic they perform:
5614
5615 C<sv_catsv_mg> performs 'get' magic on both SVs before the copy, and 'set' magic
5616 on C<dsv> afterwards.
5617
5618 C<sv_catsv> performs just 'get' magic, on both SVs.
5619
5620 C<sv_catsv_nomg> skips all magic.
5621
5622 C<sv_catsv_flags> has an extra C<flags> parameter which allows you to use
5623 C<SV_GMAGIC> and/or C<SV_SMAGIC> to specify any combination of magic handling
5624 (although either both or neither SV will have 'get' magic applied to it.)
5625
5626 C<sv_catsv>, C<sv_catsv_mg>, and C<sv_catsv_nomg> are implemented
5627 in terms of C<sv_catsv_flags>.
5628
5629 =cut */
5630
5631 void
5632 Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const sstr, const I32 flags)
5633 {
5634     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5635
5636     if (sstr) {
5637         STRLEN slen;
5638         const char *spv = SvPV_flags_const(sstr, slen, flags);
5639         if (flags & SV_GMAGIC)
5640                 SvGETMAGIC(dsv);
5641         sv_catpvn_flags(dsv, spv, slen,
5642                             DO_UTF8(sstr) ? SV_CATUTF8 : SV_CATBYTES);