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