a82350fa3f116d2fe4029ba0d692970d47ce969d
[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 (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3457         sv_recode_to_utf8(sv, PL_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);
4627             }
4628 #ifdef PERL_ANY_COW
4629             if (!(sflags & SVf_IsCOW)) {
4630                     SvIsCOW_on(sstr);
4631 # ifdef PERL_OLD_COPY_ON_WRITE
4632                     /* Make the source SV into a loop of 1.
4633                        (about to become 2) */
4634                     SV_COW_NEXT_SV_SET(sstr, sstr);
4635 # else
4636                     CowREFCNT(sstr) = 0;
4637 # endif
4638             }
4639 #endif
4640             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
4641                 SvPV_free(dstr);
4642             }
4643
4644 #ifdef PERL_ANY_COW
4645             if (len) {
4646 # ifdef PERL_OLD_COPY_ON_WRITE
4647                     assert (SvTYPE(dstr) >= SVt_PVIV);
4648                     /* SvIsCOW_normal */
4649                     /* splice us in between source and next-after-source.  */
4650                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4651                     SV_COW_NEXT_SV_SET(sstr, dstr);
4652 # else
4653                     if (sflags & SVf_IsCOW) {
4654                         sv_buf_to_rw(sstr);
4655                     }
4656                     CowREFCNT(sstr)++;
4657 # endif
4658                     SvPV_set(dstr, SvPVX_mutable(sstr));
4659                     sv_buf_to_ro(sstr);
4660             } else
4661 #endif
4662             {
4663                     /* SvIsCOW_shared_hash */
4664                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4665                                           "Copy on write: Sharing hash\n"));
4666
4667                     assert (SvTYPE(dstr) >= SVt_PV);
4668                     SvPV_set(dstr,
4669                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4670             }
4671             SvLEN_set(dstr, len);
4672             SvCUR_set(dstr, cur);
4673             SvIsCOW_on(dstr);
4674         } else {
4675             /* Failed the swipe test, and we cannot do copy-on-write either.
4676                Have to copy the string.  */
4677             SvGROW(dstr, cur + 1);      /* inlined from sv_setpvn */
4678             Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
4679             SvCUR_set(dstr, cur);
4680             *SvEND(dstr) = '\0';
4681         }
4682         if (sflags & SVp_NOK) {
4683             SvNV_set(dstr, SvNVX(sstr));
4684         }
4685         if (sflags & SVp_IOK) {
4686             SvIV_set(dstr, SvIVX(sstr));
4687             /* Must do this otherwise some other overloaded use of 0x80000000
4688                gets confused. I guess SVpbm_VALID */
4689             if (sflags & SVf_IVisUV)
4690                 SvIsUV_on(dstr);
4691         }
4692         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4693         {
4694             const MAGIC * const smg = SvVSTRING_mg(sstr);
4695             if (smg) {
4696                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4697                          smg->mg_ptr, smg->mg_len);
4698                 SvRMAGICAL_on(dstr);
4699             }
4700         }
4701     }
4702     else if (sflags & (SVp_IOK|SVp_NOK)) {
4703         (void)SvOK_off(dstr);
4704         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4705         if (sflags & SVp_IOK) {
4706             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4707             SvIV_set(dstr, SvIVX(sstr));
4708         }
4709         if (sflags & SVp_NOK) {
4710             SvNV_set(dstr, SvNVX(sstr));
4711         }
4712     }
4713     else {
4714         if (isGV_with_GP(sstr)) {
4715             gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4716         }
4717         else
4718             (void)SvOK_off(dstr);
4719     }
4720     if (SvTAINTED(sstr))
4721         SvTAINT(dstr);
4722 }
4723
4724 /*
4725 =for apidoc sv_setsv_mg
4726
4727 Like C<sv_setsv>, but also handles 'set' magic.
4728
4729 =cut
4730 */
4731
4732 void
4733 Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr)
4734 {
4735     PERL_ARGS_ASSERT_SV_SETSV_MG;
4736
4737     sv_setsv(dstr,sstr);
4738     SvSETMAGIC(dstr);
4739 }
4740
4741 #ifdef PERL_ANY_COW
4742 # ifdef PERL_OLD_COPY_ON_WRITE
4743 #  define SVt_COW SVt_PVIV
4744 # else
4745 #  define SVt_COW SVt_PV
4746 # endif
4747 SV *
4748 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4749 {
4750     STRLEN cur = SvCUR(sstr);
4751     STRLEN len = SvLEN(sstr);
4752     char *new_pv;
4753 #if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_NEW_COPY_ON_WRITE)
4754     const bool already = cBOOL(SvIsCOW(sstr));
4755 #endif
4756
4757     PERL_ARGS_ASSERT_SV_SETSV_COW;
4758
4759     if (DEBUG_C_TEST) {
4760         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4761                       (void*)sstr, (void*)dstr);
4762         sv_dump(sstr);
4763         if (dstr)
4764                     sv_dump(dstr);
4765     }
4766
4767     if (dstr) {
4768         if (SvTHINKFIRST(dstr))
4769             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4770         else if (SvPVX_const(dstr))
4771             Safefree(SvPVX_mutable(dstr));
4772     }
4773     else
4774         new_SV(dstr);
4775     SvUPGRADE(dstr, SVt_COW);
4776
4777     assert (SvPOK(sstr));
4778     assert (SvPOKp(sstr));
4779 # ifdef PERL_OLD_COPY_ON_WRITE
4780     assert (!SvIOK(sstr));
4781     assert (!SvIOKp(sstr));
4782     assert (!SvNOK(sstr));
4783     assert (!SvNOKp(sstr));
4784 # endif
4785
4786     if (SvIsCOW(sstr)) {
4787
4788         if (SvLEN(sstr) == 0) {
4789             /* source is a COW shared hash key.  */
4790             DEBUG_C(PerlIO_printf(Perl_debug_log,
4791                                   "Fast copy on write: Sharing hash\n"));
4792             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4793             goto common_exit;
4794         }
4795 # ifdef PERL_OLD_COPY_ON_WRITE
4796         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4797 # else
4798         assert(SvCUR(sstr)+1 < SvLEN(sstr));
4799         assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX);
4800 # endif
4801     } else {
4802         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4803         SvUPGRADE(sstr, SVt_COW);
4804         SvIsCOW_on(sstr);
4805         DEBUG_C(PerlIO_printf(Perl_debug_log,
4806                               "Fast copy on write: Converting sstr to COW\n"));
4807 # ifdef PERL_OLD_COPY_ON_WRITE
4808         SV_COW_NEXT_SV_SET(dstr, sstr);
4809 # else
4810         CowREFCNT(sstr) = 0;    
4811 # endif
4812     }
4813 # ifdef PERL_OLD_COPY_ON_WRITE
4814     SV_COW_NEXT_SV_SET(sstr, dstr);
4815 # else
4816 #  ifdef PERL_DEBUG_READONLY_COW
4817     if (already) sv_buf_to_rw(sstr);
4818 #  endif
4819     CowREFCNT(sstr)++;  
4820 # endif
4821     new_pv = SvPVX_mutable(sstr);
4822     sv_buf_to_ro(sstr);
4823
4824   common_exit:
4825     SvPV_set(dstr, new_pv);
4826     SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
4827     if (SvUTF8(sstr))
4828         SvUTF8_on(dstr);
4829     SvLEN_set(dstr, len);
4830     SvCUR_set(dstr, cur);
4831     if (DEBUG_C_TEST) {
4832         sv_dump(dstr);
4833     }
4834     return dstr;
4835 }
4836 #endif
4837
4838 /*
4839 =for apidoc sv_setpvn
4840
4841 Copies a string (possibly containing embedded C<NUL> characters) into an SV.
4842 The C<len> parameter indicates the number of
4843 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4844 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4845
4846 =cut
4847 */
4848
4849 void
4850 Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4851 {
4852     char *dptr;
4853
4854     PERL_ARGS_ASSERT_SV_SETPVN;
4855
4856     SV_CHECK_THINKFIRST_COW_DROP(sv);
4857     if (!ptr) {
4858         (void)SvOK_off(sv);
4859         return;
4860     }
4861     else {
4862         /* len is STRLEN which is unsigned, need to copy to signed */
4863         const IV iv = len;
4864         if (iv < 0)
4865             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
4866                        IVdf, iv);
4867     }
4868     SvUPGRADE(sv, SVt_PV);
4869
4870     dptr = SvGROW(sv, len + 1);
4871     Move(ptr,dptr,len,char);
4872     dptr[len] = '\0';
4873     SvCUR_set(sv, len);
4874     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4875     SvTAINT(sv);
4876     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4877 }
4878
4879 /*
4880 =for apidoc sv_setpvn_mg
4881
4882 Like C<sv_setpvn>, but also handles 'set' magic.
4883
4884 =cut
4885 */
4886
4887 void
4888 Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4889 {
4890     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4891
4892     sv_setpvn(sv,ptr,len);
4893     SvSETMAGIC(sv);
4894 }
4895
4896 /*
4897 =for apidoc sv_setpv
4898
4899 Copies a string into an SV.  The string must be terminated with a C<NUL>
4900 character.
4901 Does not handle 'set' magic.  See C<sv_setpv_mg>.
4902
4903 =cut
4904 */
4905
4906 void
4907 Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
4908 {
4909     STRLEN len;
4910
4911     PERL_ARGS_ASSERT_SV_SETPV;
4912
4913     SV_CHECK_THINKFIRST_COW_DROP(sv);
4914     if (!ptr) {
4915         (void)SvOK_off(sv);
4916         return;
4917     }
4918     len = strlen(ptr);
4919     SvUPGRADE(sv, SVt_PV);
4920
4921     SvGROW(sv, len + 1);
4922     Move(ptr,SvPVX(sv),len+1,char);
4923     SvCUR_set(sv, len);
4924     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4925     SvTAINT(sv);
4926     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4927 }
4928
4929 /*
4930 =for apidoc sv_setpv_mg
4931
4932 Like C<sv_setpv>, but also handles 'set' magic.
4933
4934 =cut
4935 */
4936
4937 void
4938 Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
4939 {
4940     PERL_ARGS_ASSERT_SV_SETPV_MG;
4941
4942     sv_setpv(sv,ptr);
4943     SvSETMAGIC(sv);
4944 }
4945
4946 void
4947 Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
4948 {
4949     PERL_ARGS_ASSERT_SV_SETHEK;
4950
4951     if (!hek) {
4952         return;
4953     }
4954
4955     if (HEK_LEN(hek) == HEf_SVKEY) {
4956         sv_setsv(sv, *(SV**)HEK_KEY(hek));
4957         return;
4958     } else {
4959         const int flags = HEK_FLAGS(hek);
4960         if (flags & HVhek_WASUTF8) {
4961             STRLEN utf8_len = HEK_LEN(hek);
4962             char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
4963             sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
4964             SvUTF8_on(sv);
4965             return;
4966         } else if (flags & HVhek_UNSHARED) {
4967             sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
4968             if (HEK_UTF8(hek))
4969                 SvUTF8_on(sv);
4970             else SvUTF8_off(sv);
4971             return;
4972         }
4973         {
4974             SV_CHECK_THINKFIRST_COW_DROP(sv);
4975             SvUPGRADE(sv, SVt_PV);
4976             SvPV_free(sv);
4977             SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
4978             SvCUR_set(sv, HEK_LEN(hek));
4979             SvLEN_set(sv, 0);
4980             SvIsCOW_on(sv);
4981             SvPOK_on(sv);
4982             if (HEK_UTF8(hek))
4983                 SvUTF8_on(sv);
4984             else SvUTF8_off(sv);
4985             return;
4986         }
4987     }
4988 }
4989
4990
4991 /*
4992 =for apidoc sv_usepvn_flags
4993
4994 Tells an SV to use C<ptr> to find its string value.  Normally the
4995 string is stored inside the SV, but sv_usepvn allows the SV to use an
4996 outside string.  The C<ptr> should point to memory that was allocated
4997 by L<Newx|perlclib/Memory Management and String Handling>.  It must be
4998 the start of a Newx-ed block of memory, and not a pointer to the
4999 middle of it (beware of L<OOK|perlguts/Offsets> and copy-on-write),
5000 and not be from a non-Newx memory allocator like C<malloc>.  The
5001 string length, C<len>, must be supplied.  By default this function
5002 will C<Renew> (i.e. realloc, move) the memory pointed to by C<ptr>,
5003 so that pointer should not be freed or used by the programmer after
5004 giving it to sv_usepvn, and neither should any pointers from "behind"
5005 that pointer (e.g. ptr + 1) be used.
5006
5007 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC.  If C<flags> &
5008 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be C<NUL>, and the realloc
5009 will be skipped (i.e. the buffer is actually at least 1 byte longer than
5010 C<len>, and already meets the requirements for storing in C<SvPVX>).
5011
5012 =cut
5013 */
5014
5015 void
5016 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
5017 {
5018     STRLEN allocate;
5019
5020     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
5021
5022     SV_CHECK_THINKFIRST_COW_DROP(sv);
5023     SvUPGRADE(sv, SVt_PV);
5024     if (!ptr) {
5025         (void)SvOK_off(sv);
5026         if (flags & SV_SMAGIC)
5027             SvSETMAGIC(sv);
5028         return;
5029     }
5030     if (SvPVX_const(sv))
5031         SvPV_free(sv);
5032
5033 #ifdef DEBUGGING
5034     if (flags & SV_HAS_TRAILING_NUL)
5035         assert(ptr[len] == '\0');
5036 #endif
5037
5038     allocate = (flags & SV_HAS_TRAILING_NUL)
5039         ? len + 1 :
5040 #ifdef Perl_safesysmalloc_size
5041         len + 1;
5042 #else 
5043         PERL_STRLEN_ROUNDUP(len + 1);
5044 #endif
5045     if (flags & SV_HAS_TRAILING_NUL) {
5046         /* It's long enough - do nothing.
5047            Specifically Perl_newCONSTSUB is relying on this.  */
5048     } else {
5049 #ifdef DEBUGGING
5050         /* Force a move to shake out bugs in callers.  */
5051         char *new_ptr = (char*)safemalloc(allocate);
5052         Copy(ptr, new_ptr, len, char);
5053         PoisonFree(ptr,len,char);
5054         Safefree(ptr);
5055         ptr = new_ptr;
5056 #else
5057         ptr = (char*) saferealloc (ptr, allocate);
5058 #endif
5059     }
5060 #ifdef Perl_safesysmalloc_size
5061     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
5062 #else
5063     SvLEN_set(sv, allocate);
5064 #endif
5065     SvCUR_set(sv, len);
5066     SvPV_set(sv, ptr);
5067     if (!(flags & SV_HAS_TRAILING_NUL)) {
5068         ptr[len] = '\0';
5069     }
5070     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5071     SvTAINT(sv);
5072     if (flags & SV_SMAGIC)
5073         SvSETMAGIC(sv);
5074 }
5075
5076 #ifdef PERL_OLD_COPY_ON_WRITE
5077 /* Need to do this *after* making the SV normal, as we need the buffer
5078    pointer to remain valid until after we've copied it.  If we let go too early,
5079    another thread could invalidate it by unsharing last of the same hash key
5080    (which it can do by means other than releasing copy-on-write Svs)
5081    or by changing the other copy-on-write SVs in the loop.  */
5082 STATIC void
5083 S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after)
5084 {
5085     PERL_ARGS_ASSERT_SV_RELEASE_COW;
5086
5087     { /* this SV was SvIsCOW_normal(sv) */
5088          /* we need to find the SV pointing to us.  */
5089         SV *current = SV_COW_NEXT_SV(after);
5090
5091         if (current == sv) {
5092             /* The SV we point to points back to us (there were only two of us
5093                in the loop.)
5094                Hence other SV is no longer copy on write either.  */
5095             SvIsCOW_off(after);
5096             sv_buf_to_rw(after);
5097         } else {
5098             /* We need to follow the pointers around the loop.  */
5099             SV *next;
5100             while ((next = SV_COW_NEXT_SV(current)) != sv) {
5101                 assert (next);
5102                 current = next;
5103                  /* don't loop forever if the structure is bust, and we have
5104                     a pointer into a closed loop.  */
5105                 assert (current != after);
5106                 assert (SvPVX_const(current) == pvx);
5107             }
5108             /* Make the SV before us point to the SV after us.  */
5109             SV_COW_NEXT_SV_SET(current, after);
5110         }
5111     }
5112 }
5113 #endif
5114 /*
5115 =for apidoc sv_force_normal_flags
5116
5117 Undo various types of fakery on an SV, where fakery means
5118 "more than" a string: if the PV is a shared string, make
5119 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5120 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
5121 we do the copy, and is also used locally; if this is a
5122 vstring, drop the vstring magic.  If C<SV_COW_DROP_PV> is set
5123 then a copy-on-write scalar drops its PV buffer (if any) and becomes
5124 SvPOK_off rather than making a copy.  (Used where this
5125 scalar is about to be set to some other value.)  In addition,
5126 the C<flags> parameter gets passed to C<sv_unref_flags()>
5127 when unreffing.  C<sv_force_normal> calls this function
5128 with flags set to 0.
5129
5130 This function is expected to be used to signal to perl that this SV is
5131 about to be written to, and any extra book-keeping needs to be taken care
5132 of.  Hence, it croaks on read-only values.
5133
5134 =cut
5135 */
5136
5137 static void
5138 S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
5139 {
5140     assert(SvIsCOW(sv));
5141     {
5142 #ifdef PERL_ANY_COW
5143         const char * const pvx = SvPVX_const(sv);
5144         const STRLEN len = SvLEN(sv);
5145         const STRLEN cur = SvCUR(sv);
5146 # ifdef PERL_OLD_COPY_ON_WRITE
5147         /* next COW sv in the loop.  If len is 0 then this is a shared-hash
5148            key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
5149            we'll fail an assertion.  */
5150         SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
5151 # endif
5152
5153         if (DEBUG_C_TEST) {
5154                 PerlIO_printf(Perl_debug_log,
5155                               "Copy on write: Force normal %ld\n",
5156                               (long) flags);
5157                 sv_dump(sv);
5158         }
5159         SvIsCOW_off(sv);
5160 # ifdef PERL_NEW_COPY_ON_WRITE
5161         if (len && CowREFCNT(sv) == 0)
5162             /* We own the buffer ourselves. */
5163             sv_buf_to_rw(sv);
5164         else
5165 # endif
5166         {
5167                 
5168             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
5169 # ifdef PERL_NEW_COPY_ON_WRITE
5170             /* Must do this first, since the macro uses SvPVX. */
5171             if (len) {
5172                 sv_buf_to_rw(sv);
5173                 CowREFCNT(sv)--;
5174                 sv_buf_to_ro(sv);
5175             }
5176 # endif
5177             SvPV_set(sv, NULL);
5178             SvCUR_set(sv, 0);
5179             SvLEN_set(sv, 0);
5180             if (flags & SV_COW_DROP_PV) {
5181                 /* OK, so we don't need to copy our buffer.  */
5182                 SvPOK_off(sv);
5183             } else {
5184                 SvGROW(sv, cur + 1);
5185                 Move(pvx,SvPVX(sv),cur,char);
5186                 SvCUR_set(sv, cur);
5187                 *SvEND(sv) = '\0';
5188             }
5189             if (len) {
5190 # ifdef PERL_OLD_COPY_ON_WRITE
5191                 sv_release_COW(sv, pvx, next);
5192 # endif
5193             } else {
5194                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5195             }
5196             if (DEBUG_C_TEST) {
5197                 sv_dump(sv);
5198             }
5199         }
5200 #else
5201             const char * const pvx = SvPVX_const(sv);
5202             const STRLEN len = SvCUR(sv);
5203             SvIsCOW_off(sv);
5204             SvPV_set(sv, NULL);
5205             SvLEN_set(sv, 0);
5206             if (flags & SV_COW_DROP_PV) {
5207                 /* OK, so we don't need to copy our buffer.  */
5208                 SvPOK_off(sv);
5209             } else {
5210                 SvGROW(sv, len + 1);
5211                 Move(pvx,SvPVX(sv),len,char);
5212                 *SvEND(sv) = '\0';
5213             }
5214             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5215 #endif
5216     }
5217 }
5218
5219 void
5220 Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
5221 {
5222     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
5223
5224     if (SvREADONLY(sv))
5225         Perl_croak_no_modify();
5226     else if (SvIsCOW(sv) && LIKELY(SvTYPE(sv) != SVt_PVHV))
5227         S_sv_uncow(aTHX_ sv, flags);
5228     if (SvROK(sv))
5229         sv_unref_flags(sv, flags);
5230     else if (SvFAKE(sv) && isGV_with_GP(sv))
5231         sv_unglob(sv, flags);
5232     else if (SvFAKE(sv) && isREGEXP(sv)) {
5233         /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
5234            to sv_unglob. We only need it here, so inline it.  */
5235         const bool islv = SvTYPE(sv) == SVt_PVLV;
5236         const svtype new_type =
5237           islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
5238         SV *const temp = newSV_type(new_type);
5239         regexp *const temp_p = ReANY((REGEXP *)sv);
5240
5241         if (new_type == SVt_PVMG) {
5242             SvMAGIC_set(temp, SvMAGIC(sv));
5243             SvMAGIC_set(sv, NULL);
5244             SvSTASH_set(temp, SvSTASH(sv));
5245             SvSTASH_set(sv, NULL);
5246         }
5247         if (!islv) SvCUR_set(temp, SvCUR(sv));
5248         /* Remember that SvPVX is in the head, not the body.  But
5249            RX_WRAPPED is in the body. */
5250         assert(ReANY((REGEXP *)sv)->mother_re);
5251         /* Their buffer is already owned by someone else. */
5252         if (flags & SV_COW_DROP_PV) {
5253             /* SvLEN is already 0.  For SVt_REGEXP, we have a brand new
5254                zeroed body.  For SVt_PVLV, it should have been set to 0
5255                before turning into a regexp. */
5256             assert(!SvLEN(islv ? sv : temp));
5257             sv->sv_u.svu_pv = 0;
5258         }
5259         else {
5260             sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
5261             SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
5262             SvPOK_on(sv);
5263         }
5264
5265         /* Now swap the rest of the bodies. */
5266
5267         SvFAKE_off(sv);
5268         if (!islv) {
5269             SvFLAGS(sv) &= ~SVTYPEMASK;
5270             SvFLAGS(sv) |= new_type;
5271             SvANY(sv) = SvANY(temp);
5272         }
5273
5274         SvFLAGS(temp) &= ~(SVTYPEMASK);
5275         SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
5276         SvANY(temp) = temp_p;
5277         temp->sv_u.svu_rx = (regexp *)temp_p;
5278
5279         SvREFCNT_dec_NN(temp);
5280     }
5281     else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
5282 }
5283
5284 /*
5285 =for apidoc sv_chop
5286
5287 Efficient removal of characters from the beginning of the string buffer.
5288 SvPOK(sv), or at least SvPOKp(sv), must be true and the C<ptr> must be a
5289 pointer to somewhere inside the string buffer.  The C<ptr> becomes the first
5290 character of the adjusted string.  Uses the "OOK hack".  On return, only
5291 SvPOK(sv) and SvPOKp(sv) among the OK flags will be true.
5292
5293 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
5294 refer to the same chunk of data.
5295
5296 The unfortunate similarity of this function's name to that of Perl's C<chop>
5297 operator is strictly coincidental.  This function works from the left;
5298 C<chop> works from the right.
5299
5300 =cut
5301 */
5302
5303 void
5304 Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
5305 {
5306     STRLEN delta;
5307     STRLEN old_delta;
5308     U8 *p;
5309 #ifdef DEBUGGING
5310     const U8 *evacp;
5311     STRLEN evacn;
5312 #endif
5313     STRLEN max_delta;
5314
5315     PERL_ARGS_ASSERT_SV_CHOP;
5316
5317     if (!ptr || !SvPOKp(sv))
5318         return;
5319     delta = ptr - SvPVX_const(sv);
5320     if (!delta) {
5321         /* Nothing to do.  */
5322         return;
5323     }
5324     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
5325     if (delta > max_delta)
5326         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
5327                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
5328     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
5329     SV_CHECK_THINKFIRST(sv);
5330     SvPOK_only_UTF8(sv);
5331
5332     if (!SvOOK(sv)) {
5333         if (!SvLEN(sv)) { /* make copy of shared string */
5334             const char *pvx = SvPVX_const(sv);
5335             const STRLEN len = SvCUR(sv);
5336             SvGROW(sv, len + 1);
5337             Move(pvx,SvPVX(sv),len,char);
5338             *SvEND(sv) = '\0';
5339         }
5340         SvOOK_on(sv);
5341         old_delta = 0;
5342     } else {
5343         SvOOK_offset(sv, old_delta);
5344     }
5345     SvLEN_set(sv, SvLEN(sv) - delta);
5346     SvCUR_set(sv, SvCUR(sv) - delta);
5347     SvPV_set(sv, SvPVX(sv) + delta);
5348
5349     p = (U8 *)SvPVX_const(sv);
5350
5351 #ifdef DEBUGGING
5352     /* how many bytes were evacuated?  we will fill them with sentinel
5353        bytes, except for the part holding the new offset of course. */
5354     evacn = delta;
5355     if (old_delta)
5356         evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
5357     assert(evacn);
5358     assert(evacn <= delta + old_delta);
5359     evacp = p - evacn;
5360 #endif
5361
5362     /* This sets 'delta' to the accumulated value of all deltas so far */
5363     delta += old_delta;
5364     assert(delta);
5365
5366     /* If 'delta' fits in a byte, store it just prior to the new beginning of
5367      * the string; otherwise store a 0 byte there and store 'delta' just prior
5368      * to that, using as many bytes as a STRLEN occupies.  Thus it overwrites a
5369      * portion of the chopped part of the string */
5370     if (delta < 0x100) {
5371         *--p = (U8) delta;
5372     } else {
5373         *--p = 0;
5374         p -= sizeof(STRLEN);
5375         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
5376     }
5377
5378 #ifdef DEBUGGING
5379     /* Fill the preceding buffer with sentinals to verify that no-one is
5380        using it.  */
5381     while (p > evacp) {
5382         --p;
5383         *p = (U8)PTR2UV(p);
5384     }
5385 #endif
5386 }
5387
5388 /*
5389 =for apidoc sv_catpvn
5390
5391 Concatenates the string onto the end of the string which is in the SV.  The
5392 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
5393 status set, then the bytes appended should be valid UTF-8.
5394 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
5395
5396 =for apidoc sv_catpvn_flags
5397
5398 Concatenates the string onto the end of the string which is in the SV.  The
5399 C<len> indicates number of bytes to copy.
5400
5401 By default, the string appended is assumed to be valid UTF-8 if the SV has
5402 the UTF-8 status set, and a string of bytes otherwise.  One can force the
5403 appended string to be interpreted as UTF-8 by supplying the C<SV_CATUTF8>
5404 flag, and as bytes by supplying the C<SV_CATBYTES> flag; the SV or the
5405 string appended will be upgraded to UTF-8 if necessary.
5406
5407 If C<flags> has the C<SV_SMAGIC> bit set, will
5408 C<mg_set> on C<dsv> afterwards if appropriate.
5409 C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5410 in terms of this function.
5411
5412 =cut
5413 */
5414
5415 void
5416 Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
5417 {
5418     STRLEN dlen;
5419     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5420
5421     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5422     assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5423
5424     if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
5425       if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
5426          sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5427          dlen = SvCUR(dsv);
5428       }
5429       else SvGROW(dsv, dlen + slen + 1);
5430       if (sstr == dstr)
5431         sstr = SvPVX_const(dsv);
5432       Move(sstr, SvPVX(dsv) + dlen, slen, char);
5433       SvCUR_set(dsv, SvCUR(dsv) + slen);
5434     }
5435     else {
5436         /* We inline bytes_to_utf8, to avoid an extra malloc. */
5437         const char * const send = sstr + slen;
5438         U8 *d;
5439
5440         /* Something this code does not account for, which I think is
5441            impossible; it would require the same pv to be treated as
5442            bytes *and* utf8, which would indicate a bug elsewhere. */
5443         assert(sstr != dstr);
5444
5445         SvGROW(dsv, dlen + slen * 2 + 1);
5446         d = (U8 *)SvPVX(dsv) + dlen;
5447
5448         while (sstr < send) {
5449             append_utf8_from_native_byte(*sstr, &d);
5450             sstr++;
5451         }
5452         SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5453     }
5454     *SvEND(dsv) = '\0';
5455     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
5456     SvTAINT(dsv);
5457     if (flags & SV_SMAGIC)
5458         SvSETMAGIC(dsv);
5459 }
5460
5461 /*
5462 =for apidoc sv_catsv
5463
5464 Concatenates the string from SV C<ssv> onto the end of the string in SV
5465 C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5466 Handles 'get' magic on both SVs, but no 'set' magic.  See C<sv_catsv_mg> and
5467 C<sv_catsv_nomg>.
5468
5469 =for apidoc sv_catsv_flags
5470
5471 Concatenates the string from SV C<ssv> onto the end of the string in SV
5472 C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5473 If C<flags> include C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if
5474 appropriate.  If C<flags> include C<SV_SMAGIC>, C<mg_set> will be called on
5475 the modified SV afterward, if appropriate.  C<sv_catsv>, C<sv_catsv_nomg>,
5476 and C<sv_catsv_mg> are implemented in terms of this function.
5477
5478 =cut */
5479
5480 void
5481 Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
5482 {
5483     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5484
5485     if (ssv) {
5486         STRLEN slen;
5487         const char *spv = SvPV_flags_const(ssv, slen, flags);
5488         if (flags & SV_GMAGIC)
5489                 SvGETMAGIC(dsv);
5490         sv_catpvn_flags(dsv, spv, slen,
5491                             DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
5492         if (flags & SV_SMAGIC)
5493                 SvSETMAGIC(dsv);
5494     }
5495 }
5496
5497 /*
5498 =for apidoc sv_catpv
5499
5500 Concatenates the C<NUL>-terminated string onto the end of the string which is
5501 in the SV.
5502 If the SV has the UTF-8 status set, then the bytes appended should be
5503 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
5504
5505 =cut */
5506
5507 void
5508 Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
5509 {
5510     STRLEN len;
5511     STRLEN tlen;
5512     char *junk;
5513
5514     PERL_ARGS_ASSERT_SV_CATPV;
5515
5516     if (!ptr)
5517         return;
5518     junk = SvPV_force(sv, tlen);
5519     len = strlen(ptr);
5520     SvGROW(sv, tlen + len + 1);
5521     if (ptr == junk)
5522         ptr = SvPVX_const(sv);
5523     Move(ptr,SvPVX(sv)+tlen,len+1,char);
5524     SvCUR_set(sv, SvCUR(sv) + len);
5525     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5526     SvTAINT(sv);
5527 }
5528
5529 /*
5530 =for apidoc sv_catpv_flags
5531
5532 Concatenates the C<NUL>-terminated string onto the end of the string which is
5533 in the SV.
5534 If the SV has the UTF-8 status set, then the bytes appended should
5535 be valid UTF-8.  If C<flags> has the C<SV_SMAGIC> bit set, will C<mg_set>
5536 on the modified SV if appropriate.
5537
5538 =cut
5539 */
5540
5541 void
5542 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
5543 {
5544     PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5545     sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
5546 }
5547
5548 /*
5549 =for apidoc sv_catpv_mg
5550
5551 Like C<sv_catpv>, but also handles 'set' magic.
5552
5553 =cut
5554 */
5555
5556 void
5557 Perl_sv_catpv_mg(pTHX_ SV *const sv, const char *const ptr)
5558 {
5559     PERL_ARGS_ASSERT_SV_CATPV_MG;
5560
5561     sv_catpv(sv,ptr);
5562     SvSETMAGIC(sv);
5563 }
5564
5565 /*
5566 =for apidoc newSV
5567
5568 Creates a new SV.  A non-zero C<len> parameter indicates the number of
5569 bytes of preallocated string space the SV should have.  An extra byte for a
5570 trailing C<NUL> is also reserved.  (SvPOK is not set for the SV even if string
5571 space is allocated.)  The reference count for the new SV is set to 1.
5572
5573 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
5574 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5575 This aid has been superseded by a new build option, PERL_MEM_LOG (see
5576 L<perlhacktips/PERL_MEM_LOG>).  The older API is still there for use in XS
5577 modules supporting older perls.
5578
5579 =cut
5580 */
5581
5582 SV *
5583 Perl_newSV(pTHX_ const STRLEN len)
5584 {
5585     SV *sv;
5586
5587     new_SV(sv);
5588     if (len) {
5589         sv_grow(sv, len + 1);
5590     }
5591     return sv;
5592 }
5593 /*
5594 =for apidoc sv_magicext
5595
5596 Adds magic to an SV, upgrading it if necessary.  Applies the
5597 supplied vtable and returns a pointer to the magic added.
5598
5599 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5600 In particular, you can add magic to SvREADONLY SVs, and add more than
5601 one instance of the same 'how'.
5602
5603 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5604 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5605 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5606 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5607
5608 (This is now used as a subroutine by C<sv_magic>.)
5609
5610 =cut
5611 */
5612 MAGIC * 
5613 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, 
5614                 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5615 {
5616     MAGIC* mg;
5617
5618     PERL_ARGS_ASSERT_SV_MAGICEXT;
5619
5620     if (SvTYPE(sv)==SVt_PVAV) { assert (!AvPAD_NAMELIST(sv)); }
5621
5622     SvUPGRADE(sv, SVt_PVMG);
5623     Newxz(mg, 1, MAGIC);
5624     mg->mg_moremagic = SvMAGIC(sv);
5625     SvMAGIC_set(sv, mg);
5626
5627     /* Sometimes a magic contains a reference loop, where the sv and
5628        object refer to each other.  To prevent a reference loop that
5629        would prevent such objects being freed, we look for such loops
5630        and if we find one we avoid incrementing the object refcount.
5631
5632        Note we cannot do this to avoid self-tie loops as intervening RV must
5633        have its REFCNT incremented to keep it in existence.
5634
5635     */
5636     if (!obj || obj == sv ||
5637         how == PERL_MAGIC_arylen ||
5638         how == PERL_MAGIC_symtab ||
5639         (SvTYPE(obj) == SVt_PVGV &&
5640             (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5641              || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5642              || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5643     {
5644         mg->mg_obj = obj;
5645     }
5646     else {
5647         mg->mg_obj = SvREFCNT_inc_simple(obj);
5648         mg->mg_flags |= MGf_REFCOUNTED;
5649     }
5650
5651     /* Normal self-ties simply pass a null object, and instead of
5652        using mg_obj directly, use the SvTIED_obj macro to produce a
5653        new RV as needed.  For glob "self-ties", we are tieing the PVIO
5654        with an RV obj pointing to the glob containing the PVIO.  In
5655        this case, to avoid a reference loop, we need to weaken the
5656        reference.
5657     */
5658
5659     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5660         obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5661     {
5662       sv_rvweaken(obj);
5663     }
5664
5665     mg->mg_type = how;
5666     mg->mg_len = namlen;
5667     if (name) {
5668         if (namlen > 0)
5669             mg->mg_ptr = savepvn(name, namlen);
5670         else if (namlen == HEf_SVKEY) {
5671             /* Yes, this is casting away const. This is only for the case of
5672                HEf_SVKEY. I think we need to document this aberation of the
5673                constness of the API, rather than making name non-const, as
5674                that change propagating outwards a long way.  */
5675             mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5676         } else
5677             mg->mg_ptr = (char *) name;
5678     }
5679     mg->mg_virtual = (MGVTBL *) vtable;
5680
5681     mg_magical(sv);
5682     return mg;
5683 }
5684
5685 MAGIC *
5686 Perl_sv_magicext_mglob(pTHX_ SV *sv)
5687 {
5688     PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB;
5689     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
5690         /* This sv is only a delegate.  //g magic must be attached to
5691            its target. */
5692         vivify_defelem(sv);
5693         sv = LvTARG(sv);
5694     }
5695 #ifdef PERL_OLD_COPY_ON_WRITE
5696     if (SvIsCOW(sv))
5697         sv_force_normal_flags(sv, 0);
5698 #endif
5699     return sv_magicext(sv, NULL, PERL_MAGIC_regex_global,
5700                        &PL_vtbl_mglob, 0, 0);
5701 }
5702
5703 /*
5704 =for apidoc sv_magic
5705
5706 Adds magic to an SV.  First upgrades C<sv> to type C<SVt_PVMG> if
5707 necessary, then adds a new magic item of type C<how> to the head of the
5708 magic list.
5709
5710 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5711 handling of the C<name> and C<namlen> arguments.
5712
5713 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5714 to add more than one instance of the same 'how'.
5715
5716 =cut
5717 */
5718
5719 void
5720 Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
5721              const char *const name, const I32 namlen)
5722 {
5723     const MGVTBL *vtable;
5724     MAGIC* mg;
5725     unsigned int flags;
5726     unsigned int vtable_index;
5727
5728     PERL_ARGS_ASSERT_SV_MAGIC;
5729
5730     if (how < 0 || (unsigned)how >= C_ARRAY_LENGTH(PL_magic_data)
5731         || ((flags = PL_magic_data[how]),
5732             (vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
5733             > magic_vtable_max))
5734         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5735
5736     /* PERL_MAGIC_ext is reserved for use by extensions not perl internals.
5737        Useful for attaching extension internal data to perl vars.
5738        Note that multiple extensions may clash if magical scalars
5739        etc holding private data from one are passed to another. */
5740
5741     vtable = (vtable_index == magic_vtable_max)
5742         ? NULL : PL_magic_vtables + vtable_index;
5743
5744 #ifdef PERL_OLD_COPY_ON_WRITE
5745     if (SvIsCOW(sv))
5746         sv_force_normal_flags(sv, 0);
5747 #endif
5748     if (SvREADONLY(sv)) {
5749         if (
5750             !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
5751            )
5752         {
5753             Perl_croak_no_modify();
5754         }
5755     }
5756     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5757         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5758             /* sv_magic() refuses to add a magic of the same 'how' as an
5759                existing one
5760              */
5761             if (how == PERL_MAGIC_taint)
5762                 mg->mg_len |= 1;
5763             return;
5764         }
5765     }
5766
5767     /* Force pos to be stored as characters, not bytes. */
5768     if (SvMAGICAL(sv) && DO_UTF8(sv)
5769       && (mg = mg_find(sv, PERL_MAGIC_regex_global))
5770       && mg->mg_len != -1
5771       && mg->mg_flags & MGf_BYTES) {
5772         mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len,
5773                                                SV_CONST_RETURN);
5774         mg->mg_flags &= ~MGf_BYTES;
5775     }
5776
5777     /* Rest of work is done else where */
5778     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5779
5780     switch (how) {
5781     case PERL_MAGIC_taint:
5782         mg->mg_len = 1;
5783         break;
5784     case PERL_MAGIC_ext:
5785     case PERL_MAGIC_dbfile:
5786         SvRMAGICAL_on(sv);
5787         break;
5788     }
5789 }
5790
5791 static int
5792 S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
5793 {
5794     MAGIC* mg;
5795     MAGIC** mgp;
5796
5797     assert(flags <= 1);
5798
5799     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5800         return 0;
5801     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5802     for (mg = *mgp; mg; mg = *mgp) {
5803         const MGVTBL* const virt = mg->mg_virtual;
5804         if (mg->mg_type == type && (!flags || virt == vtbl)) {
5805             *mgp = mg->mg_moremagic;
5806             if (virt && virt->svt_free)
5807                 virt->svt_free(aTHX_ sv, mg);
5808             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5809                 if (mg->mg_len > 0)
5810                     Safefree(mg->mg_ptr);
5811                 else if (mg->mg_len == HEf_SVKEY)
5812                     SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5813                 else if (mg->mg_type == PERL_MAGIC_utf8)
5814                     Safefree(mg->mg_ptr);
5815             }
5816             if (mg->mg_flags & MGf_REFCOUNTED)
5817                 SvREFCNT_dec(mg->mg_obj);
5818             Safefree(mg);
5819         }
5820         else
5821             mgp = &mg->mg_moremagic;
5822     }
5823     if (SvMAGIC(sv)) {
5824         if (SvMAGICAL(sv))      /* if we're under save_magic, wait for restore_magic; */
5825             mg_magical(sv);     /*    else fix the flags now */
5826     }
5827     else {
5828         SvMAGICAL_off(sv);
5829         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5830     }
5831     return 0;
5832 }
5833
5834 /*
5835 =for apidoc sv_unmagic
5836
5837 Removes all magic of type C<type> from an SV.
5838
5839 =cut
5840 */
5841
5842 int
5843 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5844 {
5845     PERL_ARGS_ASSERT_SV_UNMAGIC;
5846     return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
5847 }
5848
5849 /*
5850 =for apidoc sv_unmagicext
5851
5852 Removes all magic of type C<type> with the specified C<vtbl> from an SV.
5853
5854 =cut
5855 */
5856
5857 int
5858 Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
5859 {
5860     PERL_ARGS_ASSERT_SV_UNMAGICEXT;
5861     return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
5862 }
5863
5864 /*
5865 =for apidoc sv_rvweaken
5866
5867 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5868 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5869 push a back-reference to this RV onto the array of backreferences
5870 associated with that magic.  If the RV is magical, set magic will be
5871 called after the RV is cleared.
5872
5873 =cut
5874 */
5875
5876 SV *
5877 Perl_sv_rvweaken(pTHX_ SV *const sv)
5878 {
5879     SV *tsv;
5880
5881     PERL_ARGS_ASSERT_SV_RVWEAKEN;
5882
5883     if (!SvOK(sv))  /* let undefs pass */
5884         return sv;
5885     if (!SvROK(sv))
5886         Perl_croak(aTHX_ "Can't weaken a nonreference");
5887     else if (SvWEAKREF(sv)) {
5888         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5889         return sv;
5890     }
5891     else if (SvREADONLY(sv)) croak_no_modify();
5892     tsv = SvRV(sv);
5893     Perl_sv_add_backref(aTHX_ tsv, sv);
5894     SvWEAKREF_on(sv);
5895     SvREFCNT_dec_NN(tsv);
5896     return sv;
5897 }
5898
5899 /* Give tsv backref magic if it hasn't already got it, then push a
5900  * back-reference to sv onto the array associated with the backref magic.
5901  *
5902  * As an optimisation, if there's only one backref and it's not an AV,
5903  * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5904  * allocate an AV. (Whether the slot holds an AV tells us whether this is
5905  * active.)
5906  */
5907
5908 /* A discussion about the backreferences array and its refcount:
5909  *
5910  * The AV holding the backreferences is pointed to either as the mg_obj of
5911  * PERL_MAGIC_backref, or in the specific case of a HV, from the
5912  * xhv_backreferences field. The array is created with a refcount
5913  * of 2. This means that if during global destruction the array gets
5914  * picked on before its parent to have its refcount decremented by the
5915  * random zapper, it won't actually be freed, meaning it's still there for
5916  * when its parent gets freed.
5917  *
5918  * When the parent SV is freed, the extra ref is killed by
5919  * Perl_sv_kill_backrefs.  The other ref is killed, in the case of magic,
5920  * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5921  *
5922  * When a single backref SV is stored directly, it is not reference
5923  * counted.
5924  */
5925
5926 void
5927 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5928 {
5929     SV **svp;
5930     AV *av = NULL;
5931     MAGIC *mg = NULL;
5932
5933     PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5934
5935     /* find slot to store array or singleton backref */
5936
5937     if (SvTYPE(tsv) == SVt_PVHV) {
5938         svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5939     } else {
5940         if (SvMAGICAL(tsv))
5941             mg = mg_find(tsv, PERL_MAGIC_backref);
5942         if (!mg)
5943             mg = sv_magicext(tsv, NULL, PERL_MAGIC_backref, &PL_vtbl_backref, NULL, 0);
5944         svp = &(mg->mg_obj);
5945     }
5946
5947     /* create or retrieve the array */
5948
5949     if (   (!*svp && SvTYPE(sv) == SVt_PVAV)
5950         || (*svp && SvTYPE(*svp) != SVt_PVAV)
5951     ) {
5952         /* create array */
5953         if (mg)
5954             mg->mg_flags |= MGf_REFCOUNTED;
5955         av = newAV();
5956         AvREAL_off(av);
5957         SvREFCNT_inc_simple_void_NN(av);
5958         /* av now has a refcnt of 2; see discussion above */
5959         av_extend(av, *svp ? 2 : 1);
5960         if (*svp) {
5961             /* move single existing backref to the array */
5962             AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5963         }
5964         *svp = (SV*)av;
5965     }
5966     else {
5967         av = MUTABLE_AV(*svp);
5968         if (!av) {
5969             /* optimisation: store single backref directly in HvAUX or mg_obj */
5970             *svp = sv;
5971             return;
5972         }
5973         assert(SvTYPE(av) == SVt_PVAV);
5974         if (AvFILLp(av) >= AvMAX(av)) {
5975             av_extend(av, AvFILLp(av)+1);
5976         }
5977     }
5978     /* push new backref */
5979     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5980 }
5981
5982 /* delete a back-reference to ourselves from the backref magic associated
5983  * with the SV we point to.
5984  */
5985
5986 void
5987 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5988 {
5989     SV **svp = NULL;
5990
5991     PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5992
5993     if (SvTYPE(tsv) == SVt_PVHV) {
5994         if (SvOOK(tsv))
5995             svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5996     }
5997     else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) {
5998         /* It's possible for the the last (strong) reference to tsv to have
5999            become freed *before* the last thing holding a weak reference.
6000            If both survive longer than the backreferences array, then when
6001            the referent's reference count drops to 0 and it is freed, it's
6002            not able to chase the backreferences, so they aren't NULLed.
6003
6004            For example, a CV holds a weak reference to its stash. If both the
6005            CV and the stash survive longer than the backreferences array,
6006            and the CV gets picked for the SvBREAK() treatment first,
6007            *and* it turns out that the stash is only being kept alive because
6008            of an our variable in the pad of the CV, then midway during CV
6009            destruction the stash gets freed, but CvSTASH() isn't set to NULL.
6010            It ends up pointing to the freed HV. Hence it's chased in here, and
6011            if this block wasn't here, it would hit the !svp panic just below.
6012
6013            I don't believe that "better" destruction ordering is going to help
6014            here - during global destruction there's always going to be the
6015            chance that something goes out of order. We've tried to make it
6016            foolproof before, and it only resulted in evolutionary pressure on
6017            fools. Which made us look foolish for our hubris. :-(
6018         */
6019         return;
6020     }
6021     else {
6022         MAGIC *const mg
6023             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
6024         svp =  mg ? &(mg->mg_obj) : NULL;
6025     }
6026
6027     if (!svp)
6028         Perl_croak(aTHX_ "panic: del_backref, svp=0");
6029     if (!*svp) {
6030         /* It's possible that sv is being freed recursively part way through the
6031            freeing of tsv. If this happens, the backreferences array of tsv has
6032            already been freed, and so svp will be NULL. If this is the case,
6033            we should not panic. Instead, nothing needs doing, so return.  */
6034         if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
6035             return;
6036         Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
6037                    (void*)*svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
6038     }
6039
6040     if (SvTYPE(*svp) == SVt_PVAV) {
6041 #ifdef DEBUGGING
6042         int count = 1;
6043 #endif
6044         AV * const av = (AV*)*svp;
6045         SSize_t fill;
6046         assert(!SvIS_FREED(av));
6047         fill = AvFILLp(av);
6048         assert(fill > -1);
6049         svp = AvARRAY(av);
6050         /* for an SV with N weak references to it, if all those
6051          * weak refs are deleted, then sv_del_backref will be called
6052          * N times and O(N^2) compares will be done within the backref
6053          * array. To ameliorate this potential slowness, we:
6054          * 1) make sure this code is as tight as possible;
6055          * 2) when looking for SV, look for it at both the head and tail of the
6056          *    array first before searching the rest, since some create/destroy
6057          *    patterns will cause the backrefs to be freed in order.
6058          */
6059         if (*svp == sv) {
6060             AvARRAY(av)++;
6061             AvMAX(av)--;
6062         }
6063         else {
6064             SV **p = &svp[fill];
6065             SV *const topsv = *p;
6066             if (topsv != sv) {
6067 #ifdef DEBUGGING
6068                 count = 0;
6069 #endif
6070                 while (--p > svp) {
6071                     if (*p == sv) {
6072                         /* We weren't the last entry.
6073                            An unordered list has this property that you
6074                            can take the last element off the end to fill
6075                            the hole, and it's still an unordered list :-)
6076                         */
6077                         *p = topsv;
6078 #ifdef DEBUGGING
6079                         count++;
6080 #else
6081                         break; /* should only be one */
6082 #endif
6083                     }
6084                 }
6085             }
6086         }
6087         assert(count ==1);
6088         AvFILLp(av) = fill-1;
6089     }
6090     else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) {
6091         /* freed AV; skip */
6092     }
6093     else {
6094         /* optimisation: only a single backref, stored directly */
6095         if (*svp != sv)
6096             Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p",
6097                        (void*)*svp, (void*)sv);
6098         *svp = NULL;
6099     }
6100
6101 }
6102
6103 void
6104 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
6105 {
6106     SV **svp;
6107     SV **last;
6108     bool is_array;
6109
6110     PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
6111
6112     if (!av)
6113         return;
6114
6115     /* after multiple passes through Perl_sv_clean_all() for a thingy
6116      * that has badly leaked, the backref array may have gotten freed,
6117      * since we only protect it against 1 round of cleanup */
6118     if (SvIS_FREED(av)) {
6119         if (PL_in_clean_all) /* All is fair */
6120             return;
6121         Perl_croak(aTHX_
6122                    "panic: magic_killbackrefs (freed backref AV/SV)");
6123     }
6124
6125
6126     is_array = (SvTYPE(av) == SVt_PVAV);
6127     if (is_array) {
6128         assert(!SvIS_FREED(av));
6129         svp = AvARRAY(av);
6130         if (svp)
6131             last = svp + AvFILLp(av);
6132     }
6133     else {
6134         /* optimisation: only a single backref, stored directly */
6135         svp = (SV**)&av;
6136         last = svp;
6137     }
6138
6139     if (svp) {
6140         while (svp <= last) {
6141             if (*svp) {
6142                 SV *const referrer = *svp;
6143                 if (SvWEAKREF(referrer)) {
6144                     /* XXX Should we check that it hasn't changed? */
6145                     assert(SvROK(referrer));
6146                     SvRV_set(referrer, 0);
6147                     SvOK_off(referrer);
6148                     SvWEAKREF_off(referrer);
6149                     SvSETMAGIC(referrer);
6150                 } else if (SvTYPE(referrer) == SVt_PVGV ||
6151                            SvTYPE(referrer) == SVt_PVLV) {
6152                     assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
6153                     /* You lookin' at me?  */
6154                     assert(GvSTASH(referrer));
6155                     assert(GvSTASH(referrer) == (const HV *)sv);
6156                     GvSTASH(referrer) = 0;
6157                 } else if (SvTYPE(referrer) == SVt_PVCV ||
6158                            SvTYPE(referrer) == SVt_PVFM) {
6159                     if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
6160                         /* You lookin' at me?  */
6161                         assert(CvSTASH(referrer));
6162                         assert(CvSTASH(referrer) == (const HV *)sv);
6163                         SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
6164                     }
6165                     else {
6166                         assert(SvTYPE(sv) == SVt_PVGV);
6167                         /* You lookin' at me?  */
6168                         assert(CvGV(referrer));
6169                         assert(CvGV(referrer) == (const GV *)sv);
6170                         anonymise_cv_maybe(MUTABLE_GV(sv),
6171                                                 MUTABLE_CV(referrer));
6172                     }
6173
6174                 } else {
6175                     Perl_croak(aTHX_
6176                                "panic: magic_killbackrefs (flags=%"UVxf")",
6177                                (UV)SvFLAGS(referrer));
6178                 }
6179
6180                 if (is_array)
6181                     *svp = NULL;
6182             }
6183             svp++;
6184         }
6185     }
6186     if (is_array) {
6187         AvFILLp(av) = -1;
6188         SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */
6189     }
6190     return;
6191 }
6192
6193 /*
6194 =for apidoc sv_insert
6195
6196 Inserts a string at the specified offset/length within the SV.  Similar to
6197 the Perl substr() function.  Handles get magic.
6198
6199 =for apidoc sv_insert_flags
6200
6201 Same as C<sv_insert>, but the extra C<flags> are passed to the
6202 C<SvPV_force_flags> that applies to C<bigstr>.
6203
6204 =cut
6205 */
6206
6207 void
6208 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
6209 {
6210     char *big;
6211     char *mid;
6212     char *midend;
6213     char *bigend;
6214     SSize_t i;          /* better be sizeof(STRLEN) or bad things happen */
6215     STRLEN curlen;
6216
6217     PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
6218
6219     if (!bigstr)
6220         Perl_croak(aTHX_ "Can't modify nonexistent substring");
6221     SvPV_force_flags(bigstr, curlen, flags);
6222     (void)SvPOK_only_UTF8(bigstr);
6223     if (offset + len > curlen) {
6224         SvGROW(bigstr, offset+len+1);
6225         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
6226         SvCUR_set(bigstr, offset+len);
6227     }
6228
6229     SvTAINT(bigstr);
6230     i = littlelen - len;
6231     if (i > 0) {                        /* string might grow */
6232         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
6233         mid = big + offset + len;
6234         midend = bigend = big + SvCUR(bigstr);
6235         bigend += i;
6236         *bigend = '\0';
6237         while (midend > mid)            /* shove everything down */
6238             *--bigend = *--midend;
6239         Move(little,big+offset,littlelen,char);
6240         SvCUR_set(bigstr, SvCUR(bigstr) + i);
6241         SvSETMAGIC(bigstr);
6242         return;
6243     }
6244     else if (i == 0) {
6245         Move(little,SvPVX(bigstr)+offset,len,char);
6246         SvSETMAGIC(bigstr);
6247         return;
6248     }
6249
6250     big = SvPVX(bigstr);
6251     mid = big + offset;
6252     midend = mid + len;
6253     bigend = big + SvCUR(bigstr);
6254
6255     if (midend > bigend)
6256         Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p",
6257                    midend, bigend);
6258
6259     if (mid - big > bigend - midend) {  /* faster to shorten from end */
6260         if (littlelen) {
6261             Move(little, mid, littlelen,char);
6262             mid += littlelen;
6263         }
6264         i = bigend - midend;
6265         if (i > 0) {
6266             Move(midend, mid, i,char);
6267             mid += i;
6268         }
6269         *mid = '\0';
6270         SvCUR_set(bigstr, mid - big);
6271     }
6272     else if ((i = mid - big)) { /* faster from front */
6273         midend -= littlelen;
6274         mid = midend;
6275         Move(big, midend - i, i, char);
6276         sv_chop(bigstr,midend-i);
6277         if (littlelen)
6278             Move(little, mid, littlelen,char);
6279     }
6280     else if (littlelen) {
6281         midend -= littlelen;
6282         sv_chop(bigstr,midend);
6283         Move(little,midend,littlelen,char);
6284     }
6285     else {
6286         sv_chop(bigstr,midend);
6287     }
6288     SvSETMAGIC(bigstr);
6289 }
6290
6291 /*
6292 =for apidoc sv_replace
6293
6294 Make the first argument a copy of the second, then delete the original.
6295 The target SV physically takes over ownership of the body of the source SV
6296 and inherits its flags; however, the target keeps any magic it owns,
6297 and any magic in the source is discarded.
6298 Note that this is a rather specialist SV copying operation; most of the
6299 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
6300
6301 =cut
6302 */
6303
6304 void
6305 Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv)
6306 {
6307     const U32 refcnt = SvREFCNT(sv);
6308
6309     PERL_ARGS_ASSERT_SV_REPLACE;
6310
6311     SV_CHECK_THINKFIRST_COW_DROP(sv);
6312     if (SvREFCNT(nsv) != 1) {
6313         Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
6314                    " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
6315     }
6316     if (SvMAGICAL(sv)) {
6317         if (SvMAGICAL(nsv))
6318             mg_free(nsv);
6319         else
6320             sv_upgrade(nsv, SVt_PVMG);
6321         SvMAGIC_set(nsv, SvMAGIC(sv));
6322         SvFLAGS(nsv) |= SvMAGICAL(sv);
6323         SvMAGICAL_off(sv);
6324         SvMAGIC_set(sv, NULL);
6325     }
6326     SvREFCNT(sv) = 0;
6327     sv_clear(sv);
6328     assert(!SvREFCNT(sv));
6329 #ifdef DEBUG_LEAKING_SCALARS
6330     sv->sv_flags  = nsv->sv_flags;
6331     sv->sv_any    = nsv->sv_any;
6332     sv->sv_refcnt = nsv->sv_refcnt;
6333     sv->sv_u      = nsv->sv_u;
6334 #else
6335     StructCopy(nsv,sv,SV);
6336 #endif
6337     if(SvTYPE(sv) == SVt_IV) {
6338         SvANY(sv)
6339             = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
6340     }
6341         
6342
6343 #ifdef PERL_OLD_COPY_ON_WRITE
6344     if (SvIsCOW_normal(nsv)) {
6345         /* We need to follow the pointers around the loop to make the
6346            previous SV point to sv, rather than nsv.  */
6347         SV *next;
6348         SV *current = nsv;
6349         while ((next = SV_COW_NEXT_SV(current)) != nsv) {
6350             assert(next);
6351             current = next;
6352             assert(SvPVX_const(current) == SvPVX_const(nsv));
6353         }
6354         /* Make the SV before us point to the SV after us.  */
6355         if (DEBUG_C_TEST) {
6356             PerlIO_printf(Perl_debug_log, "previous is\n");
6357             sv_dump(current);
6358             PerlIO_printf(Perl_debug_log,
6359                           "move it from 0x%"UVxf" to 0x%"UVxf"\n",
6360                           (UV) SV_COW_NEXT_SV(current), (UV) sv);
6361         }
6362         SV_COW_NEXT_SV_SET(current, sv);
6363     }
6364 #endif
6365     SvREFCNT(sv) = refcnt;
6366     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
6367     SvREFCNT(nsv) = 0;
6368     del_SV(nsv);
6369 }
6370
6371 /* We're about to free a GV which has a CV that refers back to us.
6372  * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
6373  * field) */
6374
6375 STATIC void
6376 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
6377 {
6378     SV *gvname;
6379     GV *anongv;
6380
6381     PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
6382
6383     /* be assertive! */
6384     assert(SvREFCNT(gv) == 0);
6385     assert(isGV(gv) && isGV_with_GP(gv));
6386     assert(GvGP(gv));
6387     assert(!CvANON(cv));
6388     assert(CvGV(cv) == gv);
6389     assert(!CvNAMED(cv));
6390
6391     /* will the CV shortly be freed by gp_free() ? */
6392     if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
6393         SvANY(cv)->xcv_gv_u.xcv_gv = NULL;
6394         return;
6395     }
6396
6397     /* if not, anonymise: */
6398     gvname = (GvSTASH(gv) && HvNAME(GvSTASH(gv)) && HvENAME(GvSTASH(gv)))
6399                     ? newSVhek(HvENAME_HEK(GvSTASH(gv)))
6400                     : newSVpvn_flags( "__ANON__", 8, 0 );
6401     sv_catpvs(gvname, "::__ANON__");
6402     anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
6403     SvREFCNT_dec_NN(gvname);
6404
6405     CvANON_on(cv);
6406     CvCVGV_RC_on(cv);
6407     SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
6408 }
6409
6410
6411 /*
6412 =for apidoc sv_clear
6413
6414 Clear an SV: call any destructors, free up any memory used by the body,
6415 and free the body itself.  The SV's head is I<not> freed, although
6416 its type is set to all 1's so that it won't inadvertently be assumed
6417 to be live during global destruction etc.
6418 This function should only be called when REFCNT is zero.  Most of the time
6419 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
6420 instead.
6421
6422 =cut
6423 */
6424
6425 void
6426 Perl_sv_clear(pTHX_ SV *const orig_sv)
6427 {
6428     dVAR;
6429     HV *stash;
6430     U32 type;
6431     const struct body_details *sv_type_details;
6432     SV* iter_sv = NULL;
6433     SV* next_sv = NULL;
6434     SV *sv = orig_sv;
6435     STRLEN hash_index;
6436
6437     PERL_ARGS_ASSERT_SV_CLEAR;
6438
6439     /* within this loop, sv is the SV currently being freed, and
6440      * iter_sv is the most recent AV or whatever that's being iterated
6441      * over to provide more SVs */
6442
6443     while (sv) {
6444
6445         type = SvTYPE(sv);
6446
6447         assert(SvREFCNT(sv) == 0);
6448         assert(SvTYPE(sv) != (svtype)SVTYPEMASK);
6449
6450         if (type <= SVt_IV) {
6451             /* See the comment in sv.h about the collusion between this
6452              * early return and the overloading of the NULL slots in the
6453              * size table.  */
6454             if (SvROK(sv))
6455                 goto free_rv;
6456             SvFLAGS(sv) &= SVf_BREAK;
6457             SvFLAGS(sv) |= SVTYPEMASK;
6458             goto free_head;
6459         }
6460
6461         /* objs are always >= MG, but pad names use the SVs_OBJECT flag
6462            for another purpose  */
6463         assert(!SvOBJECT(sv) || type >= SVt_PVMG || SvPAD_NAME(sv));
6464
6465         if (type >= SVt_PVMG) {
6466             if (SvOBJECT(sv) && !SvPAD_NAME(sv)) {
6467                 if (!curse(sv, 1)) goto get_next_sv;
6468                 type = SvTYPE(sv); /* destructor may have changed it */
6469             }
6470             /* Free back-references before magic, in case the magic calls
6471              * Perl code that has weak references to sv. */
6472             if (type == SVt_PVHV) {
6473                 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
6474                 if (SvMAGIC(sv))
6475                     mg_free(sv);
6476             }
6477             else if (type == SVt_PVMG && SvPAD_OUR(sv)) {
6478                 SvREFCNT_dec(SvOURSTASH(sv));
6479             }
6480             else if (type == SVt_PVAV && AvPAD_NAMELIST(sv)) {
6481                 assert(!SvMAGICAL(sv));
6482             } else if (SvMAGIC(sv)) {
6483                 /* Free back-references before other types of magic. */
6484                 sv_unmagic(sv, PERL_MAGIC_backref);
6485                 mg_free(sv);
6486             }
6487             SvMAGICAL_off(sv);
6488             if (type == SVt_PVMG && SvPAD_TYPED(sv))
6489                 SvREFCNT_dec(SvSTASH(sv));
6490         }
6491         switch (type) {
6492             /* case SVt_INVLIST: */
6493         case SVt_PVIO:
6494             if (IoIFP(sv) &&
6495                 IoIFP(sv) != PerlIO_stdin() &&
6496                 IoIFP(sv) != PerlIO_stdout() &&
6497                 IoIFP(sv) != PerlIO_stderr() &&
6498                 !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6499             {
6500                 io_close(MUTABLE_IO(sv), NULL, FALSE,
6501                          (IoTYPE(sv) == IoTYPE_WRONLY ||
6502                           IoTYPE(sv) == IoTYPE_RDWR   ||
6503                           IoTYPE(sv) == IoTYPE_APPEND));
6504             }
6505             if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6506                 PerlDir_close(IoDIRP(sv));
6507             IoDIRP(sv) = (DIR*)NULL;
6508             Safefree(IoTOP_NAME(sv));
6509             Safefree(IoFMT_NAME(sv));
6510             Safefree(IoBOTTOM_NAME(sv));
6511             if ((const GV *)sv == PL_statgv)
6512                 PL_statgv = NULL;
6513             goto freescalar;
6514         case SVt_REGEXP:
6515             /* FIXME for plugins */
6516           freeregexp:
6517             pregfree2((REGEXP*) sv);
6518             goto freescalar;
6519         case SVt_PVCV:
6520         case SVt_PVFM:
6521             cv_undef(MUTABLE_CV(sv));
6522             /* If we're in a stash, we don't own a reference to it.
6523              * However it does hav