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