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