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