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