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