This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Haiku use finddir for default prefix in hints
[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)
1089     static bool done_sanity_check;
1090
1091     if (!done_sanity_check) {
1092         unsigned int i = SVt_LAST;
1093
1094         done_sanity_check = TRUE;
1095
1096         while (i--)
1097             assert (bodies_by_type[i].type == i);
1098     }
1099 #endif
1100
1101     assert(arena_size);
1102
1103     /* may need new arena-set to hold new arena */
1104     if (!aroot || aroot->curr >= aroot->set_size) {
1105         struct arena_set *newroot;
1106         Newxz(newroot, 1, struct arena_set);
1107         newroot->set_size = ARENAS_PER_SET;
1108         newroot->next = aroot;
1109         aroot = newroot;
1110         PL_body_arenas = (void *) newroot;
1111         DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1112     }
1113
1114     /* ok, now have arena-set with at least 1 empty/available arena-desc */
1115     curr = aroot->curr++;
1116     adesc = &(aroot->set[curr]);
1117     assert(!adesc->arena);
1118     
1119     Newx(adesc->arena, good_arena_size, char);
1120     adesc->size = good_arena_size;
1121     adesc->utype = sv_type;
1122     DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %" UVuf "\n",
1123                           curr, (void*)adesc->arena, (UV)good_arena_size));
1124
1125     start = (char *) adesc->arena;
1126
1127     /* Get the address of the byte after the end of the last body we can fit.
1128        Remember, this is integer division:  */
1129     end = start + good_arena_size / body_size * body_size;
1130
1131     /* computed count doesn't reflect the 1st slot reservation */
1132 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1133     DEBUG_m(PerlIO_printf(Perl_debug_log,
1134                           "arena %p end %p arena-size %d (from %d) type %d "
1135                           "size %d ct %d\n",
1136                           (void*)start, (void*)end, (int)good_arena_size,
1137                           (int)arena_size, sv_type, (int)body_size,
1138                           (int)good_arena_size / (int)body_size));
1139 #else
1140     DEBUG_m(PerlIO_printf(Perl_debug_log,
1141                           "arena %p end %p arena-size %d type %d size %d ct %d\n",
1142                           (void*)start, (void*)end,
1143                           (int)arena_size, sv_type, (int)body_size,
1144                           (int)good_arena_size / (int)body_size));
1145 #endif
1146     *root = (void *)start;
1147
1148     while (1) {
1149         /* Where the next body would start:  */
1150         char * const next = start + body_size;
1151
1152         if (next >= end) {
1153             /* This is the last body:  */
1154             assert(next == end);
1155
1156             *(void **)start = 0;
1157             return *root;
1158         }
1159
1160         *(void**) start = (void *)next;
1161         start = next;
1162     }
1163 }
1164
1165 /* grab a new thing from the free list, allocating more if necessary.
1166    The inline version is used for speed in hot routines, and the
1167    function using it serves the rest (unless PURIFY).
1168 */
1169 #define new_body_inline(xpv, sv_type) \
1170     STMT_START { \
1171         void ** const r3wt = &PL_body_roots[sv_type]; \
1172         xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \
1173           ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1174                                              bodies_by_type[sv_type].body_size,\
1175                                              bodies_by_type[sv_type].arena_size)); \
1176         *(r3wt) = *(void**)(xpv); \
1177     } STMT_END
1178
1179 #ifndef PURIFY
1180
1181 STATIC void *
1182 S_new_body(pTHX_ const svtype sv_type)
1183 {
1184     void *xpv;
1185     new_body_inline(xpv, sv_type);
1186     return xpv;
1187 }
1188
1189 #endif
1190
1191 static const struct body_details fake_rv =
1192     { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1193
1194 /*
1195 =for apidoc sv_upgrade
1196
1197 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1198 SV, then copies across as much information as possible from the old body.
1199 It croaks if the SV is already in a more complex form than requested.  You
1200 generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
1201 before calling C<sv_upgrade>, and hence does not croak.  See also
1202 C<L</svtype>>.
1203
1204 =cut
1205 */
1206
1207 void
1208 Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
1209 {
1210     void*       old_body;
1211     void*       new_body;
1212     const svtype old_type = SvTYPE(sv);
1213     const struct body_details *new_type_details;
1214     const struct body_details *old_type_details
1215         = bodies_by_type + old_type;
1216     SV *referent = NULL;
1217
1218     PERL_ARGS_ASSERT_SV_UPGRADE;
1219
1220     if (old_type == new_type)
1221         return;
1222
1223     /* This clause was purposefully added ahead of the early return above to
1224        the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1225        inference by Nick I-S that it would fix other troublesome cases. See
1226        changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1227
1228        Given that shared hash key scalars are no longer PVIV, but PV, there is
1229        no longer need to unshare so as to free up the IVX slot for its proper
1230        purpose. So it's safe to move the early return earlier.  */
1231
1232     if (new_type > SVt_PVMG && SvIsCOW(sv)) {
1233         sv_force_normal_flags(sv, 0);
1234     }
1235
1236     old_body = SvANY(sv);
1237
1238     /* Copying structures onto other structures that have been neatly zeroed
1239        has a subtle gotcha. Consider XPVMG
1240
1241        +------+------+------+------+------+-------+-------+
1242        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
1243        +------+------+------+------+------+-------+-------+
1244        0      4      8     12     16     20      24      28
1245
1246        where NVs are aligned to 8 bytes, so that sizeof that structure is
1247        actually 32 bytes long, with 4 bytes of padding at the end:
1248
1249        +------+------+------+------+------+-------+-------+------+
1250        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
1251        +------+------+------+------+------+-------+-------+------+
1252        0      4      8     12     16     20      24      28     32
1253
1254        so what happens if you allocate memory for this structure:
1255
1256        +------+------+------+------+------+-------+-------+------+------+...
1257        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
1258        +------+------+------+------+------+-------+-------+------+------+...
1259        0      4      8     12     16     20      24      28     32     36
1260
1261        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1262        expect, because you copy the area marked ??? onto GP. Now, ??? may have
1263        started out as zero once, but it's quite possible that it isn't. So now,
1264        rather than a nicely zeroed GP, you have it pointing somewhere random.
1265        Bugs ensue.
1266
1267        (In fact, GP ends up pointing at a previous GP structure, because the
1268        principle cause of the padding in XPVMG getting garbage is a copy of
1269        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1270        this happens to be moot because XPVGV has been re-ordered, with GP
1271        no longer after STASH)
1272
1273        So we are careful and work out the size of used parts of all the
1274        structures.  */
1275
1276     switch (old_type) {
1277     case SVt_NULL:
1278         break;
1279     case SVt_IV:
1280         if (SvROK(sv)) {
1281             referent = SvRV(sv);
1282             old_type_details = &fake_rv;
1283             if (new_type == SVt_NV)
1284                 new_type = SVt_PVNV;
1285         } else {
1286             if (new_type < SVt_PVIV) {
1287                 new_type = (new_type == SVt_NV)
1288                     ? SVt_PVNV : SVt_PVIV;
1289             }
1290         }
1291         break;
1292     case SVt_NV:
1293         if (new_type < SVt_PVNV) {
1294             new_type = SVt_PVNV;
1295         }
1296         break;
1297     case SVt_PV:
1298         assert(new_type > SVt_PV);
1299         STATIC_ASSERT_STMT(SVt_IV < SVt_PV);
1300         STATIC_ASSERT_STMT(SVt_NV < SVt_PV);
1301         break;
1302     case SVt_PVIV:
1303         break;
1304     case SVt_PVNV:
1305         break;
1306     case SVt_PVMG:
1307         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1308            there's no way that it can be safely upgraded, because perl.c
1309            expects to Safefree(SvANY(PL_mess_sv))  */
1310         assert(sv != PL_mess_sv);
1311         break;
1312     default:
1313         if (UNLIKELY(old_type_details->cant_upgrade))
1314             Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1315                        sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1316     }
1317
1318     if (UNLIKELY(old_type > new_type))
1319         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1320                 (int)old_type, (int)new_type);
1321
1322     new_type_details = bodies_by_type + new_type;
1323
1324     SvFLAGS(sv) &= ~SVTYPEMASK;
1325     SvFLAGS(sv) |= new_type;
1326
1327     /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1328        the return statements above will have triggered.  */
1329     assert (new_type != SVt_NULL);
1330     switch (new_type) {
1331     case SVt_IV:
1332         assert(old_type == SVt_NULL);
1333         SET_SVANY_FOR_BODYLESS_IV(sv);
1334         SvIV_set(sv, 0);
1335         return;
1336     case SVt_NV:
1337         assert(old_type == SVt_NULL);
1338 #if NVSIZE <= IVSIZE
1339         SET_SVANY_FOR_BODYLESS_NV(sv);
1340 #else
1341         SvANY(sv) = new_XNV();
1342 #endif
1343         SvNV_set(sv, 0);
1344         return;
1345     case SVt_PVHV:
1346     case SVt_PVAV:
1347         assert(new_type_details->body_size);
1348
1349 #ifndef PURIFY  
1350         assert(new_type_details->arena);
1351         assert(new_type_details->arena_size);
1352         /* This points to the start of the allocated area.  */
1353         new_body_inline(new_body, new_type);
1354         Zero(new_body, new_type_details->body_size, char);
1355         new_body = ((char *)new_body) - new_type_details->offset;
1356 #else
1357         /* We always allocated the full length item with PURIFY. To do this
1358            we fake things so that arena is false for all 16 types..  */
1359         new_body = new_NOARENAZ(new_type_details);
1360 #endif
1361         SvANY(sv) = new_body;
1362         if (new_type == SVt_PVAV) {
1363             AvMAX(sv)   = -1;
1364             AvFILLp(sv) = -1;
1365             AvREAL_only(sv);
1366             if (old_type_details->body_size) {
1367                 AvALLOC(sv) = 0;
1368             } else {
1369                 /* It will have been zeroed when the new body was allocated.
1370                    Lets not write to it, in case it confuses a write-back
1371                    cache.  */
1372             }
1373         } else {
1374             assert(!SvOK(sv));
1375             SvOK_off(sv);
1376 #ifndef NODEFAULT_SHAREKEYS
1377             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
1378 #endif
1379             /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
1380             HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
1381         }
1382
1383         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1384            The target created by newSVrv also is, and it can have magic.
1385            However, it never has SvPVX set.
1386         */
1387         if (old_type == SVt_IV) {
1388             assert(!SvROK(sv));
1389         } else if (old_type >= SVt_PV) {
1390             assert(SvPVX_const(sv) == 0);
1391         }
1392
1393         if (old_type >= SVt_PVMG) {
1394             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1395             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1396         } else {
1397             sv->sv_u.svu_array = NULL; /* or svu_hash  */
1398         }
1399         break;
1400
1401     case SVt_PVIV:
1402         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1403            no route from NV to PVIV, NOK can never be true  */
1404         assert(!SvNOKp(sv));
1405         assert(!SvNOK(sv));
1406         /* FALLTHROUGH */
1407     case SVt_PVIO:
1408     case SVt_PVFM:
1409     case SVt_PVGV:
1410     case SVt_PVCV:
1411     case SVt_PVLV:
1412     case SVt_INVLIST:
1413     case SVt_REGEXP:
1414     case SVt_PVMG:
1415     case SVt_PVNV:
1416     case SVt_PV:
1417
1418         assert(new_type_details->body_size);
1419         /* We always allocated the full length item with PURIFY. To do this
1420            we fake things so that arena is false for all 16 types..  */
1421         if(new_type_details->arena) {
1422             /* This points to the start of the allocated area.  */
1423             new_body_inline(new_body, new_type);
1424             Zero(new_body, new_type_details->body_size, char);
1425             new_body = ((char *)new_body) - new_type_details->offset;
1426         } else {
1427             new_body = new_NOARENAZ(new_type_details);
1428         }
1429         SvANY(sv) = new_body;
1430
1431         if (old_type_details->copy) {
1432             /* There is now the potential for an upgrade from something without
1433                an offset (PVNV or PVMG) to something with one (PVCV, PVFM)  */
1434             int offset = old_type_details->offset;
1435             int length = old_type_details->copy;
1436
1437             if (new_type_details->offset > old_type_details->offset) {
1438                 const int difference
1439                     = new_type_details->offset - old_type_details->offset;
1440                 offset += difference;
1441                 length -= difference;
1442             }
1443             assert (length >= 0);
1444                 
1445             Copy((char *)old_body + offset, (char *)new_body + offset, length,
1446                  char);
1447         }
1448
1449 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1450         /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1451          * correct 0.0 for us.  Otherwise, if the old body didn't have an
1452          * NV slot, but the new one does, then we need to initialise the
1453          * freshly created NV slot with whatever the correct bit pattern is
1454          * for 0.0  */
1455         if (old_type_details->zero_nv && !new_type_details->zero_nv
1456             && !isGV_with_GP(sv))
1457             SvNV_set(sv, 0);
1458 #endif
1459
1460         if (UNLIKELY(new_type == SVt_PVIO)) {
1461             IO * const io = MUTABLE_IO(sv);
1462             GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1463
1464             SvOBJECT_on(io);
1465             /* Clear the stashcache because a new IO could overrule a package
1466                name */
1467             DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
1468             hv_clear(PL_stashcache);
1469
1470             SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1471             IoPAGE_LEN(sv) = 60;
1472         }
1473         if (old_type < SVt_PV) {
1474             /* referent will be NULL unless the old type was SVt_IV emulating
1475                SVt_RV */
1476             sv->sv_u.svu_rv = referent;
1477         }
1478         break;
1479     default:
1480         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1481                    (unsigned long)new_type);
1482     }
1483
1484     /* if this is zero, this is a body-less SVt_NULL, SVt_IV/SVt_RV,
1485        and sometimes SVt_NV */
1486     if (old_type_details->body_size) {
1487 #ifdef PURIFY
1488         safefree(old_body);
1489 #else
1490         /* Note that there is an assumption that all bodies of types that
1491            can be upgraded came from arenas. Only the more complex non-
1492            upgradable types are allowed to be directly malloc()ed.  */
1493         assert(old_type_details->arena);
1494         del_body((void*)((char*)old_body + old_type_details->offset),
1495                  &PL_body_roots[old_type]);
1496 #endif
1497     }
1498 }
1499
1500 /*
1501 =for apidoc sv_backoff
1502
1503 Remove any string offset.  You should normally use the C<SvOOK_off> macro
1504 wrapper instead.
1505
1506 =cut
1507 */
1508
1509 /* prior to 5.000 stable, this function returned the new OOK-less SvFLAGS
1510    prior to 5.23.4 this function always returned 0
1511 */
1512
1513 void
1514 Perl_sv_backoff(SV *const sv)
1515 {
1516     STRLEN delta;
1517     const char * const s = SvPVX_const(sv);
1518
1519     PERL_ARGS_ASSERT_SV_BACKOFF;
1520
1521     assert(SvOOK(sv));
1522     assert(SvTYPE(sv) != SVt_PVHV);
1523     assert(SvTYPE(sv) != SVt_PVAV);
1524
1525     SvOOK_offset(sv, delta);
1526     
1527     SvLEN_set(sv, SvLEN(sv) + delta);
1528     SvPV_set(sv, SvPVX(sv) - delta);
1529     SvFLAGS(sv) &= ~SVf_OOK;
1530     Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1531     return;
1532 }
1533
1534
1535 /* forward declaration */
1536 static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
1537
1538
1539 /*
1540 =for apidoc sv_grow
1541
1542 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1543 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1544 Use the C<SvGROW> wrapper instead.
1545
1546 =cut
1547 */
1548
1549
1550 char *
1551 Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
1552 {
1553     char *s;
1554
1555     PERL_ARGS_ASSERT_SV_GROW;
1556
1557     if (SvROK(sv))
1558         sv_unref(sv);
1559     if (SvTYPE(sv) < SVt_PV) {
1560         sv_upgrade(sv, SVt_PV);
1561         s = SvPVX_mutable(sv);
1562     }
1563     else if (SvOOK(sv)) {       /* pv is offset? */
1564         sv_backoff(sv);
1565         s = SvPVX_mutable(sv);
1566         if (newlen > SvLEN(sv))
1567             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1568     }
1569     else
1570     {
1571         if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0);
1572         s = SvPVX_mutable(sv);
1573     }
1574
1575 #ifdef PERL_COPY_ON_WRITE
1576     /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1577      * to store the COW count. So in general, allocate one more byte than
1578      * asked for, to make it likely this byte is always spare: and thus
1579      * make more strings COW-able.
1580      *
1581      * Only increment if the allocation isn't MEM_SIZE_MAX,
1582      * otherwise it will wrap to 0.
1583      */
1584     if ( newlen != MEM_SIZE_MAX )
1585         newlen++;
1586 #endif
1587
1588 #if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size)
1589 #define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1590 #endif
1591
1592     if (newlen > SvLEN(sv)) {           /* need more room? */
1593         STRLEN minlen = SvCUR(sv);
1594         minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1595         if (newlen < minlen)
1596             newlen = minlen;
1597 #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1598
1599         /* Don't round up on the first allocation, as odds are pretty good that
1600          * the initial request is accurate as to what is really needed */
1601         if (SvLEN(sv)) {
1602             STRLEN rounded = PERL_STRLEN_ROUNDUP(newlen);
1603             if (rounded > newlen)
1604                 newlen = rounded;
1605         }
1606 #endif
1607         if (SvLEN(sv) && s) {
1608             s = (char*)saferealloc(s, newlen);
1609         }
1610         else {
1611             s = (char*)safemalloc(newlen);
1612             if (SvPVX_const(sv) && SvCUR(sv)) {
1613                 Move(SvPVX_const(sv), s, SvCUR(sv), char);
1614             }
1615         }
1616         SvPV_set(sv, s);
1617 #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1618         /* Do this here, do it once, do it right, and then we will never get
1619            called back into sv_grow() unless there really is some growing
1620            needed.  */
1621         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1622 #else
1623         SvLEN_set(sv, newlen);
1624 #endif
1625     }
1626     return s;
1627 }
1628
1629 /*
1630 =for apidoc sv_setiv
1631
1632 Copies an integer into the given SV, upgrading first if necessary.
1633 Does not handle 'set' magic.  See also C<L</sv_setiv_mg>>.
1634
1635 =cut
1636 */
1637
1638 void
1639 Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
1640 {
1641     PERL_ARGS_ASSERT_SV_SETIV;
1642
1643     SV_CHECK_THINKFIRST_COW_DROP(sv);
1644     switch (SvTYPE(sv)) {
1645     case SVt_NULL:
1646     case SVt_NV:
1647         sv_upgrade(sv, SVt_IV);
1648         break;
1649     case SVt_PV:
1650         sv_upgrade(sv, SVt_PVIV);
1651         break;
1652
1653     case SVt_PVGV:
1654         if (!isGV_with_GP(sv))
1655             break;
1656         /* FALLTHROUGH */
1657     case SVt_PVAV:
1658     case SVt_PVHV:
1659     case SVt_PVCV:
1660     case SVt_PVFM:
1661     case SVt_PVIO:
1662         /* diag_listed_as: Can't coerce %s to %s in %s */
1663         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1664                    OP_DESC(PL_op));
1665         NOT_REACHED; /* NOTREACHED */
1666         break;
1667     default: NOOP;
1668     }
1669     (void)SvIOK_only(sv);                       /* validate number */
1670     SvIV_set(sv, i);
1671     SvTAINT(sv);
1672 }
1673
1674 /*
1675 =for apidoc sv_setiv_mg
1676
1677 Like C<sv_setiv>, but also handles 'set' magic.
1678
1679 =cut
1680 */
1681
1682 void
1683 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1684 {
1685     PERL_ARGS_ASSERT_SV_SETIV_MG;
1686
1687     sv_setiv(sv,i);
1688     SvSETMAGIC(sv);
1689 }
1690
1691 /*
1692 =for apidoc sv_setuv
1693
1694 Copies an unsigned integer into the given SV, upgrading first if necessary.
1695 Does not handle 'set' magic.  See also C<L</sv_setuv_mg>>.
1696
1697 =cut
1698 */
1699
1700 void
1701 Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1702 {
1703     PERL_ARGS_ASSERT_SV_SETUV;
1704
1705     /* With the if statement to ensure that integers are stored as IVs whenever
1706        possible:
1707        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1708
1709        without
1710        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1711
1712        If you wish to remove the following if statement, so that this routine
1713        (and its callers) always return UVs, please benchmark to see what the
1714        effect is. Modern CPUs may be different. Or may not :-)
1715     */
1716     if (u <= (UV)IV_MAX) {
1717        sv_setiv(sv, (IV)u);
1718        return;
1719     }
1720     sv_setiv(sv, 0);
1721     SvIsUV_on(sv);
1722     SvUV_set(sv, u);
1723 }
1724
1725 /*
1726 =for apidoc sv_setuv_mg
1727
1728 Like C<sv_setuv>, but also handles 'set' magic.
1729
1730 =cut
1731 */
1732
1733 void
1734 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1735 {
1736     PERL_ARGS_ASSERT_SV_SETUV_MG;
1737
1738     sv_setuv(sv,u);
1739     SvSETMAGIC(sv);
1740 }
1741
1742 /*
1743 =for apidoc sv_setnv
1744
1745 Copies a double into the given SV, upgrading first if necessary.
1746 Does not handle 'set' magic.  See also C<L</sv_setnv_mg>>.
1747
1748 =cut
1749 */
1750
1751 void
1752 Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1753 {
1754     PERL_ARGS_ASSERT_SV_SETNV;
1755
1756     SV_CHECK_THINKFIRST_COW_DROP(sv);
1757     switch (SvTYPE(sv)) {
1758     case SVt_NULL:
1759     case SVt_IV:
1760         sv_upgrade(sv, SVt_NV);
1761         break;
1762     case SVt_PV:
1763     case SVt_PVIV:
1764         sv_upgrade(sv, SVt_PVNV);
1765         break;
1766
1767     case SVt_PVGV:
1768         if (!isGV_with_GP(sv))
1769             break;
1770         /* FALLTHROUGH */
1771     case SVt_PVAV:
1772     case SVt_PVHV:
1773     case SVt_PVCV:
1774     case SVt_PVFM:
1775     case SVt_PVIO:
1776         /* diag_listed_as: Can't coerce %s to %s in %s */
1777         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1778                    OP_DESC(PL_op));
1779         NOT_REACHED; /* NOTREACHED */
1780         break;
1781     default: NOOP;
1782     }
1783     SvNV_set(sv, num);
1784     (void)SvNOK_only(sv);                       /* validate number */
1785     SvTAINT(sv);
1786 }
1787
1788 /*
1789 =for apidoc sv_setnv_mg
1790
1791 Like C<sv_setnv>, but also handles 'set' magic.
1792
1793 =cut
1794 */
1795
1796 void
1797 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1798 {
1799     PERL_ARGS_ASSERT_SV_SETNV_MG;
1800
1801     sv_setnv(sv,num);
1802     SvSETMAGIC(sv);
1803 }
1804
1805 /* Return a cleaned-up, printable version of sv, for non-numeric, or
1806  * not incrementable warning display.
1807  * Originally part of S_not_a_number().
1808  * The return value may be != tmpbuf.
1809  */
1810
1811 STATIC const char *
1812 S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1813     const char *pv;
1814
1815      PERL_ARGS_ASSERT_SV_DISPLAY;
1816
1817      if (DO_UTF8(sv)) {
1818           SV *dsv = newSVpvs_flags("", SVs_TEMP);
1819           pv = sv_uni_display(dsv, sv, 32, UNI_DISPLAY_ISPRINT);
1820      } else {
1821           char *d = tmpbuf;
1822           const char * const limit = tmpbuf + tmpbuf_size - 8;
1823           /* each *s can expand to 4 chars + "...\0",
1824              i.e. need room for 8 chars */
1825         
1826           const char *s = SvPVX_const(sv);
1827           const char * const end = s + SvCUR(sv);
1828           for ( ; s < end && d < limit; s++ ) {
1829                int ch = *s & 0xFF;
1830                if (! isASCII(ch) && !isPRINT_LC(ch)) {
1831                     *d++ = 'M';
1832                     *d++ = '-';
1833
1834                     /* Map to ASCII "equivalent" of Latin1 */
1835                     ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1836                }
1837                if (ch == '\n') {
1838                     *d++ = '\\';
1839                     *d++ = 'n';
1840                }
1841                else if (ch == '\r') {
1842                     *d++ = '\\';
1843                     *d++ = 'r';
1844                }
1845                else if (ch == '\f') {
1846                     *d++ = '\\';
1847                     *d++ = 'f';
1848                }
1849                else if (ch == '\\') {
1850                     *d++ = '\\';
1851                     *d++ = '\\';
1852                }
1853                else if (ch == '\0') {
1854                     *d++ = '\\';
1855                     *d++ = '0';
1856                }
1857                else if (isPRINT_LC(ch))
1858                     *d++ = ch;
1859                else {
1860                     *d++ = '^';
1861                     *d++ = toCTRL(ch);
1862                }
1863           }
1864           if (s < end) {
1865                *d++ = '.';
1866                *d++ = '.';
1867                *d++ = '.';
1868           }
1869           *d = '\0';
1870           pv = tmpbuf;
1871     }
1872
1873     return pv;
1874 }
1875
1876 /* Print an "isn't numeric" warning, using a cleaned-up,
1877  * printable version of the offending string
1878  */
1879
1880 STATIC void
1881 S_not_a_number(pTHX_ SV *const sv)
1882 {
1883      char tmpbuf[64];
1884      const char *pv;
1885
1886      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1887
1888      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1889
1890     if (PL_op)
1891         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1892                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1893                     "Argument \"%s\" isn't numeric in %s", pv,
1894                     OP_DESC(PL_op));
1895     else
1896         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1897                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1898                     "Argument \"%s\" isn't numeric", pv);
1899 }
1900
1901 STATIC void
1902 S_not_incrementable(pTHX_ SV *const sv) {
1903      char tmpbuf[64];
1904      const char *pv;
1905
1906      PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1907
1908      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1909
1910      Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1911                  "Argument \"%s\" treated as 0 in increment (++)", pv);
1912 }
1913
1914 /*
1915 =for apidoc looks_like_number
1916
1917 Test if the content of an SV looks like a number (or is a number).
1918 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1919 non-numeric warning), even if your C<atof()> doesn't grok them.  Get-magic is
1920 ignored.
1921
1922 =cut
1923 */
1924
1925 I32
1926 Perl_looks_like_number(pTHX_ SV *const sv)
1927 {
1928     const char *sbegin;
1929     STRLEN len;
1930     int numtype;
1931
1932     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1933
1934     if (SvPOK(sv) || SvPOKp(sv)) {
1935         sbegin = SvPV_nomg_const(sv, len);
1936     }
1937     else
1938         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1939     numtype = grok_number(sbegin, len, NULL);
1940     return ((numtype & IS_NUMBER_TRAILING)) ? 0 : numtype;
1941 }
1942
1943 STATIC bool
1944 S_glob_2number(pTHX_ GV * const gv)
1945 {
1946     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1947
1948     /* We know that all GVs stringify to something that is not-a-number,
1949         so no need to test that.  */
1950     if (ckWARN(WARN_NUMERIC))
1951     {
1952         SV *const buffer = sv_newmortal();
1953         gv_efullname3(buffer, gv, "*");
1954         not_a_number(buffer);
1955     }
1956     /* We just want something true to return, so that S_sv_2iuv_common
1957         can tail call us and return true.  */
1958     return TRUE;
1959 }
1960
1961 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1962    until proven guilty, assume that things are not that bad... */
1963
1964 /*
1965    NV_PRESERVES_UV:
1966
1967    As 64 bit platforms often have an NV that doesn't preserve all bits of
1968    an IV (an assumption perl has been based on to date) it becomes necessary
1969    to remove the assumption that the NV always carries enough precision to
1970    recreate the IV whenever needed, and that the NV is the canonical form.
1971    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1972    precision as a side effect of conversion (which would lead to insanity
1973    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1974    1) to distinguish between IV/UV/NV slots that have a valid conversion cached
1975       where precision was lost, and IV/UV/NV slots that have a valid conversion
1976       which has lost no precision
1977    2) to ensure that if a numeric conversion to one form is requested that
1978       would lose precision, the precise conversion (or differently
1979       imprecise conversion) is also performed and cached, to prevent
1980       requests for different numeric formats on the same SV causing
1981       lossy conversion chains. (lossless conversion chains are perfectly
1982       acceptable (still))
1983
1984
1985    flags are used:
1986    SvIOKp is true if the IV slot contains a valid value
1987    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1988    SvNOKp is true if the NV slot contains a valid value
1989    SvNOK  is true only if the NV value is accurate
1990
1991    so
1992    while converting from PV to NV, check to see if converting that NV to an
1993    IV(or UV) would lose accuracy over a direct conversion from PV to
1994    IV(or UV). If it would, cache both conversions, return NV, but mark
1995    SV as IOK NOKp (ie not NOK).
1996
1997    While converting from PV to IV, check to see if converting that IV to an
1998    NV would lose accuracy over a direct conversion from PV to NV. If it
1999    would, cache both conversions, flag similarly.
2000
2001    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2002    correctly because if IV & NV were set NV *always* overruled.
2003    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2004    changes - now IV and NV together means that the two are interchangeable:
2005    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
2006
2007    The benefit of this is that operations such as pp_add know that if
2008    SvIOK is true for both left and right operands, then integer addition
2009    can be used instead of floating point (for cases where the result won't
2010    overflow). Before, floating point was always used, which could lead to
2011    loss of precision compared with integer addition.
2012
2013    * making IV and NV equal status should make maths accurate on 64 bit
2014      platforms
2015    * may speed up maths somewhat if pp_add and friends start to use
2016      integers when possible instead of fp. (Hopefully the overhead in
2017      looking for SvIOK and checking for overflow will not outweigh the
2018      fp to integer speedup)
2019    * will slow down integer operations (callers of SvIV) on "inaccurate"
2020      values, as the change from SvIOK to SvIOKp will cause a call into
2021      sv_2iv each time rather than a macro access direct to the IV slot
2022    * should speed up number->string conversion on integers as IV is
2023      favoured when IV and NV are equally accurate
2024
2025    ####################################################################
2026    You had better be using SvIOK_notUV if you want an IV for arithmetic:
2027    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2028    On the other hand, SvUOK is true iff UV.
2029    ####################################################################
2030
2031    Your mileage will vary depending your CPU's relative fp to integer
2032    performance ratio.
2033 */
2034
2035 #ifndef NV_PRESERVES_UV
2036 #  define IS_NUMBER_UNDERFLOW_IV 1
2037 #  define IS_NUMBER_UNDERFLOW_UV 2
2038 #  define IS_NUMBER_IV_AND_UV    2
2039 #  define IS_NUMBER_OVERFLOW_IV  4
2040 #  define IS_NUMBER_OVERFLOW_UV  5
2041
2042 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2043
2044 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
2045 STATIC int
2046 S_sv_2iuv_non_preserve(pTHX_ SV *const sv
2047 #  ifdef DEBUGGING
2048                        , I32 numtype
2049 #  endif
2050                        )
2051 {
2052     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
2053     PERL_UNUSED_CONTEXT;
2054
2055     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));
2056     if (SvNVX(sv) < (NV)IV_MIN) {
2057         (void)SvIOKp_on(sv);
2058         (void)SvNOK_on(sv);
2059         SvIV_set(sv, IV_MIN);
2060         return IS_NUMBER_UNDERFLOW_IV;
2061     }
2062     if (SvNVX(sv) > (NV)UV_MAX) {
2063         (void)SvIOKp_on(sv);
2064         (void)SvNOK_on(sv);
2065         SvIsUV_on(sv);
2066         SvUV_set(sv, UV_MAX);
2067         return IS_NUMBER_OVERFLOW_UV;
2068     }
2069     (void)SvIOKp_on(sv);
2070     (void)SvNOK_on(sv);
2071     /* Can't use strtol etc to convert this string.  (See truth table in
2072        sv_2iv  */
2073     if (SvNVX(sv) <= (UV)IV_MAX) {
2074         SvIV_set(sv, I_V(SvNVX(sv)));
2075         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2076             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2077         } else {
2078             /* Integer is imprecise. NOK, IOKp */
2079         }
2080         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2081     }
2082     SvIsUV_on(sv);
2083     SvUV_set(sv, U_V(SvNVX(sv)));
2084     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2085         if (SvUVX(sv) == UV_MAX) {
2086             /* As we know that NVs don't preserve UVs, UV_MAX cannot
2087                possibly be preserved by NV. Hence, it must be overflow.
2088                NOK, IOKp */
2089             return IS_NUMBER_OVERFLOW_UV;
2090         }
2091         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2092     } else {
2093         /* Integer is imprecise. NOK, IOKp */
2094     }
2095     return IS_NUMBER_OVERFLOW_IV;
2096 }
2097 #endif /* !NV_PRESERVES_UV*/
2098
2099 /* If numtype is infnan, set the NV of the sv accordingly.
2100  * If numtype is anything else, try setting the NV using Atof(PV). */
2101 static void
2102 S_sv_setnv(pTHX_ SV* sv, int numtype)
2103 {
2104     bool pok = cBOOL(SvPOK(sv));
2105     bool nok = FALSE;
2106 #ifdef NV_INF
2107     if ((numtype & IS_NUMBER_INFINITY)) {
2108         SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
2109         nok = TRUE;
2110     } else
2111 #endif
2112 #ifdef NV_NAN
2113     if ((numtype & IS_NUMBER_NAN)) {
2114         SvNV_set(sv, NV_NAN);
2115         nok = TRUE;
2116     } else
2117 #endif
2118     if (pok) {
2119         SvNV_set(sv, Atof(SvPVX_const(sv)));
2120         /* Purposefully no true nok here, since we don't want to blow
2121          * away the possible IOK/UV of an existing sv. */
2122     }
2123     if (nok) {
2124         SvNOK_only(sv); /* No IV or UV please, this is pure infnan. */
2125         if (pok)
2126             SvPOK_on(sv); /* PV is okay, though. */
2127     }
2128 }
2129
2130 STATIC bool
2131 S_sv_2iuv_common(pTHX_ SV *const sv)
2132 {
2133     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2134
2135     if (SvNOKp(sv)) {
2136         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2137          * without also getting a cached IV/UV from it at the same time
2138          * (ie PV->NV conversion should detect loss of accuracy and cache
2139          * IV or UV at same time to avoid this. */
2140         /* IV-over-UV optimisation - choose to cache IV if possible */
2141
2142         if (SvTYPE(sv) == SVt_NV)
2143             sv_upgrade(sv, SVt_PVNV);
2144
2145         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2146         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2147            certainly cast into the IV range at IV_MAX, whereas the correct
2148            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2149            cases go to UV */
2150 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2151         if (Perl_isnan(SvNVX(sv))) {
2152             SvUV_set(sv, 0);
2153             SvIsUV_on(sv);
2154             return FALSE;
2155         }
2156 #endif
2157         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2158             SvIV_set(sv, I_V(SvNVX(sv)));
2159             if (SvNVX(sv) == (NV) SvIVX(sv)
2160 #ifndef NV_PRESERVES_UV
2161                 && SvIVX(sv) != IV_MIN /* avoid negating IV_MIN below */
2162                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2163                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2164                 /* Don't flag it as "accurately an integer" if the number
2165                    came from a (by definition imprecise) NV operation, and
2166                    we're outside the range of NV integer precision */
2167 #endif
2168                 ) {
2169                 if (SvNOK(sv))
2170                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2171                 else {
2172                     /* scalar has trailing garbage, eg "42a" */
2173                 }
2174                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2175                                       "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (precise)\n",
2176                                       PTR2UV(sv),
2177                                       SvNVX(sv),
2178                                       SvIVX(sv)));
2179
2180             } else {
2181                 /* IV not precise.  No need to convert from PV, as NV
2182                    conversion would already have cached IV if it detected
2183                    that PV->IV would be better than PV->NV->IV
2184                    flags already correct - don't set public IOK.  */
2185                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2186                                       "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (imprecise)\n",
2187                                       PTR2UV(sv),
2188                                       SvNVX(sv),
2189                                       SvIVX(sv)));
2190             }
2191             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2192                but the cast (NV)IV_MIN rounds to a the value less (more
2193                negative) than IV_MIN which happens to be equal to SvNVX ??
2194                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2195                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2196                (NV)UVX == NVX are both true, but the values differ. :-(
2197                Hopefully for 2s complement IV_MIN is something like
2198                0x8000000000000000 which will be exact. NWC */
2199         }
2200         else {
2201             SvUV_set(sv, U_V(SvNVX(sv)));
2202             if (
2203                 (SvNVX(sv) == (NV) SvUVX(sv))
2204 #ifndef  NV_PRESERVES_UV
2205                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2206                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2207                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2208                 /* Don't flag it as "accurately an integer" if the number
2209                    came from a (by definition imprecise) NV operation, and
2210                    we're outside the range of NV integer precision */
2211 #endif
2212                 && SvNOK(sv)
2213                 )
2214                 SvIOK_on(sv);
2215             SvIsUV_on(sv);
2216             DEBUG_c(PerlIO_printf(Perl_debug_log,
2217                                   "0x%" UVxf " 2iv(%" UVuf " => %" IVdf ") (as unsigned)\n",
2218                                   PTR2UV(sv),
2219                                   SvUVX(sv),
2220                                   SvUVX(sv)));
2221         }
2222     }
2223     else if (SvPOKp(sv)) {
2224         UV value;
2225         int numtype;
2226         const char *s = SvPVX_const(sv);
2227         const STRLEN cur = SvCUR(sv);
2228
2229         /* short-cut for a single digit string like "1" */
2230
2231         if (cur == 1) {
2232             char c = *s;
2233             if (isDIGIT(c)) {
2234                 if (SvTYPE(sv) < SVt_PVIV)
2235                     sv_upgrade(sv, SVt_PVIV);
2236                 (void)SvIOK_on(sv);
2237                 SvIV_set(sv, (IV)(c - '0'));
2238                 return FALSE;
2239             }
2240         }
2241
2242         numtype = grok_number(s, cur, &value);
2243         /* We want to avoid a possible problem when we cache an IV/ a UV which
2244            may be later translated to an NV, and the resulting NV is not
2245            the same as the direct translation of the initial string
2246            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2247            be careful to ensure that the value with the .456 is around if the
2248            NV value is requested in the future).
2249         
2250            This means that if we cache such an IV/a UV, we need to cache the
2251            NV as well.  Moreover, we trade speed for space, and do not
2252            cache the NV if we are sure it's not needed.
2253          */
2254
2255         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2256         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2257              == IS_NUMBER_IN_UV) {
2258             /* It's definitely an integer, only upgrade to PVIV */
2259             if (SvTYPE(sv) < SVt_PVIV)
2260                 sv_upgrade(sv, SVt_PVIV);
2261             (void)SvIOK_on(sv);
2262         } else if (SvTYPE(sv) < SVt_PVNV)
2263             sv_upgrade(sv, SVt_PVNV);
2264
2265         if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
2266             if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING)))
2267                 not_a_number(sv);
2268             S_sv_setnv(aTHX_ sv, numtype);
2269             return FALSE;
2270         }
2271
2272         /* If NVs preserve UVs then we only use the UV value if we know that
2273            we aren't going to call atof() below. If NVs don't preserve UVs
2274            then the value returned may have more precision than atof() will
2275            return, even though value isn't perfectly accurate.  */
2276         if ((numtype & (IS_NUMBER_IN_UV
2277 #ifdef NV_PRESERVES_UV
2278                         | IS_NUMBER_NOT_INT
2279 #endif
2280             )) == IS_NUMBER_IN_UV) {
2281             /* This won't turn off the public IOK flag if it was set above  */
2282             (void)SvIOKp_on(sv);
2283
2284             if (!(numtype & IS_NUMBER_NEG)) {
2285                 /* positive */;
2286                 if (value <= (UV)IV_MAX) {
2287                     SvIV_set(sv, (IV)value);
2288                 } else {
2289                     /* it didn't overflow, and it was positive. */
2290                     SvUV_set(sv, value);
2291                     SvIsUV_on(sv);
2292                 }
2293             } else {
2294                 /* 2s complement assumption  */
2295                 if (value <= (UV)IV_MIN) {
2296                     SvIV_set(sv, value == (UV)IV_MIN
2297                                     ? IV_MIN : -(IV)value);
2298                 } else {
2299                     /* Too negative for an IV.  This is a double upgrade, but
2300                        I'm assuming it will be rare.  */
2301                     if (SvTYPE(sv) < SVt_PVNV)
2302                         sv_upgrade(sv, SVt_PVNV);
2303                     SvNOK_on(sv);
2304                     SvIOK_off(sv);
2305                     SvIOKp_on(sv);
2306                     SvNV_set(sv, -(NV)value);
2307                     SvIV_set(sv, IV_MIN);
2308                 }
2309             }
2310         }
2311         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2312            will be in the previous block to set the IV slot, and the next
2313            block to set the NV slot.  So no else here.  */
2314         
2315         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2316             != IS_NUMBER_IN_UV) {
2317             /* It wasn't an (integer that doesn't overflow the UV). */
2318             S_sv_setnv(aTHX_ sv, numtype);
2319
2320             if (! numtype && ckWARN(WARN_NUMERIC))
2321                 not_a_number(sv);
2322
2323             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" NVgf ")\n",
2324                                   PTR2UV(sv), SvNVX(sv)));
2325
2326 #ifdef NV_PRESERVES_UV
2327             (void)SvIOKp_on(sv);
2328             (void)SvNOK_on(sv);
2329 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2330             if (Perl_isnan(SvNVX(sv))) {
2331                 SvUV_set(sv, 0);
2332                 SvIsUV_on(sv);
2333                 return FALSE;
2334             }
2335 #endif
2336             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2337                 SvIV_set(sv, I_V(SvNVX(sv)));
2338                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2339                     SvIOK_on(sv);
2340                 } else {
2341                     NOOP;  /* Integer is imprecise. NOK, IOKp */
2342                 }
2343                 /* UV will not work better than IV */
2344             } else {
2345                 if (SvNVX(sv) > (NV)UV_MAX) {
2346                     SvIsUV_on(sv);
2347                     /* Integer is inaccurate. NOK, IOKp, is UV */
2348                     SvUV_set(sv, UV_MAX);
2349                 } else {
2350                     SvUV_set(sv, U_V(SvNVX(sv)));
2351                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2352                        NV preservse UV so can do correct comparison.  */
2353                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2354                         SvIOK_on(sv);
2355                     } else {
2356                         NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
2357                     }
2358                 }
2359                 SvIsUV_on(sv);
2360             }
2361 #else /* NV_PRESERVES_UV */
2362             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2363                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2364                 /* The IV/UV slot will have been set from value returned by
2365                    grok_number above.  The NV slot has just been set using
2366                    Atof.  */
2367                 SvNOK_on(sv);
2368                 assert (SvIOKp(sv));
2369             } else {
2370                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2371                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2372                     /* Small enough to preserve all bits. */
2373                     (void)SvIOKp_on(sv);
2374                     SvNOK_on(sv);
2375                     SvIV_set(sv, I_V(SvNVX(sv)));
2376                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2377                         SvIOK_on(sv);
2378                     /* Assumption: first non-preserved integer is < IV_MAX,
2379                        this NV is in the preserved range, therefore: */
2380                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2381                           < (UV)IV_MAX)) {
2382                         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);
2383                     }
2384                 } else {
2385                     /* IN_UV NOT_INT
2386                          0      0       already failed to read UV.
2387                          0      1       already failed to read UV.
2388                          1      0       you won't get here in this case. IV/UV
2389                                         slot set, public IOK, Atof() unneeded.
2390                          1      1       already read UV.
2391                        so there's no point in sv_2iuv_non_preserve() attempting
2392                        to use atol, strtol, strtoul etc.  */
2393 #  ifdef DEBUGGING
2394                     sv_2iuv_non_preserve (sv, numtype);
2395 #  else
2396                     sv_2iuv_non_preserve (sv);
2397 #  endif
2398                 }
2399             }
2400 #endif /* NV_PRESERVES_UV */
2401         /* It might be more code efficient to go through the entire logic above
2402            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2403            gets complex and potentially buggy, so more programmer efficient
2404            to do it this way, by turning off the public flags:  */
2405         if (!numtype)
2406             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2407         }
2408     }
2409     else {
2410         if (isGV_with_GP(sv))
2411             return glob_2number(MUTABLE_GV(sv));
2412
2413         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2414                 report_uninit(sv);
2415         if (SvTYPE(sv) < SVt_IV)
2416             /* Typically the caller expects that sv_any is not NULL now.  */
2417             sv_upgrade(sv, SVt_IV);
2418         /* Return 0 from the caller.  */
2419         return TRUE;
2420     }
2421     return FALSE;
2422 }
2423
2424 /*
2425 =for apidoc sv_2iv_flags
2426
2427 Return the integer value of an SV, doing any necessary string
2428 conversion.  If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2429 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2430
2431 =cut
2432 */
2433
2434 IV
2435 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2436 {
2437     PERL_ARGS_ASSERT_SV_2IV_FLAGS;
2438
2439     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2440          && SvTYPE(sv) != SVt_PVFM);
2441
2442     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2443         mg_get(sv);
2444
2445     if (SvROK(sv)) {
2446         if (SvAMAGIC(sv)) {
2447             SV * tmpstr;
2448             if (flags & SV_SKIP_OVERLOAD)
2449                 return 0;
2450             tmpstr = AMG_CALLunary(sv, numer_amg);
2451             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2452                 return SvIV(tmpstr);
2453             }
2454         }
2455         return PTR2IV(SvRV(sv));
2456     }
2457
2458     if (SvVALID(sv) || isREGEXP(sv)) {
2459         /* FBMs use the space for SvIVX and SvNVX for other purposes, so
2460            must not let them cache IVs.
2461            In practice they are extremely unlikely to actually get anywhere
2462            accessible by user Perl code - the only way that I'm aware of is when
2463            a constant subroutine which is used as the second argument to index.
2464
2465            Regexps have no SvIVX and SvNVX fields.
2466         */
2467         assert(SvPOKp(sv));
2468         {
2469             UV value;
2470             const char * const ptr =
2471                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2472             const int numtype
2473                 = grok_number(ptr, SvCUR(sv), &value);
2474
2475             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2476                 == IS_NUMBER_IN_UV) {
2477                 /* It's definitely an integer */
2478                 if (numtype & IS_NUMBER_NEG) {
2479                     if (value < (UV)IV_MIN)
2480                         return -(IV)value;
2481                 } else {
2482                     if (value < (UV)IV_MAX)
2483                         return (IV)value;
2484                 }
2485             }
2486
2487             /* Quite wrong but no good choices. */
2488             if ((numtype & IS_NUMBER_INFINITY)) {
2489                 return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX;
2490             } else if ((numtype & IS_NUMBER_NAN)) {
2491                 return 0; /* So wrong. */
2492             }
2493
2494             if (!numtype) {
2495                 if (ckWARN(WARN_NUMERIC))
2496                     not_a_number(sv);
2497             }
2498             return I_V(Atof(ptr));
2499         }
2500     }
2501
2502     if (SvTHINKFIRST(sv)) {
2503         if (SvREADONLY(sv) && !SvOK(sv)) {
2504             if (ckWARN(WARN_UNINITIALIZED))
2505                 report_uninit(sv);
2506             return 0;
2507         }
2508     }
2509
2510     if (!SvIOKp(sv)) {
2511         if (S_sv_2iuv_common(aTHX_ sv))
2512             return 0;
2513     }
2514
2515     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" IVdf ")\n",
2516         PTR2UV(sv),SvIVX(sv)));
2517     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2518 }
2519
2520 /*
2521 =for apidoc sv_2uv_flags
2522
2523 Return the unsigned integer value of an SV, doing any necessary string
2524 conversion.  If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2525 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2526
2527 =for apidoc Amnh||SV_GMAGIC
2528
2529 =cut
2530 */
2531
2532 UV
2533 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2534 {
2535     PERL_ARGS_ASSERT_SV_2UV_FLAGS;
2536
2537     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2538         mg_get(sv);
2539
2540     if (SvROK(sv)) {
2541         if (SvAMAGIC(sv)) {
2542             SV *tmpstr;
2543             if (flags & SV_SKIP_OVERLOAD)
2544                 return 0;
2545             tmpstr = AMG_CALLunary(sv, numer_amg);
2546             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2547                 return SvUV(tmpstr);
2548             }
2549         }
2550         return PTR2UV(SvRV(sv));
2551     }
2552
2553     if (SvVALID(sv) || isREGEXP(sv)) {
2554         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2555            the same flag bit as SVf_IVisUV, so must not let them cache IVs.  
2556            Regexps have no SvIVX and SvNVX fields. */
2557         assert(SvPOKp(sv));
2558         {
2559             UV value;
2560             const char * const ptr =
2561                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2562             const int numtype
2563                 = grok_number(ptr, SvCUR(sv), &value);
2564
2565             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2566                 == IS_NUMBER_IN_UV) {
2567                 /* It's definitely an integer */
2568                 if (!(numtype & IS_NUMBER_NEG))
2569                     return value;
2570             }
2571
2572             /* Quite wrong but no good choices. */
2573             if ((numtype & IS_NUMBER_INFINITY)) {
2574                 return UV_MAX; /* So wrong. */
2575             } else if ((numtype & IS_NUMBER_NAN)) {
2576                 return 0; /* So wrong. */
2577             }
2578
2579             if (!numtype) {
2580                 if (ckWARN(WARN_NUMERIC))
2581                     not_a_number(sv);
2582             }
2583             return U_V(Atof(ptr));
2584         }
2585     }
2586
2587     if (SvTHINKFIRST(sv)) {
2588         if (SvREADONLY(sv) && !SvOK(sv)) {
2589             if (ckWARN(WARN_UNINITIALIZED))
2590                 report_uninit(sv);
2591             return 0;
2592         }
2593     }
2594
2595     if (!SvIOKp(sv)) {
2596         if (S_sv_2iuv_common(aTHX_ sv))
2597             return 0;
2598     }
2599
2600     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2uv(%" UVuf ")\n",
2601                           PTR2UV(sv),SvUVX(sv)));
2602     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2603 }
2604
2605 /*
2606 =for apidoc sv_2nv_flags
2607
2608 Return the num value of an SV, doing any necessary string or integer
2609 conversion.  If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2610 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2611
2612 =cut
2613 */
2614
2615 NV
2616 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2617 {
2618     PERL_ARGS_ASSERT_SV_2NV_FLAGS;
2619
2620     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2621          && SvTYPE(sv) != SVt_PVFM);
2622     if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
2623         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2624            the same flag bit as SVf_IVisUV, so must not let them cache NVs.
2625            Regexps have no SvIVX and SvNVX fields.  */
2626         const char *ptr;
2627         if (flags & SV_GMAGIC)
2628             mg_get(sv);
2629         if (SvNOKp(sv))
2630             return SvNVX(sv);
2631         if (SvPOKp(sv) && !SvIOKp(sv)) {
2632             ptr = SvPVX_const(sv);
2633             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2634                 !grok_number(ptr, SvCUR(sv), NULL))
2635                 not_a_number(sv);
2636             return Atof(ptr);
2637         }
2638         if (SvIOKp(sv)) {
2639             if (SvIsUV(sv))
2640                 return (NV)SvUVX(sv);
2641             else
2642                 return (NV)SvIVX(sv);
2643         }
2644         if (SvROK(sv)) {
2645             goto return_rok;
2646         }
2647         assert(SvTYPE(sv) >= SVt_PVMG);
2648         /* This falls through to the report_uninit near the end of the
2649            function. */
2650     } else if (SvTHINKFIRST(sv)) {
2651         if (SvROK(sv)) {
2652         return_rok:
2653             if (SvAMAGIC(sv)) {
2654                 SV *tmpstr;
2655                 if (flags & SV_SKIP_OVERLOAD)
2656                     return 0;
2657                 tmpstr = AMG_CALLunary(sv, numer_amg);
2658                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2659                     return SvNV(tmpstr);
2660                 }
2661             }
2662             return PTR2NV(SvRV(sv));
2663         }
2664         if (SvREADONLY(sv) && !SvOK(sv)) {
2665             if (ckWARN(WARN_UNINITIALIZED))
2666                 report_uninit(sv);
2667             return 0.0;
2668         }
2669     }
2670     if (SvTYPE(sv) < SVt_NV) {
2671         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2672         sv_upgrade(sv, SVt_NV);
2673         CLANG_DIAG_IGNORE_STMT(-Wthread-safety);
2674         DEBUG_c({
2675             DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2676             STORE_LC_NUMERIC_SET_STANDARD();
2677             PerlIO_printf(Perl_debug_log,
2678                           "0x%" UVxf " num(%" NVgf ")\n",
2679                           PTR2UV(sv), SvNVX(sv));
2680             RESTORE_LC_NUMERIC();
2681         });
2682         CLANG_DIAG_RESTORE_STMT;
2683
2684     }
2685     else if (SvTYPE(sv) < SVt_PVNV)
2686         sv_upgrade(sv, SVt_PVNV);
2687     if (SvNOKp(sv)) {
2688         return SvNVX(sv);
2689     }
2690     if (SvIOKp(sv)) {
2691         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2692 #ifdef NV_PRESERVES_UV
2693         if (SvIOK(sv))
2694             SvNOK_on(sv);
2695         else
2696             SvNOKp_on(sv);
2697 #else
2698         /* Only set the public NV OK flag if this NV preserves the IV  */
2699         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2700         if (SvIOK(sv) &&
2701             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2702                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2703             SvNOK_on(sv);
2704         else
2705             SvNOKp_on(sv);
2706 #endif
2707     }
2708     else if (SvPOKp(sv)) {
2709         UV value;
2710         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2711         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2712             not_a_number(sv);
2713 #ifdef NV_PRESERVES_UV
2714         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2715             == IS_NUMBER_IN_UV) {
2716             /* It's definitely an integer */
2717             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2718         } else {
2719             S_sv_setnv(aTHX_ sv, numtype);
2720         }
2721         if (numtype)
2722             SvNOK_on(sv);
2723         else
2724             SvNOKp_on(sv);
2725 #else
2726         SvNV_set(sv, Atof(SvPVX_const(sv)));
2727         /* Only set the public NV OK flag if this NV preserves the value in
2728            the PV at least as well as an IV/UV would.
2729            Not sure how to do this 100% reliably. */
2730         /* if that shift count is out of range then Configure's test is
2731            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2732            UV_BITS */
2733         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2734             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2735             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2736         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2737             /* Can't use strtol etc to convert this string, so don't try.
2738                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2739             SvNOK_on(sv);
2740         } else {
2741             /* value has been set.  It may not be precise.  */
2742             if ((numtype & IS_NUMBER_NEG) && (value >= (UV)IV_MIN)) {
2743                 /* 2s complement assumption for (UV)IV_MIN  */
2744                 SvNOK_on(sv); /* Integer is too negative.  */
2745             } else {
2746                 SvNOKp_on(sv);
2747                 SvIOKp_on(sv);
2748
2749                 if (numtype & IS_NUMBER_NEG) {
2750                     /* -IV_MIN is undefined, but we should never reach
2751                      * this point with both IS_NUMBER_NEG and value ==
2752                      * (UV)IV_MIN */
2753                     assert(value != (UV)IV_MIN);
2754                     SvIV_set(sv, -(IV)value);
2755                 } else if (value <= (UV)IV_MAX) {
2756                     SvIV_set(sv, (IV)value);
2757                 } else {
2758                     SvUV_set(sv, value);
2759                     SvIsUV_on(sv);
2760                 }
2761
2762                 if (numtype & IS_NUMBER_NOT_INT) {
2763                     /* I believe that even if the original PV had decimals,
2764                        they are lost beyond the limit of the FP precision.
2765                        However, neither is canonical, so both only get p
2766                        flags.  NWC, 2000/11/25 */
2767                     /* Both already have p flags, so do nothing */
2768                 } else {
2769                     const NV nv = SvNVX(sv);
2770                     /* XXX should this spot have NAN_COMPARE_BROKEN, too? */
2771                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2772                         if (SvIVX(sv) == I_V(nv)) {
2773                             SvNOK_on(sv);
2774                         } else {
2775                             /* It had no "." so it must be integer.  */
2776                         }
2777                         SvIOK_on(sv);
2778                     } else {
2779                         /* between IV_MAX and NV(UV_MAX).
2780                            Could be slightly > UV_MAX */
2781
2782                         if (numtype & IS_NUMBER_NOT_INT) {
2783                             /* UV and NV both imprecise.  */
2784                         } else {
2785                             const UV nv_as_uv = U_V(nv);
2786
2787                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2788                                 SvNOK_on(sv);
2789                             }
2790                             SvIOK_on(sv);
2791                         }
2792                     }
2793                 }
2794             }
2795         }
2796         /* It might be more code efficient to go through the entire logic above
2797            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2798            gets complex and potentially buggy, so more programmer efficient
2799            to do it this way, by turning off the public flags:  */
2800         if (!numtype)
2801             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2802 #endif /* NV_PRESERVES_UV */
2803     }
2804     else {
2805         if (isGV_with_GP(sv)) {
2806             glob_2number(MUTABLE_GV(sv));
2807             return 0.0;
2808         }
2809
2810         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2811             report_uninit(sv);
2812         assert (SvTYPE(sv) >= SVt_NV);
2813         /* Typically the caller expects that sv_any is not NULL now.  */
2814         /* XXX Ilya implies that this is a bug in callers that assume this
2815            and ideally should be fixed.  */
2816         return 0.0;
2817     }
2818     CLANG_DIAG_IGNORE_STMT(-Wthread-safety);
2819     DEBUG_c({
2820         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2821         STORE_LC_NUMERIC_SET_STANDARD();
2822         PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2nv(%" NVgf ")\n",
2823                       PTR2UV(sv), SvNVX(sv));
2824         RESTORE_LC_NUMERIC();
2825     });
2826     CLANG_DIAG_RESTORE_STMT;
2827     return SvNVX(sv);
2828 }
2829
2830 /*
2831 =for apidoc sv_2num
2832
2833 Return an SV with the numeric value of the source SV, doing any necessary
2834 reference or overload conversion.  The caller is expected to have handled
2835 get-magic already.
2836
2837 =cut
2838 */
2839
2840 SV *
2841 Perl_sv_2num(pTHX_ SV *const sv)
2842 {
2843     PERL_ARGS_ASSERT_SV_2NUM;
2844
2845     if (!SvROK(sv))
2846         return sv;
2847     if (SvAMAGIC(sv)) {
2848         SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2849         TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2850         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2851             return sv_2num(tmpsv);
2852     }
2853     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2854 }
2855
2856 /* int2str_table: lookup table containing string representations of all
2857  * two digit numbers. For example, int2str_table.arr[0] is "00" and
2858  * int2str_table.arr[12*2] is "12".
2859  *
2860  * We are going to read two bytes at a time, so we have to ensure that
2861  * the array is aligned to a 2 byte boundary. That's why it was made a
2862  * union with a dummy U16 member. */
2863 static const union {
2864     char arr[200];
2865     U16 dummy;
2866 } int2str_table = {{
2867     '0', '0', '0', '1', '0', '2', '0', '3', '0', '4', '0', '5', '0', '6',
2868     '0', '7', '0', '8', '0', '9', '1', '0', '1', '1', '1', '2', '1', '3',
2869     '1', '4', '1', '5', '1', '6', '1', '7', '1', '8', '1', '9', '2', '0',
2870     '2', '1', '2', '2', '2', '3', '2', '4', '2', '5', '2', '6', '2', '7',
2871     '2', '8', '2', '9', '3', '0', '3', '1', '3', '2', '3', '3', '3', '4',
2872     '3', '5', '3', '6', '3', '7', '3', '8', '3', '9', '4', '0', '4', '1',
2873     '4', '2', '4', '3', '4', '4', '4', '5', '4', '6', '4', '7', '4', '8',
2874     '4', '9', '5', '0', '5', '1', '5', '2', '5', '3', '5', '4', '5', '5',
2875     '5', '6', '5', '7', '5', '8', '5', '9', '6', '0', '6', '1', '6', '2',
2876     '6', '3', '6', '4', '6', '5', '6', '6', '6', '7', '6', '8', '6', '9',
2877     '7', '0', '7', '1', '7', '2', '7', '3', '7', '4', '7', '5', '7', '6',
2878     '7', '7', '7', '8', '7', '9', '8', '0', '8', '1', '8', '2', '8', '3',
2879     '8', '4', '8', '5', '8', '6', '8', '7', '8', '8', '8', '9', '9', '0',
2880     '9', '1', '9', '2', '9', '3', '9', '4', '9', '5', '9', '6', '9', '7',
2881     '9', '8', '9', '9'
2882 }};
2883
2884 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2885  * UV as a string towards the end of buf, and return pointers to start and
2886  * end of it.
2887  *
2888  * We assume that buf is at least TYPE_CHARS(UV) long.
2889  */
2890
2891 PERL_STATIC_INLINE char *
2892 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2893 {
2894     char *ptr = buf + TYPE_CHARS(UV);
2895     char * const ebuf = ptr;
2896     int sign;
2897     U16 *word_ptr, *word_table;
2898
2899     PERL_ARGS_ASSERT_UIV_2BUF;
2900
2901     /* ptr has to be properly aligned, because we will cast it to U16* */
2902     assert(PTR2nat(ptr) % 2 == 0);
2903     /* we are going to read/write two bytes at a time */
2904     word_ptr = (U16*)ptr;
2905     word_table = (U16*)int2str_table.arr;
2906
2907     if (UNLIKELY(is_uv))
2908         sign = 0;
2909     else if (iv >= 0) {
2910         uv = iv;
2911         sign = 0;
2912     } else {
2913         /* Using 0- here to silence bogus warning from MS VC */
2914         uv = (UV) (0 - (UV) iv);
2915         sign = 1;
2916     }
2917
2918     while (uv > 99) {
2919         *--word_ptr = word_table[uv % 100];
2920         uv /= 100;
2921     }
2922     ptr = (char*)word_ptr;
2923
2924     if (uv < 10)
2925         *--ptr = (char)uv + '0';
2926     else {
2927         *--word_ptr = word_table[uv];
2928         ptr = (char*)word_ptr;
2929     }
2930
2931     if (sign)
2932         *--ptr = '-';
2933
2934     *peob = ebuf;
2935     return ptr;
2936 }
2937
2938 /* Helper for sv_2pv_flags and sv_vcatpvfn_flags.  If the NV is an
2939  * infinity or a not-a-number, writes the appropriate strings to the
2940  * buffer, including a zero byte.  On success returns the written length,
2941  * excluding the zero byte, on failure (not an infinity, not a nan)
2942  * returns zero, assert-fails on maxlen being too short.
2943  *
2944  * XXX for "Inf", "-Inf", and "NaN", we could have three read-only
2945  * shared string constants we point to, instead of generating a new
2946  * string for each instance. */
2947 STATIC size_t
2948 S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char plus) {
2949     char* s = buffer;
2950     assert(maxlen >= 4);
2951     if (Perl_isinf(nv)) {
2952         if (nv < 0) {
2953             if (maxlen < 5) /* "-Inf\0"  */
2954                 return 0;
2955             *s++ = '-';
2956         } else if (plus) {
2957             *s++ = '+';
2958         }
2959         *s++ = 'I';
2960         *s++ = 'n';
2961         *s++ = 'f';
2962     }
2963     else if (Perl_isnan(nv)) {
2964         *s++ = 'N';
2965         *s++ = 'a';
2966         *s++ = 'N';
2967         /* XXX optionally output the payload mantissa bits as
2968          * "(unsigned)" (to match the nan("...") C99 function,
2969          * or maybe as "(0xhhh...)"  would make more sense...
2970          * provide a format string so that the user can decide?
2971          * NOTE: would affect the maxlen and assert() logic.*/
2972     }
2973     else {
2974       return 0;
2975     }
2976     assert((s == buffer + 3) || (s == buffer + 4));
2977     *s = 0;
2978     return s - buffer;
2979 }
2980
2981 /*
2982 =for apidoc sv_2pv_flags
2983
2984 Returns a pointer to the string value of an SV, and sets C<*lp> to its length.
2985 If flags has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.  Coerces C<sv> to a
2986 string if necessary.  Normally invoked via the C<SvPV_flags> macro.
2987 C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
2988
2989 =cut
2990 */
2991
2992 char *
2993 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
2994 {
2995     char *s;
2996
2997     PERL_ARGS_ASSERT_SV_2PV_FLAGS;
2998
2999     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
3000          && SvTYPE(sv) != SVt_PVFM);
3001     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
3002         mg_get(sv);
3003     if (SvROK(sv)) {
3004         if (SvAMAGIC(sv)) {
3005             SV *tmpstr;
3006             if (flags & SV_SKIP_OVERLOAD)
3007                 return NULL;
3008             tmpstr = AMG_CALLunary(sv, string_amg);
3009             TAINT_IF(tmpstr && SvTAINTED(tmpstr));
3010             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3011                 /* Unwrap this:  */
3012                 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
3013                  */
3014
3015                 char *pv;
3016                 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
3017                     if (flags & SV_CONST_RETURN) {
3018                         pv = (char *) SvPVX_const(tmpstr);
3019                     } else {
3020                         pv = (flags & SV_MUTABLE_RETURN)
3021                             ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
3022                     }
3023                     if (lp)
3024                         *lp = SvCUR(tmpstr);
3025                 } else {
3026                     pv = sv_2pv_flags(tmpstr, lp, flags);
3027                 }
3028                 if (SvUTF8(tmpstr))
3029                     SvUTF8_on(sv);
3030                 else
3031                     SvUTF8_off(sv);
3032                 return pv;
3033             }
3034         }
3035         {
3036             STRLEN len;
3037             char *retval;
3038             char *buffer;
3039             SV *const referent = SvRV(sv);
3040
3041             if (!referent) {
3042                 len = 7;
3043                 retval = buffer = savepvn("NULLREF", len);
3044             } else if (SvTYPE(referent) == SVt_REGEXP &&
3045                        (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
3046                         amagic_is_enabled(string_amg))) {
3047                 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
3048
3049                 assert(re);
3050                         
3051                 /* If the regex is UTF-8 we want the containing scalar to
3052                    have an UTF-8 flag too */
3053                 if (RX_UTF8(re))
3054                     SvUTF8_on(sv);
3055                 else
3056                     SvUTF8_off(sv);     
3057
3058                 if (lp)
3059                     *lp = RX_WRAPLEN(re);
3060  
3061                 return RX_WRAPPED(re);
3062             } else {
3063                 const char *const typestr = sv_reftype(referent, 0);
3064                 const STRLEN typelen = strlen(typestr);
3065                 UV addr = PTR2UV(referent);
3066                 const char *stashname = NULL;
3067                 STRLEN stashnamelen = 0; /* hush, gcc */
3068                 const char *buffer_end;
3069
3070                 if (SvOBJECT(referent)) {
3071                     const HEK *const name = HvNAME_HEK(SvSTASH(referent));
3072
3073                     if (name) {
3074                         stashname = HEK_KEY(name);
3075                         stashnamelen = HEK_LEN(name);
3076
3077                         if (HEK_UTF8(name)) {
3078                             SvUTF8_on(sv);
3079                         } else {
3080                             SvUTF8_off(sv);
3081                         }
3082                     } else {
3083                         stashname = "__ANON__";
3084                         stashnamelen = 8;
3085                     }
3086                     len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
3087                         + 2 * sizeof(UV) + 2 /* )\0 */;
3088                 } else {
3089                     len = typelen + 3 /* (0x */
3090                         + 2 * sizeof(UV) + 2 /* )\0 */;
3091                 }
3092
3093                 Newx(buffer, len, char);
3094                 buffer_end = retval = buffer + len;
3095
3096                 /* Working backwards  */
3097                 *--retval = '\0';
3098                 *--retval = ')';
3099                 do {
3100                     *--retval = PL_hexdigit[addr & 15];
3101                 } while (addr >>= 4);
3102                 *--retval = 'x';
3103                 *--retval = '0';
3104                 *--retval = '(';
3105
3106                 retval -= typelen;
3107                 memcpy(retval, typestr, typelen);
3108
3109                 if (stashname) {
3110                     *--retval = '=';
3111                     retval -= stashnamelen;
3112                     memcpy(retval, stashname, stashnamelen);
3113                 }
3114                 /* retval may not necessarily have reached the start of the
3115                    buffer here.  */
3116                 assert (retval >= buffer);
3117
3118                 len = buffer_end - retval - 1; /* -1 for that \0  */
3119             }
3120             if (lp)
3121                 *lp = len;
3122             SAVEFREEPV(buffer);
3123             return retval;
3124         }
3125     }
3126
3127     if (SvPOKp(sv)) {
3128         if (lp)
3129             *lp = SvCUR(sv);
3130         if (flags & SV_MUTABLE_RETURN)
3131             return SvPVX_mutable(sv);
3132         if (flags & SV_CONST_RETURN)
3133             return (char *)SvPVX_const(sv);
3134         return SvPVX(sv);
3135     }
3136
3137     if (SvIOK(sv)) {
3138         /* I'm assuming that if both IV and NV are equally valid then
3139            converting the IV is going to be more efficient */
3140         const U32 isUIOK = SvIsUV(sv);
3141         /* The purpose of this union is to ensure that arr is aligned on
3142            a 2 byte boundary, because that is what uiv_2buf() requires */
3143         union {
3144             char arr[TYPE_CHARS(UV)];
3145             U16 dummy;
3146         } buf;
3147         char *ebuf, *ptr;
3148         STRLEN len;
3149
3150         if (SvTYPE(sv) < SVt_PVIV)
3151             sv_upgrade(sv, SVt_PVIV);
3152         ptr = uiv_2buf(buf.arr, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
3153         len = ebuf - ptr;
3154         /* inlined from sv_setpvn */
3155         s = SvGROW_mutable(sv, len + 1);
3156         Move(ptr, s, len, char);
3157         s += len;
3158         *s = '\0';
3159         SvPOK_on(sv);
3160     }
3161     else if (SvNOK(sv)) {
3162         if (SvTYPE(sv) < SVt_PVNV)
3163             sv_upgrade(sv, SVt_PVNV);
3164         if (SvNVX(sv) == 0.0
3165 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3166             && !Perl_isnan(SvNVX(sv))
3167 #endif
3168         ) {
3169             s = SvGROW_mutable(sv, 2);
3170             *s++ = '0';
3171             *s = '\0';
3172         } else {
3173             STRLEN len;
3174             STRLEN size = 5; /* "-Inf\0" */
3175
3176             s = SvGROW_mutable(sv, size);
3177             len = S_infnan_2pv(SvNVX(sv), s, size, 0);
3178             if (len > 0) {
3179                 s += len;
3180                 SvPOK_on(sv);
3181             }
3182             else {
3183                 /* some Xenix systems wipe out errno here */
3184                 dSAVE_ERRNO;
3185
3186                 size =
3187                     1 + /* sign */
3188                     1 + /* "." */
3189                     NV_DIG +
3190                     1 + /* "e" */
3191                     1 + /* sign */
3192                     5 + /* exponent digits */
3193                     1 + /* \0 */
3194                     2; /* paranoia */
3195
3196                 s = SvGROW_mutable(sv, size);
3197 #ifndef USE_LOCALE_NUMERIC
3198                 SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3199
3200                 SvPOK_on(sv);
3201 #else
3202                 {
3203                     bool local_radix;
3204                     DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3205                     STORE_LC_NUMERIC_SET_TO_NEEDED();
3206
3207                     local_radix = _NOT_IN_NUMERIC_STANDARD;
3208                     if (local_radix && SvCUR(PL_numeric_radix_sv) > 1) {
3209                         size += SvCUR(PL_numeric_radix_sv) - 1;
3210                         s = SvGROW_mutable(sv, size);
3211                     }
3212
3213                     SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3214
3215                     /* If the radix character is UTF-8, and actually is in the
3216                      * output, turn on the UTF-8 flag for the scalar */
3217                     if (   local_radix
3218                         && SvUTF8(PL_numeric_radix_sv)
3219                         && instr(s, SvPVX_const(PL_numeric_radix_sv)))
3220                     {
3221                         SvUTF8_on(sv);
3222                     }
3223
3224                     RESTORE_LC_NUMERIC();
3225                 }
3226
3227                 /* We don't call SvPOK_on(), because it may come to
3228                  * pass that the locale changes so that the
3229                  * stringification we just did is no longer correct.  We
3230                  * will have to re-stringify every time it is needed */
3231 #endif
3232                 RESTORE_ERRNO;
3233             }
3234             while (*s) s++;
3235         }
3236     }
3237     else if (isGV_with_GP(sv)) {
3238         GV *const gv = MUTABLE_GV(sv);
3239         SV *const buffer = sv_newmortal();
3240
3241         gv_efullname3(buffer, gv, "*");
3242
3243         assert(SvPOK(buffer));
3244         if (SvUTF8(buffer))
3245             SvUTF8_on(sv);
3246         else
3247             SvUTF8_off(sv);
3248         if (lp)
3249             *lp = SvCUR(buffer);
3250         return SvPVX(buffer);
3251     }
3252     else {
3253         if (lp)
3254             *lp = 0;
3255         if (flags & SV_UNDEF_RETURNS_NULL)
3256             return NULL;
3257         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3258             report_uninit(sv);
3259         /* Typically the caller expects that sv_any is not NULL now.  */
3260         if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
3261             sv_upgrade(sv, SVt_PV);
3262         return (char *)"";
3263     }
3264
3265     {
3266         const STRLEN len = s - SvPVX_const(sv);
3267         if (lp) 
3268             *lp = len;
3269         SvCUR_set(sv, len);
3270     }
3271     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2pv(%s)\n",
3272                           PTR2UV(sv),SvPVX_const(sv)));
3273     if (flags & SV_CONST_RETURN)
3274         return (char *)SvPVX_const(sv);
3275     if (flags & SV_MUTABLE_RETURN)
3276         return SvPVX_mutable(sv);
3277     return SvPVX(sv);
3278 }
3279
3280 /*
3281 =for apidoc sv_copypv
3282
3283 Copies a stringified representation of the source SV into the
3284 destination SV.  Automatically performs any necessary C<mg_get> and
3285 coercion of numeric values into strings.  Guaranteed to preserve
3286 C<UTF8> flag even from overloaded objects.  Similar in nature to
3287 C<sv_2pv[_flags]> but operates directly on an SV instead of just the
3288 string.  Mostly uses C<sv_2pv_flags> to do its work, except when that
3289 would lose the UTF-8'ness of the PV.
3290
3291 =for apidoc sv_copypv_nomg
3292
3293 Like C<sv_copypv>, but doesn't invoke get magic first.
3294
3295 =for apidoc sv_copypv_flags
3296
3297 Implementation of C<sv_copypv> and C<sv_copypv_nomg>.  Calls get magic iff flags
3298 has the C<SV_GMAGIC> bit set.
3299
3300 =cut
3301 */
3302
3303 void
3304 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3305 {
3306     STRLEN len;
3307     const char *s;
3308
3309     PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3310
3311     s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC));
3312     sv_setpvn(dsv,s,len);
3313     if (SvUTF8(ssv))
3314         SvUTF8_on(dsv);
3315     else
3316         SvUTF8_off(dsv);
3317 }
3318
3319 /*
3320 =for apidoc sv_2pvbyte
3321
3322 Return a pointer to the byte-encoded representation of the SV, and set C<*lp>
3323 to its length.  If the SV is marked as being encoded as UTF-8, it will
3324 downgrade it to a byte string as a side-effect, if possible.  If the SV cannot
3325 be downgraded, this croaks.
3326
3327 Usually accessed via the C<SvPVbyte> macro.
3328
3329 =cut
3330 */
3331
3332 char *
3333 Perl_sv_2pvbyte_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags)
3334 {
3335     PERL_ARGS_ASSERT_SV_2PVBYTE_FLAGS;
3336
3337     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
3338         mg_get(sv);
3339     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3340      || isGV_with_GP(sv) || SvROK(sv)) {
3341         SV *sv2 = sv_newmortal();
3342         sv_copypv_nomg(sv2,sv);
3343         sv = sv2;
3344     }
3345     sv_utf8_downgrade_nomg(sv,0);
3346     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3347 }
3348
3349 /*
3350 =for apidoc sv_2pvutf8
3351
3352 Return a pointer to the UTF-8-encoded representation of the SV, and set C<*lp>
3353 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3354
3355 Usually accessed via the C<SvPVutf8> macro.
3356
3357 =cut
3358 */
3359
3360 char *
3361 Perl_sv_2pvutf8_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags)
3362 {
3363     PERL_ARGS_ASSERT_SV_2PVUTF8_FLAGS;
3364
3365     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
3366         mg_get(sv);
3367     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3368      || isGV_with_GP(sv) || SvROK(sv)) {
3369         SV *sv2 = sv_newmortal();
3370         sv_copypv_nomg(sv2,sv);
3371         sv = sv2;
3372     }
3373     sv_utf8_upgrade_nomg(sv);
3374     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3375 }
3376
3377
3378 /*
3379 =for apidoc sv_2bool
3380
3381 This macro is only used by C<sv_true()> or its macro equivalent, and only if
3382 the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>.
3383 It calls C<sv_2bool_flags> with the C<SV_GMAGIC> flag.
3384
3385 =for apidoc sv_2bool_flags
3386
3387 This function is only used by C<sv_true()> and friends,  and only if
3388 the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>.  If the flags
3389 contain C<SV_GMAGIC>, then it does an C<mg_get()> first.
3390
3391
3392 =cut
3393 */
3394
3395 bool
3396 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
3397 {
3398     PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3399
3400     restart:
3401     if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3402
3403     if (!SvOK(sv))
3404         return 0;
3405     if (SvROK(sv)) {
3406         if (SvAMAGIC(sv)) {
3407             SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3408             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
3409                 bool svb;
3410                 sv = tmpsv;
3411                 if(SvGMAGICAL(sv)) {
3412                     flags = SV_GMAGIC;
3413                     goto restart; /* call sv_2bool */
3414                 }
3415                 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
3416                 else if(!SvOK(sv)) {
3417                     svb = 0;
3418                 }
3419                 else if(SvPOK(sv)) {
3420                     svb = SvPVXtrue(sv);
3421                 }
3422                 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
3423                     svb = (SvIOK(sv) && SvIVX(sv) != 0)
3424                         || (SvNOK(sv) && SvNVX(sv) != 0.0);
3425                 }
3426                 else {
3427                     flags = 0;
3428                     goto restart; /* call sv_2bool_nomg */
3429                 }
3430                 return cBOOL(svb);
3431             }
3432         }
3433         assert(SvRV(sv));
3434         return TRUE;
3435     }
3436     if (isREGEXP(sv))
3437         return
3438           RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
3439
3440     if (SvNOK(sv) && !SvPOK(sv))
3441         return SvNVX(sv) != 0.0;
3442
3443     return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
3444 }
3445
3446 /*
3447 =for apidoc sv_utf8_upgrade
3448
3449 Converts the PV of an SV to its UTF-8-encoded form.
3450 Forces the SV to string form if it is not already.
3451 Will C<mg_get> on C<sv> if appropriate.
3452 Always sets the C<SvUTF8> flag to avoid future validity checks even
3453 if the whole string is the same in UTF-8 as not.
3454 Returns the number of bytes in the converted string
3455
3456 This is not a general purpose byte encoding to Unicode interface:
3457 use the Encode extension for that.
3458
3459 =for apidoc sv_utf8_upgrade_nomg
3460
3461 Like C<sv_utf8_upgrade>, but doesn't do magic on C<sv>.
3462
3463 =for apidoc sv_utf8_upgrade_flags
3464
3465 Converts the PV of an SV to its UTF-8-encoded form.
3466 Forces the SV to string form if it is not already.
3467 Always sets the SvUTF8 flag to avoid future validity checks even
3468 if all the bytes are invariant in UTF-8.
3469 If C<flags> has C<SV_GMAGIC> bit set,
3470 will C<mg_get> on C<sv> if appropriate, else not.
3471
3472 The C<SV_FORCE_UTF8_UPGRADE> flag is now ignored.
3473
3474 Returns the number of bytes in the converted string.
3475
3476 This is not a general purpose byte encoding to Unicode interface:
3477 use the Encode extension for that.
3478
3479 =for apidoc sv_utf8_upgrade_flags_grow
3480
3481 Like C<sv_utf8_upgrade_flags>, but has an additional parameter C<extra>, which is
3482 the number of unused bytes the string of C<sv> is guaranteed to have free after
3483 it upon return.  This allows the caller to reserve extra space that it intends
3484 to fill, to avoid extra grows.
3485
3486 C<sv_utf8_upgrade>, C<sv_utf8_upgrade_nomg>, and C<sv_utf8_upgrade_flags>
3487 are implemented in terms of this function.
3488
3489 Returns the number of bytes in the converted string (not including the spares).
3490
3491 =cut
3492
3493 If the routine itself changes the string, it adds a trailing C<NUL>.  Such a
3494 C<NUL> isn't guaranteed due to having other routines do the work in some input
3495 cases, or if the input is already flagged as being in utf8.
3496
3497 */
3498
3499 STRLEN
3500 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3501 {
3502     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3503
3504     if (sv == &PL_sv_undef)
3505         return 0;
3506     if (!SvPOK_nog(sv)) {
3507         STRLEN len = 0;
3508         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3509             (void) sv_2pv_flags(sv,&len, flags);
3510             if (SvUTF8(sv)) {
3511                 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3512                 return len;
3513             }
3514         } else {
3515             (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3516         }
3517     }
3518
3519     /* SVt_REGEXP's shouldn't be upgraded to UTF8 - they're already
3520      * compiled and individual nodes will remain non-utf8 even if the
3521      * stringified version of the pattern gets upgraded. Whether the
3522      * PVX of a REGEXP should be grown or we should just croak, I don't
3523      * know - DAPM */
3524     if (SvUTF8(sv) || isREGEXP(sv)) {
3525         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3526         return SvCUR(sv);
3527     }
3528
3529     if (SvIsCOW(sv)) {
3530         S_sv_uncow(aTHX_ sv, 0);
3531     }
3532
3533     if (SvCUR(sv) == 0) {
3534         if (extra) SvGROW(sv, extra + 1); /* Make sure is room for a trailing
3535                                              byte */
3536     } else { /* Assume Latin-1/EBCDIC */
3537         /* This function could be much more efficient if we
3538          * had a FLAG in SVs to signal if there are any variant
3539          * chars in the PV.  Given that there isn't such a flag
3540          * make the loop as fast as possible. */
3541         U8 * s = (U8 *) SvPVX_const(sv);
3542         U8 *t = s;
3543         
3544         if (is_utf8_invariant_string_loc(s, SvCUR(sv), (const U8 **) &t)) {
3545
3546             /* utf8 conversion not needed because all are invariants.  Mark
3547              * as UTF-8 even if no variant - saves scanning loop */
3548             SvUTF8_on(sv);
3549             if (extra) SvGROW(sv, SvCUR(sv) + extra);
3550             return SvCUR(sv);
3551         }
3552
3553         /* Here, there is at least one variant (t points to the first one), so
3554          * the string should be converted to utf8.  Everything from 's' to
3555          * 't - 1' will occupy only 1 byte each on output.
3556          *
3557          * Note that the incoming SV may not have a trailing '\0', as certain
3558          * code in pp_formline can send us partially built SVs.
3559          *
3560          * There are two main ways to convert.  One is to create a new string
3561          * and go through the input starting from the beginning, appending each
3562          * converted value onto the new string as we go along.  Going this
3563          * route, it's probably best to initially allocate enough space in the
3564          * string rather than possibly running out of space and having to
3565          * reallocate and then copy what we've done so far.  Since everything
3566          * from 's' to 't - 1' is invariant, the destination can be initialized
3567          * with these using a fast memory copy.  To be sure to allocate enough
3568          * space, one could use the worst case scenario, where every remaining
3569          * byte expands to two under UTF-8, or one could parse it and count
3570          * exactly how many do expand.
3571          *
3572          * The other way is to unconditionally parse the remainder of the
3573          * string to figure out exactly how big the expanded string will be,
3574          * growing if needed.  Then start at the end of the string and place
3575          * the character there at the end of the unfilled space in the expanded
3576          * one, working backwards until reaching 't'.
3577          *
3578          * The problem with assuming the worst case scenario is that for very
3579          * long strings, we could allocate much more memory than actually
3580          * needed, which can create performance problems.  If we have to parse
3581          * anyway, the second method is the winner as it may avoid an extra
3582          * copy.  The code used to use the first method under some
3583          * circumstances, but now that there is faster variant counting on
3584          * ASCII platforms, the second method is used exclusively, eliminating
3585          * some code that no longer has to be maintained. */
3586
3587         {
3588             /* Count the total number of variants there are.  We can start
3589              * just beyond the first one, which is known to be at 't' */
3590             const Size_t invariant_length = t - s;
3591             U8 * e = (U8 *) SvEND(sv);
3592
3593             /* The length of the left overs, plus 1. */
3594             const Size_t remaining_length_p1 = e - t;
3595
3596             /* We expand by 1 for the variant at 't' and one for each remaining
3597              * variant (we start looking at 't+1') */
3598             Size_t expansion = 1 + variant_under_utf8_count(t + 1, e);
3599
3600             /* +1 = trailing NUL */
3601             Size_t need = SvCUR(sv) + expansion + extra + 1;
3602             U8 * d;
3603
3604             /* Grow if needed */
3605             if (SvLEN(sv) < need) {
3606                 t = invariant_length + (U8*) SvGROW(sv, need);
3607                 e = t + remaining_length_p1;
3608             }
3609             SvCUR_set(sv, invariant_length + remaining_length_p1 + expansion);
3610
3611             /* Set the NUL at the end */
3612             d = (U8 *) SvEND(sv);
3613             *d-- = '\0';
3614
3615             /* Having decremented d, it points to the position to put the
3616              * very last byte of the expanded string.  Go backwards through
3617              * the string, copying and expanding as we go, stopping when we
3618              * get to the part that is invariant the rest of the way down */
3619
3620             e--;
3621             while (e >= t) {
3622                 if (NATIVE_BYTE_IS_INVARIANT(*e)) {
3623                     *d-- = *e;
3624                 } else {
3625                     *d-- = UTF8_EIGHT_BIT_LO(*e);
3626                     *d-- = UTF8_EIGHT_BIT_HI(*e);
3627                 }
3628                 e--;
3629             }
3630
3631             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3632                 /* Update pos. We do it at the end rather than during
3633                  * the upgrade, to avoid slowing down the common case
3634                  * (upgrade without pos).
3635                  * pos can be stored as either bytes or characters.  Since
3636                  * this was previously a byte string we can just turn off
3637                  * the bytes flag. */
3638                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3639                 if (mg) {
3640                     mg->mg_flags &= ~MGf_BYTES;
3641                 }
3642                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3643                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3644             }
3645         }
3646     }
3647
3648     SvUTF8_on(sv);
3649     return SvCUR(sv);
3650 }
3651
3652 /*
3653 =for apidoc sv_utf8_downgrade
3654
3655 Attempts to convert the PV of an SV from characters to bytes.
3656 If the PV contains a character that cannot fit
3657 in a byte, this conversion will fail;
3658 in this case, either returns false or, if C<fail_ok> is not
3659 true, croaks.
3660
3661 This is not a general purpose Unicode to byte encoding interface:
3662 use the C<Encode> extension for that.
3663
3664 This function process get magic on C<sv>.
3665
3666 =for apidoc sv_utf8_downgrade_nomg
3667
3668 Like C<sv_utf8_downgrade>, but does not process get magic on C<sv>.
3669
3670 =for apidoc sv_utf8_downgrade_flags
3671
3672 Like C<sv_utf8_downgrade>, but with additional C<flags>.
3673 If C<flags> has C<SV_GMAGIC> bit set, processes get magic on C<sv>.
3674
3675 =cut
3676 */
3677
3678 bool
3679 Perl_sv_utf8_downgrade_flags(pTHX_ SV *const sv, const bool fail_ok, const U32 flags)
3680 {
3681     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE_FLAGS;
3682
3683     if (SvPOKp(sv) && SvUTF8(sv)) {
3684         if (SvCUR(sv)) {
3685             U8 *s;
3686             STRLEN len;
3687             U32 mg_flags = flags & SV_GMAGIC;
3688
3689             if (SvIsCOW(sv)) {
3690                 S_sv_uncow(aTHX_ sv, 0);
3691             }
3692             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3693                 /* update pos */
3694                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3695                 if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
3696                         mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
3697                                                 mg_flags|SV_CONST_RETURN);
3698                         mg_flags = 0; /* sv_pos_b2u does get magic */
3699                 }
3700                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3701                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3702
3703             }
3704             s = (U8 *) SvPV_flags(sv, len, mg_flags);
3705
3706             if (!utf8_to_bytes(s, &len)) {
3707                 if (fail_ok)
3708                     return FALSE;
3709                 else {
3710                     if (PL_op)
3711                         Perl_croak(aTHX_ "Wide character in %s",
3712                                    OP_DESC(PL_op));
3713                     else
3714                         Perl_croak(aTHX_ "Wide character");
3715                 }
3716             }
3717             SvCUR_set(sv, len);
3718         }
3719     }
3720     SvUTF8_off(sv);
3721     return TRUE;
3722 }
3723
3724 /*
3725 =for apidoc sv_utf8_encode
3726
3727 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3728 flag off so that it looks like octets again.
3729
3730 =cut
3731 */
3732
3733 void
3734 Perl_sv_utf8_encode(pTHX_ SV *const sv)
3735 {
3736     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3737
3738     if (SvREADONLY(sv)) {
3739         sv_force_normal_flags(sv, 0);
3740     }
3741     (void) sv_utf8_upgrade(sv);
3742     SvUTF8_off(sv);
3743 }
3744
3745 /*
3746 =for apidoc sv_utf8_decode
3747
3748 If the PV of the SV is an octet sequence in Perl's extended UTF-8
3749 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3750 so that it looks like a character.  If the PV contains only single-byte
3751 characters, the C<SvUTF8> flag stays off.
3752 Scans PV for validity and returns FALSE if the PV is invalid UTF-8.
3753
3754 =cut
3755 */
3756
3757 bool
3758 Perl_sv_utf8_decode(pTHX_ SV *const sv)
3759 {
3760     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3761
3762     if (SvPOKp(sv)) {
3763         const U8 *start, *c, *first_variant;
3764
3765         /* The octets may have got themselves encoded - get them back as
3766          * bytes
3767          */
3768         if (!sv_utf8_downgrade(sv, TRUE))
3769             return FALSE;
3770
3771         /* it is actually just a matter of turning the utf8 flag on, but
3772          * we want to make sure everything inside is valid utf8 first.
3773          */
3774         c = start = (const U8 *) SvPVX_const(sv);
3775         if (! is_utf8_invariant_string_loc(c, SvCUR(sv), &first_variant)) {
3776             if (!is_utf8_string(first_variant, SvCUR(sv) - (first_variant -c)))
3777                 return FALSE;
3778             SvUTF8_on(sv);
3779         }
3780         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3781             /* XXX Is this dead code?  XS_utf8_decode calls SvSETMAGIC
3782                    after this, clearing pos.  Does anything on CPAN
3783                    need this? */
3784             /* adjust pos to the start of a UTF8 char sequence */
3785             MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3786             if (mg) {
3787                 I32 pos = mg->mg_len;
3788                 if (pos > 0) {
3789                     for (c = start + pos; c > start; c--) {
3790                         if (UTF8_IS_START(*c))
3791                             break;
3792                     }
3793                     mg->mg_len  = c - start;
3794                 }
3795             }
3796             if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3797                 magic_setutf8(sv,mg); /* clear UTF8 cache */
3798         }
3799     }
3800     return TRUE;
3801 }
3802
3803 /*
3804 =for apidoc sv_setsv
3805
3806 Copies the contents of the source SV C<ssv> into the destination SV
3807 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3808 function if the source SV needs to be reused.  Does not handle 'set' magic on
3809 destination SV.  Calls 'get' magic on source SV.  Loosely speaking, it
3810 performs a copy-by-value, obliterating any previous content of the
3811 destination.
3812
3813 You probably want to use one of the assortment of wrappers, such as
3814 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3815 C<SvSetMagicSV_nosteal>.
3816
3817 =for apidoc sv_setsv_flags
3818
3819 Copies the contents of the source SV C<ssv> into the destination SV
3820 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3821 function if the source SV needs to be reused.  Does not handle 'set' magic.
3822 Loosely speaking, it performs a copy-by-value, obliterating any previous
3823 content of the destination.
3824 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3825 C<ssv> if appropriate, else not.  If the C<flags>
3826 parameter has the C<SV_NOSTEAL> bit set then the
3827 buffers of temps will not be stolen.  C<sv_setsv>
3828 and C<sv_setsv_nomg> are implemented in terms of this function.
3829
3830 You probably want to use one of the assortment of wrappers, such as
3831 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3832 C<SvSetMagicSV_nosteal>.
3833
3834 This is the primary function for copying scalars, and most other
3835 copy-ish functions and macros use this underneath.
3836
3837 =for apidoc Amnh||SV_NOSTEAL
3838
3839 =cut
3840 */
3841
3842 static void
3843 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3844 {
3845     I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3846     HV *old_stash = NULL;
3847
3848     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3849
3850     if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3851         const char * const name = GvNAME(sstr);
3852         const STRLEN len = GvNAMELEN(sstr);
3853         {
3854             if (dtype >= SVt_PV) {
3855                 SvPV_free(dstr);
3856                 SvPV_set(dstr, 0);
3857                 SvLEN_set(dstr, 0);
3858                 SvCUR_set(dstr, 0);
3859             }
3860             SvUPGRADE(dstr, SVt_PVGV);
3861             (void)SvOK_off(dstr);
3862             isGV_with_GP_on(dstr);
3863         }
3864         GvSTASH(dstr) = GvSTASH(sstr);
3865         if (GvSTASH(dstr))
3866             Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3867         gv_name_set(MUTABLE_GV(dstr), name, len,
3868                         GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
3869         SvFAKE_on(dstr);        /* can coerce to non-glob */
3870     }
3871
3872     if(GvGP(MUTABLE_GV(sstr))) {
3873         /* If source has method cache entry, clear it */
3874         if(GvCVGEN(sstr)) {
3875             SvREFCNT_dec(GvCV(sstr));
3876             GvCV_set(sstr, NULL);
3877             GvCVGEN(sstr) = 0;
3878         }
3879         /* If source has a real method, then a method is
3880            going to change */
3881         else if(
3882          GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3883         ) {
3884             mro_changes = 1;
3885         }
3886     }
3887
3888     /* If dest already had a real method, that's a change as well */
3889     if(
3890         !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3891      && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3892     ) {
3893         mro_changes = 1;
3894     }
3895
3896     /* We don't need to check the name of the destination if it was not a
3897        glob to begin with. */
3898     if(dtype == SVt_PVGV) {
3899         const char * const name = GvNAME((const GV *)dstr);
3900         const STRLEN len = GvNAMELEN(dstr);
3901         if(memEQs(name, len, "ISA")
3902          /* The stash may have been detached from the symbol table, so
3903             check its name. */
3904          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3905         )
3906             mro_changes = 2;
3907         else {
3908             if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3909              || (len == 1 && name[0] == ':')) {
3910                 mro_changes = 3;
3911
3912                 /* Set aside the old stash, so we can reset isa caches on
3913                    its subclasses. */
3914                 if((old_stash = GvHV(dstr)))
3915                     /* Make sure we do not lose it early. */
3916                     SvREFCNT_inc_simple_void_NN(
3917                      sv_2mortal((SV *)old_stash)
3918                     );
3919             }
3920         }
3921
3922         SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
3923     }
3924
3925     /* freeing dstr's GP might free sstr (e.g. *x = $x),
3926      * so temporarily protect it */
3927     ENTER;
3928     SAVEFREESV(SvREFCNT_inc_simple_NN(sstr));
3929     gp_free(MUTABLE_GV(dstr));
3930     GvINTRO_off(dstr);          /* one-shot flag */
3931     GvGP_set(dstr, gp_ref(GvGP(sstr)));
3932     LEAVE;
3933
3934     if (SvTAINTED(sstr))
3935         SvTAINT(dstr);
3936     if (GvIMPORTED(dstr) != GVf_IMPORTED
3937         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3938         {
3939             GvIMPORTED_on(dstr);
3940         }
3941     GvMULTI_on(dstr);
3942     if(mro_changes == 2) {
3943       if (GvAV((const GV *)sstr)) {
3944         MAGIC *mg;
3945         SV * const sref = (SV *)GvAV((const GV *)dstr);
3946         if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3947             if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3948                 AV * const ary = newAV();
3949                 av_push(ary, mg->mg_obj); /* takes the refcount */
3950                 mg->mg_obj = (SV *)ary;
3951             }
3952             av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3953         }
3954         else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3955       }
3956       mro_isa_changed_in(GvSTASH(dstr));
3957     }
3958     else if(mro_changes == 3) {
3959         HV * const stash = GvHV(dstr);
3960         if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3961             mro_package_moved(
3962                 stash, old_stash,
3963                 (GV *)dstr, 0
3964             );
3965     }
3966     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3967     if (GvIO(dstr) && dtype == SVt_PVGV) {
3968         DEBUG_o(Perl_deb(aTHX_
3969                         "glob_assign_glob clearing PL_stashcache\n"));
3970         /* It's a cache. It will rebuild itself quite happily.
3971            It's a lot of effort to work out exactly which key (or keys)
3972            might be invalidated by the creation of the this file handle.
3973          */
3974         hv_clear(PL_stashcache);
3975     }
3976     return;
3977 }
3978
3979 void
3980 Perl_gv_setref(pTHX_ SV *const dstr, SV *const sstr)
3981 {
3982     SV * const sref = SvRV(sstr);
3983     SV *dref;
3984     const int intro = GvINTRO(dstr);
3985     SV **location;
3986     U8 import_flag = 0;
3987     const U32 stype = SvTYPE(sref);
3988
3989     PERL_ARGS_ASSERT_GV_SETREF;
3990
3991     if (intro) {
3992         GvINTRO_off(dstr);      /* one-shot flag */
3993         GvLINE(dstr) = CopLINE(PL_curcop);
3994         GvEGV(dstr) = MUTABLE_GV(dstr);
3995     }
3996     GvMULTI_on(dstr);
3997     switch (stype) {
3998     case SVt_PVCV:
3999         location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
4000         import_flag = GVf_IMPORTED_CV;
4001         goto common;
4002     case SVt_PVHV:
4003         location = (SV **) &GvHV(dstr);
4004         import_flag = GVf_IMPORTED_HV;
4005         goto common;
4006     case SVt_PVAV:
4007         location = (SV **) &GvAV(dstr);
4008         import_flag = GVf_IMPORTED_AV;
4009         goto common;
4010     case SVt_PVIO:
4011         location = (SV **) &GvIOp(dstr);
4012         goto common;
4013     case SVt_PVFM:
4014         location = (SV **) &GvFORM(dstr);
4015         goto common;
4016     default:
4017         location = &GvSV(dstr);
4018         import_flag = GVf_IMPORTED_SV;
4019     common:
4020         if (intro) {
4021             if (stype == SVt_PVCV) {
4022                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
4023                 if (GvCVGEN(dstr)) {
4024                     SvREFCNT_dec(GvCV(dstr));
4025                     GvCV_set(dstr, NULL);
4026                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4027                 }
4028             }
4029             /* SAVEt_GVSLOT takes more room on the savestack and has more
4030                overhead in leave_scope than SAVEt_GENERIC_SV.  But for CVs
4031                leave_scope needs access to the GV so it can reset method
4032                caches.  We must use SAVEt_GVSLOT whenever the type is
4033                SVt_PVCV, even if the stash is anonymous, as the stash may
4034                gain a name somehow before leave_scope. */
4035             if (stype == SVt_PVCV) {
4036                 /* There is no save_pushptrptrptr.  Creating it for this
4037                    one call site would be overkill.  So inline the ss add
4038                    routines here. */
4039                 dSS_ADD;
4040                 SS_ADD_PTR(dstr);
4041                 SS_ADD_PTR(location);
4042                 SS_ADD_PTR(SvREFCNT_inc(*location));
4043                 SS_ADD_UV(SAVEt_GVSLOT);
4044                 SS_ADD_END(4);
4045             }
4046             else SAVEGENERICSV(*location);
4047         }
4048         dref = *location;
4049         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
4050             CV* const cv = MUTABLE_CV(*location);
4051             if (cv) {
4052                 if (!GvCVGEN((const GV *)dstr) &&
4053                     (CvROOT(cv) || CvXSUB(cv)) &&
4054                     /* redundant check that avoids creating the extra SV
4055                        most of the time: */
4056                     (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
4057                     {
4058                         SV * const new_const_sv =
4059                             CvCONST((const CV *)sref)
4060                                  ? cv_const_sv((const CV *)sref)
4061                                  : NULL;
4062                         HV * const stash = GvSTASH((const GV *)dstr);
4063                         report_redefined_cv(
4064                            sv_2mortal(
4065                              stash
4066                                ? Perl_newSVpvf(aTHX_
4067                                     "%" HEKf "::%" HEKf,
4068                                     HEKfARG(HvNAME_HEK(stash)),
4069                                     HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr))))
4070                                : Perl_newSVpvf(aTHX_
4071                                     "%" HEKf,
4072                                     HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr))))
4073                            ),
4074                            cv,
4075                            CvCONST((const CV *)sref) ? &new_const_sv : NULL
4076                         );
4077                     }
4078                 if (!intro)
4079                     cv_ckproto_len_flags(cv, (const GV *)dstr,
4080                                    SvPOK(sref) ? CvPROTO(sref) : NULL,
4081                                    SvPOK(sref) ? CvPROTOLEN(sref) : 0,
4082                                    SvPOK(sref) ? SvUTF8(sref) : 0);
4083             }
4084             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4085             GvASSUMECV_on(dstr);
4086             if(GvSTASH(dstr)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
4087                 if (intro && GvREFCNT(dstr) > 1) {
4088                     /* temporary remove extra savestack's ref */
4089                     --GvREFCNT(dstr);
4090                     gv_method_changed(dstr);
4091                     ++GvREFCNT(dstr);
4092                 }
4093                 else gv_method_changed(dstr);
4094             }
4095         }
4096         *location = SvREFCNT_inc_simple_NN(sref);
4097         if (import_flag && !(GvFLAGS(dstr) & import_flag)
4098             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
4099             GvFLAGS(dstr) |= import_flag;
4100         }
4101
4102         if (stype == SVt_PVHV) {
4103             const char * const name = GvNAME((GV*)dstr);
4104             const STRLEN len = GvNAMELEN(dstr);
4105             if (
4106                 (
4107                    (len > 1 && name[len-2] == ':' && name[len-1] == ':')
4108                 || (len == 1 && name[0] == ':')
4109                 )
4110              && (!dref || HvENAME_get(dref))
4111             ) {
4112                 mro_package_moved(
4113                     (HV *)sref, (HV *)dref,
4114                     (GV *)dstr, 0
4115                 );
4116             }
4117         }
4118         else if (
4119             stype == SVt_PVAV && sref != dref
4120          && memEQs(GvNAME((GV*)dstr), GvNAMELEN((GV*)dstr), "ISA")
4121          /* The stash may have been detached from the symbol table, so
4122             check its name before doing anything. */
4123          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
4124         ) {
4125             MAGIC *mg;
4126             MAGIC * const omg = dref && SvSMAGICAL(dref)
4127                                  ? mg_find(dref, PERL_MAGIC_isa)
4128                                  : NULL;
4129             if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
4130                 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
4131                     AV * const ary = newAV();
4132                     av_push(ary, mg->mg_obj); /* takes the refcount */
4133                     mg->mg_obj = (SV *)ary;
4134                 }
4135                 if (omg) {
4136                     if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
4137                         SV **svp = AvARRAY((AV *)omg->mg_obj);
4138                         I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
4139                         while (items--)
4140                             av_push(
4141                              (AV *)mg->mg_obj,
4142                              SvREFCNT_inc_simple_NN(*svp++)
4143                             );
4144                     }
4145                     else
4146                         av_push(
4147                          (AV *)mg->mg_obj,
4148                          SvREFCNT_inc_simple_NN(omg->mg_obj)
4149                         );
4150                 }
4151                 else
4152                     av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
4153             }
4154             else
4155             {
4156                 SSize_t i;
4157                 sv_magic(
4158                  sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
4159                 );
4160                 for (i = 0; i <= AvFILL(sref); ++i) {
4161                     SV **elem = av_fetch ((AV*)sref, i, 0);
4162                     if (elem) {
4163                         sv_magic(
4164                           *elem, sref, PERL_MAGIC_isaelem, NULL, i
4165                         );
4166                     }
4167                 }
4168                 mg = mg_find(sref, PERL_MAGIC_isa);
4169             }
4170             /* Since the *ISA assignment could have affected more than
4171                one stash, don't call mro_isa_changed_in directly, but let
4172                magic_clearisa do it for us, as it already has the logic for
4173                dealing with globs vs arrays of globs. */
4174             assert(mg);
4175             Perl_magic_clearisa(aTHX_ NULL, mg);
4176         }
4177         else if (stype == SVt_PVIO) {
4178             DEBUG_o(Perl_deb(aTHX_ "gv_setref clearing PL_stashcache\n"));
4179             /* It's a cache. It will rebuild itself quite happily.
4180                It's a lot of effort to work out exactly which key (or keys)
4181                might be invalidated by the creation of the this file handle.
4182             */
4183             hv_clear(PL_stashcache);
4184         }
4185         break;
4186     }
4187     if (!intro) SvREFCNT_dec(dref);
4188     if (SvTAINTED(sstr))
4189         SvTAINT(dstr);
4190     return;
4191 }
4192
4193
4194
4195
4196 #ifdef PERL_DEBUG_READONLY_COW
4197 # include <sys/mman.h>
4198
4199 # ifndef PERL_MEMORY_DEBUG_HEADER_SIZE
4200 #  define PERL_MEMORY_DEBUG_HEADER_SIZE 0
4201 # endif
4202
4203 void
4204 Perl_sv_buf_to_ro(pTHX_ SV *sv)
4205 {
4206     struct perl_memory_debug_header * const header =
4207         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4208     const MEM_SIZE len = header->size;
4209     PERL_ARGS_ASSERT_SV_BUF_TO_RO;
4210 # ifdef PERL_TRACK_MEMPOOL
4211     if (!header->readonly) header->readonly = 1;
4212 # endif
4213     if (mprotect(header, len, PROT_READ))
4214         Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
4215                          header, len, errno);
4216 }
4217
4218 static void
4219 S_sv_buf_to_rw(pTHX_ SV *sv)
4220 {
4221     struct perl_memory_debug_header * const header =
4222         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4223     const MEM_SIZE len = header->size;
4224     PERL_ARGS_ASSERT_SV_BUF_TO_RW;
4225     if (mprotect(header, len, PROT_READ|PROT_WRITE))
4226         Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
4227                          header, len, errno);
4228 # ifdef PERL_TRACK_MEMPOOL
4229     header->readonly = 0;
4230 # endif
4231 }
4232
4233 #else
4234 # define sv_buf_to_ro(sv)       NOOP
4235 # define sv_buf_to_rw(sv)       NOOP
4236 #endif
4237
4238 void
4239 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
4240 {
4241     U32 sflags;
4242     int dtype;
4243     svtype stype;
4244     unsigned int both_type;
4245
4246     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
4247
4248     if (UNLIKELY( sstr == dstr ))
4249         return;
4250
4251     if (UNLIKELY( !sstr ))
4252         sstr = &PL_sv_undef;
4253
4254     stype = SvTYPE(sstr);
4255     dtype = SvTYPE(dstr);
4256     both_type = (stype | dtype);
4257
4258     /* with these values, we can check that both SVs are NULL/IV (and not
4259      * freed) just by testing the or'ed types */
4260     STATIC_ASSERT_STMT(SVt_NULL == 0);
4261     STATIC_ASSERT_STMT(SVt_IV   == 1);
4262     if (both_type <= 1) {
4263         /* both src and dst are UNDEF/IV/RV, so we can do a lot of
4264          * special-casing */
4265         U32 sflags;
4266         U32 new_dflags;
4267         SV *old_rv = NULL;
4268
4269         /* minimal subset of SV_CHECK_THINKFIRST_COW_DROP(dstr) */
4270         if (SvREADONLY(dstr))
4271             Perl_croak_no_modify();
4272         if (SvROK(dstr)) {
4273             if (SvWEAKREF(dstr))
4274                 sv_unref_flags(dstr, 0);
4275             else
4276                 old_rv = SvRV(dstr);
4277         }
4278
4279         assert(!SvGMAGICAL(sstr));
4280         assert(!SvGMAGICAL(dstr));
4281
4282         sflags = SvFLAGS(sstr);
4283         if (sflags & (SVf_IOK|SVf_ROK)) {
4284             SET_SVANY_FOR_BODYLESS_IV(dstr);
4285             new_dflags = SVt_IV;
4286
4287             if (sflags & SVf_ROK) {
4288                 dstr->sv_u.svu_rv = SvREFCNT_inc(SvRV(sstr));
4289                 new_dflags |= SVf_ROK;
4290             }
4291             else {
4292                 /* both src and dst are <= SVt_IV, so sv_any points to the
4293                  * head; so access the head directly
4294                  */
4295                 assert(    &(sstr->sv_u.svu_iv)
4296                         == &(((XPVIV*) SvANY(sstr))->xiv_iv));
4297                 assert(    &(dstr->sv_u.svu_iv)
4298                         == &(((XPVIV*) SvANY(dstr))->xiv_iv));
4299                 dstr->sv_u.svu_iv = sstr->sv_u.svu_iv;
4300                 new_dflags |= (SVf_IOK|SVp_IOK|(sflags & SVf_IVisUV));
4301             }
4302         }
4303         else {
4304             new_dflags = dtype; /* turn off everything except the type */
4305         }
4306         SvFLAGS(dstr) = new_dflags;
4307         SvREFCNT_dec(old_rv);
4308
4309         return;
4310     }
4311
4312     if (UNLIKELY(both_type == SVTYPEMASK)) {
4313         if (SvIS_FREED(dstr)) {
4314             Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
4315                        " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
4316         }
4317         if (SvIS_FREED(sstr)) {
4318             Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
4319                        (void*)sstr, (void*)dstr);
4320         }
4321     }
4322
4323
4324
4325     SV_CHECK_THINKFIRST_COW_DROP(dstr);
4326     dtype = SvTYPE(dstr); /* THINKFIRST may have changed type */
4327
4328     /* There's a lot of redundancy below but we're going for speed here */
4329
4330     switch (stype) {
4331     case SVt_NULL:
4332       undef_sstr:
4333         if (LIKELY( dtype != SVt_PVGV && dtype != SVt_PVLV )) {
4334             (void)SvOK_off(dstr);
4335             return;
4336         }
4337         break;
4338     case SVt_IV:
4339         if (SvIOK(sstr)) {
4340             switch (dtype) {
4341             case SVt_NULL:
4342                 /* For performance, we inline promoting to type SVt_IV. */
4343                 /* We're starting from SVt_NULL, so provided that define is
4344                  * actual 0, we don't have to unset any SV type flags
4345                  * to promote to SVt_IV. */
4346                 STATIC_ASSERT_STMT(SVt_NULL == 0);
4347                 SET_SVANY_FOR_BODYLESS_IV(dstr);
4348                 SvFLAGS(dstr) |= SVt_IV;
4349                 break;
4350             case SVt_NV:
4351             case SVt_PV:
4352                 sv_upgrade(dstr, SVt_PVIV);
4353                 break;
4354             case SVt_PVGV:
4355             case SVt_PVLV:
4356                 goto end_of_first_switch;
4357             }
4358             (void)SvIOK_only(dstr);
4359             SvIV_set(dstr,  SvIVX(sstr));
4360             if (SvIsUV(sstr))
4361                 SvIsUV_on(dstr);
4362             /* SvTAINTED can only be true if the SV has taint magic, which in
4363                turn means that the SV type is PVMG (or greater). This is the
4364                case statement for SVt_IV, so this cannot be true (whatever gcov
4365                may say).  */
4366             assert(!SvTAINTED(sstr));
4367             return;
4368         }
4369         if (!SvROK(sstr))
4370             goto undef_sstr;
4371         if (dtype < SVt_PV && dtype != SVt_IV)
4372             sv_upgrade(dstr, SVt_IV);
4373         break;
4374
4375     case SVt_NV:
4376         if (LIKELY( SvNOK(sstr) )) {
4377             switch (dtype) {
4378             case SVt_NULL:
4379             case SVt_IV:
4380                 sv_upgrade(dstr, SVt_NV);
4381                 break;
4382             case SVt_PV:
4383             case SVt_PVIV:
4384                 sv_upgrade(dstr, SVt_PVNV);
4385                 break;
4386             case SVt_PVGV:
4387             case SVt_PVLV:
4388                 goto end_of_first_switch;
4389             }
4390             SvNV_set(dstr, SvNVX(sstr));
4391             (void)SvNOK_only(dstr);
4392             /* SvTAINTED can only be true if the SV has taint magic, which in
4393                turn means that the SV type is PVMG (or greater). This is the
4394                case statement for SVt_NV, so this cannot be true (whatever gcov
4395                may say).  */
4396             assert(!SvTAINTED(sstr));
4397             return;
4398         }
4399         goto undef_sstr;
4400
4401     case SVt_PV:
4402         if (dtype < SVt_PV)
4403             sv_upgrade(dstr, SVt_PV);
4404         break;
4405     case SVt_PVIV:
4406         if (dtype < SVt_PVIV)
4407             sv_upgrade(dstr, SVt_PVIV);
4408         break;
4409     case SVt_PVNV:
4410         if (dtype < SVt_PVNV)
4411             sv_upgrade(dstr, SVt_PVNV);
4412         break;
4413
4414     case SVt_INVLIST:
4415         invlist_clone(sstr, dstr);
4416         break;
4417     default:
4418         {
4419         const char * const type = sv_reftype(sstr,0);
4420         if (PL_op)
4421             /* diag_listed_as: Bizarre copy of %s */
4422             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4423         else
4424             Perl_croak(aTHX_ "Bizarre copy of %s", type);
4425         }
4426         NOT_REACHED; /* NOTREACHED */
4427
4428     case SVt_REGEXP:
4429       upgregexp:
4430         if (dtype < SVt_REGEXP)
4431             sv_upgrade(dstr, SVt_REGEXP);
4432         break;
4433
4434     case SVt_PVLV:
4435     case SVt_PVGV:
4436     case SVt_PVMG:
4437         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4438             mg_get(sstr);
4439             if (SvTYPE(sstr) != stype)
4440                 stype = SvTYPE(sstr);
4441         }
4442         if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4443                     glob_assign_glob(dstr, sstr, dtype);
4444                     return;
4445         }
4446         if (stype == SVt_PVLV)
4447         {
4448             if (isREGEXP(sstr)) goto upgregexp;
4449             SvUPGRADE(dstr, SVt_PVNV);
4450         }
4451         else
4452             SvUPGRADE(dstr, (svtype)stype);
4453     }
4454  end_of_first_switch:
4455
4456     /* dstr may have been upgraded.  */
4457     dtype = SvTYPE(dstr);
4458     sflags = SvFLAGS(sstr);
4459
4460     if (UNLIKELY( dtype == SVt_PVCV )) {
4461         /* Assigning to a subroutine sets the prototype.  */
4462         if (SvOK(sstr)) {
4463             STRLEN len;
4464             const char *const ptr = SvPV_const(sstr, len);
4465
4466             SvGROW(dstr, len + 1);
4467             Copy(ptr, SvPVX(dstr), len + 1, char);
4468             SvCUR_set(dstr, len);
4469             SvPOK_only(dstr);
4470             SvFLAGS(dstr) |= sflags & SVf_UTF8;
4471             CvAUTOLOAD_off(dstr);
4472         } else {
4473             SvOK_off(dstr);
4474         }
4475     }
4476     else if (UNLIKELY(dtype == SVt_PVAV || dtype == SVt_PVHV
4477              || dtype == SVt_PVFM))
4478     {
4479         const char * const type = sv_reftype(dstr,0);
4480         if (PL_op)
4481             /* diag_listed_as: Cannot copy to %s */
4482             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4483         else
4484             Perl_croak(aTHX_ "Cannot copy to %s", type);
4485     } else if (sflags & SVf_ROK) {
4486         if (isGV_with_GP(dstr)
4487             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4488             sstr = SvRV(sstr);
4489             if (sstr == dstr) {
4490                 if (GvIMPORTED(dstr) != GVf_IMPORTED
4491                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4492                 {
4493                     GvIMPORTED_on(dstr);
4494                 }
4495                 GvMULTI_on(dstr);
4496                 return;
4497             }
4498             glob_assign_glob(dstr, sstr, dtype);
4499             return;
4500         }
4501
4502         if (dtype >= SVt_PV) {
4503             if (isGV_with_GP(dstr)) {
4504                 gv_setref(dstr, sstr);
4505                 return;
4506             }
4507             if (SvPVX_const(dstr)) {
4508                 SvPV_free(dstr);
4509                 SvLEN_set(dstr, 0);
4510                 SvCUR_set(dstr, 0);
4511             }
4512         }
4513         (void)SvOK_off(dstr);
4514         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4515         SvFLAGS(dstr) |= sflags & SVf_ROK;
4516         assert(!(sflags & SVp_NOK));
4517         assert(!(sflags & SVp_IOK));
4518         assert(!(sflags & SVf_NOK));
4519         assert(!(sflags & SVf_IOK));
4520     }
4521     else if (isGV_with_GP(dstr)) {
4522         if (!(sflags & SVf_OK)) {
4523             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4524                            "Undefined value assigned to typeglob");
4525         }
4526         else {
4527             GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
4528             if (dstr != (const SV *)gv) {
4529                 const char * const name = GvNAME((const GV *)dstr);
4530                 const STRLEN len = GvNAMELEN(dstr);
4531                 HV *old_stash = NULL;
4532                 bool reset_isa = FALSE;
4533                 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4534                  || (len == 1 && name[0] == ':')) {
4535                     /* Set aside the old stash, so we can reset isa caches
4536                        on its subclasses. */
4537                     if((old_stash = GvHV(dstr))) {
4538                         /* Make sure we do not lose it early. */
4539                         SvREFCNT_inc_simple_void_NN(
4540                          sv_2mortal((SV *)old_stash)
4541                         );
4542                     }
4543                     reset_isa = TRUE;
4544                 }
4545
4546                 if (GvGP(dstr)) {
4547                     SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
4548                     gp_free(MUTABLE_GV(dstr));
4549                 }
4550                 GvGP_set(dstr, gp_ref(GvGP(gv)));
4551
4552                 if (reset_isa) {
4553                     HV * const stash = GvHV(dstr);
4554                     if(
4555                         old_stash ? (HV *)HvENAME_get(old_stash) : stash
4556                     )
4557                         mro_package_moved(
4558                          stash, old_stash,
4559                          (GV *)dstr, 0
4560                         );
4561                 }
4562             }
4563         }
4564     }
4565     else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4566           && (stype == SVt_REGEXP || isREGEXP(sstr))) {
4567         reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4568     }
4569     else if (sflags & SVp_POK) {
4570         const STRLEN cur = SvCUR(sstr);
4571         const STRLEN len = SvLEN(sstr);
4572
4573         /*
4574          * We have three basic ways to copy the string:
4575          *
4576          *  1. Swipe
4577          *  2. Copy-on-write
4578          *  3. Actual copy
4579          * 
4580          * Which we choose is based on various factors.  The following
4581          * things are listed in order of speed, fastest to slowest:
4582          *  - Swipe
4583          *  - Copying a short string
4584          *  - Copy-on-write bookkeeping
4585          *  - malloc
4586          *  - Copying a long string
4587          * 
4588          * We swipe the string (steal the string buffer) if the SV on the
4589          * rhs is about to be freed anyway (TEMP and refcnt==1).  This is a
4590          * big win on long strings.  It should be a win on short strings if
4591          * SvPVX_const(dstr) has to be allocated.  If not, it should not 
4592          * slow things down, as SvPVX_const(sstr) would have been freed
4593          * soon anyway.
4594          * 
4595          * We also steal the buffer from a PADTMP (operator target) if it
4596          * is ‘long enough’.  For short strings, a swipe does not help
4597          * here, as it causes more malloc calls the next time the target
4598          * is used.  Benchmarks show that even if SvPVX_const(dstr) has to
4599          * be allocated it is still not worth swiping PADTMPs for short
4600          * strings, as the savings here are small.
4601          * 
4602          * If swiping is not an option, then we see whether it is
4603          * worth using copy-on-write.  If the lhs already has a buf-
4604          * fer big enough and the string is short, we skip it and fall back
4605          * to method 3, since memcpy is faster for short strings than the
4606          * later bookkeeping overhead that copy-on-write entails.
4607
4608          * If the rhs is not a copy-on-write string yet, then we also
4609          * consider whether the buffer is too large relative to the string
4610          * it holds.  Some operations such as readline allocate a large
4611          * buffer in the expectation of reusing it.  But turning such into
4612          * a COW buffer is counter-productive because it increases memory
4613          * usage by making readline allocate a new large buffer the sec-
4614          * ond time round.  So, if the buffer is too large, again, we use
4615          * method 3 (copy).
4616          * 
4617          * Finally, if there is no buffer on the left, or the buffer is too 
4618          * small, then we use copy-on-write and make both SVs share the
4619          * string buffer.
4620          *
4621          */
4622
4623         /* Whichever path we take through the next code, we want this true,
4624            and doing it now facilitates the COW check.  */
4625         (void)SvPOK_only(dstr);
4626
4627         if (
4628                  (              /* Either ... */
4629                                 /* slated for free anyway (and not COW)? */
4630                     (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
4631                                 /* or a swipable TARG */
4632                  || ((sflags &
4633                            (SVs_PADTMP|SVf_READONLY|SVf_PROTECT|SVf_IsCOW))
4634                        == SVs_PADTMP
4635                                 /* whose buffer is worth stealing */
4636                      && CHECK_COWBUF_THRESHOLD(cur,len)
4637                     )
4638                  ) &&
4639                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4640                  (!(flags & SV_NOSTEAL)) &&
4641                                         /* and we're allowed to steal temps */
4642                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4643                  len)             /* and really is a string */
4644         {       /* Passes the swipe test.  */
4645             if (SvPVX_const(dstr))      /* we know&n