6aa29e117b784aafb3e627b7a718b0b9d4a3e61b
[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 POSION_SV_HEAD(sv)    PoisonNew(sv, 1, struct STRUCT_SV)
263 */
264 #  define POSION_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 POSION_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         POSION_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     (void)curse(sv, 0);
614 }
615
616 /*
617 =for apidoc sv_clean_objs
618
619 Attempt to destroy all objects not yet freed.
620
621 =cut
622 */
623
624 void
625 Perl_sv_clean_objs(pTHX)
626 {
627     GV *olddef, *olderr;
628     PL_in_clean_objs = TRUE;
629     visit(do_clean_objs, SVf_ROK, SVf_ROK);
630     /* Some barnacles may yet remain, clinging to typeglobs.
631      * Run the non-IO destructors first: they may want to output
632      * error messages, close files etc */
633     visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
634     visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
635     /* And if there are some very tenacious barnacles clinging to arrays,
636        closures, or what have you.... */
637     visit(do_curse, SVs_OBJECT, SVs_OBJECT);
638     olddef = PL_defoutgv;
639     PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
640     if (olddef && isGV_with_GP(olddef))
641         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
642     olderr = PL_stderrgv;
643     PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
644     if (olderr && isGV_with_GP(olderr))
645         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
646     SvREFCNT_dec(olddef);
647     PL_in_clean_objs = FALSE;
648 }
649
650 /* called by sv_clean_all() for each live SV */
651
652 static void
653 do_clean_all(pTHX_ SV *const sv)
654 {
655     if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
656         /* don't clean pid table and strtab */
657         return;
658     }
659     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
660     SvFLAGS(sv) |= SVf_BREAK;
661     SvREFCNT_dec_NN(sv);
662 }
663
664 /*
665 =for apidoc sv_clean_all
666
667 Decrement the refcnt of each remaining SV, possibly triggering a
668 cleanup.  This function may have to be called multiple times to free
669 SVs which are in complex self-referential hierarchies.
670
671 =cut
672 */
673
674 I32
675 Perl_sv_clean_all(pTHX)
676 {
677     I32 cleaned;
678     PL_in_clean_all = TRUE;
679     cleaned = visit(do_clean_all, 0,0);
680     return cleaned;
681 }
682
683 /*
684   ARENASETS: a meta-arena implementation which separates arena-info
685   into struct arena_set, which contains an array of struct
686   arena_descs, each holding info for a single arena.  By separating
687   the meta-info from the arena, we recover the 1st slot, formerly
688   borrowed for list management.  The arena_set is about the size of an
689   arena, avoiding the needless malloc overhead of a naive linked-list.
690
691   The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
692   memory in the last arena-set (1/2 on average).  In trade, we get
693   back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
694   smaller types).  The recovery of the wasted space allows use of
695   small arenas for large, rare body types, by changing array* fields
696   in body_details_by_type[] below.
697 */
698 struct arena_desc {
699     char       *arena;          /* the raw storage, allocated aligned */
700     size_t      size;           /* its size ~4k typ */
701     svtype      utype;          /* bodytype stored in arena */
702 };
703
704 struct arena_set;
705
706 /* Get the maximum number of elements in set[] such that struct arena_set
707    will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
708    therefore likely to be 1 aligned memory page.  */
709
710 #define ARENAS_PER_SET  ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
711                           - 2 * sizeof(int)) / sizeof (struct arena_desc))
712
713 struct arena_set {
714     struct arena_set* next;
715     unsigned int   set_size;    /* ie ARENAS_PER_SET */
716     unsigned int   curr;        /* index of next available arena-desc */
717     struct arena_desc set[ARENAS_PER_SET];
718 };
719
720 /*
721 =for apidoc sv_free_arenas
722
723 Deallocate the memory used by all arenas.  Note that all the individual SV
724 heads and bodies within the arenas must already have been freed.
725
726 =cut
727
728 */
729 void
730 Perl_sv_free_arenas(pTHX)
731 {
732     SV* sva;
733     SV* svanext;
734     unsigned int i;
735
736     /* Free arenas here, but be careful about fake ones.  (We assume
737        contiguity of the fake ones with the corresponding real ones.) */
738
739     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
740         svanext = MUTABLE_SV(SvANY(sva));
741         while (svanext && SvFAKE(svanext))
742             svanext = MUTABLE_SV(SvANY(svanext));
743
744         if (!SvFAKE(sva))
745             Safefree(sva);
746     }
747
748     {
749         struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
750
751         while (aroot) {
752             struct arena_set *current = aroot;
753             i = aroot->curr;
754             while (i--) {
755                 assert(aroot->set[i].arena);
756                 Safefree(aroot->set[i].arena);
757             }
758             aroot = aroot->next;
759             Safefree(current);
760         }
761     }
762     PL_body_arenas = 0;
763
764     i = PERL_ARENA_ROOTS_SIZE;
765     while (i--)
766         PL_body_roots[i] = 0;
767
768     PL_sv_arenaroot = 0;
769     PL_sv_root = 0;
770 }
771
772 /*
773   Here are mid-level routines that manage the allocation of bodies out
774   of the various arenas.  There are 5 kinds of arenas:
775
776   1. SV-head arenas, which are discussed and handled above
777   2. regular body arenas
778   3. arenas for reduced-size bodies
779   4. Hash-Entry arenas
780
781   Arena types 2 & 3 are chained by body-type off an array of
782   arena-root pointers, which is indexed by svtype.  Some of the
783   larger/less used body types are malloced singly, since a large
784   unused block of them is wasteful.  Also, several svtypes dont have
785   bodies; the data fits into the sv-head itself.  The arena-root
786   pointer thus has a few unused root-pointers (which may be hijacked
787   later for arena types 4,5)
788
789   3 differs from 2 as an optimization; some body types have several
790   unused fields in the front of the structure (which are kept in-place
791   for consistency).  These bodies can be allocated in smaller chunks,
792   because the leading fields arent accessed.  Pointers to such bodies
793   are decremented to point at the unused 'ghost' memory, knowing that
794   the pointers are used with offsets to the real memory.
795
796
797 =head1 SV-Body Allocation
798
799 =cut
800
801 Allocation of SV-bodies is similar to SV-heads, differing as follows;
802 the allocation mechanism is used for many body types, so is somewhat
803 more complicated, it uses arena-sets, and has no need for still-live
804 SV detection.
805
806 At the outermost level, (new|del)_X*V macros return bodies of the
807 appropriate type.  These macros call either (new|del)_body_type or
808 (new|del)_body_allocated macro pairs, depending on specifics of the
809 type.  Most body types use the former pair, the latter pair is used to
810 allocate body types with "ghost fields".
811
812 "ghost fields" are fields that are unused in certain types, and
813 consequently don't need to actually exist.  They are declared because
814 they're part of a "base type", which allows use of functions as
815 methods.  The simplest examples are AVs and HVs, 2 aggregate types
816 which don't use the fields which support SCALAR semantics.
817
818 For these types, the arenas are carved up into appropriately sized
819 chunks, we thus avoid wasted memory for those unaccessed members.
820 When bodies are allocated, we adjust the pointer back in memory by the
821 size of the part not allocated, so it's as if we allocated the full
822 structure.  (But things will all go boom if you write to the part that
823 is "not there", because you'll be overwriting the last members of the
824 preceding structure in memory.)
825
826 We calculate the correction using the STRUCT_OFFSET macro on the first
827 member present.  If the allocated structure is smaller (no initial NV
828 actually allocated) then the net effect is to subtract the size of the NV
829 from the pointer, to return a new pointer as if an initial NV were actually
830 allocated.  (We were using structures named *_allocated for this, but
831 this turned out to be a subtle bug, because a structure without an NV
832 could have a lower alignment constraint, but the compiler is allowed to
833 optimised accesses based on the alignment constraint of the actual pointer
834 to the full structure, for example, using a single 64 bit load instruction
835 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
836
837 This is the same trick as was used for NV and IV bodies.  Ironically it
838 doesn't need to be used for NV bodies any more, because NV is now at
839 the start of the structure.  IV bodies, and also in some builds NV bodies,
840 don't need it either, because they are no longer allocated.
841
842 In turn, the new_body_* allocators call S_new_body(), which invokes
843 new_body_inline macro, which takes a lock, and takes a body off the
844 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
845 necessary to refresh an empty list.  Then the lock is released, and
846 the body is returned.
847
848 Perl_more_bodies allocates a new arena, and carves it up into an array of N
849 bodies, which it strings into a linked list.  It looks up arena-size
850 and body-size from the body_details table described below, thus
851 supporting the multiple body-types.
852
853 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
854 the (new|del)_X*V macros are mapped directly to malloc/free.
855
856 For each sv-type, struct body_details bodies_by_type[] carries
857 parameters which control these aspects of SV handling:
858
859 Arena_size determines whether arenas are used for this body type, and if
860 so, how big they are.  PURIFY or PERL_ARENA_SIZE=0 set this field to
861 zero, forcing individual mallocs and frees.
862
863 Body_size determines how big a body is, and therefore how many fit into
864 each arena.  Offset carries the body-pointer adjustment needed for
865 "ghost fields", and is used in *_allocated macros.
866
867 But its main purpose is to parameterize info needed in
868 Perl_sv_upgrade().  The info here dramatically simplifies the function
869 vs the implementation in 5.8.8, making it table-driven.  All fields
870 are used for this, except for arena_size.
871
872 For the sv-types that have no bodies, arenas are not used, so those
873 PL_body_roots[sv_type] are unused, and can be overloaded.  In
874 something of a special case, SVt_NULL is borrowed for HE arenas;
875 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
876 bodies_by_type[SVt_NULL] slot is not used, as the table is not
877 available in hv.c.
878
879 */
880
881 struct body_details {
882     U8 body_size;       /* Size to allocate  */
883     U8 copy;            /* Size of structure to copy (may be shorter)  */
884     U8 offset;          /* Size of unalloced ghost fields to first alloced field*/
885     PERL_BITFIELD8 type : 4;        /* We have space for a sanity check. */
886     PERL_BITFIELD8 cant_upgrade : 1;/* Cannot upgrade this type */
887     PERL_BITFIELD8 zero_nv : 1;     /* zero the NV when upgrading from this */
888     PERL_BITFIELD8 arena : 1;       /* Allocated from an arena */
889     U32 arena_size;                 /* Size of arena to allocate */
890 };
891
892 #define HADNV FALSE
893 #define NONV TRUE
894
895
896 #ifdef PURIFY
897 /* With -DPURFIY we allocate everything directly, and don't use arenas.
898    This seems a rather elegant way to simplify some of the code below.  */
899 #define HASARENA FALSE
900 #else
901 #define HASARENA TRUE
902 #endif
903 #define NOARENA FALSE
904
905 /* Size the arenas to exactly fit a given number of bodies.  A count
906    of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
907    simplifying the default.  If count > 0, the arena is sized to fit
908    only that many bodies, allowing arenas to be used for large, rare
909    bodies (XPVFM, XPVIO) without undue waste.  The arena size is
910    limited by PERL_ARENA_SIZE, so we can safely oversize the
911    declarations.
912  */
913 #define FIT_ARENA0(body_size)                           \
914     ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
915 #define FIT_ARENAn(count,body_size)                     \
916     ( count * body_size <= PERL_ARENA_SIZE)             \
917     ? count * body_size                                 \
918     : FIT_ARENA0 (body_size)
919 #define FIT_ARENA(count,body_size)                      \
920    (U32)(count                                          \
921     ? FIT_ARENAn (count, body_size)                     \
922     : FIT_ARENA0 (body_size))
923
924 /* Calculate the length to copy. Specifically work out the length less any
925    final padding the compiler needed to add.  See the comment in sv_upgrade
926    for why copying the padding proved to be a bug.  */
927
928 #define copy_length(type, last_member) \
929         STRUCT_OFFSET(type, last_member) \
930         + sizeof (((type*)SvANY((const SV *)0))->last_member)
931
932 static const struct body_details bodies_by_type[] = {
933     /* HEs use this offset for their arena.  */
934     { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
935
936     /* IVs are in the head, so the allocation size is 0.  */
937     { 0,
938       sizeof(IV), /* This is used to copy out the IV body.  */
939       STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
940       NOARENA /* IVS don't need an arena  */, 0
941     },
942
943 #if NVSIZE <= IVSIZE
944     { 0, sizeof(NV),
945       STRUCT_OFFSET(XPVNV, xnv_u),
946       SVt_NV, FALSE, HADNV, NOARENA, 0 },
947 #else
948     { sizeof(NV), sizeof(NV),
949       STRUCT_OFFSET(XPVNV, xnv_u),
950       SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
951 #endif
952
953     { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
954       copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
955       + STRUCT_OFFSET(XPV, xpv_cur),
956       SVt_PV, FALSE, NONV, HASARENA,
957       FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
958
959     { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur),
960       copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur),
961       + STRUCT_OFFSET(XPV, xpv_cur),
962       SVt_INVLIST, TRUE, NONV, HASARENA,
963       FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) },
964
965     { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
966       copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
967       + STRUCT_OFFSET(XPV, xpv_cur),
968       SVt_PVIV, FALSE, NONV, HASARENA,
969       FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
970
971     { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
972       copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
973       + STRUCT_OFFSET(XPV, xpv_cur),
974       SVt_PVNV, FALSE, HADNV, HASARENA,
975       FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
976
977     { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
978       HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
979
980     { sizeof(regexp),
981       sizeof(regexp),
982       0,
983       SVt_REGEXP, TRUE, NONV, HASARENA,
984       FIT_ARENA(0, sizeof(regexp))
985     },
986
987     { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
988       HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
989     
990     { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
991       HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
992
993     { sizeof(XPVAV),
994       copy_length(XPVAV, xav_alloc),
995       0,
996       SVt_PVAV, TRUE, NONV, HASARENA,
997       FIT_ARENA(0, sizeof(XPVAV)) },
998
999     { sizeof(XPVHV),
1000       copy_length(XPVHV, xhv_max),
1001       0,
1002       SVt_PVHV, TRUE, NONV, HASARENA,
1003       FIT_ARENA(0, sizeof(XPVHV)) },
1004
1005     { sizeof(XPVCV),
1006       sizeof(XPVCV),
1007       0,
1008       SVt_PVCV, TRUE, NONV, HASARENA,
1009       FIT_ARENA(0, sizeof(XPVCV)) },
1010
1011     { sizeof(XPVFM),
1012       sizeof(XPVFM),
1013       0,
1014       SVt_PVFM, TRUE, NONV, NOARENA,
1015       FIT_ARENA(20, sizeof(XPVFM)) },
1016
1017     { sizeof(XPVIO),
1018       sizeof(XPVIO),
1019       0,
1020       SVt_PVIO, TRUE, NONV, HASARENA,
1021       FIT_ARENA(24, sizeof(XPVIO)) },
1022 };
1023
1024 #define new_body_allocated(sv_type)             \
1025     (void *)((char *)S_new_body(aTHX_ sv_type)  \
1026              - bodies_by_type[sv_type].offset)
1027
1028 /* return a thing to the free list */
1029
1030 #define del_body(thing, root)                           \
1031     STMT_START {                                        \
1032         void ** const thing_copy = (void **)thing;      \
1033         *thing_copy = *root;                            \
1034         *root = (void*)thing_copy;                      \
1035     } STMT_END
1036
1037 #ifdef PURIFY
1038 #if !(NVSIZE <= IVSIZE)
1039 #  define new_XNV()     safemalloc(sizeof(XPVNV))
1040 #endif
1041 #define new_XPVNV()     safemalloc(sizeof(XPVNV))
1042 #define new_XPVMG()     safemalloc(sizeof(XPVMG))
1043
1044 #define del_XPVGV(p)    safefree(p)
1045
1046 #else /* !PURIFY */
1047
1048 #if !(NVSIZE <= IVSIZE)
1049 #  define new_XNV()     new_body_allocated(SVt_NV)
1050 #endif
1051 #define new_XPVNV()     new_body_allocated(SVt_PVNV)
1052 #define new_XPVMG()     new_body_allocated(SVt_PVMG)
1053
1054 #define del_XPVGV(p)    del_body(p + bodies_by_type[SVt_PVGV].offset,   \
1055                                  &PL_body_roots[SVt_PVGV])
1056
1057 #endif /* PURIFY */
1058
1059 /* no arena for you! */
1060
1061 #define new_NOARENA(details) \
1062         safemalloc((details)->body_size + (details)->offset)
1063 #define new_NOARENAZ(details) \
1064         safecalloc((details)->body_size + (details)->offset, 1)
1065
1066 void *
1067 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
1068                   const size_t arena_size)
1069 {
1070     void ** const root = &PL_body_roots[sv_type];
1071     struct arena_desc *adesc;
1072     struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1073     unsigned int curr;
1074     char *start;
1075     const char *end;
1076     const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1077 #if defined(DEBUGGING) && defined(PERL_GLOBAL_STRUCT)
1078     dVAR;
1079 #endif
1080 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1081     static bool done_sanity_check;
1082
1083     /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1084      * variables like done_sanity_check. */
1085     if (!done_sanity_check) {
1086         unsigned int i = SVt_LAST;
1087
1088         done_sanity_check = TRUE;
1089
1090         while (i--)
1091             assert (bodies_by_type[i].type == i);
1092     }
1093 #endif
1094
1095     assert(arena_size);
1096
1097     /* may need new arena-set to hold new arena */
1098     if (!aroot || aroot->curr >= aroot->set_size) {
1099         struct arena_set *newroot;
1100         Newxz(newroot, 1, struct arena_set);
1101         newroot->set_size = ARENAS_PER_SET;
1102         newroot->next = aroot;
1103         aroot = newroot;
1104         PL_body_arenas = (void *) newroot;
1105         DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1106     }
1107
1108     /* ok, now have arena-set with at least 1 empty/available arena-desc */
1109     curr = aroot->curr++;
1110     adesc = &(aroot->set[curr]);
1111     assert(!adesc->arena);
1112     
1113     Newx(adesc->arena, good_arena_size, char);
1114     adesc->size = good_arena_size;
1115     adesc->utype = sv_type;
1116     DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n", 
1117                           curr, (void*)adesc->arena, (UV)good_arena_size));
1118
1119     start = (char *) adesc->arena;
1120
1121     /* Get the address of the byte after the end of the last body we can fit.
1122        Remember, this is integer division:  */
1123     end = start + good_arena_size / body_size * body_size;
1124
1125     /* computed count doesn't reflect the 1st slot reservation */
1126 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1127     DEBUG_m(PerlIO_printf(Perl_debug_log,
1128                           "arena %p end %p arena-size %d (from %d) type %d "
1129                           "size %d ct %d\n",
1130                           (void*)start, (void*)end, (int)good_arena_size,
1131                           (int)arena_size, sv_type, (int)body_size,
1132                           (int)good_arena_size / (int)body_size));
1133 #else
1134     DEBUG_m(PerlIO_printf(Perl_debug_log,
1135                           "arena %p end %p arena-size %d type %d size %d ct %d\n",
1136                           (void*)start, (void*)end,
1137                           (int)arena_size, sv_type, (int)body_size,
1138                           (int)good_arena_size / (int)body_size));
1139 #endif
1140     *root = (void *)start;
1141
1142     while (1) {
1143         /* Where the next body would start:  */
1144         char * const next = start + body_size;
1145
1146         if (next >= end) {
1147             /* This is the last body:  */
1148             assert(next == end);
1149
1150             *(void **)start = 0;
1151             return *root;
1152         }
1153
1154         *(void**) start = (void *)next;
1155         start = next;
1156     }
1157 }
1158
1159 /* grab a new thing from the free list, allocating more if necessary.
1160    The inline version is used for speed in hot routines, and the
1161    function using it serves the rest (unless PURIFY).
1162 */
1163 #define new_body_inline(xpv, sv_type) \
1164     STMT_START { \
1165         void ** const r3wt = &PL_body_roots[sv_type]; \
1166         xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \
1167           ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1168                                              bodies_by_type[sv_type].body_size,\
1169                                              bodies_by_type[sv_type].arena_size)); \
1170         *(r3wt) = *(void**)(xpv); \
1171     } STMT_END
1172
1173 #ifndef PURIFY
1174
1175 STATIC void *
1176 S_new_body(pTHX_ const svtype sv_type)
1177 {
1178     void *xpv;
1179     new_body_inline(xpv, sv_type);
1180     return xpv;
1181 }
1182
1183 #endif
1184
1185 static const struct body_details fake_rv =
1186     { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1187
1188 /*
1189 =for apidoc sv_upgrade
1190
1191 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1192 SV, then copies across as much information as possible from the old body.
1193 It croaks if the SV is already in a more complex form than requested.  You
1194 generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
1195 before calling C<sv_upgrade>, and hence does not croak.  See also
1196 C<svtype>.
1197
1198 =cut
1199 */
1200
1201 void
1202 Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
1203 {
1204     void*       old_body;
1205     void*       new_body;
1206     const svtype old_type = SvTYPE(sv);
1207     const struct body_details *new_type_details;
1208     const struct body_details *old_type_details
1209         = bodies_by_type + old_type;
1210     SV *referant = NULL;
1211
1212     PERL_ARGS_ASSERT_SV_UPGRADE;
1213
1214     if (old_type == new_type)
1215         return;
1216
1217     /* This clause was purposefully added ahead of the early return above to
1218        the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1219        inference by Nick I-S that it would fix other troublesome cases. See
1220        changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1221
1222        Given that shared hash key scalars are no longer PVIV, but PV, there is
1223        no longer need to unshare so as to free up the IVX slot for its proper
1224        purpose. So it's safe to move the early return earlier.  */
1225
1226     if (new_type > SVt_PVMG && SvIsCOW(sv)) {
1227         sv_force_normal_flags(sv, 0);
1228     }
1229
1230     old_body = SvANY(sv);
1231
1232     /* Copying structures onto other structures that have been neatly zeroed
1233        has a subtle gotcha. Consider XPVMG
1234
1235        +------+------+------+------+------+-------+-------+
1236        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
1237        +------+------+------+------+------+-------+-------+
1238        0      4      8     12     16     20      24      28
1239
1240        where NVs are aligned to 8 bytes, so that sizeof that structure is
1241        actually 32 bytes long, with 4 bytes of padding at the end:
1242
1243        +------+------+------+------+------+-------+-------+------+
1244        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
1245        +------+------+------+------+------+-------+-------+------+
1246        0      4      8     12     16     20      24      28     32
1247
1248        so what happens if you allocate memory for this structure:
1249
1250        +------+------+------+------+------+-------+-------+------+------+...
1251        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
1252        +------+------+------+------+------+-------+-------+------+------+...
1253        0      4      8     12     16     20      24      28     32     36
1254
1255        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1256        expect, because you copy the area marked ??? onto GP. Now, ??? may have
1257        started out as zero once, but it's quite possible that it isn't. So now,
1258        rather than a nicely zeroed GP, you have it pointing somewhere random.
1259        Bugs ensue.
1260
1261        (In fact, GP ends up pointing at a previous GP structure, because the
1262        principle cause of the padding in XPVMG getting garbage is a copy of
1263        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1264        this happens to be moot because XPVGV has been re-ordered, with GP
1265        no longer after STASH)
1266
1267        So we are careful and work out the size of used parts of all the
1268        structures.  */
1269
1270     switch (old_type) {
1271     case SVt_NULL:
1272         break;
1273     case SVt_IV:
1274         if (SvROK(sv)) {
1275             referant = SvRV(sv);
1276             old_type_details = &fake_rv;
1277             if (new_type == SVt_NV)
1278                 new_type = SVt_PVNV;
1279         } else {
1280             if (new_type < SVt_PVIV) {
1281                 new_type = (new_type == SVt_NV)
1282                     ? SVt_PVNV : SVt_PVIV;
1283             }
1284         }
1285         break;
1286     case SVt_NV:
1287         if (new_type < SVt_PVNV) {
1288             new_type = SVt_PVNV;
1289         }
1290         break;
1291     case SVt_PV:
1292         assert(new_type > SVt_PV);
1293         assert(SVt_IV < SVt_PV);
1294         assert(SVt_NV < SVt_PV);
1295         break;
1296     case SVt_PVIV:
1297         break;
1298     case SVt_PVNV:
1299         break;
1300     case SVt_PVMG:
1301         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1302            there's no way that it can be safely upgraded, because perl.c
1303            expects to Safefree(SvANY(PL_mess_sv))  */
1304         assert(sv != PL_mess_sv);
1305         /* This flag bit is used to mean other things in other scalar types.
1306            Given that it only has meaning inside the pad, it shouldn't be set
1307            on anything that can get upgraded.  */
1308         assert(!SvPAD_TYPED(sv));
1309         break;
1310     default:
1311         if (UNLIKELY(old_type_details->cant_upgrade))
1312             Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1313                        sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1314     }
1315
1316     if (UNLIKELY(old_type > new_type))
1317         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1318                 (int)old_type, (int)new_type);
1319
1320     new_type_details = bodies_by_type + new_type;
1321
1322     SvFLAGS(sv) &= ~SVTYPEMASK;
1323     SvFLAGS(sv) |= new_type;
1324
1325     /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1326        the return statements above will have triggered.  */
1327     assert (new_type != SVt_NULL);
1328     switch (new_type) {
1329     case SVt_IV:
1330         assert(old_type == SVt_NULL);
1331         SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1332         SvIV_set(sv, 0);
1333         return;
1334     case SVt_NV:
1335         assert(old_type == SVt_NULL);
1336 #if NVSIZE <= IVSIZE
1337         SvANY(sv) = (XPVNV*)((char*)&(sv->sv_u.svu_nv) - STRUCT_OFFSET(XPVNV, xnv_u.xnv_nv));
1338 #else
1339         SvANY(sv) = new_XNV();
1340 #endif
1341         SvNV_set(sv, 0);
1342         return;
1343     case SVt_PVHV:
1344     case SVt_PVAV:
1345         assert(new_type_details->body_size);
1346
1347 #ifndef PURIFY  
1348         assert(new_type_details->arena);
1349         assert(new_type_details->arena_size);
1350         /* This points to the start of the allocated area.  */
1351         new_body_inline(new_body, new_type);
1352         Zero(new_body, new_type_details->body_size, char);
1353         new_body = ((char *)new_body) - new_type_details->offset;
1354 #else
1355         /* We always allocated the full length item with PURIFY. To do this
1356            we fake things so that arena is false for all 16 types..  */
1357         new_body = new_NOARENAZ(new_type_details);
1358 #endif
1359         SvANY(sv) = new_body;
1360         if (new_type == SVt_PVAV) {
1361             AvMAX(sv)   = -1;
1362             AvFILLp(sv) = -1;
1363             AvREAL_only(sv);
1364             if (old_type_details->body_size) {
1365                 AvALLOC(sv) = 0;
1366             } else {
1367                 /* It will have been zeroed when the new body was allocated.
1368                    Lets not write to it, in case it confuses a write-back
1369                    cache.  */
1370             }
1371         } else {
1372             assert(!SvOK(sv));
1373             SvOK_off(sv);
1374 #ifndef NODEFAULT_SHAREKEYS
1375             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
1376 #endif
1377             /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
1378             HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
1379         }
1380
1381         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1382            The target created by newSVrv also is, and it can have magic.
1383            However, it never has SvPVX set.
1384         */
1385         if (old_type == SVt_IV) {
1386             assert(!SvROK(sv));
1387         } else if (old_type >= SVt_PV) {
1388             assert(SvPVX_const(sv) == 0);
1389         }
1390
1391         if (old_type >= SVt_PVMG) {
1392             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1393             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1394         } else {
1395             sv->sv_u.svu_array = NULL; /* or svu_hash  */
1396         }
1397         break;
1398
1399     case SVt_PVIV:
1400         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1401            no route from NV to PVIV, NOK can never be true  */
1402         assert(!SvNOKp(sv));
1403         assert(!SvNOK(sv));
1404     case SVt_PVIO:
1405     case SVt_PVFM:
1406     case SVt_PVGV:
1407     case SVt_PVCV:
1408     case SVt_PVLV:
1409     case SVt_INVLIST:
1410     case SVt_REGEXP:
1411     case SVt_PVMG:
1412     case SVt_PVNV:
1413     case SVt_PV:
1414
1415         assert(new_type_details->body_size);
1416         /* We always allocated the full length item with PURIFY. To do this
1417            we fake things so that arena is false for all 16 types..  */
1418         if(new_type_details->arena) {
1419             /* This points to the start of the allocated area.  */
1420             new_body_inline(new_body, new_type);
1421             Zero(new_body, new_type_details->body_size, char);
1422             new_body = ((char *)new_body) - new_type_details->offset;
1423         } else {
1424             new_body = new_NOARENAZ(new_type_details);
1425         }
1426         SvANY(sv) = new_body;
1427
1428         if (old_type_details->copy) {
1429             /* There is now the potential for an upgrade from something without
1430                an offset (PVNV or PVMG) to something with one (PVCV, PVFM)  */
1431             int offset = old_type_details->offset;
1432             int length = old_type_details->copy;
1433
1434             if (new_type_details->offset > old_type_details->offset) {
1435                 const int difference
1436                     = new_type_details->offset - old_type_details->offset;
1437                 offset += difference;
1438                 length -= difference;
1439             }
1440             assert (length >= 0);
1441                 
1442             Copy((char *)old_body + offset, (char *)new_body + offset, length,
1443                  char);
1444         }
1445
1446 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1447         /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1448          * correct 0.0 for us.  Otherwise, if the old body didn't have an
1449          * NV slot, but the new one does, then we need to initialise the
1450          * freshly created NV slot with whatever the correct bit pattern is
1451          * for 0.0  */
1452         if (old_type_details->zero_nv && !new_type_details->zero_nv
1453             && !isGV_with_GP(sv))
1454             SvNV_set(sv, 0);
1455 #endif
1456
1457         if (UNLIKELY(new_type == SVt_PVIO)) {
1458             IO * const io = MUTABLE_IO(sv);
1459             GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1460
1461             SvOBJECT_on(io);
1462             /* Clear the stashcache because a new IO could overrule a package
1463                name */
1464             DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
1465             hv_clear(PL_stashcache);
1466
1467             SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1468             IoPAGE_LEN(sv) = 60;
1469         }
1470         if (UNLIKELY(new_type == SVt_REGEXP))
1471             sv->sv_u.svu_rx = (regexp *)new_body;
1472         else if (old_type < SVt_PV) {
1473             /* referant will be NULL unless the old type was SVt_IV emulating
1474                SVt_RV */
1475             sv->sv_u.svu_rv = referant;
1476         }
1477         break;
1478     default:
1479         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1480                    (unsigned long)new_type);
1481     }
1482
1483     /* if this is zero, this is a body-less SVt_NULL, SVt_IV/SVt_RV,
1484        and sometimes SVt_NV */
1485     if (old_type_details->body_size) {
1486 #ifdef PURIFY
1487         safefree(old_body);
1488 #else
1489         /* Note that there is an assumption that all bodies of types that
1490            can be upgraded came from arenas. Only the more complex non-
1491            upgradable types are allowed to be directly malloc()ed.  */
1492         assert(old_type_details->arena);
1493         del_body((void*)((char*)old_body + old_type_details->offset),
1494                  &PL_body_roots[old_type]);
1495 #endif
1496     }
1497 }
1498
1499 /*
1500 =for apidoc sv_backoff
1501
1502 Remove any string offset.  You should normally use the C<SvOOK_off> macro
1503 wrapper instead.
1504
1505 =cut
1506 */
1507
1508 int
1509 Perl_sv_backoff(SV *const sv)
1510 {
1511     STRLEN delta;
1512     const char * const s = SvPVX_const(sv);
1513
1514     PERL_ARGS_ASSERT_SV_BACKOFF;
1515
1516     assert(SvOOK(sv));
1517     assert(SvTYPE(sv) != SVt_PVHV);
1518     assert(SvTYPE(sv) != SVt_PVAV);
1519
1520     SvOOK_offset(sv, delta);
1521     
1522     SvLEN_set(sv, SvLEN(sv) + delta);
1523     SvPV_set(sv, SvPVX(sv) - delta);
1524     Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1525     SvFLAGS(sv) &= ~SVf_OOK;
1526     return 0;
1527 }
1528
1529 /*
1530 =for apidoc sv_grow
1531
1532 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1533 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1534 Use the C<SvGROW> wrapper instead.
1535
1536 =cut
1537 */
1538
1539 static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
1540
1541 char *
1542 Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
1543 {
1544     char *s;
1545
1546     PERL_ARGS_ASSERT_SV_GROW;
1547
1548     if (SvROK(sv))
1549         sv_unref(sv);
1550     if (SvTYPE(sv) < SVt_PV) {
1551         sv_upgrade(sv, SVt_PV);
1552         s = SvPVX_mutable(sv);
1553     }
1554     else if (SvOOK(sv)) {       /* pv is offset? */
1555         sv_backoff(sv);
1556         s = SvPVX_mutable(sv);
1557         if (newlen > SvLEN(sv))
1558             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1559     }
1560     else
1561     {
1562         if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0);
1563         s = SvPVX_mutable(sv);
1564     }
1565
1566 #ifdef PERL_NEW_COPY_ON_WRITE
1567     /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1568      * to store the COW count. So in general, allocate one more byte than
1569      * asked for, to make it likely this byte is always spare: and thus
1570      * make more strings COW-able.
1571      * If the new size is a big power of two, don't bother: we assume the
1572      * caller wanted a nice 2^N sized block and will be annoyed at getting
1573      * 2^N+1 */
1574     if (newlen & 0xff)
1575         newlen++;
1576 #endif
1577
1578 #if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size)
1579 #define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1580 #endif
1581
1582     if (newlen > SvLEN(sv)) {           /* need more room? */
1583         STRLEN minlen = SvCUR(sv);
1584         minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1585         if (newlen < minlen)
1586             newlen = minlen;
1587 #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1588
1589         /* Don't round up on the first allocation, as odds are pretty good that
1590          * the initial request is accurate as to what is really needed */
1591         if (SvLEN(sv)) {
1592             newlen = PERL_STRLEN_ROUNDUP(newlen);
1593         }
1594 #endif
1595         if (SvLEN(sv) && s) {
1596             s = (char*)saferealloc(s, newlen);
1597         }
1598         else {
1599             s = (char*)safemalloc(newlen);
1600             if (SvPVX_const(sv) && SvCUR(sv)) {
1601                 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1602             }
1603         }
1604         SvPV_set(sv, s);
1605 #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1606         /* Do this here, do it once, do it right, and then we will never get
1607            called back into sv_grow() unless there really is some growing
1608            needed.  */
1609         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1610 #else
1611         SvLEN_set(sv, newlen);
1612 #endif
1613     }
1614     return s;
1615 }
1616
1617 /*
1618 =for apidoc sv_setiv
1619
1620 Copies an integer into the given SV, upgrading first if necessary.
1621 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1622
1623 =cut
1624 */
1625
1626 void
1627 Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
1628 {
1629     PERL_ARGS_ASSERT_SV_SETIV;
1630
1631     SV_CHECK_THINKFIRST_COW_DROP(sv);
1632     switch (SvTYPE(sv)) {
1633     case SVt_NULL:
1634     case SVt_NV:
1635         sv_upgrade(sv, SVt_IV);
1636         break;
1637     case SVt_PV:
1638         sv_upgrade(sv, SVt_PVIV);
1639         break;
1640
1641     case SVt_PVGV:
1642         if (!isGV_with_GP(sv))
1643             break;
1644     case SVt_PVAV:
1645     case SVt_PVHV:
1646     case SVt_PVCV:
1647     case SVt_PVFM:
1648     case SVt_PVIO:
1649         /* diag_listed_as: Can't coerce %s to %s in %s */
1650         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1651                    OP_DESC(PL_op));
1652     default: NOOP;
1653     }
1654     (void)SvIOK_only(sv);                       /* validate number */
1655     SvIV_set(sv, i);
1656     SvTAINT(sv);
1657 }
1658
1659 /*
1660 =for apidoc sv_setiv_mg
1661
1662 Like C<sv_setiv>, but also handles 'set' magic.
1663
1664 =cut
1665 */
1666
1667 void
1668 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1669 {
1670     PERL_ARGS_ASSERT_SV_SETIV_MG;
1671
1672     sv_setiv(sv,i);
1673     SvSETMAGIC(sv);
1674 }
1675
1676 /*
1677 =for apidoc sv_setuv
1678
1679 Copies an unsigned integer into the given SV, upgrading first if necessary.
1680 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1681
1682 =cut
1683 */
1684
1685 void
1686 Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1687 {
1688     PERL_ARGS_ASSERT_SV_SETUV;
1689
1690     /* With the if statement to ensure that integers are stored as IVs whenever
1691        possible:
1692        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1693
1694        without
1695        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1696
1697        If you wish to remove the following if statement, so that this routine
1698        (and its callers) always return UVs, please benchmark to see what the
1699        effect is. Modern CPUs may be different. Or may not :-)
1700     */
1701     if (u <= (UV)IV_MAX) {
1702        sv_setiv(sv, (IV)u);
1703        return;
1704     }
1705     sv_setiv(sv, 0);
1706     SvIsUV_on(sv);
1707     SvUV_set(sv, u);
1708 }
1709
1710 /*
1711 =for apidoc sv_setuv_mg
1712
1713 Like C<sv_setuv>, but also handles 'set' magic.
1714
1715 =cut
1716 */
1717
1718 void
1719 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1720 {
1721     PERL_ARGS_ASSERT_SV_SETUV_MG;
1722
1723     sv_setuv(sv,u);
1724     SvSETMAGIC(sv);
1725 }
1726
1727 /*
1728 =for apidoc sv_setnv
1729
1730 Copies a double into the given SV, upgrading first if necessary.
1731 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1732
1733 =cut
1734 */
1735
1736 void
1737 Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1738 {
1739     PERL_ARGS_ASSERT_SV_SETNV;
1740
1741     SV_CHECK_THINKFIRST_COW_DROP(sv);
1742     switch (SvTYPE(sv)) {
1743     case SVt_NULL:
1744     case SVt_IV:
1745         sv_upgrade(sv, SVt_NV);
1746         break;
1747     case SVt_PV:
1748     case SVt_PVIV:
1749         sv_upgrade(sv, SVt_PVNV);
1750         break;
1751
1752     case SVt_PVGV:
1753         if (!isGV_with_GP(sv))
1754             break;
1755     case SVt_PVAV:
1756     case SVt_PVHV:
1757     case SVt_PVCV:
1758     case SVt_PVFM:
1759     case SVt_PVIO:
1760         /* diag_listed_as: Can't coerce %s to %s in %s */
1761         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1762                    OP_DESC(PL_op));
1763     default: NOOP;
1764     }
1765     SvNV_set(sv, num);
1766     (void)SvNOK_only(sv);                       /* validate number */
1767     SvTAINT(sv);
1768 }
1769
1770 /*
1771 =for apidoc sv_setnv_mg
1772
1773 Like C<sv_setnv>, but also handles 'set' magic.
1774
1775 =cut
1776 */
1777
1778 void
1779 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1780 {
1781     PERL_ARGS_ASSERT_SV_SETNV_MG;
1782
1783     sv_setnv(sv,num);
1784     SvSETMAGIC(sv);
1785 }
1786
1787 /* Return a cleaned-up, printable version of sv, for non-numeric, or
1788  * not incrementable warning display.
1789  * Originally part of S_not_a_number().
1790  * The return value may be != tmpbuf.
1791  */
1792
1793 STATIC const char *
1794 S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1795     const char *pv;
1796
1797      PERL_ARGS_ASSERT_SV_DISPLAY;
1798
1799      if (DO_UTF8(sv)) {
1800           SV *dsv = newSVpvs_flags("", SVs_TEMP);
1801           pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
1802      } else {
1803           char *d = tmpbuf;
1804           const char * const limit = tmpbuf + tmpbuf_size - 8;
1805           /* each *s can expand to 4 chars + "...\0",
1806              i.e. need room for 8 chars */
1807         
1808           const char *s = SvPVX_const(sv);
1809           const char * const end = s + SvCUR(sv);
1810           for ( ; s < end && d < limit; s++ ) {
1811                int ch = *s & 0xFF;
1812                if (! isASCII(ch) && !isPRINT_LC(ch)) {
1813                     *d++ = 'M';
1814                     *d++ = '-';
1815
1816                     /* Map to ASCII "equivalent" of Latin1 */
1817                     ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1818                }
1819                if (ch == '\n') {
1820                     *d++ = '\\';
1821                     *d++ = 'n';
1822                }
1823                else if (ch == '\r') {
1824                     *d++ = '\\';
1825                     *d++ = 'r';
1826                }
1827                else if (ch == '\f') {
1828                     *d++ = '\\';
1829                     *d++ = 'f';
1830                }
1831                else if (ch == '\\') {
1832                     *d++ = '\\';
1833                     *d++ = '\\';
1834                }
1835                else if (ch == '\0') {
1836                     *d++ = '\\';
1837                     *d++ = '0';
1838                }
1839                else if (isPRINT_LC(ch))
1840                     *d++ = ch;
1841                else {
1842                     *d++ = '^';
1843                     *d++ = toCTRL(ch);
1844                }
1845           }
1846           if (s < end) {
1847                *d++ = '.';
1848                *d++ = '.';
1849                *d++ = '.';
1850           }
1851           *d = '\0';
1852           pv = tmpbuf;
1853     }
1854
1855     return pv;
1856 }
1857
1858 /* Print an "isn't numeric" warning, using a cleaned-up,
1859  * printable version of the offending string
1860  */
1861
1862 STATIC void
1863 S_not_a_number(pTHX_ SV *const sv)
1864 {
1865      char tmpbuf[64];
1866      const char *pv;
1867
1868      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1869
1870      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1871
1872     if (PL_op)
1873         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1874                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1875                     "Argument \"%s\" isn't numeric in %s", pv,
1876                     OP_DESC(PL_op));
1877     else
1878         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1879                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1880                     "Argument \"%s\" isn't numeric", pv);
1881 }
1882
1883 STATIC void
1884 S_not_incrementable(pTHX_ SV *const sv) {
1885      char tmpbuf[64];
1886      const char *pv;
1887
1888      PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1889
1890      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1891
1892      Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1893                  "Argument \"%s\" treated as 0 in increment (++)", pv);
1894 }
1895
1896 /*
1897 =for apidoc looks_like_number
1898
1899 Test if the content of an SV looks like a number (or is a number).
1900 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1901 non-numeric warning), even if your atof() doesn't grok them.  Get-magic is
1902 ignored.
1903
1904 =cut
1905 */
1906
1907 I32
1908 Perl_looks_like_number(pTHX_ SV *const sv)
1909 {
1910     const char *sbegin;
1911     STRLEN len;
1912
1913     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1914
1915     if (SvPOK(sv) || SvPOKp(sv)) {
1916         sbegin = SvPV_nomg_const(sv, len);
1917     }
1918     else
1919         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1920     return grok_number(sbegin, len, NULL);
1921 }
1922
1923 STATIC bool
1924 S_glob_2number(pTHX_ GV * const gv)
1925 {
1926     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1927
1928     /* We know that all GVs stringify to something that is not-a-number,
1929         so no need to test that.  */
1930     if (ckWARN(WARN_NUMERIC))
1931     {
1932         SV *const buffer = sv_newmortal();
1933         gv_efullname3(buffer, gv, "*");
1934         not_a_number(buffer);
1935     }
1936     /* We just want something true to return, so that S_sv_2iuv_common
1937         can tail call us and return true.  */
1938     return TRUE;
1939 }
1940
1941 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1942    until proven guilty, assume that things are not that bad... */
1943
1944 /*
1945    NV_PRESERVES_UV:
1946
1947    As 64 bit platforms often have an NV that doesn't preserve all bits of
1948    an IV (an assumption perl has been based on to date) it becomes necessary
1949    to remove the assumption that the NV always carries enough precision to
1950    recreate the IV whenever needed, and that the NV is the canonical form.
1951    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1952    precision as a side effect of conversion (which would lead to insanity
1953    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1954    1) to distinguish between IV/UV/NV slots that have a valid conversion cached
1955       where precision was lost, and IV/UV/NV slots that have a valid conversion
1956       which has lost no precision
1957    2) to ensure that if a numeric conversion to one form is requested that
1958       would lose precision, the precise conversion (or differently
1959       imprecise conversion) is also performed and cached, to prevent
1960       requests for different numeric formats on the same SV causing
1961       lossy conversion chains. (lossless conversion chains are perfectly
1962       acceptable (still))
1963
1964
1965    flags are used:
1966    SvIOKp is true if the IV slot contains a valid value
1967    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1968    SvNOKp is true if the NV slot contains a valid value
1969    SvNOK  is true only if the NV value is accurate
1970
1971    so
1972    while converting from PV to NV, check to see if converting that NV to an
1973    IV(or UV) would lose accuracy over a direct conversion from PV to
1974    IV(or UV). If it would, cache both conversions, return NV, but mark
1975    SV as IOK NOKp (ie not NOK).
1976
1977    While converting from PV to IV, check to see if converting that IV to an
1978    NV would lose accuracy over a direct conversion from PV to NV. If it
1979    would, cache both conversions, flag similarly.
1980
1981    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1982    correctly because if IV & NV were set NV *always* overruled.
1983    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1984    changes - now IV and NV together means that the two are interchangeable:
1985    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1986
1987    The benefit of this is that operations such as pp_add know that if
1988    SvIOK is true for both left and right operands, then integer addition
1989    can be used instead of floating point (for cases where the result won't
1990    overflow). Before, floating point was always used, which could lead to
1991    loss of precision compared with integer addition.
1992
1993    * making IV and NV equal status should make maths accurate on 64 bit
1994      platforms
1995    * may speed up maths somewhat if pp_add and friends start to use
1996      integers when possible instead of fp. (Hopefully the overhead in
1997      looking for SvIOK and checking for overflow will not outweigh the
1998      fp to integer speedup)
1999    * will slow down integer operations (callers of SvIV) on "inaccurate"
2000      values, as the change from SvIOK to SvIOKp will cause a call into
2001      sv_2iv each time rather than a macro access direct to the IV slot
2002    * should speed up number->string conversion on integers as IV is
2003      favoured when IV and NV are equally accurate
2004
2005    ####################################################################
2006    You had better be using SvIOK_notUV if you want an IV for arithmetic:
2007    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2008    On the other hand, SvUOK is true iff UV.
2009    ####################################################################
2010
2011    Your mileage will vary depending your CPU's relative fp to integer
2012    performance ratio.
2013 */
2014
2015 #ifndef NV_PRESERVES_UV
2016 #  define IS_NUMBER_UNDERFLOW_IV 1
2017 #  define IS_NUMBER_UNDERFLOW_UV 2
2018 #  define IS_NUMBER_IV_AND_UV    2
2019 #  define IS_NUMBER_OVERFLOW_IV  4
2020 #  define IS_NUMBER_OVERFLOW_UV  5
2021
2022 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2023
2024 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
2025 STATIC int
2026 S_sv_2iuv_non_preserve(pTHX_ SV *const sv
2027 #  ifdef DEBUGGING
2028                        , I32 numtype
2029 #  endif
2030                        )
2031 {
2032     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
2033     PERL_UNUSED_CONTEXT;
2034
2035     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));
2036     if (SvNVX(sv) < (NV)IV_MIN) {
2037         (void)SvIOKp_on(sv);
2038         (void)SvNOK_on(sv);
2039         SvIV_set(sv, IV_MIN);
2040         return IS_NUMBER_UNDERFLOW_IV;
2041     }
2042     if (SvNVX(sv) > (NV)UV_MAX) {
2043         (void)SvIOKp_on(sv);
2044         (void)SvNOK_on(sv);
2045         SvIsUV_on(sv);
2046         SvUV_set(sv, UV_MAX);
2047         return IS_NUMBER_OVERFLOW_UV;
2048     }
2049     (void)SvIOKp_on(sv);
2050     (void)SvNOK_on(sv);
2051     /* Can't use strtol etc to convert this string.  (See truth table in
2052        sv_2iv  */
2053     if (SvNVX(sv) <= (UV)IV_MAX) {
2054         SvIV_set(sv, I_V(SvNVX(sv)));
2055         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2056             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2057         } else {
2058             /* Integer is imprecise. NOK, IOKp */
2059         }
2060         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2061     }
2062     SvIsUV_on(sv);
2063     SvUV_set(sv, U_V(SvNVX(sv)));
2064     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2065         if (SvUVX(sv) == UV_MAX) {
2066             /* As we know that NVs don't preserve UVs, UV_MAX cannot
2067                possibly be preserved by NV. Hence, it must be overflow.
2068                NOK, IOKp */
2069             return IS_NUMBER_OVERFLOW_UV;
2070         }
2071         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2072     } else {
2073         /* Integer is imprecise. NOK, IOKp */
2074     }
2075     return IS_NUMBER_OVERFLOW_IV;
2076 }
2077 #endif /* !NV_PRESERVES_UV*/
2078
2079 /* If numtype is infnan, set the NV of the sv accordingly.
2080  * If numtype is anything else, try setting the NV using Atof(PV). */
2081 static void
2082 S_sv_setnv(pTHX_ SV* sv, int numtype)
2083 {
2084     bool pok = cBOOL(SvPOK(sv));
2085     bool nok = FALSE;
2086     if ((numtype & IS_NUMBER_INFINITY)) {
2087         SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
2088         nok = TRUE;
2089     }
2090     else if ((numtype & IS_NUMBER_NAN)) {
2091         SvNV_set(sv, NV_NAN);
2092         nok = TRUE;
2093     }
2094     else if (pok) {
2095         SvNV_set(sv, Atof(SvPVX_const(sv)));
2096         /* Purposefully no true nok here, since we don't want to blow
2097          * away the possible IOK/UV of an existing sv. */
2098     }
2099     if (nok) {
2100         SvNOK_only(sv); /* No IV or UV please, this is pure infnan. */
2101         if (pok)
2102             SvPOK_on(sv); /* PV is okay, though. */
2103     }
2104 }
2105
2106 STATIC bool
2107 S_sv_2iuv_common(pTHX_ SV *const sv)
2108 {
2109     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2110
2111     if (SvNOKp(sv)) {
2112         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2113          * without also getting a cached IV/UV from it at the same time
2114          * (ie PV->NV conversion should detect loss of accuracy and cache
2115          * IV or UV at same time to avoid this. */
2116         /* IV-over-UV optimisation - choose to cache IV if possible */
2117
2118         if (SvTYPE(sv) == SVt_NV)
2119             sv_upgrade(sv, SVt_PVNV);
2120
2121         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2122         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2123            certainly cast into the IV range at IV_MAX, whereas the correct
2124            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2125            cases go to UV */
2126 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2127         if (Perl_isnan(SvNVX(sv))) {
2128             SvUV_set(sv, 0);
2129             SvIsUV_on(sv);
2130             return FALSE;
2131         }
2132 #endif
2133         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2134             SvIV_set(sv, I_V(SvNVX(sv)));
2135             if (SvNVX(sv) == (NV) SvIVX(sv)
2136 #ifndef NV_PRESERVES_UV
2137                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2138                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2139                 /* Don't flag it as "accurately an integer" if the number
2140                    came from a (by definition imprecise) NV operation, and
2141                    we're outside the range of NV integer precision */
2142 #endif
2143                 ) {
2144                 if (SvNOK(sv))
2145                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2146                 else {
2147                     /* scalar has trailing garbage, eg "42a" */
2148                 }
2149                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2150                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2151                                       PTR2UV(sv),
2152                                       SvNVX(sv),
2153                                       SvIVX(sv)));
2154
2155             } else {
2156                 /* IV not precise.  No need to convert from PV, as NV
2157                    conversion would already have cached IV if it detected
2158                    that PV->IV would be better than PV->NV->IV
2159                    flags already correct - don't set public IOK.  */
2160                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2161                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2162                                       PTR2UV(sv),
2163                                       SvNVX(sv),
2164                                       SvIVX(sv)));
2165             }
2166             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2167                but the cast (NV)IV_MIN rounds to a the value less (more
2168                negative) than IV_MIN which happens to be equal to SvNVX ??
2169                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2170                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2171                (NV)UVX == NVX are both true, but the values differ. :-(
2172                Hopefully for 2s complement IV_MIN is something like
2173                0x8000000000000000 which will be exact. NWC */
2174         }
2175         else {
2176             SvUV_set(sv, U_V(SvNVX(sv)));
2177             if (
2178                 (SvNVX(sv) == (NV) SvUVX(sv))
2179 #ifndef  NV_PRESERVES_UV
2180                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2181                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2182                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2183                 /* Don't flag it as "accurately an integer" if the number
2184                    came from a (by definition imprecise) NV operation, and
2185                    we're outside the range of NV integer precision */
2186 #endif
2187                 && SvNOK(sv)
2188                 )
2189                 SvIOK_on(sv);
2190             SvIsUV_on(sv);
2191             DEBUG_c(PerlIO_printf(Perl_debug_log,
2192                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2193                                   PTR2UV(sv),
2194                                   SvUVX(sv),
2195                                   SvUVX(sv)));
2196         }
2197     }
2198     else if (SvPOKp(sv)) {
2199         UV value;
2200         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2201         /* We want to avoid a possible problem when we cache an IV/ a UV which
2202            may be later translated to an NV, and the resulting NV is not
2203            the same as the direct translation of the initial string
2204            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2205            be careful to ensure that the value with the .456 is around if the
2206            NV value is requested in the future).
2207         
2208            This means that if we cache such an IV/a UV, we need to cache the
2209            NV as well.  Moreover, we trade speed for space, and do not
2210            cache the NV if we are sure it's not needed.
2211          */
2212
2213         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2214         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2215              == IS_NUMBER_IN_UV) {
2216             /* It's definitely an integer, only upgrade to PVIV */
2217             if (SvTYPE(sv) < SVt_PVIV)
2218                 sv_upgrade(sv, SVt_PVIV);
2219             (void)SvIOK_on(sv);
2220         } else if (SvTYPE(sv) < SVt_PVNV)
2221             sv_upgrade(sv, SVt_PVNV);
2222
2223         if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
2224             S_sv_setnv(aTHX_ sv, numtype);
2225             return FALSE;
2226         }
2227
2228         /* If NVs preserve UVs then we only use the UV value if we know that
2229            we aren't going to call atof() below. If NVs don't preserve UVs
2230            then the value returned may have more precision than atof() will
2231            return, even though value isn't perfectly accurate.  */
2232         if ((numtype & (IS_NUMBER_IN_UV
2233 #ifdef NV_PRESERVES_UV
2234                         | IS_NUMBER_NOT_INT
2235 #endif
2236             )) == IS_NUMBER_IN_UV) {
2237             /* This won't turn off the public IOK flag if it was set above  */
2238             (void)SvIOKp_on(sv);
2239
2240             if (!(numtype & IS_NUMBER_NEG)) {
2241                 /* positive */;
2242                 if (value <= (UV)IV_MAX) {
2243                     SvIV_set(sv, (IV)value);
2244                 } else {
2245                     /* it didn't overflow, and it was positive. */
2246                     SvUV_set(sv, value);
2247                     SvIsUV_on(sv);
2248                 }
2249             } else {
2250                 /* 2s complement assumption  */
2251                 if (value <= (UV)IV_MIN) {
2252                     SvIV_set(sv, -(IV)value);
2253                 } else {
2254                     /* Too negative for an IV.  This is a double upgrade, but
2255                        I'm assuming it will be rare.  */
2256                     if (SvTYPE(sv) < SVt_PVNV)
2257                         sv_upgrade(sv, SVt_PVNV);
2258                     SvNOK_on(sv);
2259                     SvIOK_off(sv);
2260                     SvIOKp_on(sv);
2261                     SvNV_set(sv, -(NV)value);
2262                     SvIV_set(sv, IV_MIN);
2263                 }
2264             }
2265         }
2266         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2267            will be in the previous block to set the IV slot, and the next
2268            block to set the NV slot.  So no else here.  */
2269         
2270         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2271             != IS_NUMBER_IN_UV) {
2272             /* It wasn't an (integer that doesn't overflow the UV). */
2273             S_sv_setnv(aTHX_ sv, numtype);
2274
2275             if (! numtype && ckWARN(WARN_NUMERIC))
2276                 not_a_number(sv);
2277
2278             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" NVgf ")\n",
2279                                   PTR2UV(sv), SvNVX(sv)));
2280
2281 #ifdef NV_PRESERVES_UV
2282             (void)SvIOKp_on(sv);
2283             (void)SvNOK_on(sv);
2284 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2285             if (Perl_isnan(SvNVX(sv))) {
2286                 SvUV_set(sv, 0);
2287                 SvIsUV_on(sv);
2288                 return FALSE;
2289             }
2290 #endif
2291             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2292                 SvIV_set(sv, I_V(SvNVX(sv)));
2293                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2294                     SvIOK_on(sv);
2295                 } else {
2296                     NOOP;  /* Integer is imprecise. NOK, IOKp */
2297                 }
2298                 /* UV will not work better than IV */
2299             } else {
2300                 if (SvNVX(sv) > (NV)UV_MAX) {
2301                     SvIsUV_on(sv);
2302                     /* Integer is inaccurate. NOK, IOKp, is UV */
2303                     SvUV_set(sv, UV_MAX);
2304                 } else {
2305                     SvUV_set(sv, U_V(SvNVX(sv)));
2306                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2307                        NV preservse UV so can do correct comparison.  */
2308                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2309                         SvIOK_on(sv);
2310                     } else {
2311                         NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
2312                     }
2313                 }
2314                 SvIsUV_on(sv);
2315             }
2316 #else /* NV_PRESERVES_UV */
2317             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2318                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2319                 /* The IV/UV slot will have been set from value returned by
2320                    grok_number above.  The NV slot has just been set using
2321                    Atof.  */
2322                 SvNOK_on(sv);
2323                 assert (SvIOKp(sv));
2324             } else {
2325                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2326                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2327                     /* Small enough to preserve all bits. */
2328                     (void)SvIOKp_on(sv);
2329                     SvNOK_on(sv);
2330                     SvIV_set(sv, I_V(SvNVX(sv)));
2331                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2332                         SvIOK_on(sv);
2333                     /* Assumption: first non-preserved integer is < IV_MAX,
2334                        this NV is in the preserved range, therefore: */
2335                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2336                           < (UV)IV_MAX)) {
2337                         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);
2338                     }
2339                 } else {
2340                     /* IN_UV NOT_INT
2341                          0      0       already failed to read UV.
2342                          0      1       already failed to read UV.
2343                          1      0       you won't get here in this case. IV/UV
2344                                         slot set, public IOK, Atof() unneeded.
2345                          1      1       already read UV.
2346                        so there's no point in sv_2iuv_non_preserve() attempting
2347                        to use atol, strtol, strtoul etc.  */
2348 #  ifdef DEBUGGING
2349                     sv_2iuv_non_preserve (sv, numtype);
2350 #  else
2351                     sv_2iuv_non_preserve (sv);
2352 #  endif
2353                 }
2354             }
2355 #endif /* NV_PRESERVES_UV */
2356         /* It might be more code efficient to go through the entire logic above
2357            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2358            gets complex and potentially buggy, so more programmer efficient
2359            to do it this way, by turning off the public flags:  */
2360         if (!numtype)
2361             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2362         }
2363     }
2364     else  {
2365         if (isGV_with_GP(sv))
2366             return glob_2number(MUTABLE_GV(sv));
2367
2368         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2369                 report_uninit(sv);
2370         if (SvTYPE(sv) < SVt_IV)
2371             /* Typically the caller expects that sv_any is not NULL now.  */
2372             sv_upgrade(sv, SVt_IV);
2373         /* Return 0 from the caller.  */
2374         return TRUE;
2375     }
2376     return FALSE;
2377 }
2378
2379 /*
2380 =for apidoc sv_2iv_flags
2381
2382 Return the integer value of an SV, doing any necessary string
2383 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2384 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2385
2386 =cut
2387 */
2388
2389 IV
2390 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2391 {
2392     PERL_ARGS_ASSERT_SV_2IV_FLAGS;
2393
2394     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2395          && SvTYPE(sv) != SVt_PVFM);
2396
2397     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2398         mg_get(sv);
2399
2400     if (SvROK(sv)) {
2401         if (SvAMAGIC(sv)) {
2402             SV * tmpstr;
2403             if (flags & SV_SKIP_OVERLOAD)
2404                 return 0;
2405             tmpstr = AMG_CALLunary(sv, numer_amg);
2406             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2407                 return SvIV(tmpstr);
2408             }
2409         }
2410         return PTR2IV(SvRV(sv));
2411     }
2412
2413     if (SvVALID(sv) || isREGEXP(sv)) {
2414         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2415            the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2416            In practice they are extremely unlikely to actually get anywhere
2417            accessible by user Perl code - the only way that I'm aware of is when
2418            a constant subroutine which is used as the second argument to index.
2419
2420            Regexps have no SvIVX and SvNVX fields.
2421         */
2422         assert(isREGEXP(sv) || SvPOKp(sv));
2423         {
2424             UV value;
2425             const char * const ptr =
2426                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2427             const int numtype
2428                 = grok_number(ptr, SvCUR(sv), &value);
2429
2430             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2431                 == IS_NUMBER_IN_UV) {
2432                 /* It's definitely an integer */
2433                 if (numtype & IS_NUMBER_NEG) {
2434                     if (value < (UV)IV_MIN)
2435                         return -(IV)value;
2436                 } else {
2437                     if (value < (UV)IV_MAX)
2438                         return (IV)value;
2439                 }
2440             }
2441
2442             /* Quite wrong but no good choices. */
2443             if ((numtype & IS_NUMBER_INFINITY)) {
2444                 return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX;
2445             } else if ((numtype & IS_NUMBER_NAN)) {
2446                 return 0; /* So wrong. */
2447             }
2448
2449             if (!numtype) {
2450                 if (ckWARN(WARN_NUMERIC))
2451                     not_a_number(sv);
2452             }
2453             return I_V(Atof(ptr));
2454         }
2455     }
2456
2457     if (SvTHINKFIRST(sv)) {
2458 #ifdef PERL_OLD_COPY_ON_WRITE
2459         if (SvIsCOW(sv)) {
2460             sv_force_normal_flags(sv, 0);
2461         }
2462 #endif
2463         if (SvREADONLY(sv) && !SvOK(sv)) {
2464             if (ckWARN(WARN_UNINITIALIZED))
2465                 report_uninit(sv);
2466             return 0;
2467         }
2468     }
2469
2470     if (!SvIOKp(sv)) {
2471         if (S_sv_2iuv_common(aTHX_ sv))
2472             return 0;
2473     }
2474
2475     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2476         PTR2UV(sv),SvIVX(sv)));
2477     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2478 }
2479
2480 /*
2481 =for apidoc sv_2uv_flags
2482
2483 Return the unsigned integer value of an SV, doing any necessary string
2484 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2485 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2486
2487 =cut
2488 */
2489
2490 UV
2491 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2492 {
2493     PERL_ARGS_ASSERT_SV_2UV_FLAGS;
2494
2495     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2496         mg_get(sv);
2497
2498     if (SvROK(sv)) {
2499         if (SvAMAGIC(sv)) {
2500             SV *tmpstr;
2501             if (flags & SV_SKIP_OVERLOAD)
2502                 return 0;
2503             tmpstr = AMG_CALLunary(sv, numer_amg);
2504             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2505                 return SvUV(tmpstr);
2506             }
2507         }
2508         return PTR2UV(SvRV(sv));
2509     }
2510
2511     if (SvVALID(sv) || isREGEXP(sv)) {
2512         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2513            the same flag bit as SVf_IVisUV, so must not let them cache IVs.  
2514            Regexps have no SvIVX and SvNVX fields. */
2515         assert(isREGEXP(sv) || SvPOKp(sv));
2516         {
2517             UV value;
2518             const char * const ptr =
2519                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2520             const int numtype
2521                 = grok_number(ptr, SvCUR(sv), &value);
2522
2523             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2524                 == IS_NUMBER_IN_UV) {
2525                 /* It's definitely an integer */
2526                 if (!(numtype & IS_NUMBER_NEG))
2527                     return value;
2528             }
2529
2530             /* Quite wrong but no good choices. */
2531             if ((numtype & IS_NUMBER_INFINITY)) {
2532                 return UV_MAX; /* So wrong. */
2533             } else if ((numtype & IS_NUMBER_NAN)) {
2534                 return 0; /* So wrong. */
2535             }
2536
2537             if (!numtype) {
2538                 if (ckWARN(WARN_NUMERIC))
2539                     not_a_number(sv);
2540             }
2541             return U_V(Atof(ptr));
2542         }
2543     }
2544
2545     if (SvTHINKFIRST(sv)) {
2546 #ifdef PERL_OLD_COPY_ON_WRITE
2547         if (SvIsCOW(sv)) {
2548             sv_force_normal_flags(sv, 0);
2549         }
2550 #endif
2551         if (SvREADONLY(sv) && !SvOK(sv)) {
2552             if (ckWARN(WARN_UNINITIALIZED))
2553                 report_uninit(sv);
2554             return 0;
2555         }
2556     }
2557
2558     if (!SvIOKp(sv)) {
2559         if (S_sv_2iuv_common(aTHX_ sv))
2560             return 0;
2561     }
2562
2563     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2564                           PTR2UV(sv),SvUVX(sv)));
2565     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2566 }
2567
2568 /*
2569 =for apidoc sv_2nv_flags
2570
2571 Return the num value of an SV, doing any necessary string or integer
2572 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2573 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2574
2575 =cut
2576 */
2577
2578 NV
2579 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2580 {
2581     PERL_ARGS_ASSERT_SV_2NV_FLAGS;
2582
2583     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2584          && SvTYPE(sv) != SVt_PVFM);
2585     if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
2586         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2587            the same flag bit as SVf_IVisUV, so must not let them cache NVs.
2588            Regexps have no SvIVX and SvNVX fields.  */
2589         const char *ptr;
2590         if (flags & SV_GMAGIC)
2591             mg_get(sv);
2592         if (SvNOKp(sv))
2593             return SvNVX(sv);
2594         if (SvPOKp(sv) && !SvIOKp(sv)) {
2595             ptr = SvPVX_const(sv);
2596           grokpv:
2597             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2598                 !grok_number(ptr, SvCUR(sv), NULL))
2599                 not_a_number(sv);
2600             return Atof(ptr);
2601         }
2602         if (SvIOKp(sv)) {
2603             if (SvIsUV(sv))
2604                 return (NV)SvUVX(sv);
2605             else
2606                 return (NV)SvIVX(sv);
2607         }
2608         if (SvROK(sv)) {
2609             goto return_rok;
2610         }
2611         if (isREGEXP(sv)) {
2612             ptr = RX_WRAPPED((REGEXP *)sv);
2613             goto grokpv;
2614         }
2615         assert(SvTYPE(sv) >= SVt_PVMG);
2616         /* This falls through to the report_uninit near the end of the
2617            function. */
2618     } else if (SvTHINKFIRST(sv)) {
2619         if (SvROK(sv)) {
2620         return_rok:
2621             if (SvAMAGIC(sv)) {
2622                 SV *tmpstr;
2623                 if (flags & SV_SKIP_OVERLOAD)
2624                     return 0;
2625                 tmpstr = AMG_CALLunary(sv, numer_amg);
2626                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2627                     return SvNV(tmpstr);
2628                 }
2629             }
2630             return PTR2NV(SvRV(sv));
2631         }
2632 #ifdef PERL_OLD_COPY_ON_WRITE
2633         if (SvIsCOW(sv)) {
2634             sv_force_normal_flags(sv, 0);
2635         }
2636 #endif
2637         if (SvREADONLY(sv) && !SvOK(sv)) {
2638             if (ckWARN(WARN_UNINITIALIZED))
2639                 report_uninit(sv);
2640             return 0.0;
2641         }
2642     }
2643     if (SvTYPE(sv) < SVt_NV) {
2644         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2645         sv_upgrade(sv, SVt_NV);
2646         DEBUG_c({
2647             STORE_NUMERIC_LOCAL_SET_STANDARD();
2648             PerlIO_printf(Perl_debug_log,
2649                           "0x%"UVxf" num(%" NVgf ")\n",
2650                           PTR2UV(sv), SvNVX(sv));
2651             RESTORE_NUMERIC_LOCAL();
2652         });
2653     }
2654     else if (SvTYPE(sv) < SVt_PVNV)
2655         sv_upgrade(sv, SVt_PVNV);
2656     if (SvNOKp(sv)) {
2657         return SvNVX(sv);
2658     }
2659     if (SvIOKp(sv)) {
2660         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2661 #ifdef NV_PRESERVES_UV
2662         if (SvIOK(sv))
2663             SvNOK_on(sv);
2664         else
2665             SvNOKp_on(sv);
2666 #else
2667         /* Only set the public NV OK flag if this NV preserves the IV  */
2668         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2669         if (SvIOK(sv) &&
2670             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2671                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2672             SvNOK_on(sv);
2673         else
2674             SvNOKp_on(sv);
2675 #endif
2676     }
2677     else if (SvPOKp(sv)) {
2678         UV value;
2679         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2680         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2681             not_a_number(sv);
2682 #ifdef NV_PRESERVES_UV
2683         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2684             == IS_NUMBER_IN_UV) {
2685             /* It's definitely an integer */
2686             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2687         } else {
2688             S_sv_setnv(aTHX_ sv, numtype);
2689         }
2690         if (numtype)
2691             SvNOK_on(sv);
2692         else
2693             SvNOKp_on(sv);
2694 #else
2695         SvNV_set(sv, Atof(SvPVX_const(sv)));
2696         /* Only set the public NV OK flag if this NV preserves the value in
2697            the PV at least as well as an IV/UV would.
2698            Not sure how to do this 100% reliably. */
2699         /* if that shift count is out of range then Configure's test is
2700            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2701            UV_BITS */
2702         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2703             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2704             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2705         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2706             /* Can't use strtol etc to convert this string, so don't try.
2707                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2708             SvNOK_on(sv);
2709         } else {
2710             /* value has been set.  It may not be precise.  */
2711             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2712                 /* 2s complement assumption for (UV)IV_MIN  */
2713                 SvNOK_on(sv); /* Integer is too negative.  */
2714             } else {
2715                 SvNOKp_on(sv);
2716                 SvIOKp_on(sv);
2717
2718                 if (numtype & IS_NUMBER_NEG) {
2719                     SvIV_set(sv, -(IV)value);
2720                 } else if (value <= (UV)IV_MAX) {
2721                     SvIV_set(sv, (IV)value);
2722                 } else {
2723                     SvUV_set(sv, value);
2724                     SvIsUV_on(sv);
2725                 }
2726
2727                 if (numtype & IS_NUMBER_NOT_INT) {
2728                     /* I believe that even if the original PV had decimals,
2729                        they are lost beyond the limit of the FP precision.
2730                        However, neither is canonical, so both only get p
2731                        flags.  NWC, 2000/11/25 */
2732                     /* Both already have p flags, so do nothing */
2733                 } else {
2734                     const NV nv = SvNVX(sv);
2735                     /* XXX should this spot have NAN_COMPARE_BROKEN, too? */
2736                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2737                         if (SvIVX(sv) == I_V(nv)) {
2738                             SvNOK_on(sv);
2739                         } else {
2740                             /* It had no "." so it must be integer.  */
2741                         }
2742                         SvIOK_on(sv);
2743                     } else {
2744                         /* between IV_MAX and NV(UV_MAX).
2745                            Could be slightly > UV_MAX */
2746
2747                         if (numtype & IS_NUMBER_NOT_INT) {
2748                             /* UV and NV both imprecise.  */
2749                         } else {
2750                             const UV nv_as_uv = U_V(nv);
2751
2752                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2753                                 SvNOK_on(sv);
2754                             }
2755                             SvIOK_on(sv);
2756                         }
2757                     }
2758                 }
2759             }
2760         }
2761         /* It might be more code efficient to go through the entire logic above
2762            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2763            gets complex and potentially buggy, so more programmer efficient
2764            to do it this way, by turning off the public flags:  */
2765         if (!numtype)
2766             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2767 #endif /* NV_PRESERVES_UV */
2768     }
2769     else  {
2770         if (isGV_with_GP(sv)) {
2771             glob_2number(MUTABLE_GV(sv));
2772             return 0.0;
2773         }
2774
2775         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2776             report_uninit(sv);
2777         assert (SvTYPE(sv) >= SVt_NV);
2778         /* Typically the caller expects that sv_any is not NULL now.  */
2779         /* XXX Ilya implies that this is a bug in callers that assume this
2780            and ideally should be fixed.  */
2781         return 0.0;
2782     }
2783     DEBUG_c({
2784         STORE_NUMERIC_LOCAL_SET_STANDARD();
2785         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" NVgf ")\n",
2786                       PTR2UV(sv), SvNVX(sv));
2787         RESTORE_NUMERIC_LOCAL();
2788     });
2789     return SvNVX(sv);
2790 }
2791
2792 /*
2793 =for apidoc sv_2num
2794
2795 Return an SV with the numeric value of the source SV, doing any necessary
2796 reference or overload conversion.  You must use the C<SvNUM(sv)> macro to
2797 access this function.
2798
2799 =cut
2800 */
2801
2802 SV *
2803 Perl_sv_2num(pTHX_ SV *const sv)
2804 {
2805     PERL_ARGS_ASSERT_SV_2NUM;
2806
2807     if (!SvROK(sv))
2808         return sv;
2809     if (SvAMAGIC(sv)) {
2810         SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2811         TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2812         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2813             return sv_2num(tmpsv);
2814     }
2815     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2816 }
2817
2818 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2819  * UV as a string towards the end of buf, and return pointers to start and
2820  * end of it.
2821  *
2822  * We assume that buf is at least TYPE_CHARS(UV) long.
2823  */
2824
2825 static char *
2826 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2827 {
2828     char *ptr = buf + TYPE_CHARS(UV);
2829     char * const ebuf = ptr;
2830     int sign;
2831
2832     PERL_ARGS_ASSERT_UIV_2BUF;
2833
2834     if (is_uv)
2835         sign = 0;
2836     else if (iv >= 0) {
2837         uv = iv;
2838         sign = 0;
2839     } else {
2840         uv = -iv;
2841         sign = 1;
2842     }
2843     do {
2844         *--ptr = '0' + (char)(uv % 10);
2845     } while (uv /= 10);
2846     if (sign)
2847         *--ptr = '-';
2848     *peob = ebuf;
2849     return ptr;
2850 }
2851
2852 /* Helper for sv_2pv_flags and sv_vcatpvfn_flags.  If the NV is an
2853  * infinity or a not-a-number, writes the appropriate strings to the
2854  * buffer, including a zero byte.  On success returns the written length,
2855  * excluding the zero byte, on failure (not an infinity, not a nan, or the
2856  * maxlen too small) returns zero.
2857  *
2858  * XXX for "Inf", "-Inf", and "NaN", we could have three read-only
2859  * shared string constants we point to, instead of generating a new
2860  * string for each instance. */
2861 STATIC size_t
2862 S_infnan_2pv(NV nv, char* buffer, size_t maxlen) {
2863     assert(maxlen >= 4);
2864     if (maxlen < 4) /* "Inf\0", "NaN\0" */
2865         return 0;
2866     else {
2867         char* s = buffer;
2868         if (Perl_isinf(nv)) {
2869             if (nv < 0) {
2870                 if (maxlen < 5) /* "-Inf\0"  */
2871                     return 0;
2872                 *s++ = '-';
2873             }
2874             *s++ = 'I';
2875             *s++ = 'n';
2876             *s++ = 'f';
2877         } else if (Perl_isnan(nv)) {
2878             *s++ = 'N';
2879             *s++ = 'a';
2880             *s++ = 'N';
2881             /* XXX optionally output the payload mantissa bits as
2882              * "(unsigned)" (to match the nan("...") C99 function,
2883              * or maybe as "(0xhhh...)"  would make more sense...
2884              * provide a format string so that the user can decide?
2885              * NOTE: would affect the maxlen and assert() logic.*/
2886         }
2887
2888         else
2889             return 0;
2890         assert((s == buffer + 3) || (s == buffer + 4));
2891         *s++ = 0;
2892         return s - buffer - 1; /* -1: excluding the zero byte */
2893     }
2894 }
2895
2896 /*
2897 =for apidoc sv_2pv_flags
2898
2899 Returns a pointer to the string value of an SV, and sets *lp to its length.
2900 If flags includes SV_GMAGIC, does an mg_get() first.  Coerces sv to a
2901 string if necessary.  Normally invoked via the C<SvPV_flags> macro.
2902 C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
2903
2904 =cut
2905 */
2906
2907 char *
2908 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
2909 {
2910     char *s;
2911
2912     PERL_ARGS_ASSERT_SV_2PV_FLAGS;
2913
2914     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2915          && SvTYPE(sv) != SVt_PVFM);
2916     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2917         mg_get(sv);
2918     if (SvROK(sv)) {
2919         if (SvAMAGIC(sv)) {
2920             SV *tmpstr;
2921             if (flags & SV_SKIP_OVERLOAD)
2922                 return NULL;
2923             tmpstr = AMG_CALLunary(sv, string_amg);
2924             TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2925             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2926                 /* Unwrap this:  */
2927                 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2928                  */
2929
2930                 char *pv;
2931                 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2932                     if (flags & SV_CONST_RETURN) {
2933                         pv = (char *) SvPVX_const(tmpstr);
2934                     } else {
2935                         pv = (flags & SV_MUTABLE_RETURN)
2936                             ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2937                     }
2938                     if (lp)
2939                         *lp = SvCUR(tmpstr);
2940                 } else {
2941                     pv = sv_2pv_flags(tmpstr, lp, flags);
2942                 }
2943                 if (SvUTF8(tmpstr))
2944                     SvUTF8_on(sv);
2945                 else
2946                     SvUTF8_off(sv);
2947                 return pv;
2948             }
2949         }
2950         {
2951             STRLEN len;
2952             char *retval;
2953             char *buffer;
2954             SV *const referent = SvRV(sv);
2955
2956             if (!referent) {
2957                 len = 7;
2958                 retval = buffer = savepvn("NULLREF", len);
2959             } else if (SvTYPE(referent) == SVt_REGEXP &&
2960                        (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
2961                         amagic_is_enabled(string_amg))) {
2962                 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2963
2964                 assert(re);
2965                         
2966                 /* If the regex is UTF-8 we want the containing scalar to
2967                    have an UTF-8 flag too */
2968                 if (RX_UTF8(re))
2969                     SvUTF8_on(sv);
2970                 else
2971                     SvUTF8_off(sv);     
2972
2973                 if (lp)
2974                     *lp = RX_WRAPLEN(re);
2975  
2976                 return RX_WRAPPED(re);
2977             } else {
2978                 const char *const typestr = sv_reftype(referent, 0);
2979                 const STRLEN typelen = strlen(typestr);
2980                 UV addr = PTR2UV(referent);
2981                 const char *stashname = NULL;
2982                 STRLEN stashnamelen = 0; /* hush, gcc */
2983                 const char *buffer_end;
2984
2985                 if (SvOBJECT(referent)) {
2986                     const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2987
2988                     if (name) {
2989                         stashname = HEK_KEY(name);
2990                         stashnamelen = HEK_LEN(name);
2991
2992                         if (HEK_UTF8(name)) {
2993                             SvUTF8_on(sv);
2994                         } else {
2995                             SvUTF8_off(sv);
2996                         }
2997                     } else {
2998                         stashname = "__ANON__";
2999                         stashnamelen = 8;
3000                     }
3001                     len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
3002                         + 2 * sizeof(UV) + 2 /* )\0 */;
3003                 } else {
3004                     len = typelen + 3 /* (0x */
3005                         + 2 * sizeof(UV) + 2 /* )\0 */;
3006                 }
3007
3008                 Newx(buffer, len, char);
3009                 buffer_end = retval = buffer + len;
3010
3011                 /* Working backwards  */
3012                 *--retval = '\0';
3013                 *--retval = ')';
3014                 do {
3015                     *--retval = PL_hexdigit[addr & 15];
3016                 } while (addr >>= 4);
3017                 *--retval = 'x';
3018                 *--retval = '0';
3019                 *--retval = '(';
3020
3021                 retval -= typelen;
3022                 memcpy(retval, typestr, typelen);
3023
3024                 if (stashname) {
3025                     *--retval = '=';
3026                     retval -= stashnamelen;
3027                     memcpy(retval, stashname, stashnamelen);
3028                 }
3029                 /* retval may not necessarily have reached the start of the
3030                    buffer here.  */
3031                 assert (retval >= buffer);
3032
3033                 len = buffer_end - retval - 1; /* -1 for that \0  */
3034             }
3035             if (lp)
3036                 *lp = len;
3037             SAVEFREEPV(buffer);
3038             return retval;
3039         }
3040     }
3041
3042     if (SvPOKp(sv)) {
3043         if (lp)
3044             *lp = SvCUR(sv);
3045         if (flags & SV_MUTABLE_RETURN)
3046             return SvPVX_mutable(sv);
3047         if (flags & SV_CONST_RETURN)
3048             return (char *)SvPVX_const(sv);
3049         return SvPVX(sv);
3050     }
3051
3052     if (SvIOK(sv)) {
3053         /* I'm assuming that if both IV and NV are equally valid then
3054            converting the IV is going to be more efficient */
3055         const U32 isUIOK = SvIsUV(sv);
3056         char buf[TYPE_CHARS(UV)];
3057         char *ebuf, *ptr;
3058         STRLEN len;
3059
3060         if (SvTYPE(sv) < SVt_PVIV)
3061             sv_upgrade(sv, SVt_PVIV);
3062         ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
3063         len = ebuf - ptr;
3064         /* inlined from sv_setpvn */
3065         s = SvGROW_mutable(sv, len + 1);
3066         Move(ptr, s, len, char);
3067         s += len;
3068         *s = '\0';
3069         SvPOK_on(sv);
3070     }
3071     else if (SvNOK(sv)) {
3072         if (SvTYPE(sv) < SVt_PVNV)
3073             sv_upgrade(sv, SVt_PVNV);
3074         if (SvNVX(sv) == 0.0
3075 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3076             && !Perl_isnan(SvNVX(sv))
3077 #endif
3078         ) {
3079             s = SvGROW_mutable(sv, 2);
3080             *s++ = '0';
3081             *s = '\0';
3082         } else {
3083             STRLEN len;
3084             STRLEN size = 5; /* "-Inf\0" */
3085
3086             s = SvGROW_mutable(sv, size);
3087             len = S_infnan_2pv(SvNVX(sv), s, size);
3088             if (len > 0) {
3089                 s += len;
3090                 SvPOK_on(sv);
3091             }
3092             else {
3093                 /* some Xenix systems wipe out errno here */
3094                 dSAVE_ERRNO;
3095
3096                 size =
3097                     1 + /* sign */
3098                     1 + /* "." */
3099                     NV_DIG +
3100                     1 + /* "e" */
3101                     1 + /* sign */
3102                     5 + /* exponent digits */
3103                     1 + /* \0 */
3104                     2; /* paranoia */
3105
3106                 s = SvGROW_mutable(sv, size);
3107 #ifndef USE_LOCALE_NUMERIC
3108                 SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3109
3110                 SvPOK_on(sv);
3111 #else
3112                 {
3113                     bool local_radix;
3114                     DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
3115
3116                     local_radix =
3117                         PL_numeric_local &&
3118                         PL_numeric_radix_sv &&
3119                         SvUTF8(PL_numeric_radix_sv);
3120                     if (local_radix && SvLEN(PL_numeric_radix_sv) > 1) {
3121                         size += SvLEN(PL_numeric_radix_sv) - 1;
3122                         s = SvGROW_mutable(sv, size);
3123                     }
3124
3125                     SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3126
3127                     /* If the radix character is UTF-8, and actually is in the
3128                      * output, turn on the UTF-8 flag for the scalar */
3129                     if (local_radix &&
3130                         instr(s, SvPVX_const(PL_numeric_radix_sv))) {
3131                         SvUTF8_on(sv);
3132                     }
3133
3134                     RESTORE_LC_NUMERIC();
3135                 }
3136
3137                 /* We don't call SvPOK_on(), because it may come to
3138                  * pass that the locale changes so that the
3139                  * stringification we just did is no longer correct.  We
3140                  * will have to re-stringify every time it is needed */
3141 #endif
3142                 RESTORE_ERRNO;
3143             }
3144             while (*s) s++;
3145         }
3146     }
3147     else if (isGV_with_GP(sv)) {
3148         GV *const gv = MUTABLE_GV(sv);
3149         SV *const buffer = sv_newmortal();
3150
3151         gv_efullname3(buffer, gv, "*");
3152
3153         assert(SvPOK(buffer));
3154         if (SvUTF8(buffer))
3155             SvUTF8_on(sv);
3156         if (lp)
3157             *lp = SvCUR(buffer);
3158         return SvPVX(buffer);
3159     }
3160     else if (isREGEXP(sv)) {
3161         if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
3162         return RX_WRAPPED((REGEXP *)sv);
3163     }
3164     else {
3165         if (lp)
3166             *lp = 0;
3167         if (flags & SV_UNDEF_RETURNS_NULL)
3168             return NULL;
3169         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3170             report_uninit(sv);
3171         /* Typically the caller expects that sv_any is not NULL now.  */
3172         if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
3173             sv_upgrade(sv, SVt_PV);
3174         return (char *)"";
3175     }
3176
3177     {
3178         const STRLEN len = s - SvPVX_const(sv);
3179         if (lp) 
3180             *lp = len;
3181         SvCUR_set(sv, len);
3182     }
3183     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3184                           PTR2UV(sv),SvPVX_const(sv)));
3185     if (flags & SV_CONST_RETURN)
3186         return (char *)SvPVX_const(sv);
3187     if (flags & SV_MUTABLE_RETURN)
3188         return SvPVX_mutable(sv);
3189     return SvPVX(sv);
3190 }
3191
3192 /*
3193 =for apidoc sv_copypv
3194
3195 Copies a stringified representation of the source SV into the
3196 destination SV.  Automatically performs any necessary mg_get and
3197 coercion of numeric values into strings.  Guaranteed to preserve
3198 UTF8 flag even from overloaded objects.  Similar in nature to
3199 sv_2pv[_flags] but operates directly on an SV instead of just the
3200 string.  Mostly uses sv_2pv_flags to do its work, except when that
3201 would lose the UTF-8'ness of the PV.
3202
3203 =for apidoc sv_copypv_nomg
3204
3205 Like sv_copypv, but doesn't invoke get magic first.
3206
3207 =for apidoc sv_copypv_flags
3208
3209 Implementation of sv_copypv and sv_copypv_nomg.  Calls get magic iff flags
3210 include SV_GMAGIC.
3211
3212 =cut
3213 */
3214
3215 void
3216 Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
3217 {
3218     PERL_ARGS_ASSERT_SV_COPYPV;
3219
3220     sv_copypv_flags(dsv, ssv, 0);
3221 }
3222
3223 void
3224 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3225 {
3226     STRLEN len;
3227     const char *s;
3228
3229     PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3230
3231     s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC));
3232     sv_setpvn(dsv,s,len);
3233     if (SvUTF8(ssv))
3234         SvUTF8_on(dsv);
3235     else
3236         SvUTF8_off(dsv);
3237 }
3238
3239 /*
3240 =for apidoc sv_2pvbyte
3241
3242 Return a pointer to the byte-encoded representation of the SV, and set *lp
3243 to its length.  May cause the SV to be downgraded from UTF-8 as a
3244 side-effect.
3245
3246 Usually accessed via the C<SvPVbyte> macro.
3247
3248 =cut
3249 */
3250
3251 char *
3252 Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
3253 {
3254     PERL_ARGS_ASSERT_SV_2PVBYTE;
3255
3256     SvGETMAGIC(sv);
3257     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3258      || isGV_with_GP(sv) || SvROK(sv)) {
3259         SV *sv2 = sv_newmortal();
3260         sv_copypv_nomg(sv2,sv);
3261         sv = sv2;
3262     }
3263     sv_utf8_downgrade(sv,0);
3264     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3265 }
3266
3267 /*
3268 =for apidoc sv_2pvutf8
3269
3270 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3271 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3272
3273 Usually accessed via the C<SvPVutf8> macro.
3274
3275 =cut
3276 */
3277
3278 char *
3279 Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
3280 {
3281     PERL_ARGS_ASSERT_SV_2PVUTF8;
3282
3283     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3284      || isGV_with_GP(sv) || SvROK(sv))
3285         sv = sv_mortalcopy(sv);
3286     else
3287         SvGETMAGIC(sv);
3288     sv_utf8_upgrade_nomg(sv);
3289     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3290 }
3291
3292
3293 /*
3294 =for apidoc sv_2bool
3295
3296 This macro is only used by sv_true() or its macro equivalent, and only if
3297 the latter's argument is neither SvPOK, SvIOK nor SvNOK.
3298 It calls sv_2bool_flags with the SV_GMAGIC flag.
3299
3300 =for apidoc sv_2bool_flags
3301
3302 This function is only used by sv_true() and friends,  and only if
3303 the latter's argument is neither SvPOK, SvIOK nor SvNOK.  If the flags
3304 contain SV_GMAGIC, then it does an mg_get() first.
3305
3306
3307 =cut
3308 */
3309
3310 bool
3311 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
3312 {
3313     PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3314
3315     restart:
3316     if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3317
3318     if (!SvOK(sv))
3319         return 0;
3320     if (SvROK(sv)) {
3321         if (SvAMAGIC(sv)) {
3322             SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3323             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
3324                 bool svb;
3325                 sv = tmpsv;
3326                 if(SvGMAGICAL(sv)) {
3327                     flags = SV_GMAGIC;
3328                     goto restart; /* call sv_2bool */
3329                 }
3330                 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
3331                 else if(!SvOK(sv)) {
3332                     svb = 0;
3333                 }
3334                 else if(SvPOK(sv)) {
3335                     svb = SvPVXtrue(sv);
3336                 }
3337                 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
3338                     svb = (SvIOK(sv) && SvIVX(sv) != 0)
3339                         || (SvNOK(sv) && SvNVX(sv) != 0.0);
3340                 }
3341                 else {
3342                     flags = 0;
3343                     goto restart; /* call sv_2bool_nomg */
3344                 }
3345                 return cBOOL(svb);
3346             }
3347         }
3348         return SvRV(sv) != 0;
3349     }
3350     if (isREGEXP(sv))
3351         return
3352           RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
3353     return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
3354 }
3355
3356 /*
3357 =for apidoc sv_utf8_upgrade
3358
3359 Converts the PV of an SV to its UTF-8-encoded form.
3360 Forces the SV to string form if it is not already.
3361 Will C<mg_get> on C<sv> if appropriate.
3362 Always sets the SvUTF8 flag to avoid future validity checks even
3363 if the whole string is the same in UTF-8 as not.
3364 Returns the number of bytes in the converted string
3365
3366 This is not a general purpose byte encoding to Unicode interface:
3367 use the Encode extension for that.
3368
3369 =for apidoc sv_utf8_upgrade_nomg
3370
3371 Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
3372
3373 =for apidoc sv_utf8_upgrade_flags
3374
3375 Converts the PV of an SV to its UTF-8-encoded form.
3376 Forces the SV to string form if it is not already.
3377 Always sets the SvUTF8 flag to avoid future validity checks even
3378 if all the bytes are invariant in UTF-8.
3379 If C<flags> has C<SV_GMAGIC> bit set,
3380 will C<mg_get> on C<sv> if appropriate, else not.
3381
3382 If C<flags> has SV_FORCE_UTF8_UPGRADE set, this function assumes that the PV
3383 will expand when converted to UTF-8, and skips the extra work of checking for
3384 that.  Typically this flag is used by a routine that has already parsed the
3385 string and found such characters, and passes this information on so that the
3386 work doesn't have to be repeated.
3387
3388 Returns the number of bytes in the converted string.
3389
3390 This is not a general purpose byte encoding to Unicode interface:
3391 use the Encode extension for that.
3392
3393 =for apidoc sv_utf8_upgrade_flags_grow
3394
3395 Like sv_utf8_upgrade_flags, but has an additional parameter C<extra>, which is
3396 the number of unused bytes the string of 'sv' is guaranteed to have free after
3397 it upon return.  This allows the caller to reserve extra space that it intends
3398 to fill, to avoid extra grows.
3399
3400 C<sv_utf8_upgrade>, C<sv_utf8_upgrade_nomg>, and C<sv_utf8_upgrade_flags>
3401 are implemented in terms of this function.
3402
3403 Returns the number of bytes in the converted string (not including the spares).
3404
3405 =cut
3406
3407 (One might think that the calling routine could pass in the position of the
3408 first variant character when it has set SV_FORCE_UTF8_UPGRADE, so it wouldn't
3409 have to be found again.  But that is not the case, because typically when the
3410 caller is likely to use this flag, it won't be calling this routine unless it
3411 finds something that won't fit into a byte.  Otherwise it tries to not upgrade
3412 and just use bytes.  But some things that do fit into a byte are variants in
3413 utf8, and the caller may not have been keeping track of these.)
3414
3415 If the routine itself changes the string, it adds a trailing C<NUL>.  Such a
3416 C<NUL> isn't guaranteed due to having other routines do the work in some input
3417 cases, or if the input is already flagged as being in utf8.
3418
3419 The speed of this could perhaps be improved for many cases if someone wanted to
3420 write a fast function that counts the number of variant characters in a string,
3421 especially if it could return the position of the first one.
3422
3423 */
3424
3425 STRLEN
3426 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3427 {
3428     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3429
3430     if (sv == &PL_sv_undef)
3431         return 0;
3432     if (!SvPOK_nog(sv)) {
3433         STRLEN len = 0;
3434         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3435             (void) sv_2pv_flags(sv,&len, flags);
3436             if (SvUTF8(sv)) {
3437                 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3438                 return len;
3439             }
3440         } else {
3441             (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3442         }
3443     }
3444
3445     if (SvUTF8(sv)) {
3446         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3447         return SvCUR(sv);
3448     }
3449
3450     if (SvIsCOW(sv)) {
3451         S_sv_uncow(aTHX_ sv, 0);
3452     }
3453
3454     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3455         sv_recode_to_utf8(sv, PL_encoding);
3456         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3457         return SvCUR(sv);
3458     }
3459
3460     if (SvCUR(sv) == 0) {
3461         if (extra) SvGROW(sv, extra);
3462     } else { /* Assume Latin-1/EBCDIC */
3463         /* This function could be much more efficient if we
3464          * had a FLAG in SVs to signal if there are any variant
3465          * chars in the PV.  Given that there isn't such a flag
3466          * make the loop as fast as possible (although there are certainly ways
3467          * to speed this up, eg. through vectorization) */
3468         U8 * s = (U8 *) SvPVX_const(sv);
3469         U8 * e = (U8 *) SvEND(sv);
3470         U8 *t = s;
3471         STRLEN two_byte_count = 0;
3472         
3473         if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3474
3475         /* See if really will need to convert to utf8.  We mustn't rely on our
3476          * incoming SV being well formed and having a trailing '\0', as certain
3477          * code in pp_formline can send us partially built SVs. */
3478
3479         while (t < e) {
3480             const U8 ch = *t++;
3481             if (NATIVE_BYTE_IS_INVARIANT(ch)) continue;
3482
3483             t--;    /* t already incremented; re-point to first variant */
3484             two_byte_count = 1;
3485             goto must_be_utf8;
3486         }
3487
3488         /* utf8 conversion not needed because all are invariants.  Mark as
3489          * UTF-8 even if no variant - saves scanning loop */
3490         SvUTF8_on(sv);
3491         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3492         return SvCUR(sv);
3493
3494 must_be_utf8:
3495
3496         /* Here, the string should be converted to utf8, either because of an
3497          * input flag (two_byte_count = 0), or because a character that
3498          * requires 2 bytes was found (two_byte_count = 1).  t points either to
3499          * the beginning of the string (if we didn't examine anything), or to
3500          * the first variant.  In either case, everything from s to t - 1 will
3501          * occupy only 1 byte each on output.
3502          *
3503          * There are two main ways to convert.  One is to create a new string
3504          * and go through the input starting from the beginning, appending each
3505          * converted value onto the new string as we go along.  It's probably
3506          * best to allocate enough space in the string for the worst possible
3507          * case rather than possibly running out of space and having to
3508          * reallocate and then copy what we've done so far.  Since everything
3509          * from s to t - 1 is invariant, the destination can be initialized
3510          * with these using a fast memory copy
3511          *
3512          * The other way is to figure out exactly how big the string should be
3513          * by parsing the entire input.  Then you don't have to make it big
3514          * enough to handle the worst possible case, and more importantly, if
3515          * the string you already have is large enough, you don't have to
3516          * allocate a new string, you can copy the last character in the input
3517          * string to the final position(s) that will be occupied by the
3518          * converted string and go backwards, stopping at t, since everything
3519          * before that is invariant.
3520          *
3521          * There are advantages and disadvantages to each method.
3522          *
3523          * In the first method, we can allocate a new string, do the memory
3524          * copy from the s to t - 1, and then proceed through the rest of the
3525          * string byte-by-byte.
3526          *
3527          * In the second method, we proceed through the rest of the input
3528          * string just calculating how big the converted string will be.  Then
3529          * there are two cases:
3530          *  1)  if the string has enough extra space to handle the converted
3531          *      value.  We go backwards through the string, converting until we
3532          *      get to the position we are at now, and then stop.  If this
3533          *      position is far enough along in the string, this method is
3534          *      faster than the other method.  If the memory copy were the same
3535          *      speed as the byte-by-byte loop, that position would be about
3536          *      half-way, as at the half-way mark, parsing to the end and back
3537          *      is one complete string's parse, the same amount as starting
3538          *      over and going all the way through.  Actually, it would be
3539          *      somewhat less than half-way, as it's faster to just count bytes
3540          *      than to also copy, and we don't have the overhead of allocating
3541          *      a new string, changing the scalar to use it, and freeing the
3542          *      existing one.  But if the memory copy is fast, the break-even
3543          *      point is somewhere after half way.  The counting loop could be
3544          *      sped up by vectorization, etc, to move the break-even point
3545          *      further towards the beginning.
3546          *  2)  if the string doesn't have enough space to handle the converted
3547          *      value.  A new string will have to be allocated, and one might
3548          *      as well, given that, start from the beginning doing the first
3549          *      method.  We've spent extra time parsing the string and in
3550          *      exchange all we've gotten is that we know precisely how big to
3551          *      make the new one.  Perl is more optimized for time than space,
3552          *      so this case is a loser.
3553          * So what I've decided to do is not use the 2nd method unless it is
3554          * guaranteed that a new string won't have to be allocated, assuming
3555          * the worst case.  I also decided not to put any more conditions on it
3556          * than this, for now.  It seems likely that, since the worst case is
3557          * twice as big as the unknown portion of the string (plus 1), we won't
3558          * be guaranteed enough space, causing us to go to the first method,
3559          * unless the string is short, or the first variant character is near
3560          * the end of it.  In either of these cases, it seems best to use the
3561          * 2nd method.  The only circumstance I can think of where this would
3562          * be really slower is if the string had once had much more data in it
3563          * than it does now, but there is still a substantial amount in it  */
3564
3565         {
3566             STRLEN invariant_head = t - s;
3567             STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3568             if (SvLEN(sv) < size) {
3569
3570                 /* Here, have decided to allocate a new string */
3571
3572                 U8 *dst;
3573                 U8 *d;
3574
3575                 Newx(dst, size, U8);
3576
3577                 /* If no known invariants at the beginning of the input string,
3578                  * set so starts from there.  Otherwise, can use memory copy to
3579                  * get up to where we are now, and then start from here */
3580
3581                 if (invariant_head == 0) {
3582                     d = dst;
3583                 } else {
3584                     Copy(s, dst, invariant_head, char);
3585                     d = dst + invariant_head;
3586                 }
3587
3588                 while (t < e) {
3589                     append_utf8_from_native_byte(*t, &d);
3590                     t++;
3591                 }
3592                 *d = '\0';
3593                 SvPV_free(sv); /* No longer using pre-existing string */
3594                 SvPV_set(sv, (char*)dst);
3595                 SvCUR_set(sv, d - dst);
3596                 SvLEN_set(sv, size);
3597             } else {
3598
3599                 /* Here, have decided to get the exact size of the string.
3600                  * Currently this happens only when we know that there is
3601                  * guaranteed enough space to fit the converted string, so
3602                  * don't have to worry about growing.  If two_byte_count is 0,
3603                  * then t points to the first byte of the string which hasn't
3604                  * been examined yet.  Otherwise two_byte_count is 1, and t
3605                  * points to the first byte in the string that will expand to
3606                  * two.  Depending on this, start examining at t or 1 after t.
3607                  * */
3608
3609                 U8 *d = t + two_byte_count;
3610
3611
3612                 /* Count up the remaining bytes that expand to two */
3613
3614                 while (d < e) {
3615                     const U8 chr = *d++;
3616                     if (! NATIVE_BYTE_IS_INVARIANT(chr)) two_byte_count++;
3617                 }
3618
3619                 /* The string will expand by just the number of bytes that
3620                  * occupy two positions.  But we are one afterwards because of
3621                  * the increment just above.  This is the place to put the
3622                  * trailing NUL, and to set the length before we decrement */
3623
3624                 d += two_byte_count;
3625                 SvCUR_set(sv, d - s);
3626                 *d-- = '\0';
3627
3628
3629                 /* Having decremented d, it points to the position to put the
3630                  * very last byte of the expanded string.  Go backwards through
3631                  * the string, copying and expanding as we go, stopping when we
3632                  * get to the part that is invariant the rest of the way down */
3633
3634                 e--;
3635                 while (e >= t) {
3636                     if (NATIVE_BYTE_IS_INVARIANT(*e)) {
3637                         *d-- = *e;
3638                     } else {
3639                         *d-- = UTF8_EIGHT_BIT_LO(*e);
3640                         *d-- = UTF8_EIGHT_BIT_HI(*e);
3641                     }
3642                     e--;
3643                 }
3644             }
3645
3646             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3647                 /* Update pos. We do it at the end rather than during
3648                  * the upgrade, to avoid slowing down the common case
3649                  * (upgrade without pos).
3650                  * pos can be stored as either bytes or characters.  Since
3651                  * this was previously a byte string we can just turn off
3652                  * the bytes flag. */
3653                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3654                 if (mg) {
3655                     mg->mg_flags &= ~MGf_BYTES;
3656                 }
3657                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3658                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3659             }
3660         }
3661     }
3662
3663     /* Mark as UTF-8 even if no variant - saves scanning loop */
3664     SvUTF8_on(sv);
3665     return SvCUR(sv);
3666 }
3667
3668 /*
3669 =for apidoc sv_utf8_downgrade
3670
3671 Attempts to convert the PV of an SV from characters to bytes.
3672 If the PV contains a character that cannot fit
3673 in a byte, this conversion will fail;
3674 in this case, either returns false or, if C<fail_ok> is not
3675 true, croaks.
3676
3677 This is not a general purpose Unicode to byte encoding interface:
3678 use the Encode extension for that.
3679
3680 =cut
3681 */
3682
3683 bool
3684 Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
3685 {
3686     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3687
3688     if (SvPOKp(sv) && SvUTF8(sv)) {
3689         if (SvCUR(sv)) {
3690             U8 *s;
3691             STRLEN len;
3692             int mg_flags = SV_GMAGIC;
3693
3694             if (SvIsCOW(sv)) {
3695                 S_sv_uncow(aTHX_ sv, 0);
3696             }
3697             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3698                 /* update pos */
3699                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3700                 if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
3701                         mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
3702                                                 SV_GMAGIC|SV_CONST_RETURN);
3703                         mg_flags = 0; /* sv_pos_b2u does get magic */
3704                 }
3705                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3706                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3707
3708             }
3709             s = (U8 *) SvPV_flags(sv, len, mg_flags);
3710
3711             if (!utf8_to_bytes(s, &len)) {
3712                 if (fail_ok)
3713                     return FALSE;
3714                 else {
3715                     if (PL_op)
3716                         Perl_croak(aTHX_ "Wide character in %s",
3717                                    OP_DESC(PL_op));
3718                     else
3719                         Perl_croak(aTHX_ "Wide character");
3720                 }
3721             }
3722             SvCUR_set(sv, len);
3723         }
3724     }
3725     SvUTF8_off(sv);
3726     return TRUE;
3727 }
3728
3729 /*
3730 =for apidoc sv_utf8_encode
3731
3732 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3733 flag off so that it looks like octets again.
3734
3735 =cut
3736 */
3737
3738 void
3739 Perl_sv_utf8_encode(pTHX_ SV *const sv)
3740 {
3741     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3742
3743     if (SvREADONLY(sv)) {
3744         sv_force_normal_flags(sv, 0);
3745     }
3746     (void) sv_utf8_upgrade(sv);
3747     SvUTF8_off(sv);
3748 }
3749
3750 /*
3751 =for apidoc sv_utf8_decode
3752
3753 If the PV of the SV is an octet sequence in UTF-8
3754 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3755 so that it looks like a character.  If the PV contains only single-byte
3756 characters, the C<SvUTF8> flag stays off.
3757 Scans PV for validity and returns false if the PV is invalid UTF-8.
3758
3759 =cut
3760 */
3761
3762 bool
3763 Perl_sv_utf8_decode(pTHX_ SV *const sv)
3764 {
3765     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3766
3767     if (SvPOKp(sv)) {
3768         const U8 *start, *c;
3769         const U8 *e;
3770
3771         /* The octets may have got themselves encoded - get them back as
3772          * bytes
3773          */
3774         if (!sv_utf8_downgrade(sv, TRUE))
3775             return FALSE;
3776
3777         /* it is actually just a matter of turning the utf8 flag on, but
3778          * we want to make sure everything inside is valid utf8 first.
3779          */
3780         c = start = (const U8 *) SvPVX_const(sv);
3781         if (!is_utf8_string(c, SvCUR(sv)))
3782             return FALSE;
3783         e = (const U8 *) SvEND(sv);
3784         while (c < e) {
3785             const U8 ch = *c++;
3786             if (!UTF8_IS_INVARIANT(ch)) {
3787                 SvUTF8_on(sv);
3788                 break;
3789             }
3790         }
3791         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3792             /* XXX Is this dead code?  XS_utf8_decode calls SvSETMAGIC
3793                    after this, clearing pos.  Does anything on CPAN
3794                    need this? */
3795             /* adjust pos to the start of a UTF8 char sequence */
3796             MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3797             if (mg) {
3798                 I32 pos = mg->mg_len;
3799                 if (pos > 0) {
3800                     for (c = start + pos; c > start; c--) {
3801                         if (UTF8_IS_START(*c))
3802                             break;
3803                     }
3804                     mg->mg_len  = c - start;
3805                 }
3806             }
3807             if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3808                 magic_setutf8(sv,mg); /* clear UTF8 cache */
3809         }
3810     }
3811     return TRUE;
3812 }
3813
3814 /*
3815 =for apidoc sv_setsv
3816
3817 Copies the contents of the source SV C<ssv> into the destination SV
3818 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3819 function if the source SV needs to be reused.  Does not handle 'set' magic on
3820 destination SV.  Calls 'get' magic on source SV.  Loosely speaking, it
3821 performs a copy-by-value, obliterating any previous content of the
3822 destination.
3823
3824 You probably want to use one of the assortment of wrappers, such as
3825 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3826 C<SvSetMagicSV_nosteal>.
3827
3828 =for apidoc sv_setsv_flags
3829
3830 Copies the contents of the source SV C<ssv> into the destination SV
3831 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3832 function if the source SV needs to be reused.  Does not handle 'set' magic.
3833 Loosely speaking, it performs a copy-by-value, obliterating any previous
3834 content of the destination.
3835 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3836 C<ssv> if appropriate, else not.  If the C<flags>
3837 parameter has the C<SV_NOSTEAL> bit set then the
3838 buffers of temps will not be stolen.  <sv_setsv>
3839 and C<sv_setsv_nomg> are implemented in terms of this function.
3840
3841 You probably want to use one of the assortment of wrappers, such as
3842 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3843 C<SvSetMagicSV_nosteal>.
3844
3845 This is the primary function for copying scalars, and most other
3846 copy-ish functions and macros use this underneath.
3847
3848 =cut
3849 */
3850
3851 static void
3852 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3853 {
3854     I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3855     HV *old_stash = NULL;
3856
3857     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3858
3859     if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3860         const char * const name = GvNAME(sstr);
3861         const STRLEN len = GvNAMELEN(sstr);
3862         {
3863             if (dtype >= SVt_PV) {
3864                 SvPV_free(dstr);
3865                 SvPV_set(dstr, 0);
3866                 SvLEN_set(dstr, 0);
3867                 SvCUR_set(dstr, 0);
3868             }
3869             SvUPGRADE(dstr, SVt_PVGV);
3870             (void)SvOK_off(dstr);
3871             isGV_with_GP_on(dstr);
3872         }
3873         GvSTASH(dstr) = GvSTASH(sstr);
3874         if (GvSTASH(dstr))
3875             Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3876         gv_name_set(MUTABLE_GV(dstr), name, len,
3877                         GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
3878         SvFAKE_on(dstr);        /* can coerce to non-glob */
3879     }
3880
3881     if(GvGP(MUTABLE_GV(sstr))) {
3882         /* If source has method cache entry, clear it */
3883         if(GvCVGEN(sstr)) {
3884             SvREFCNT_dec(GvCV(sstr));
3885             GvCV_set(sstr, NULL);
3886             GvCVGEN(sstr) = 0;
3887         }
3888         /* If source has a real method, then a method is
3889            going to change */
3890         else if(
3891          GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3892         ) {
3893             mro_changes = 1;
3894         }
3895     }
3896
3897     /* If dest already had a real method, that's a change as well */
3898     if(
3899         !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3900      && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3901     ) {
3902         mro_changes = 1;
3903     }
3904
3905     /* We don't need to check the name of the destination if it was not a
3906        glob to begin with. */
3907     if(dtype == SVt_PVGV) {
3908         const char * const name = GvNAME((const GV *)dstr);
3909         if(
3910             strEQ(name,"ISA")
3911          /* The stash may have been detached from the symbol table, so
3912             check its name. */
3913          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3914         )
3915             mro_changes = 2;
3916         else {
3917             const STRLEN len = GvNAMELEN(dstr);
3918             if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3919              || (len == 1 && name[0] == ':')) {
3920                 mro_changes = 3;
3921
3922                 /* Set aside the old stash, so we can reset isa caches on
3923                    its subclasses. */
3924                 if((old_stash = GvHV(dstr)))
3925                     /* Make sure we do not lose it early. */
3926                     SvREFCNT_inc_simple_void_NN(
3927                      sv_2mortal((SV *)old_stash)
3928                     );
3929             }
3930         }
3931
3932         SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
3933     }
3934
3935     gp_free(MUTABLE_GV(dstr));
3936     GvINTRO_off(dstr);          /* one-shot flag */
3937     GvGP_set(dstr, gp_ref(GvGP(sstr)));
3938     if (SvTAINTED(sstr))
3939         SvTAINT(dstr);
3940     if (GvIMPORTED(dstr) != GVf_IMPORTED
3941         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3942         {
3943             GvIMPORTED_on(dstr);
3944         }
3945     GvMULTI_on(dstr);
3946     if(mro_changes == 2) {
3947       if (GvAV((const GV *)sstr)) {
3948         MAGIC *mg;
3949         SV * const sref = (SV *)GvAV((const GV *)dstr);
3950         if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3951             if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3952                 AV * const ary = newAV();
3953                 av_push(ary, mg->mg_obj); /* takes the refcount */
3954                 mg->mg_obj = (SV *)ary;
3955             }
3956             av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3957         }
3958         else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3959       }
3960       mro_isa_changed_in(GvSTASH(dstr));
3961     }
3962     else if(mro_changes == 3) {
3963         HV * const stash = GvHV(dstr);
3964         if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3965             mro_package_moved(
3966                 stash, old_stash,
3967                 (GV *)dstr, 0
3968             );
3969     }
3970     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3971     if (GvIO(dstr) && dtype == SVt_PVGV) {
3972         DEBUG_o(Perl_deb(aTHX_
3973                         "glob_assign_glob clearing PL_stashcache\n"));
3974         /* It's a cache. It will rebuild itself quite happily.
3975            It's a lot of effort to work out exactly which key (or keys)
3976            might be invalidated by the creation of the this file handle.
3977          */
3978         hv_clear(PL_stashcache);
3979     }
3980     return;
3981 }
3982
3983 void
3984 Perl_gv_setref(pTHX_ SV *const dstr, SV *const sstr)
3985 {
3986     SV * const sref = SvRV(sstr);
3987     SV *dref;
3988     const int intro = GvINTRO(dstr);
3989     SV **location;
3990     U8 import_flag = 0;
3991     const U32 stype = SvTYPE(sref);
3992
3993     PERL_ARGS_ASSERT_GV_SETREF;
3994
3995     if (intro) {
3996         GvINTRO_off(dstr);      /* one-shot flag */
3997         GvLINE(dstr) = CopLINE(PL_curcop);
3998         GvEGV(dstr) = MUTABLE_GV(dstr);
3999     }
4000     GvMULTI_on(dstr);
4001     switch (stype) {
4002     case SVt_PVCV:
4003         location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
4004         import_flag = GVf_IMPORTED_CV;
4005         goto common;
4006     case SVt_PVHV:
4007         location = (SV **) &GvHV(dstr);
4008         import_flag = GVf_IMPORTED_HV;
4009         goto common;
4010     case SVt_PVAV:
4011         location = (SV **) &GvAV(dstr);
4012         import_flag = GVf_IMPORTED_AV;
4013         goto common;
4014     case SVt_PVIO:
4015         location = (SV **) &GvIOp(dstr);
4016         goto common;
4017     case SVt_PVFM:
4018         location = (SV **) &GvFORM(dstr);
4019         goto common;
4020     default:
4021         location = &GvSV(dstr);
4022         import_flag = GVf_IMPORTED_SV;
4023     common:
4024         if (intro) {
4025             if (stype == SVt_PVCV) {
4026                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
4027                 if (GvCVGEN(dstr)) {
4028                     SvREFCNT_dec(GvCV(dstr));
4029                     GvCV_set(dstr, NULL);
4030                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4031                 }
4032             }
4033             /* SAVEt_GVSLOT takes more room on the savestack and has more
4034                overhead in leave_scope than SAVEt_GENERIC_SV.  But for CVs
4035                leave_scope needs access to the GV so it can reset method
4036                caches.  We must use SAVEt_GVSLOT whenever the type is
4037                SVt_PVCV, even if the stash is anonymous, as the stash may
4038                gain a name somehow before leave_scope. */
4039             if (stype == SVt_PVCV) {
4040                 /* There is no save_pushptrptrptr.  Creating it for this
4041                    one call site would be overkill.  So inline the ss add
4042                    routines here. */
4043                 dSS_ADD;
4044                 SS_ADD_PTR(dstr);
4045                 SS_ADD_PTR(location);
4046                 SS_ADD_PTR(SvREFCNT_inc(*location));
4047                 SS_ADD_UV(SAVEt_GVSLOT);
4048                 SS_ADD_END(4);
4049             }
4050             else SAVEGENERICSV(*location);
4051         }
4052         dref = *location;
4053         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
4054             CV* const cv = MUTABLE_CV(*location);
4055             if (cv) {
4056                 if (!GvCVGEN((const GV *)dstr) &&
4057                     (CvROOT(cv) || CvXSUB(cv)) &&
4058                     /* redundant check that avoids creating the extra SV
4059                        most of the time: */
4060                     (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
4061                     {
4062                         SV * const new_const_sv =
4063                             CvCONST((const CV *)sref)
4064                                  ? cv_const_sv((const CV *)sref)
4065                                  : NULL;
4066                         report_redefined_cv(
4067                            sv_2mortal(Perl_newSVpvf(aTHX_
4068                                 "%"HEKf"::%"HEKf,
4069                                 HEKfARG(
4070                                  HvNAME_HEK(GvSTASH((const GV *)dstr))
4071                                 ),
4072                                 HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
4073                            )),
4074                            cv,
4075                            CvCONST((const CV *)sref) ? &new_const_sv : NULL
4076                         );
4077                     }
4078                 if (!intro)
4079                     cv_ckproto_len_flags(cv, (const GV *)dstr,
4080                                    SvPOK(sref) ? CvPROTO(sref) : NULL,
4081                                    SvPOK(sref) ? CvPROTOLEN(sref) : 0,
4082                                    SvPOK(sref) ? SvUTF8(sref) : 0);
4083             }
4084             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4085             GvASSUMECV_on(dstr);
4086             if(GvSTASH(dstr)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
4087                 if (intro && GvREFCNT(dstr) > 1) {
4088                     /* temporary remove extra savestack's ref */
4089                     --GvREFCNT(dstr);
4090                     gv_method_changed(dstr);
4091                     ++GvREFCNT(dstr);
4092                 }
4093                 else gv_method_changed(dstr);
4094             }
4095         }
4096         *location = SvREFCNT_inc_simple_NN(sref);
4097         if (import_flag && !(GvFLAGS(dstr) & import_flag)
4098             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
4099             GvFLAGS(dstr) |= import_flag;
4100         }
4101         if (import_flag == GVf_IMPORTED_SV) {
4102             if (intro) {
4103                 save_aliased_sv((GV *)dstr);
4104             }
4105             /* Turn off the flag if sref is not referenced elsewhere,
4106                even by weak refs.  (SvRMAGICAL is a pessimistic check for
4107                back refs.)  */
4108             if (SvREFCNT(sref) <= 2 && !SvRMAGICAL(sref))
4109                 GvALIASED_SV_off(dstr);
4110             else
4111                 GvALIASED_SV_on(dstr);
4112         }
4113         if (stype == SVt_PVHV) {
4114             const char * const name = GvNAME((GV*)dstr);
4115             const STRLEN len = GvNAMELEN(dstr);
4116             if (
4117                 (
4118                    (len > 1 && name[len-2] == ':' && name[len-1] == ':')
4119                 || (len == 1 && name[0] == ':')
4120                 )
4121              && (!dref || HvENAME_get(dref))
4122             ) {
4123                 mro_package_moved(
4124                     (HV *)sref, (HV *)dref,
4125                     (GV *)dstr, 0
4126                 );
4127             }
4128         }
4129         else if (
4130             stype == SVt_PVAV && sref != dref
4131          && strEQ(GvNAME((GV*)dstr), "ISA")
4132          /* The stash may have been detached from the symbol table, so
4133             check its name before doing anything. */
4134          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
4135         ) {
4136             MAGIC *mg;
4137             MAGIC * const omg = dref && SvSMAGICAL(dref)
4138                                  ? mg_find(dref, PERL_MAGIC_isa)
4139                                  : NULL;
4140             if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
4141                 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
4142                     AV * const ary = newAV();
4143                     av_push(ary, mg->mg_obj); /* takes the refcount */
4144                     mg->mg_obj = (SV *)ary;
4145                 }
4146                 if (omg) {
4147                     if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
4148                         SV **svp = AvARRAY((AV *)omg->mg_obj);
4149                         I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
4150                         while (items--)
4151                             av_push(
4152                              (AV *)mg->mg_obj,
4153                              SvREFCNT_inc_simple_NN(*svp++)
4154                             );
4155                     }
4156                     else
4157                         av_push(
4158                          (AV *)mg->mg_obj,
4159                          SvREFCNT_inc_simple_NN(omg->mg_obj)
4160                         );
4161                 }
4162                 else
4163                     av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
4164             }
4165             else
4166             {
4167                 sv_magic(
4168                  sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
4169                 );
4170                 mg = mg_find(sref, PERL_MAGIC_isa);
4171             }
4172             /* Since the *ISA assignment could have affected more than
4173                one stash, don't call mro_isa_changed_in directly, but let
4174                magic_clearisa do it for us, as it already has the logic for
4175                dealing with globs vs arrays of globs. */
4176             assert(mg);
4177             Perl_magic_clearisa(aTHX_ NULL, mg);
4178         }
4179         else if (stype == SVt_PVIO) {
4180             DEBUG_o(Perl_deb(aTHX_ "gv_setref clearing PL_stashcache\n"));
4181             /* It's a cache. It will rebuild itself quite happily.
4182                It's a lot of effort to work out exactly which key (or keys)
4183                might be invalidated by the creation of the this file handle.
4184             */
4185             hv_clear(PL_stashcache);
4186         }
4187         break;
4188     }
4189     if (!intro) SvREFCNT_dec(dref);
4190     if (SvTAINTED(sstr))
4191         SvTAINT(dstr);
4192     return;
4193 }
4194
4195
4196
4197
4198 #ifdef PERL_DEBUG_READONLY_COW
4199 # include <sys/mman.h>
4200
4201 # ifndef PERL_MEMORY_DEBUG_HEADER_SIZE
4202 #  define PERL_MEMORY_DEBUG_HEADER_SIZE 0
4203 # endif
4204
4205 void
4206 Perl_sv_buf_to_ro(pTHX_ SV *sv)
4207 {
4208     struct perl_memory_debug_header * const header =
4209         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4210     const MEM_SIZE len = header->size;
4211     PERL_ARGS_ASSERT_SV_BUF_TO_RO;
4212 # ifdef PERL_TRACK_MEMPOOL
4213     if (!header->readonly) header->readonly = 1;
4214 # endif
4215     if (mprotect(header, len, PROT_READ))
4216         Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
4217                          header, len, errno);
4218 }
4219
4220 static void
4221 S_sv_buf_to_rw(pTHX_ SV *sv)
4222 {
4223     struct perl_memory_debug_header * const header =
4224         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4225     const MEM_SIZE len = header->size;
4226     PERL_ARGS_ASSERT_SV_BUF_TO_RW;
4227     if (mprotect(header, len, PROT_READ|PROT_WRITE))
4228         Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
4229                          header, len, errno);
4230 # ifdef PERL_TRACK_MEMPOOL
4231     header->readonly = 0;
4232 # endif
4233 }
4234
4235 #else
4236 # define sv_buf_to_ro(sv)       NOOP
4237 # define sv_buf_to_rw(sv)       NOOP
4238 #endif
4239
4240 void
4241 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
4242 {
4243     U32 sflags;
4244     int dtype;
4245     svtype stype;
4246
4247     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
4248
4249     if (sstr == dstr)
4250         return;
4251
4252     if (SvIS_FREED(dstr)) {
4253         Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
4254                    " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
4255     }
4256     SV_CHECK_THINKFIRST_COW_DROP(dstr);
4257     if (!sstr)
4258         sstr = &PL_sv_undef;
4259     if (SvIS_FREED(sstr)) {
4260         Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
4261                    (void*)sstr, (void*)dstr);
4262     }
4263     stype = SvTYPE(sstr);
4264     dtype = SvTYPE(dstr);
4265
4266     /* There's a lot of redundancy below but we're going for speed here */
4267
4268     switch (stype) {
4269     case SVt_NULL:
4270       undef_sstr:
4271         if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
4272             (void)SvOK_off(dstr);
4273             return;
4274         }
4275         break;
4276     case SVt_IV:
4277         if (SvIOK(sstr)) {
4278             switch (dtype) {
4279             case SVt_NULL:
4280                 sv_upgrade(dstr, SVt_IV);
4281                 break;
4282             case SVt_NV:
4283             case SVt_PV:
4284                 sv_upgrade(dstr, SVt_PVIV);
4285                 break;
4286             case SVt_PVGV:
4287             case SVt_PVLV:
4288                 goto end_of_first_switch;
4289             }
4290             (void)SvIOK_only(dstr);
4291             SvIV_set(dstr,  SvIVX(sstr));
4292             if (SvIsUV(sstr))
4293                 SvIsUV_on(dstr);
4294             /* SvTAINTED can only be true if the SV has taint magic, which in
4295                turn means that the SV type is PVMG (or greater). This is the
4296                case statement for SVt_IV, so this cannot be true (whatever gcov
4297                may say).  */
4298             assert(!SvTAINTED(sstr));
4299             return;
4300         }
4301         if (!SvROK(sstr))
4302             goto undef_sstr;
4303         if (dtype < SVt_PV && dtype != SVt_IV)
4304             sv_upgrade(dstr, SVt_IV);
4305         break;
4306
4307     case SVt_NV:
4308         if (SvNOK(sstr)) {
4309             switch (dtype) {
4310             case SVt_NULL:
4311             case SVt_IV:
4312                 sv_upgrade(dstr, SVt_NV);
4313                 break;
4314             case SVt_PV:
4315             case SVt_PVIV:
4316                 sv_upgrade(dstr, SVt_PVNV);
4317                 break;
4318             case SVt_PVGV:
4319             case SVt_PVLV:
4320                 goto end_of_first_switch;
4321             }
4322             SvNV_set(dstr, SvNVX(sstr));
4323             (void)SvNOK_only(dstr);
4324             /* SvTAINTED can only be true if the SV has taint magic, which in
4325                turn means that the SV type is PVMG (or greater). This is the
4326                case statement for SVt_NV, so this cannot be true (whatever gcov
4327                may say).  */
4328             assert(!SvTAINTED(sstr));
4329             return;
4330         }
4331         goto undef_sstr;
4332
4333     case SVt_PV:
4334         if (dtype < SVt_PV)
4335             sv_upgrade(dstr, SVt_PV);
4336         break;
4337     case SVt_PVIV:
4338         if (dtype < SVt_PVIV)
4339             sv_upgrade(dstr, SVt_PVIV);
4340         break;
4341     case SVt_PVNV:
4342         if (dtype < SVt_PVNV)
4343             sv_upgrade(dstr, SVt_PVNV);
4344         break;
4345     default:
4346         {
4347         const char * const type = sv_reftype(sstr,0);
4348         if (PL_op)
4349             /* diag_listed_as: Bizarre copy of %s */
4350             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4351         else
4352             Perl_croak(aTHX_ "Bizarre copy of %s", type);
4353         }
4354         NOT_REACHED; /* NOTREACHED */
4355
4356     case SVt_REGEXP:
4357       upgregexp:
4358         if (dtype < SVt_REGEXP)
4359         {
4360             if (dtype >= SVt_PV) {
4361                 SvPV_free(dstr);
4362                 SvPV_set(dstr, 0);
4363                 SvLEN_set(dstr, 0);
4364                 SvCUR_set(dstr, 0);
4365             }
4366             sv_upgrade(dstr, SVt_REGEXP);
4367         }
4368         break;
4369
4370         case SVt_INVLIST:
4371     case SVt_PVLV:
4372     case SVt_PVGV:
4373     case SVt_PVMG:
4374         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4375             mg_get(sstr);
4376             if (SvTYPE(sstr) != stype)
4377                 stype = SvTYPE(sstr);
4378         }
4379         if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4380                     glob_assign_glob(dstr, sstr, dtype);
4381                     return;
4382         }
4383         if (stype == SVt_PVLV)
4384         {
4385             if (isREGEXP(sstr)) goto upgregexp;
4386             SvUPGRADE(dstr, SVt_PVNV);
4387         }
4388         else
4389             SvUPGRADE(dstr, (svtype)stype);
4390     }
4391  end_of_first_switch:
4392
4393     /* dstr may have been upgraded.  */
4394     dtype = SvTYPE(dstr);
4395     sflags = SvFLAGS(sstr);
4396
4397     if (dtype == SVt_PVCV) {
4398         /* Assigning to a subroutine sets the prototype.  */
4399         if (SvOK(sstr)) {
4400             STRLEN len;
4401             const char *const ptr = SvPV_const(sstr, len);
4402
4403             SvGROW(dstr, len + 1);
4404             Copy(ptr, SvPVX(dstr), len + 1, char);
4405             SvCUR_set(dstr, len);
4406             SvPOK_only(dstr);
4407             SvFLAGS(dstr) |= sflags & SVf_UTF8;
4408             CvAUTOLOAD_off(dstr);
4409         } else {
4410             SvOK_off(dstr);
4411         }
4412     }
4413     else if (dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM) {
4414         const char * const type = sv_reftype(dstr,0);
4415         if (PL_op)
4416             /* diag_listed_as: Cannot copy to %s */
4417             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4418         else
4419             Perl_croak(aTHX_ "Cannot copy to %s", type);
4420     } else if (sflags & SVf_ROK) {
4421         if (isGV_with_GP(dstr)
4422             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4423             sstr = SvRV(sstr);
4424             if (sstr == dstr) {
4425                 if (GvIMPORTED(dstr) != GVf_IMPORTED
4426                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4427                 {
4428                     GvIMPORTED_on(dstr);
4429                 }
4430                 GvMULTI_on(dstr);
4431                 return;
4432             }
4433             glob_assign_glob(dstr, sstr, dtype);
4434             return;
4435         }
4436
4437         if (dtype >= SVt_PV) {
4438             if (isGV_with_GP(dstr)) {
4439                 gv_setref(dstr, sstr);
4440                 return;
4441             }
4442             if (SvPVX_const(dstr)) {
4443                 SvPV_free(dstr);
4444                 SvLEN_set(dstr, 0);
4445                 SvCUR_set(dstr, 0);
4446             }
4447         }
4448         (void)SvOK_off(dstr);
4449         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4450         SvFLAGS(dstr) |= sflags & SVf_ROK;
4451         assert(!(sflags & SVp_NOK));
4452         assert(!(sflags & SVp_IOK));
4453         assert(!(sflags & SVf_NOK));
4454         assert(!(sflags & SVf_IOK));
4455     }
4456     else if (isGV_with_GP(dstr)) {
4457         if (!(sflags & SVf_OK)) {
4458             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4459                            "Undefined value assigned to typeglob");
4460         }
4461         else {
4462             GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
4463             if (dstr != (const SV *)gv) {
4464                 const char * const name = GvNAME((const GV *)dstr);
4465                 const STRLEN len = GvNAMELEN(dstr);
4466                 HV *old_stash = NULL;
4467                 bool reset_isa = FALSE;
4468                 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4469                  || (len == 1 && name[0] == ':')) {
4470                     /* Set aside the old stash, so we can reset isa caches
4471                        on its subclasses. */
4472                     if((old_stash = GvHV(dstr))) {
4473                         /* Make sure we do not lose it early. */
4474                         SvREFCNT_inc_simple_void_NN(
4475                          sv_2mortal((SV *)old_stash)
4476                         );
4477                     }
4478                     reset_isa = TRUE;
4479                 }
4480
4481                 if (GvGP(dstr)) {
4482                     SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
4483                     gp_free(MUTABLE_GV(dstr));
4484                 }
4485                 GvGP_set(dstr, gp_ref(GvGP(gv)));
4486
4487                 if (reset_isa) {
4488                     HV * const stash = GvHV(dstr);
4489                     if(
4490                         old_stash ? (HV *)HvENAME_get(old_stash) : stash
4491                     )
4492                         mro_package_moved(
4493                          stash, old_stash,
4494                          (GV *)dstr, 0
4495                         );
4496                 }
4497             }
4498         }
4499     }
4500     else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4501           && (stype == SVt_REGEXP || isREGEXP(sstr))) {
4502         reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4503     }
4504     else if (sflags & SVp_POK) {
4505         const STRLEN cur = SvCUR(sstr);
4506         const STRLEN len = SvLEN(sstr);
4507
4508         /*
4509          * We have three basic ways to copy the string:
4510          *
4511          *  1. Swipe
4512          *  2. Copy-on-write
4513          *  3. Actual copy
4514          * 
4515          * Which we choose is based on various factors.  The following
4516          * things are listed in order of speed, fastest to slowest:
4517          *  - Swipe
4518          *  - Copying a short string
4519          *  - Copy-on-write bookkeeping
4520          *  - malloc
4521          *  - Copying a long string
4522          * 
4523          * We swipe the string (steal the string buffer) if the SV on the
4524          * rhs is about to be freed anyway (TEMP and refcnt==1).  This is a
4525          * big win on long strings.  It should be a win on short strings if
4526          * SvPVX_const(dstr) has to be allocated.  If not, it should not 
4527          * slow things down, as SvPVX_const(sstr) would have been freed
4528          * soon anyway.
4529          * 
4530          * We also steal the buffer from a PADTMP (operator target) if it
4531          * is ‘long enough’.  For short strings, a swipe does not help
4532          * here, as it causes more malloc calls the next time the target
4533          * is used.  Benchmarks show that even if SvPVX_const(dstr) has to
4534          * be allocated it is still not worth swiping PADTMPs for short
4535          * strings, as the savings here are small.
4536          * 
4537          * If swiping is not an option, then we see whether it is
4538          * worth using copy-on-write.  If the lhs already has a buf-
4539          * fer big enough and the string is short, we skip it and fall back
4540          * to method 3, since memcpy is faster for short strings than the
4541          * later bookkeeping overhead that copy-on-write entails.
4542
4543          * If the rhs is not a copy-on-write string yet, then we also
4544          * consider whether the buffer is too large relative to the string
4545          * it holds.  Some operations such as readline allocate a large
4546          * buffer in the expectation of reusing it.  But turning such into
4547          * a COW buffer is counter-productive because it increases memory
4548          * usage by making readline allocate a new large buffer the sec-
4549          * ond time round.  So, if the buffer is too large, again, we use
4550          * method 3 (copy).
4551          * 
4552          * Finally, if there is no buffer on the left, or the buffer is too 
4553          * small, then we use copy-on-write and make both SVs share the
4554          * string buffer.
4555          *
4556          */
4557
4558         /* Whichever path we take through the next code, we want this true,
4559            and doing it now facilitates the COW check.  */
4560         (void)SvPOK_only(dstr);
4561
4562         if (
4563                  (              /* Either ... */
4564                                 /* slated for free anyway (and not COW)? */
4565                     (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
4566                                 /* or a swipable TARG */
4567                  || ((sflags &
4568                            (SVs_PADTMP|SVf_READONLY|SVf_PROTECT|SVf_IsCOW))
4569                        == SVs_PADTMP
4570                                 /* whose buffer is worth stealing */
4571                      && CHECK_COWBUF_THRESHOLD(cur,len)
4572                     )
4573                  ) &&
4574                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4575                  (!(flags & SV_NOSTEAL)) &&
4576                                         /* and we're allowed to steal temps */
4577                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4578                  len)             /* and really is a string */
4579         {       /* Passes the swipe test.  */
4580             if (SvPVX_const(dstr))      /* we know that dtype >= SVt_PV */
4581                 SvPV_free(dstr);
4582             SvPV_set(dstr, SvPVX_mutable(sstr));
4583             SvLEN_set(dstr, SvLEN(sstr));
4584             SvCUR_set(dstr, SvCUR(sstr));
4585
4586             SvTEMP_off(dstr);
4587             (void)SvOK_off(sstr);       /* NOTE: nukes most SvFLAGS on sstr */
4588             SvPV_set(sstr, NULL);
4589             SvLEN_set(sstr, 0);
4590             SvCUR_set(sstr, 0);
4591             SvTEMP_off(sstr);
4592         }
4593         else if (flags & SV_COW_SHARED_HASH_KEYS
4594               &&
4595 #ifdef PERL_OLD_COPY_ON_WRITE
4596                  (  sflags & SVf_IsCOW
4597                  || (   (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4598                      && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4599                      && SvTYPE(sstr) >= SVt_PVIV && len
4600                     )
4601                  )
4602 #elif defined(PERL_NEW_COPY_ON_WRITE)
4603                  (sflags & SVf_IsCOW
4604                    ? (!len ||
4605                        (  (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
4606                           /* If this is a regular (non-hek) COW, only so
4607                              many COW "copies" are possible. */
4608                        && CowREFCNT(sstr) != SV_COW_REFCNT_MAX  ))
4609                    : (  (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4610                      && !(SvFLAGS(dstr) & SVf_BREAK)
4611                      && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len
4612                      && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
4613                     ))
4614 #else
4615                  sflags & SVf_IsCOW
4616               && !(SvFLAGS(dstr) & SVf_BREAK)
4617 #endif
4618             ) {
4619             /* Either it's a shared hash key, or it's suitable for
4620                copy-on-write.  */
4621             if (DEBUG_C_TEST) {
4622                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4623                 sv_dump(sstr);
4624                 sv_dump(dstr);
4625             }
4626 #ifdef PERL_ANY_COW
4627             if (!(sflags & SVf_IsCOW)) {
4628                     SvIsCOW_on(sstr);
4629 # ifdef PERL_OLD_COPY_ON_WRITE
4630                     /* Make the source SV into a loop of 1.
4631                        (about to become 2) */
4632                     SV_COW_NEXT_SV_SET(sstr, sstr);
4633 # else
4634                     CowREFCNT(sstr) = 0;
4635 # endif
4636             }
4637 #endif
4638             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
4639                 SvPV_free(dstr);
4640             }
4641
4642 #ifdef PERL_ANY_COW
4643             if (len) {
4644 # ifdef PERL_OLD_COPY_ON_WRITE
4645                     assert (SvTYPE(dstr) >= SVt_PVIV);
4646                     /* SvIsCOW_normal */
4647                     /* splice us in between source and next-after-source.  */
4648                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4649                     SV_COW_NEXT_SV_SET(sstr, dstr);
4650 # else
4651                     if (sflags & SVf_IsCOW) {
4652                         sv_buf_to_rw(sstr);
4653                     }
4654                     CowREFCNT(sstr)++;
4655 # endif
4656                     SvPV_set(dstr, SvPVX_mutable(sstr));
4657                     sv_buf_to_ro(sstr);
4658             } else
4659 #endif
4660             {
4661                     /* SvIsCOW_shared_hash */
4662                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4663                                           "Copy on write: Sharing hash\n"));
4664
4665                     assert (SvTYPE(dstr) >= SVt_PV);
4666                     SvPV_set(dstr,
4667                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4668             }
4669             SvLEN_set(dstr, len);
4670             SvCUR_set(dstr, cur);
4671             SvIsCOW_on(dstr);
4672         } else {
4673             /* Failed the swipe test, and we cannot do copy-on-write either.
4674                Have to copy the string.  */
4675             SvGROW(dstr, cur + 1);      /* inlined from sv_setpvn */
4676             Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
4677             SvCUR_set(dstr, cur);
4678             *SvEND(dstr) = '\0';
4679         }
4680         if (sflags & SVp_NOK) {
4681             SvNV_set(dstr, SvNVX(sstr));
4682         }
4683         if (sflags & SVp_IOK) {
4684             SvIV_set(dstr, SvIVX(sstr));
4685             /* Must do this otherwise some other overloaded use of 0x80000000
4686                gets confused. I guess SVpbm_VALID */
4687             if (sflags & SVf_IVisUV)
4688                 SvIsUV_on(dstr);
4689         }
4690         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4691         {
4692             const MAGIC * const smg = SvVSTRING_mg(sstr);
4693             if (smg) {
4694                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4695                          smg->mg_ptr, smg->mg_len);
4696                 SvRMAGICAL_on(dstr);
4697             }
4698         }
4699     }
4700     else if (sflags & (SVp_IOK|SVp_NOK)) {
4701         (void)SvOK_off(dstr);
4702         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4703         if (sflags & SVp_IOK) {
4704             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4705             SvIV_set(dstr, SvIVX(sstr));
4706         }
4707         if (sflags & SVp_NOK) {
4708             SvNV_set(dstr, SvNVX(sstr));
4709         }
4710     }
4711     else {
4712         if (isGV_with_GP(sstr)) {
4713             gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4714         }
4715         else
4716             (void)SvOK_off(dstr);
4717     }
4718     if (SvTAINTED(sstr))
4719         SvTAINT(dstr);
4720 }
4721
4722 /*
4723 =for apidoc sv_setsv_mg
4724
4725 Like C<sv_setsv>, but also handles 'set' magic.
4726
4727 =cut
4728 */
4729
4730 void
4731 Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr)
4732 {
4733     PERL_ARGS_ASSERT_SV_SETSV_MG;
4734
4735     sv_setsv(dstr,sstr);
4736     SvSETMAGIC(dstr);
4737 }
4738
4739 #ifdef PERL_ANY_COW
4740 # ifdef PERL_OLD_COPY_ON_WRITE
4741 #  define SVt_COW SVt_PVIV
4742 # else
4743 #  define SVt_COW SVt_PV
4744 # endif
4745 SV *
4746 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4747 {
4748     STRLEN cur = SvCUR(sstr);
4749     STRLEN len = SvLEN(sstr);
4750     char *new_pv;
4751 #if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_NEW_COPY_ON_WRITE)
4752     const bool already = cBOOL(SvIsCOW(sstr));
4753 #endif
4754
4755     PERL_ARGS_ASSERT_SV_SETSV_COW;
4756
4757     if (DEBUG_C_TEST) {
4758         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4759                       (void*)sstr, (void*)dstr);
4760         sv_dump(sstr);
4761         if (dstr)
4762                     sv_dump(dstr);
4763     }
4764
4765     if (dstr) {
4766         if (SvTHINKFIRST(dstr))
4767             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4768         else if (SvPVX_const(dstr))
4769             Safefree(SvPVX_mutable(dstr));
4770     }
4771     else
4772         new_SV(dstr);
4773     SvUPGRADE(dstr, SVt_COW);
4774
4775     assert (SvPOK(sstr));
4776     assert (SvPOKp(sstr));
4777 # ifdef PERL_OLD_COPY_ON_WRITE
4778     assert (!SvIOK(sstr));
4779     assert (!SvIOKp(sstr));
4780     assert (!SvNOK(sstr));
4781     assert (!SvNOKp(sstr));
4782 # endif
4783
4784     if (SvIsCOW(sstr)) {
4785
4786         if (SvLEN(sstr) == 0) {
4787             /* source is a COW shared hash key.  */
4788             DEBUG_C(PerlIO_printf(Perl_debug_log,
4789                                   "Fast copy on write: Sharing hash\n"));
4790             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4791             goto common_exit;
4792         }
4793 # ifdef PERL_OLD_COPY_ON_WRITE
4794         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4795 # else
4796         assert(SvCUR(sstr)+1 < SvLEN(sstr));
4797         assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX);
4798 # endif
4799     } else {
4800         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4801         SvUPGRADE(sstr, SVt_COW);
4802         SvIsCOW_on(sstr);
4803         DEBUG_C(PerlIO_printf(Perl_debug_log,
4804                               "Fast copy on write: Converting sstr to COW\n"));
4805 # ifdef PERL_OLD_COPY_ON_WRITE
4806         SV_COW_NEXT_SV_SET(dstr, sstr);
4807 # else
4808         CowREFCNT(sstr) = 0;    
4809 # endif
4810     }
4811 # ifdef PERL_OLD_COPY_ON_WRITE
4812     SV_COW_NEXT_SV_SET(sstr, dstr);
4813 # else
4814 #  ifdef PERL_DEBUG_READONLY_COW
4815     if (already) sv_buf_to_rw(sstr);
4816 #  endif
4817     CowREFCNT(sstr)++;  
4818 # endif
4819     new_pv = SvPVX_mutable(sstr);
4820     sv_buf_to_ro(sstr);
4821
4822   common_exit:
4823     SvPV_set(dstr, new_pv);
4824     SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
4825     if (SvUTF8(sstr))
4826         SvUTF8_on(dstr);
4827     SvLEN_set(dstr, len);
4828     SvCUR_set(dstr, cur);
4829     if (DEBUG_C_TEST) {
4830         sv_dump(dstr);
4831     }
4832     return dstr;
4833 }
4834 #endif
4835
4836 /*
4837 =for apidoc sv_setpvn
4838
4839 Copies a string (possibly containing embedded C<NUL> characters) into an SV.
4840 The C<len> parameter indicates the number of
4841 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4842 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4843
4844 =cut
4845 */
4846
4847 void
4848 Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4849 {
4850     char *dptr;
4851
4852     PERL_ARGS_ASSERT_SV_SETPVN;
4853
4854     SV_CHECK_THINKFIRST_COW_DROP(sv);
4855     if (!ptr) {
4856         (void)SvOK_off(sv);
4857         return;
4858     }
4859     else {
4860         /* len is STRLEN which is unsigned, need to copy to signed */
4861         const IV iv = len;
4862         if (iv < 0)
4863             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
4864                        IVdf, iv);
4865     }
4866     SvUPGRADE(sv, SVt_PV);
4867
4868     dptr = SvGROW(sv, len + 1);
4869     Move(ptr,dptr,len,char);
4870     dptr[len] = '\0';
4871     SvCUR_set(sv, len);
4872     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4873     SvTAINT(sv);
4874     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4875 }
4876
4877 /*
4878 =for apidoc sv_setpvn_mg
4879
4880 Like C<sv_setpvn>, but also handles 'set' magic.
4881
4882 =cut
4883 */
4884
4885 void
4886 Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4887 {
4888     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4889
4890     sv_setpvn(sv,ptr,len);
4891     SvSETMAGIC(sv);
4892 }
4893
4894 /*
4895 =for apidoc sv_setpv
4896
4897 Copies a string into an SV.  The string must be terminated with a C<NUL>
4898 character.
4899 Does not handle 'set' magic.  See C<sv_setpv_mg>.
4900
4901 =cut
4902 */
4903
4904 void
4905 Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
4906 {
4907     STRLEN len;
4908
4909     PERL_ARGS_ASSERT_SV_SETPV;
4910
4911     SV_CHECK_THINKFIRST_COW_DROP(sv);
4912     if (!ptr) {
4913         (void)SvOK_off(sv);
4914         return;
4915     }
4916     len = strlen(ptr);
4917     SvUPGRADE(sv, SVt_PV);
4918
4919     SvGROW(sv, len + 1);
4920     Move(ptr,SvPVX(sv),len+1,char);
4921     SvCUR_set(sv, len);
4922     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4923     SvTAINT(sv);
4924     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4925 }
4926
4927 /*
4928 =for apidoc sv_setpv_mg
4929
4930 Like C<sv_setpv>, but also handles 'set' magic.
4931
4932 =cut
4933 */
4934
4935 void
4936 Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
4937 {
4938     PERL_ARGS_ASSERT_SV_SETPV_MG;
4939
4940     sv_setpv(sv,ptr);
4941     SvSETMAGIC(sv);
4942 }
4943
4944 void
4945 Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
4946 {
4947     PERL_ARGS_ASSERT_SV_SETHEK;
4948
4949     if (!hek) {
4950         return;
4951     }
4952
4953     if (HEK_LEN(hek) == HEf_SVKEY) {
4954         sv_setsv(sv, *(SV**)HEK_KEY(hek));
4955         return;
4956     } else {
4957         const int flags = HEK_FLAGS(hek);
4958         if (flags & HVhek_WASUTF8) {
4959             STRLEN utf8_len = HEK_LEN(hek);
4960             char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
4961             sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
4962             SvUTF8_on(sv);
4963             return;
4964         } else if (flags & HVhek_UNSHARED) {
4965             sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
4966             if (HEK_UTF8(hek))
4967                 SvUTF8_on(sv);
4968             else SvUTF8_off(sv);
4969             return;
4970         }
4971         {
4972             SV_CHECK_THINKFIRST_COW_DROP(sv);
4973             SvUPGRADE(sv, SVt_PV);
4974             SvPV_free(sv);
4975             SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
4976             SvCUR_set(sv, HEK_LEN(hek));
4977             SvLEN_set(sv, 0);
4978             SvIsCOW_on(sv);
4979             SvPOK_on(sv);
4980             if (HEK_UTF8(hek))
4981                 SvUTF8_on(sv);
4982             else SvUTF8_off(sv);
4983             return;
4984         }
4985     }
4986 }
4987
4988
4989 /*
4990 =for apidoc sv_usepvn_flags
4991
4992 Tells an SV to use C<ptr> to find its string value.  Normally the
4993 string is stored inside the SV, but sv_usepvn allows the SV to use an
4994 outside string.  The C<ptr> should point to memory that was allocated
4995 by L<Newx|perlclib/Memory Management and String Handling>.  It must be
4996 the start of a Newx-ed block of memory, and not a pointer to the
4997 middle of it (beware of L<OOK|perlguts/Offsets> and copy-on-write),
4998 and not be from a non-Newx memory allocator like C<malloc>.  The
4999 string length, C<len>, must be supplied.  By default this function
5000 will C<Renew> (i.e. realloc, move) the memory pointed to by C<ptr>,
5001 so that pointer should not be freed or used by the programmer after
5002 giving it to sv_usepvn, and neither should any pointers from "behind"
5003 that pointer (e.g. ptr + 1) be used.
5004
5005 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC.  If C<flags> &
5006 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be C<NUL>, and the realloc
5007 will be skipped (i.e. the buffer is actually at least 1 byte longer than
5008 C<len>, and already meets the requirements for storing in C<SvPVX>).
5009
5010 =cut
5011 */
5012
5013 void
5014 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
5015 {
5016     STRLEN allocate;
5017
5018     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
5019
5020     SV_CHECK_THINKFIRST_COW_DROP(sv);
5021     SvUPGRADE(sv, SVt_PV);
5022     if (!ptr) {
5023         (void)SvOK_off(sv);
5024         if (flags & SV_SMAGIC)
5025             SvSETMAGIC(sv);
5026         return;
5027     }
5028     if (SvPVX_const(sv))
5029         SvPV_free(sv);
5030
5031 #ifdef DEBUGGING
5032     if (flags & SV_HAS_TRAILING_NUL)
5033         assert(ptr[len] == '\0');
5034 #endif
5035
5036     allocate = (flags & SV_HAS_TRAILING_NUL)
5037         ? len + 1 :
5038 #ifdef Perl_safesysmalloc_size
5039         len + 1;
5040 #else 
5041         PERL_STRLEN_ROUNDUP(len + 1);
5042 #endif
5043     if (flags & SV_HAS_TRAILING_NUL) {
5044         /* It's long enough - do nothing.
5045            Specifically Perl_newCONSTSUB is relying on this.  */
5046     } else {
5047 #ifdef DEBUGGING
5048         /* Force a move to shake out bugs in callers.  */
5049         char *new_ptr = (char*)safemalloc(allocate);
5050         Copy(ptr, new_ptr, len, char);
5051         PoisonFree(ptr,len,char);
5052         Safefree(ptr);
5053         ptr = new_ptr;
5054 #else
5055         ptr = (char*) saferealloc (ptr, allocate);
5056 #endif
5057     }
5058 #ifdef Perl_safesysmalloc_size
5059     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
5060 #else
5061     SvLEN_set(sv, allocate);
5062 #endif
5063     SvCUR_set(sv, len);
5064     SvPV_set(sv, ptr);
5065     if (!(flags & SV_HAS_TRAILING_NUL)) {
5066         ptr[len] = '\0';
5067     }
5068     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5069     SvTAINT(sv);
5070     if (flags & SV_SMAGIC)
5071         SvSETMAGIC(sv);
5072 }
5073
5074 #ifdef PERL_OLD_COPY_ON_WRITE
5075 /* Need to do this *after* making the SV normal, as we need the buffer
5076    pointer to remain valid until after we've copied it.  If we let go too early,
5077    another thread could invalidate it by unsharing last of the same hash key
5078    (which it can do by means other than releasing copy-on-write Svs)
5079    or by changing the other copy-on-write SVs in the loop.  */
5080 STATIC void
5081 S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after)
5082 {
5083     PERL_ARGS_ASSERT_SV_RELEASE_COW;
5084
5085     { /* this SV was SvIsCOW_normal(sv) */
5086          /* we need to find the SV pointing to us.  */
5087         SV *current = SV_COW_NEXT_SV(after);
5088
5089         if (current == sv) {
5090             /* The SV we point to points back to us (there were only two of us
5091                in the loop.)
5092                Hence other SV is no longer copy on write either.  */
5093             SvIsCOW_off(after);
5094             sv_buf_to_rw(after);
5095         } else {
5096             /* We need to follow the pointers around the loop.  */
5097             SV *next;
5098             while ((next = SV_COW_NEXT_SV(current)) != sv) {
5099                 assert (next);
5100                 current = next;
5101                  /* don't loop forever if the structure is bust, and we have
5102                     a pointer into a closed loop.  */
5103                 assert (current != after);
5104                 assert (SvPVX_const(current) == pvx);
5105             }
5106             /* Make the SV before us point to the SV after us.  */
5107             SV_COW_NEXT_SV_SET(current, after);
5108         }
5109     }
5110 }
5111 #endif
5112 /*
5113 =for apidoc sv_force_normal_flags
5114
5115 Undo various types of fakery on an SV, where fakery means
5116 "more than" a string: if the PV is a shared string, make
5117 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5118 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
5119 we do the copy, and is also used locally; if this is a
5120 vstring, drop the vstring magic.  If C<SV_COW_DROP_PV> is set
5121 then a copy-on-write scalar drops its PV buffer (if any) and becomes
5122 SvPOK_off rather than making a copy.  (Used where this
5123 scalar is about to be set to some other value.)  In addition,
5124 the C<flags> parameter gets passed to C<sv_unref_flags()>
5125 when unreffing.  C<sv_force_normal> calls this function
5126 with flags set to 0.
5127
5128 This function is expected to be used to signal to perl that this SV is
5129 about to be written to, and any extra book-keeping needs to be taken care
5130 of.  Hence, it croaks on read-only values.
5131
5132 =cut
5133 */
5134
5135 static void
5136 S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
5137 {
5138     assert(SvIsCOW(sv));
5139     {
5140 #ifdef PERL_ANY_COW
5141         const char * const pvx = SvPVX_const(sv);
5142         const STRLEN len = SvLEN(sv);
5143         const STRLEN cur = SvCUR(sv);
5144 # ifdef PERL_OLD_COPY_ON_WRITE
5145         /* next COW sv in the loop.  If len is 0 then this is a shared-hash
5146            key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
5147            we'll fail an assertion.  */
5148         SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
5149 # endif
5150
5151         if (DEBUG_C_TEST) {
5152                 PerlIO_printf(Perl_debug_log,
5153                               "Copy on write: Force normal %ld\n",
5154                               (long) flags);
5155                 sv_dump(sv);
5156         }
5157         SvIsCOW_off(sv);
5158 # ifdef PERL_NEW_COPY_ON_WRITE
5159         if (len && CowREFCNT(sv) == 0)
5160             /* We own the buffer ourselves. */
5161             sv_buf_to_rw(sv);
5162         else
5163 # endif
5164         {
5165                 
5166             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
5167 # ifdef PERL_NEW_COPY_ON_WRITE
5168             /* Must do this first, since the macro uses SvPVX. */
5169             if (len) {
5170                 sv_buf_to_rw(sv);
5171                 CowREFCNT(sv)--;
5172                 sv_buf_to_ro(sv);
5173             }
5174 # endif
5175             SvPV_set(sv, NULL);
5176             SvCUR_set(sv, 0);
5177             SvLEN_set(sv, 0);
5178             if (flags & SV_COW_DROP_PV) {
5179                 /* OK, so we don't need to copy our buffer.  */
5180                 SvPOK_off(sv);
5181             } else {
5182                 SvGROW(sv, cur + 1);
5183                 Move(pvx,SvPVX(sv),cur,char);
5184                 SvCUR_set(sv, cur);
5185                 *SvEND(sv) = '\0';
5186             }
5187             if (len) {
5188 # ifdef PERL_OLD_COPY_ON_WRITE
5189                 sv_release_COW(sv, pvx, next);
5190 # endif
5191             } else {
5192                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5193             }
5194             if (DEBUG_C_TEST) {
5195                 sv_dump(sv);
5196             }
5197         }
5198 #else
5199             const char * const pvx = SvPVX_const(sv);
5200             const STRLEN len = SvCUR(sv);
5201             SvIsCOW_off(sv);
5202             SvPV_set(sv, NULL);
5203             SvLEN_set(sv, 0);
5204             if (flags & SV_COW_DROP_PV) {
5205                 /* OK, so we don't need to copy our buffer.  */
5206                 SvPOK_off(sv);
5207             } else {
5208                 SvGROW(sv, len + 1);
5209                 Move(pvx,SvPVX(sv),len,char);
5210                 *SvEND(sv) = '\0';
5211             }
5212             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5213 #endif
5214     }
5215 }
5216
5217 void
5218 Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
5219 {
5220     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
5221
5222     if (SvREADONLY(sv))
5223         Perl_croak_no_modify();
5224     else if (SvIsCOW(sv) && LIKELY(SvTYPE(sv) != SVt_PVHV))
5225         S_sv_uncow(aTHX_ sv, flags);
5226     if (SvROK(sv))
5227         sv_unref_flags(sv, flags);
5228     else if (SvFAKE(sv) && isGV_with_GP(sv))
5229         sv_unglob(sv, flags);
5230     else if (SvFAKE(sv) && isREGEXP(sv)) {
5231         /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
5232            to sv_unglob. We only need it here, so inline it.  */
5233         const bool islv = SvTYPE(sv) == SVt_PVLV;
5234         const svtype new_type =
5235           islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
5236         SV *const temp = newSV_type(new_type);
5237         regexp *const temp_p = ReANY((REGEXP *)sv);
5238
5239         if (new_type == SVt_PVMG) {
5240             SvMAGIC_set(temp, SvMAGIC(sv));
5241             SvMAGIC_set(sv, NULL);
5242             SvSTASH_set(temp, SvSTASH(sv));
5243             SvSTASH_set(sv, NULL);
5244         }
5245         if (!islv) SvCUR_set(temp, SvCUR(sv));
5246         /* Remember that SvPVX is in the head, not the body.  But
5247            RX_WRAPPED is in the body. */
5248         assert(ReANY((REGEXP *)sv)->mother_re);
5249         /* Their buffer is already owned by someone else. */
5250         if (flags & SV_COW_DROP_PV) {
5251             /* SvLEN is already 0.  For SVt_REGEXP, we have a brand new
5252                zeroed body.  For SVt_PVLV, it should have been set to 0
5253                before turning into a regexp. */
5254             assert(!SvLEN(islv ? sv : temp));
5255             sv->sv_u.svu_pv = 0;
5256         }
5257         else {
5258             sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
5259             SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
5260             SvPOK_on(sv);
5261         }
5262
5263         /* Now swap the rest of the bodies. */
5264
5265         SvFAKE_off(sv);
5266         if (!islv) {
5267             SvFLAGS(sv) &= ~SVTYPEMASK;
5268             SvFLAGS(sv) |= new_type;
5269             SvANY(sv) = SvANY(temp);
5270         }
5271
5272         SvFLAGS(temp) &= ~(SVTYPEMASK);
5273         SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
5274         SvANY(temp) = temp_p;
5275         temp->sv_u.svu_rx = (regexp *)temp_p;
5276
5277         SvREFCNT_dec_NN(temp);
5278     }
5279     else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
5280 }
5281
5282 /*
5283 =for apidoc sv_chop
5284
5285 Efficient removal of characters from the beginning of the string buffer.
5286 SvPOK(sv), or at least SvPOKp(sv), must be true and the C<ptr> must be a
5287 pointer to somewhere inside the string buffer.  The C<ptr> becomes the first
5288 character of the adjusted string.  Uses the "OOK hack".  On return, only
5289 SvPOK(sv) and SvPOKp(sv) among the OK flags will be true.
5290
5291 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
5292 refer to the same chunk of data.
5293
5294 The unfortunate similarity of this function's name to that of Perl's C<chop>
5295 operator is strictly coincidental.  This function works from the left;
5296 C<chop> works from the right.
5297
5298 =cut
5299 */
5300
5301 void
5302 Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
5303 {
5304     STRLEN delta;
5305     STRLEN old_delta;
5306     U8 *p;
5307 #ifdef DEBUGGING
5308     const U8 *evacp;
5309     STRLEN evacn;
5310 #endif
5311     STRLEN max_delta;
5312
5313     PERL_ARGS_ASSERT_SV_CHOP;
5314
5315     if (!ptr || !SvPOKp(sv))
5316         return;
5317     delta = ptr - SvPVX_const(sv);
5318     if (!delta) {
5319         /* Nothing to do.  */
5320         return;
5321     }
5322     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
5323     if (delta > max_delta)
5324         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
5325                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
5326     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
5327     SV_CHECK_THINKFIRST(sv);
5328     SvPOK_only_UTF8(sv);
5329
5330     if (!SvOOK(sv)) {
5331         if (!SvLEN(sv)) { /* make copy of shared string */
5332             const char *pvx = SvPVX_const(sv);
5333             const STRLEN len = SvCUR(sv);
5334             SvGROW(sv, len + 1);
5335             Move(pvx,SvPVX(sv),len,char);
5336             *SvEND(sv) = '\0';
5337         }
5338         SvOOK_on(sv);
5339         old_delta = 0;
5340     } else {
5341         SvOOK_offset(sv, old_delta);
5342     }
5343     SvLEN_set(sv, SvLEN(sv) - delta);
5344     SvCUR_set(sv, SvCUR(sv) - delta);
5345     SvPV_set(sv, SvPVX(sv) + delta);
5346
5347     p = (U8 *)SvPVX_const(sv);
5348
5349 #ifdef DEBUGGING
5350     /* how many bytes were evacuated?  we will fill them with sentinel
5351        bytes, except for the part holding the new offset of course. */
5352     evacn = delta;
5353     if (old_delta)
5354         evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
5355     assert(evacn);
5356     assert(evacn <= delta + old_delta);
5357     evacp = p - evacn;
5358 #endif
5359
5360     /* This sets 'delta' to the accumulated value of all deltas so far */
5361     delta += old_delta;
5362     assert(delta);
5363
5364     /* If 'delta' fits in a byte, store it just prior to the new beginning of
5365      * the string; otherwise store a 0 byte there and store 'delta' just prior
5366      * to that, using as many bytes as a STRLEN occupies.  Thus it overwrites a
5367      * portion of the chopped part of the string */
5368     if (delta < 0x100) {
5369         *--p = (U8) delta;
5370     } else {
5371         *--p = 0;
5372         p -= sizeof(STRLEN);
5373         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
5374     }
5375
5376 #ifdef DEBUGGING
5377     /* Fill the preceding buffer with sentinals to verify that no-one is
5378        using it.  */
5379     while (p > evacp) {
5380         --p;
5381         *p = (U8)PTR2UV(p);
5382     }
5383 #endif
5384 }
5385
5386 /*
5387 =for apidoc sv_catpvn
5388
5389 Concatenates the string onto the end of the string which is in the SV.  The
5390 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
5391 status set, then the bytes appended should be valid UTF-8.
5392 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
5393
5394 =for apidoc sv_catpvn_flags
5395
5396 Concatenates the string onto the end of the string which is in the SV.  The
5397 C<len> indicates number of bytes to copy.
5398
5399 By default, the string appended is assumed to be valid UTF-8 if the SV has
5400 the UTF-8 status set, and a string of bytes otherwise.  One can force the
5401 appended string to be interpreted as UTF-8 by supplying the C<SV_CATUTF8>
5402 flag, and as bytes by supplying the C<SV_CATBYTES> flag; the SV or the
5403 string appended will be upgraded to UTF-8 if necessary.
5404
5405 If C<flags> has the C<SV_SMAGIC> bit set, will
5406 C<mg_set> on C<dsv> afterwards if appropriate.
5407 C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5408 in terms of this function.
5409
5410 =cut
5411 */
5412
5413 void
5414 Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
5415 {
5416     STRLEN dlen;
5417     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5418
5419     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5420     assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5421
5422     if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
5423       if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
5424          sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5425          dlen = SvCUR(dsv);
5426       }
5427       else SvGROW(dsv, dlen + slen + 1);
5428       if (sstr == dstr)
5429         sstr = SvPVX_const(dsv);
5430       Move(sstr, SvPVX(dsv) + dlen, slen, char);
5431       SvCUR_set(dsv, SvCUR(dsv) + slen);
5432     }
5433     else {
5434         /* We inline bytes_to_utf8, to avoid an extra malloc. */
5435         const char * const send = sstr + slen;
5436         U8 *d;
5437
5438         /* Something this code does not account for, which I think is
5439            impossible; it would require the same pv to be treated as
5440            bytes *and* utf8, which would indicate a bug elsewhere. */
5441         assert(sstr != dstr);
5442
5443         SvGROW(dsv, dlen + slen * 2 + 1);
5444         d = (U8 *)SvPVX(dsv) + dlen;
5445
5446         while (sstr < send) {
5447             append_utf8_from_native_byte(*sstr, &d);
5448             sstr++;
5449         }
5450         SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5451     }
5452     *SvEND(dsv) = '\0';
5453     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
5454     SvTAINT(dsv);
5455     if (flags & SV_SMAGIC)
5456         SvSETMAGIC(dsv);
5457 }
5458
5459 /*
5460 =for apidoc sv_catsv
5461
5462 Concatenates the string from SV C<ssv> onto the end of the string in SV
5463 C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5464 Handles 'get' magic on both SVs, but no 'set' magic.  See C<sv_catsv_mg> and
5465 C<sv_catsv_nomg>.
5466
5467 =for apidoc sv_catsv_flags
5468
5469 Concatenates the string from SV C<ssv> onto the end of the string in SV
5470 C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5471 If C<flags> include C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if
5472 appropriate.  If C<flags> include C<SV_SMAGIC>, C<mg_set> will be called on
5473 the modified SV afterward, if appropriate.  C<sv_catsv>, C<sv_catsv_nomg>,
5474 and C<sv_catsv_mg> are implemented in terms of this function.
5475
5476 =cut */
5477
5478 void
5479 Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
5480 {
5481     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5482
5483     if (ssv) {
5484         STRLEN slen;
5485         const char *spv = SvPV_flags_const(ssv, slen, flags);
5486         if (flags & SV_GMAGIC)
5487                 SvGETMAGIC(dsv);
5488         sv_catpvn_flags(dsv, spv, slen,
5489                             DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
5490         if (flags & SV_SMAGIC)
5491                 SvSETMAGIC(dsv);
5492     }
5493 }
5494
5495 /*
5496 =for apidoc sv_catpv
5497
5498 Concatenates the C<NUL>-terminated string onto the end of the string which is
5499 in the SV.
5500 If the SV has the UTF-8 status set, then the bytes appended should be
5501 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
5502
5503 =cut */
5504
5505 void
5506 Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
5507 {
5508     STRLEN len;
5509     STRLEN tlen;
5510     char *junk;
5511
5512     PERL_ARGS_ASSERT_SV_CATPV;
5513
5514     if (!ptr)
5515         return;
5516     junk = SvPV_force(sv, tlen);
5517     len = strlen(ptr);
5518     SvGROW(sv, tlen + len + 1);
5519     if (ptr == junk)
5520         ptr = SvPVX_const(sv);
5521     Move(ptr,SvPVX(sv)+tlen,len+1,char);
5522     SvCUR_set(sv, SvCUR(sv) + len);
5523     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5524     SvTAINT(sv);
5525 }
5526
5527 /*
5528 =for apidoc sv_catpv_flags
5529
5530 Concatenates the C<NUL>-terminated string onto the end of the string which is
5531 in the SV.
5532 If the SV has the UTF-8 status set, then the bytes appended should
5533 be valid UTF-8.  If C<flags> has the C<SV_SMAGIC> bit set, will C<mg_set>
5534 on the modified SV if appropriate.
5535
5536 =cut
5537 */
5538
5539 void
5540 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
5541 {
5542     PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5543     sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
5544 }
5545
5546 /*
5547 =for apidoc sv_catpv_mg
5548
5549 Like C<sv_catpv>, but also handles 'set' magic.
5550
5551 =cut
5552 */
5553
5554 void
5555 Perl_sv_catpv_mg(pTHX_ SV *const sv, const char *const ptr)
5556 {
5557     PERL_ARGS_ASSERT_SV_CATPV_MG;
5558
5559     sv_catpv(sv,ptr);
5560     SvSETMAGIC(sv);
5561 }
5562
5563 /*
5564 =for apidoc newSV
5565
5566 Creates a new SV.  A non-zero C<len> parameter indicates the number of
5567 bytes of preallocated string space the SV should have.  An extra byte for a
5568 trailing C<NUL> is also reserved.  (SvPOK is not set for the SV even if string
5569 space is allocated.)  The reference count for the new SV is set to 1.
5570
5571 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
5572 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5573 This aid has been superseded by a new build option, PERL_MEM_LOG (see
5574 L<perlhacktips/PERL_MEM_LOG>).  The older API is still there for use in XS
5575 modules supporting older perls.
5576
5577 =cut
5578 */
5579
5580 SV *
5581 Perl_newSV(pTHX_ const STRLEN len)
5582 {
5583     SV *sv;
5584
5585     new_SV(sv);
5586     if (len) {
5587         sv_grow(sv, len + 1);
5588     }
5589     return sv;
5590 }
5591 /*
5592 =for apidoc sv_magicext
5593
5594 Adds magic to an SV, upgrading it if necessary.  Applies the
5595 supplied vtable and returns a pointer to the magic added.
5596
5597 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5598 In particular, you can add magic to SvREADONLY SVs, and add more than
5599 one instance of the same 'how'.
5600
5601 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5602 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5603 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5604 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5605
5606 (This is now used as a subroutine by C<sv_magic>.)
5607
5608 =cut
5609 */
5610 MAGIC * 
5611 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, 
5612                 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5613 {
5614     MAGIC* mg;
5615
5616     PERL_ARGS_ASSERT_SV_MAGICEXT;
5617
5618     if (SvTYPE(sv)==SVt_PVAV) { assert (!AvPAD_NAMELIST(sv)); }
5619
5620     SvUPGRADE(sv, SVt_PVMG);
5621     Newxz(mg, 1, MAGIC);
5622     mg->mg_moremagic = SvMAGIC(sv);
5623     SvMAGIC_set(sv, mg);
5624
5625     /* Sometimes a magic contains a reference loop, where the sv and
5626        object refer to each other.  To prevent a reference loop that
5627        would prevent such objects being freed, we look for such loops
5628        and if we find one we avoid incrementing the object refcount.
5629
5630        Note we cannot do this to avoid self-tie loops as intervening RV must
5631        have its REFCNT incremented to keep it in existence.
5632
5633     */
5634     if (!obj || obj == sv ||
5635         how == PERL_MAGIC_arylen ||
5636         how == PERL_MAGIC_symtab ||
5637         (SvTYPE(obj) == SVt_PVGV &&
5638             (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5639              || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5640              || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5641     {
5642         mg->mg_obj = obj;
5643     }
5644     else {
5645         mg->mg_obj = SvREFCNT_inc_simple(obj);
5646         mg->mg_flags |= MGf_REFCOUNTED;
5647     }
5648
5649     /* Normal self-ties simply pass a null object, and instead of
5650        using mg_obj directly, use the SvTIED_obj macro to produce a
5651        new RV as needed.  For glob "self-ties", we are tieing the PVIO
5652        with an RV obj pointing to the glob containing the PVIO.  In
5653        this case, to avoid a reference loop, we need to weaken the
5654        reference.
5655     */
5656
5657     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5658         obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5659     {
5660       sv_rvweaken(obj);
5661     }
5662
5663     mg->mg_type = how;
5664     mg->mg_len = namlen;
5665     if (name) {
5666         if (namlen > 0)
5667             mg->mg_ptr = savepvn(name, namlen);
5668         else if (namlen == HEf_SVKEY) {
5669             /* Yes, this is casting away const. This is only for the case of
5670                HEf_SVKEY. I think we need to document this aberation of the
5671                constness of the API, rather than making name non-const, as
5672                that change propagating outwards a long way.  */
5673             mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5674         } else
5675             mg->mg_ptr = (char *) name;
5676     }
5677     mg->mg_virtual = (MGVTBL *) vtable;
5678
5679     mg_magical(sv);
5680     return mg;
5681 }
5682
5683 MAGIC *
5684 Perl_sv_magicext_mglob(pTHX_ SV *sv)
5685 {
5686     PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB;
5687     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
5688         /* This sv is only a delegate.  //g magic must be attached to
5689            its target. */
5690         vivify_defelem(sv);
5691         sv = LvTARG(sv);
5692     }
5693 #ifdef PERL_OLD_COPY_ON_WRITE
5694     if (SvIsCOW(sv))
5695         sv_force_normal_flags(sv, 0);
5696 #endif
5697     return sv_magicext(sv, NULL, PERL_MAGIC_regex_global,
5698                        &PL_vtbl_mglob, 0, 0);
5699 }
5700
5701 /*
5702 =for apidoc sv_magic
5703
5704 Adds magic to an SV.  First upgrades C<sv> to type C<SVt_PVMG> if
5705 necessary, then adds a new magic item of type C<how> to the head of the
5706 magic list.
5707
5708 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5709 handling of the C<name> and C<namlen> arguments.
5710
5711 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5712 to add more than one instance of the same 'how'.
5713
5714 =cut
5715 */
5716
5717 void
5718 Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
5719              const char *const name, const I32 namlen)
5720 {
5721     const MGVTBL *vtable;
5722     MAGIC* mg;
5723     unsigned int flags;
5724     unsigned int vtable_index;
5725
5726     PERL_ARGS_ASSERT_SV_MAGIC;
5727
5728     if (how < 0 || (unsigned)how >= C_ARRAY_LENGTH(PL_magic_data)
5729         || ((flags = PL_magic_data[how]),
5730             (vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
5731             > magic_vtable_max))
5732         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5733
5734     /* PERL_MAGIC_ext is reserved for use by extensions not perl internals.
5735        Useful for attaching extension internal data to perl vars.
5736        Note that multiple extensions may clash if magical scalars
5737        etc holding private data from one are passed to another. */
5738
5739     vtable = (vtable_index == magic_vtable_max)
5740         ? NULL : PL_magic_vtables + vtable_index;
5741
5742 #ifdef PERL_OLD_COPY_ON_WRITE
5743     if (SvIsCOW(sv))
5744         sv_force_normal_flags(sv, 0);
5745 #endif
5746     if (SvREADONLY(sv)) {
5747         if (
5748             !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
5749            )
5750         {
5751             Perl_croak_no_modify();
5752         }
5753     }
5754     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5755         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5756             /* sv_magic() refuses to add a magic of the same 'how' as an
5757                existing one
5758              */
5759             if (how == PERL_MAGIC_taint)
5760                 mg->mg_len |= 1;
5761             return;
5762         }
5763     }
5764
5765     /* Force pos to be stored as characters, not bytes. */
5766     if (SvMAGICAL(sv) && DO_UTF8(sv)
5767       && (mg = mg_find(sv, PERL_MAGIC_regex_global))
5768       && mg->mg_len != -1
5769       && mg->mg_flags & MGf_BYTES) {
5770         mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len,
5771                                                SV_CONST_RETURN);
5772         mg->mg_flags &= ~MGf_BYTES;
5773     }
5774
5775     /* Rest of work is done else where */
5776     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5777
5778     switch (how) {
5779     case PERL_MAGIC_taint:
5780         mg->mg_len = 1;
5781         break;
5782     case PERL_MAGIC_ext:
5783     case PERL_MAGIC_dbfile:
5784         SvRMAGICAL_on(sv);
5785         break;
5786     }
5787 }
5788
5789 static int
5790 S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
5791 {
5792     MAGIC* mg;
5793     MAGIC** mgp;
5794
5795     assert(flags <= 1);
5796
5797     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5798         return 0;
5799     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5800     for (mg = *mgp; mg; mg = *mgp) {
5801         const MGVTBL* const virt = mg->mg_virtual;
5802         if (mg->mg_type == type && (!flags || virt == vtbl)) {
5803             *mgp = mg->mg_moremagic;
5804             if (virt && virt->svt_free)
5805                 virt->svt_free(aTHX_ sv, mg);
5806             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5807                 if (mg->mg_len > 0)
5808                     Safefree(mg->mg_ptr);
5809                 else if (mg->mg_len == HEf_SVKEY)
5810                     SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5811                 else if (mg->mg_type == PERL_MAGIC_utf8)
5812                     Safefree(mg->mg_ptr);
5813             }
5814             if (mg->mg_flags & MGf_REFCOUNTED)
5815                 SvREFCNT_dec(mg->mg_obj);
5816             Safefree(mg);
5817         }
5818         else
5819             mgp = &mg->mg_moremagic;
5820     }
5821     if (SvMAGIC(sv)) {
5822         if (SvMAGICAL(sv))      /* if we're under save_magic, wait for restore_magic; */
5823             mg_magical(sv);     /*    else fix the flags now */
5824     }
5825     else {
5826         SvMAGICAL_off(sv);
5827         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5828     }
5829     return 0;
5830 }
5831
5832 /*
5833 =for apidoc sv_unmagic
5834
5835 Removes all magic of type C<type> from an SV.
5836
5837 =cut
5838 */
5839
5840 int
5841 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5842 {
5843     PERL_ARGS_ASSERT_SV_UNMAGIC;
5844     return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
5845 }
5846
5847 /*
5848 =for apidoc sv_unmagicext
5849
5850 Removes all magic of type C<type> with the specified C<vtbl> from an SV.
5851
5852 =cut
5853 */
5854
5855 int
5856 Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
5857 {
5858     PERL_ARGS_ASSERT_SV_UNMAGICEXT;
5859     return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
5860 }
5861
5862 /*
5863 =for apidoc sv_rvweaken
5864
5865 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5866 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5867 push a back-reference to this RV onto the array of backreferences
5868 associated with that magic.  If the RV is magical, set magic will be
5869 called after the RV is cleared.
5870
5871 =cut
5872 */
5873
5874 SV *
5875 Perl_sv_rvweaken(pTHX_ SV *const sv)
5876 {
5877     SV *tsv;
5878
5879     PERL_ARGS_ASSERT_SV_RVWEAKEN;
5880
5881     if (!SvOK(sv))  /* let undefs pass */
5882         return sv;
5883     if (!SvROK(sv))
5884         Perl_croak(aTHX_ "Can't weaken a nonreference");
5885     else if (SvWEAKREF(sv)) {
5886         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5887         return sv;
5888     }
5889     else if (SvREADONLY(sv)) croak_no_modify();
5890     tsv = SvRV(sv);
5891     Perl_sv_add_backref(aTHX_ tsv, sv);
5892     SvWEAKREF_on(sv);
5893     SvREFCNT_dec_NN(tsv);
5894     return sv;
5895 }
5896
5897 /* Give tsv backref magic if it hasn't already got it, then push a
5898  * back-reference to sv onto the array associated with the backref magic.
5899  *
5900  * As an optimisation, if there's only one backref and it's not an AV,
5901  * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5902  * allocate an AV. (Whether the slot holds an AV tells us whether this is
5903  * active.)
5904  */
5905
5906 /* A discussion about the backreferences array and its refcount:
5907  *
5908  * The AV holding the backreferences is pointed to either as the mg_obj of
5909  * PERL_MAGIC_backref, or in the specific case of a HV, from the
5910  * xhv_backreferences field. The array is created with a refcount
5911  * of 2. This means that if during global destruction the array gets
5912  * picked on before its parent to have its refcount decremented by the
5913  * random zapper, it won't actually be freed, meaning it's still there for
5914  * when its parent gets freed.
5915  *
5916  * When the parent SV is freed, the extra ref is killed by
5917  * Perl_sv_kill_backrefs.  The other ref is killed, in the case of magic,
5918  * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5919  *
5920  * When a single backref SV is stored directly, it is not reference
5921  * counted.
5922  */
5923
5924 void
5925 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5926 {
5927     SV **svp;
5928     AV *av = NULL;
5929     MAGIC *mg = NULL;
5930
5931     PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5932
5933     /* find slot to store array or singleton backref */
5934
5935     if (SvTYPE(tsv) == SVt_PVHV) {
5936         svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5937     } else {
5938         if (SvMAGICAL(tsv))
5939             mg = mg_find(tsv, PERL_MAGIC_backref);
5940         if (!mg)
5941             mg = sv_magicext(tsv, NULL, PERL_MAGIC_backref, &PL_vtbl_backref, NULL, 0);
5942         svp = &(mg->mg_obj);
5943     }
5944
5945     /* create or retrieve the array */
5946
5947     if (   (!*svp && SvTYPE(sv) == SVt_PVAV)
5948         || (*svp && SvTYPE(*svp) != SVt_PVAV)
5949     ) {
5950         /* create array */
5951         if (mg)
5952             mg->mg_flags |= MGf_REFCOUNTED;
5953         av = newAV();
5954         AvREAL_off(av);
5955         SvREFCNT_inc_simple_void_NN(av);
5956         /* av now has a refcnt of 2; see discussion above */
5957         av_extend(av, *svp ? 2 : 1);
5958         if (*svp) {
5959             /* move single existing backref to the array */
5960             AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5961         }
5962         *svp = (SV*)av;
5963     }
5964     else {
5965         av = MUTABLE_AV(*svp);
5966         if (!av) {
5967             /* optimisation: store single backref directly in HvAUX or mg_obj */
5968             *svp = sv;
5969             return;
5970         }
5971         assert(SvTYPE(av) == SVt_PVAV);
5972         if (AvFILLp(av) >= AvMAX(av)) {
5973             av_extend(av, AvFILLp(av)+1);
5974         }
5975     }
5976     /* push new backref */
5977     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5978 }
5979
5980 /* delete a back-reference to ourselves from the backref magic associated
5981  * with the SV we point to.
5982  */
5983
5984 void
5985 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5986 {
5987     SV **svp = NULL;
5988
5989     PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5990
5991     if (SvTYPE(tsv) == SVt_PVHV) {
5992         if (SvOOK(tsv))
5993             svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5994     }
5995     else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) {
5996         /* It's possible for the the last (strong) reference to tsv to have
5997            become freed *before* the last thing holding a weak reference.
5998            If both survive longer than the backreferences array, then when
5999            the referent's reference count drops to 0 and it is freed, it's
6000            not able to chase the backreferences, so they aren't NULLed.
6001
6002            For example, a CV holds a weak reference to its stash. If both the
6003            CV and the stash survive longer than the backreferences array,
6004            and the CV gets picked for the SvBREAK() treatment first,
6005            *and* it turns out that the stash is only being kept alive because
6006            of an our variable in the pad of the CV, then midway during CV
6007            destruction the stash gets freed, but CvSTASH() isn't set to NULL.
6008            It ends up pointing to the freed HV. Hence it's chased in here, and
6009            if this block wasn't here, it would hit the !svp panic just below.
6010
6011            I don't believe that "better" destruction ordering is going to help
6012            here - during global destruction there's always going to be the
6013            chance that something goes out of order. We've tried to make it
6014            foolproof before, and it only resulted in evolutionary pressure on
6015            fools. Which made us look foolish for our hubris. :-(
6016         */
6017         return;
6018     }
6019     else {
6020         MAGIC *const mg
6021             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
6022         svp =  mg ? &(mg->mg_obj) : NULL;
6023     }
6024
6025     if (!svp)
6026         Perl_croak(aTHX_ "panic: del_backref, svp=0");
6027     if (!*svp) {
6028         /* It's possible that sv is being freed recursively part way through the
6029            freeing of tsv. If this happens, the backreferences array of tsv has
6030            already been freed, and so svp will be NULL. If this is the case,
6031            we should not panic. Instead, nothing needs doing, so return.  */
6032         if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
6033             return;
6034         Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
6035                    (void*)*svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
6036     }
6037
6038     if (SvTYPE(*svp) == SVt_PVAV) {
6039 #ifdef DEBUGGING
6040         int count = 1;
6041 #endif
6042         AV * const av = (AV*)*svp;
6043         SSize_t fill;
6044         assert(!SvIS_FREED(av));
6045         fill = AvFILLp(av);
6046         assert(fill > -1);
6047         svp = AvARRAY(av);
6048         /* for an SV with N weak references to it, if all those
6049          * weak refs are deleted, then sv_del_backref will be called
6050          * N times and O(N^2) compares will be done within the backref
6051          * array. To ameliorate this potential slowness, we:
6052          * 1) make sure this code is as tight as possible;
6053          * 2) when looking for SV, look for it at both the head and tail of the
6054          *    array first before searching the rest, since some create/destroy
6055          *    patterns will cause the backrefs to be freed in order.
6056          */
6057         if (*svp == sv) {
6058             AvARRAY(av)++;
6059             AvMAX(av)--;
6060         }
6061         else {
6062             SV **p = &svp[fill];
6063             SV *const topsv = *p;
6064             if (topsv != sv) {
6065 #ifdef DEBUGGING
6066                 count = 0;
6067 #endif
6068                 while (--p > svp) {
6069                     if (*p == sv) {
6070                         /* We weren't the last entry.
6071                            An unordered list has this property that you
6072                            can take the last element off the end to fill
6073                            the hole, and it's still an unordered list :-)
6074                         */
6075                         *p = topsv;
6076 #ifdef DEBUGGING
6077                         count++;
6078 #else
6079                         break; /* should only be one */
6080 #endif
6081                     }
6082                 }
6083             }
6084         }
6085         assert(count ==1);
6086         AvFILLp(av) = fill-1;
6087     }
6088     else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) {
6089         /* freed AV; skip */
6090     }
6091     else {
6092         /* optimisation: only a single backref, stored directly */
6093         if (*svp != sv)
6094             Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p",
6095                        (void*)*svp, (void*)sv);
6096         *svp = NULL;
6097     }
6098
6099 }
6100
6101 void
6102 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
6103 {
6104     SV **svp;
6105     SV **last;
6106     bool is_array;
6107
6108     PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
6109
6110     if (!av)
6111         return;
6112
6113     /* after multiple passes through Perl_sv_clean_all() for a thingy
6114      * that has badly leaked, the backref array may have gotten freed,
6115      * since we only protect it against 1 round of cleanup */
6116     if (SvIS_FREED(av)) {
6117         if (PL_in_clean_all) /* All is fair */
6118             return;
6119         Perl_croak(aTHX_
6120                    "panic: magic_killbackrefs (freed backref AV/SV)");
6121     }
6122
6123
6124     is_array = (SvTYPE(av) == SVt_PVAV);
6125     if (is_array) {
6126         assert(!SvIS_FREED(av));
6127         svp = AvARRAY(av);
6128         if (svp)
6129             last = svp + AvFILLp(av);
6130     }
6131     else {
6132         /* optimisation: only a single backref, stored directly */
6133         svp = (SV**)&av;
6134         last = svp;
6135     }
6136
6137     if (svp) {
6138         while (svp <= last) {
6139             if (*svp) {
6140                 SV *const referrer = *svp;
6141                 if (SvWEAKREF(referrer)) {
6142                     /* XXX Should we check that it hasn't changed? */
6143                     assert(SvROK(referrer));
6144                     SvRV_set(referrer, 0);
6145                     SvOK_off(referrer);
6146                     SvWEAKREF_off(referrer);
6147                     SvSETMAGIC(referrer);
6148                 } else if (SvTYPE(referrer) == SVt_PVGV ||
6149                            SvTYPE(referrer) == SVt_PVLV) {
6150                     assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
6151                     /* You lookin' at me?  */
6152                     assert(GvSTASH(referrer));
6153                     assert(GvSTASH(referrer) == (const HV *)sv);
6154                     GvSTASH(referrer) = 0;
6155                 } else if (SvTYPE(referrer) == SVt_PVCV ||
6156                            SvTYPE(referrer) == SVt_PVFM) {
6157                     if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
6158                         /* You lookin' at me?  */
6159                         assert(CvSTASH(referrer));
6160                         assert(CvSTASH(referrer) == (const HV *)sv);
6161                         SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
6162                     }
6163                     else {
6164                         assert(SvTYPE(sv) == SVt_PVGV);
6165                         /* You lookin' at me?  */
6166                         assert(CvGV(referrer));
6167                         assert(CvGV(referrer) == (const GV *)sv);
6168                         anonymise_cv_maybe(MUTABLE_GV(sv),
6169                                                 MUTABLE_CV(referrer));
6170                     }
6171
6172                 } else {
6173                     Perl_croak(aTHX_
6174                                "panic: magic_killbackrefs (flags=%"UVxf")",
6175                                (UV)SvFLAGS(referrer));
6176                 }
6177
6178                 if (is_array)
6179                     *svp = NULL;
6180             }
6181             svp++;
6182         }
6183     }
6184     if (is_array) {
6185         AvFILLp(av) = -1;
6186         SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */
6187     }
6188     return;
6189 }
6190
6191 /*
6192 =for apidoc sv_insert
6193
6194 Inserts a string at the specified offset/length within the SV.  Similar to
6195 the Perl substr() function.  Handles get magic.
6196
6197 =for apidoc sv_insert_flags
6198
6199 Same as C<sv_insert>, but the extra C<flags> are passed to the
6200 C<SvPV_force_flags> that applies to C<bigstr>.
6201
6202 =cut
6203 */
6204
6205 void
6206 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
6207 {
6208     char *big;
6209     char *mid;
6210     char *midend;
6211     char *bigend;
6212     SSize_t i;          /* better be sizeof(STRLEN) or bad things happen */
6213     STRLEN curlen;
6214
6215     PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
6216
6217     if (!bigstr)
6218         Perl_croak(aTHX_ "Can't modify nonexistent substring");
6219     SvPV_force_flags(bigstr, curlen, flags);
6220     (void)SvPOK_only_UTF8(bigstr);
6221     if (offset + len > curlen) {
6222         SvGROW(bigstr, offset+len+1);
6223         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
6224         SvCUR_set(bigstr, offset+len);
6225     }
6226
6227     SvTAINT(bigstr);
6228     i = littlelen - len;
6229     if (i > 0) {                        /* string might grow */
6230         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
6231         mid = big + offset + len;
6232         midend = bigend = big + SvCUR(bigstr);
6233         bigend += i;
6234         *bigend = '\0';
6235         while (midend > mid)            /* shove everything down */
6236             *--bigend = *--midend;
6237         Move(little,big+offset,littlelen,char);
6238         SvCUR_set(bigstr, SvCUR(bigstr) + i);
6239         SvSETMAGIC(bigstr);
6240         return;
6241     }
6242     else if (i == 0) {
6243         Move(little,SvPVX(bigstr)+offset,len,char);
6244         SvSETMAGIC(bigstr);
6245         return;
6246     }
6247
6248     big = SvPVX(bigstr);
6249     mid = big + offset;
6250     midend = mid + len;
6251     bigend = big + SvCUR(bigstr);
6252
6253     if (midend > bigend)
6254         Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p",
6255                    midend, bigend);
6256
6257     if (mid - big > bigend - midend) {  /* faster to shorten from end */
6258         if (littlelen) {
6259             Move(little, mid, littlelen,char);
6260             mid += littlelen;
6261         }
6262         i = bigend - midend;
6263         if (i > 0) {
6264             Move(midend, mid, i,char);
6265             mid += i;
6266         }
6267         *mid = '\0';
6268         SvCUR_set(bigstr, mid - big);
6269     }
6270     else if ((i = mid - big)) { /* faster from front */
6271         midend -= littlelen;
6272         mid = midend;
6273         Move(big, midend - i, i, char);
6274         sv_chop(bigstr,midend-i);
6275         if (littlelen)
6276             Move(little, mid, littlelen,char);
6277     }
6278     else if (littlelen) {
6279         midend -= littlelen;
6280         sv_chop(bigstr,midend);
6281         Move(little,midend,littlelen,char);
6282     }
6283     else {
6284         sv_chop(bigstr,midend);
6285     }
6286     SvSETMAGIC(bigstr);
6287 }
6288
6289 /*
6290 =for apidoc sv_replace
6291
6292 Make the first argument a copy of the second, then delete the original.
6293 The target SV physically takes over ownership of the body of the source SV
6294 and inherits its flags; however, the target keeps any magic it owns,
6295 and any magic in the source is discarded.
6296 Note that this is a rather specialist SV copying operation; most of the
6297 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
6298
6299 =cut
6300 */
6301
6302 void
6303 Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv)
6304 {
6305     const U32 refcnt = SvREFCNT(sv);
6306
6307     PERL_ARGS_ASSERT_SV_REPLACE;
6308
6309     SV_CHECK_THINKFIRST_COW_DROP(sv);
6310     if (SvREFCNT(nsv) != 1) {
6311         Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
6312                    " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
6313     }
6314     if (SvMAGICAL(sv)) {
6315         if (SvMAGICAL(nsv))
6316             mg_free(nsv);
6317         else
6318             sv_upgrade(nsv, SVt_PVMG);
6319         SvMAGIC_set(nsv, SvMAGIC(sv));
6320         SvFLAGS(nsv) |= SvMAGICAL(sv);
6321         SvMAGICAL_off(sv);
6322         SvMAGIC_set(sv, NULL);
6323     }
6324     SvREFCNT(sv) = 0;
6325     sv_clear(sv);
6326     assert(!SvREFCNT(sv));
6327 #ifdef DEBUG_LEAKING_SCALARS
6328     sv->sv_flags  = nsv->sv_flags;
6329     sv->sv_any    = nsv->sv_any;
6330     sv->sv_refcnt = nsv->sv_refcnt;
6331     sv->sv_u      = nsv->sv_u;
6332 #else
6333     StructCopy(nsv,sv,SV);
6334 #endif
6335     if(SvTYPE(sv) == SVt_IV) {
6336         SvANY(sv)
6337             = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
6338     }
6339         
6340
6341 #ifdef PERL_OLD_COPY_ON_WRITE
6342     if (SvIsCOW_normal(nsv)) {
6343         /* We need to follow the pointers around the loop to make the
6344            previous SV point to sv, rather than nsv.  */
6345         SV *next;
6346         SV *current = nsv;
6347         while ((next = SV_COW_NEXT_SV(current)) != nsv) {
6348             assert(next);
6349             current = next;
6350             assert(SvPVX_const(current) == SvPVX_const(nsv));
6351         }
6352         /* Make the SV before us point to the SV after us.  */
6353         if (DEBUG_C_TEST) {
6354             PerlIO_printf(Perl_debug_log, "previous is\n");
6355             sv_dump(current);
6356             PerlIO_printf(Perl_debug_log,
6357                           "move it from 0x%"UVxf" to 0x%"UVxf"\n",
6358                           (UV) SV_COW_NEXT_SV(current), (UV) sv);
6359         }
6360         SV_COW_NEXT_SV_SET(current, sv);
6361     }
6362 #endif
6363     SvREFCNT(sv) = refcnt;
6364     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
6365     SvREFCNT(nsv) = 0;
6366     del_SV(nsv);
6367 }
6368
6369 /* We're about to free a GV which has a CV that refers back to us.
6370  * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
6371  * field) */
6372
6373 STATIC void
6374 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
6375 {
6376     SV *gvname;
6377     GV *anongv;
6378
6379     PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
6380
6381     /* be assertive! */
6382     assert(SvREFCNT(gv) == 0);
6383     assert(isGV(gv) && isGV_with_GP(gv));
6384     assert(GvGP(gv));
6385     assert(!CvANON(cv));
6386     assert(CvGV(cv) == gv);
6387     assert(!CvNAMED(cv));
6388
6389     /* will the CV shortly be freed by gp_free() ? */
6390     if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
6391         SvANY(cv)->xcv_gv_u.xcv_gv = NULL;
6392         return;
6393     }
6394
6395     /* if not, anonymise: */
6396     gvname = (GvSTASH(gv) && HvNAME(GvSTASH(gv)) && HvENAME(GvSTASH(gv)))
6397                     ? newSVhek(HvENAME_HEK(GvSTASH(gv)))
6398                     : newSVpvn_flags( "__ANON__", 8, 0 );
6399     sv_catpvs(gvname, "::__ANON__");
6400     anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
6401     SvREFCNT_dec_NN(gvname);
6402
6403     CvANON_on(cv);
6404     CvCVGV_RC_on(cv);
6405     SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
6406 }
6407
6408
6409 /*
6410 =for apidoc sv_clear
6411
6412 Clear an SV: call any destructors, free up any memory used by the body,
6413 and free the body itself.  The SV's head is I<not> freed, although
6414 its type is set to all 1's so that it won't inadvertently be assumed
6415 to be live during global destruction etc.
6416 This function should only be called when REFCNT is zero.  Most of the time
6417 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
6418 instead.
6419
6420 =cut
6421 */
6422
6423 void
6424 Perl_sv_clear(pTHX_ SV *const orig_sv)
6425 {
6426     dVAR;
6427     HV *stash;
6428     U32 type;
6429     const struct body_details *sv_type_details;
6430     SV* iter_sv = NULL;
6431     SV* next_sv = NULL;
6432     SV *sv = orig_sv;
6433     STRLEN hash_index;
6434
6435     PERL_ARGS_ASSERT_SV_CLEAR;
6436
6437     /* within this loop, sv is the SV currently being freed, and
6438      * iter_sv is the most recent AV or whatever that's being iterated
6439      * over to provide more SVs */
6440
6441     while (sv) {
6442
6443         type = SvTYPE(sv);
6444
6445         assert(SvREFCNT(sv) == 0);
6446         assert(SvTYPE(sv) != (svtype)SVTYPEMASK);
6447
6448         if (type <= SVt_IV) {
6449             /* See the comment in sv.h about the collusion between this
6450              * early return and the overloading of the NULL slots in the
6451              * size table.  */
6452             if (SvROK(sv))
6453                 goto free_rv;
6454             SvFLAGS(sv) &= SVf_BREAK;
6455             SvFLAGS(sv) |= SVTYPEMASK;
6456             goto free_head;
6457         }
6458
6459         assert(!SvOBJECT(sv) || type >= SVt_PVMG); /* objs are always >= MG */
6460
6461         if (type >= SVt_PVMG) {
6462             if (SvOBJECT(sv)) {
6463                 if (!curse(sv, 1)) goto get_next_sv;
6464                 type = SvTYPE(sv); /* destructor may have changed it */
6465             }
6466             /* Free back-references before magic, in case the magic calls
6467              * Perl code that has weak references to sv. */
6468             if (type == SVt_PVHV) {
6469                 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
6470                 if (SvMAGIC(sv))
6471                     mg_free(sv);
6472             }
6473             else if (type == SVt_PVMG && SvPAD_OUR(sv)) {
6474                 SvREFCNT_dec(SvOURSTASH(sv));
6475             }
6476             else if (type == SVt_PVAV && AvPAD_NAMELIST(sv)) {
6477                 assert(!SvMAGICAL(sv));
6478             } else if (SvMAGIC(sv)) {
6479                 /* Free back-references before other types of magic. */
6480                 sv_unmagic(sv, PERL_MAGIC_backref);
6481                 mg_free(sv);
6482             }
6483             SvMAGICAL_off(sv);
6484             if (type == SVt_PVMG && SvPAD_TYPED(sv))
6485                 SvREFCNT_dec(SvSTASH(sv));
6486         }
6487         switch (type) {
6488             /* case SVt_INVLIST: */
6489         case SVt_PVIO:
6490             if (IoIFP(sv) &&
6491                 IoIFP(sv) != PerlIO_stdin() &&
6492                 IoIFP(sv) != PerlIO_stdout() &&
6493                 IoIFP(sv) != PerlIO_stderr() &&
6494                 !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6495             {
6496                 io_close(MUTABLE_IO(sv), FALSE);
6497             }
6498             if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6499                 PerlDir_close(IoDIRP(sv));
6500             IoDIRP(sv) = (DIR*)NULL;
6501             Safefree(IoTOP_NAME(sv));
6502             Safefree(IoFMT_NAME(sv));
6503             Safefree(IoBOTTOM_NAME(sv));
6504             if ((const GV *)sv == PL_statgv)
6505                 PL_statgv = NULL;
6506             goto freescalar;
6507         case SVt_REGEXP:
6508             /* FIXME for plugins */
6509           freeregexp:
6510             pregfree2((REGEXP*) sv);
6511             goto freescalar;
6512         case SVt_PVCV:
6513         case SVt_PVFM:
6514             cv_undef(MUTABLE_CV(sv));
6515             /* If we're in a stash, we don't own a reference to it.
6516              * However it does have a back reference to us, which needs to
6517              * be cleared.  */
6518             if ((stash = CvSTASH(sv)))
6519                 sv_del_backref(MUTABLE_SV(stash), sv);
6520             goto freescalar;
6521         case SVt_PVHV:
6522             if (PL_last_swash_hv == (const HV *)sv) {
6523                 PL_last_swash_hv = NULL;
6524             }
6525             if (HvTOTALKEYS((HV*)sv) > 0) {
6526                 const char *name;
6527                 /* this statement should match the one at the beginning of
6528                  * hv_undef_flags() */
6529                 if (   PL_phase != PERL_PHASE_DESTRUCT
6530                    &