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