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