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