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