Merge branch 'release-5.21.7' into blead
[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     if (newlen & 0xff)
1599         newlen++;
1600 #endif
1601
1602 #if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size)
1603 #define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1604 #endif
1605
1606     if (newlen > SvLEN(sv)) {           /* need more room? */
1607         STRLEN minlen = SvCUR(sv);
1608         minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1609         if (newlen < minlen)
1610             newlen = minlen;
1611 #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1612
1613         /* Don't round up on the first allocation, as odds are pretty good that
1614          * the initial request is accurate as to what is really needed */
1615         if (SvLEN(sv)) {
1616             newlen = PERL_STRLEN_ROUNDUP(newlen);
1617         }
1618 #endif
1619         if (SvLEN(sv) && s) {
1620             s = (char*)saferealloc(s, newlen);
1621         }
1622         else {
1623             s = (char*)safemalloc(newlen);
1624             if (SvPVX_const(sv) && SvCUR(sv)) {
1625                 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1626             }
1627         }
1628         SvPV_set(sv, s);
1629 #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1630         /* Do this here, do it once, do it right, and then we will never get
1631            called back into sv_grow() unless there really is some growing
1632            needed.  */
1633         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1634 #else
1635         SvLEN_set(sv, newlen);
1636 #endif
1637     }
1638     return s;
1639 }
1640
1641 /*
1642 =for apidoc sv_setiv
1643
1644 Copies an integer into the given SV, upgrading first if necessary.
1645 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1646
1647 =cut
1648 */
1649
1650 void
1651 Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
1652 {
1653     PERL_ARGS_ASSERT_SV_SETIV;
1654
1655     SV_CHECK_THINKFIRST_COW_DROP(sv);
1656     switch (SvTYPE(sv)) {
1657     case SVt_NULL:
1658     case SVt_NV:
1659         sv_upgrade(sv, SVt_IV);
1660         break;
1661     case SVt_PV:
1662         sv_upgrade(sv, SVt_PVIV);
1663         break;
1664
1665     case SVt_PVGV:
1666         if (!isGV_with_GP(sv))
1667             break;
1668     case SVt_PVAV:
1669     case SVt_PVHV:
1670     case SVt_PVCV:
1671     case SVt_PVFM:
1672     case SVt_PVIO:
1673         /* diag_listed_as: Can't coerce %s to %s in %s */
1674         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1675                    OP_DESC(PL_op));
1676     default: NOOP;
1677     }
1678     (void)SvIOK_only(sv);                       /* validate number */
1679     SvIV_set(sv, i);
1680     SvTAINT(sv);
1681 }
1682
1683 /*
1684 =for apidoc sv_setiv_mg
1685
1686 Like C<sv_setiv>, but also handles 'set' magic.
1687
1688 =cut
1689 */
1690
1691 void
1692 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1693 {
1694     PERL_ARGS_ASSERT_SV_SETIV_MG;
1695
1696     sv_setiv(sv,i);
1697     SvSETMAGIC(sv);
1698 }
1699
1700 /*
1701 =for apidoc sv_setuv
1702
1703 Copies an unsigned integer into the given SV, upgrading first if necessary.
1704 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1705
1706 =cut
1707 */
1708
1709 void
1710 Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1711 {
1712     PERL_ARGS_ASSERT_SV_SETUV;
1713
1714     /* With the if statement to ensure that integers are stored as IVs whenever
1715        possible:
1716        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1717
1718        without
1719        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1720
1721        If you wish to remove the following if statement, so that this routine
1722        (and its callers) always return UVs, please benchmark to see what the
1723        effect is. Modern CPUs may be different. Or may not :-)
1724     */
1725     if (u <= (UV)IV_MAX) {
1726        sv_setiv(sv, (IV)u);
1727        return;
1728     }
1729     sv_setiv(sv, 0);
1730     SvIsUV_on(sv);
1731     SvUV_set(sv, u);
1732 }
1733
1734 /*
1735 =for apidoc sv_setuv_mg
1736
1737 Like C<sv_setuv>, but also handles 'set' magic.
1738
1739 =cut
1740 */
1741
1742 void
1743 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1744 {
1745     PERL_ARGS_ASSERT_SV_SETUV_MG;
1746
1747     sv_setuv(sv,u);
1748     SvSETMAGIC(sv);
1749 }
1750
1751 /*
1752 =for apidoc sv_setnv
1753
1754 Copies a double into the given SV, upgrading first if necessary.
1755 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1756
1757 =cut
1758 */
1759
1760 void
1761 Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1762 {
1763     PERL_ARGS_ASSERT_SV_SETNV;
1764
1765     SV_CHECK_THINKFIRST_COW_DROP(sv);
1766     switch (SvTYPE(sv)) {
1767     case SVt_NULL:
1768     case SVt_IV:
1769         sv_upgrade(sv, SVt_NV);
1770         break;
1771     case SVt_PV:
1772     case SVt_PVIV:
1773         sv_upgrade(sv, SVt_PVNV);
1774         break;
1775
1776     case SVt_PVGV:
1777         if (!isGV_with_GP(sv))
1778             break;
1779     case SVt_PVAV:
1780     case SVt_PVHV:
1781     case SVt_PVCV:
1782     case SVt_PVFM:
1783     case SVt_PVIO:
1784         /* diag_listed_as: Can't coerce %s to %s in %s */
1785         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1786                    OP_DESC(PL_op));
1787     default: NOOP;
1788     }
1789     SvNV_set(sv, num);
1790     (void)SvNOK_only(sv);                       /* validate number */
1791     SvTAINT(sv);
1792 }
1793
1794 /*
1795 =for apidoc sv_setnv_mg
1796
1797 Like C<sv_setnv>, but also handles 'set' magic.
1798
1799 =cut
1800 */
1801
1802 void
1803 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1804 {
1805     PERL_ARGS_ASSERT_SV_SETNV_MG;
1806
1807     sv_setnv(sv,num);
1808     SvSETMAGIC(sv);
1809 }
1810
1811 /* Return a cleaned-up, printable version of sv, for non-numeric, or
1812  * not incrementable warning display.
1813  * Originally part of S_not_a_number().
1814  * The return value may be != tmpbuf.
1815  */
1816
1817 STATIC const char *
1818 S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1819     const char *pv;
1820
1821      PERL_ARGS_ASSERT_SV_DISPLAY;
1822
1823      if (DO_UTF8(sv)) {
1824           SV *dsv = newSVpvs_flags("", SVs_TEMP);
1825           pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
1826      } else {
1827           char *d = tmpbuf;
1828           const char * const limit = tmpbuf + tmpbuf_size - 8;
1829           /* each *s can expand to 4 chars + "...\0",
1830              i.e. need room for 8 chars */
1831         
1832           const char *s = SvPVX_const(sv);
1833           const char * const end = s + SvCUR(sv);
1834           for ( ; s < end && d < limit; s++ ) {
1835                int ch = *s & 0xFF;
1836                if (! isASCII(ch) && !isPRINT_LC(ch)) {
1837                     *d++ = 'M';
1838                     *d++ = '-';
1839
1840                     /* Map to ASCII "equivalent" of Latin1 */
1841                     ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1842                }
1843                if (ch == '\n') {
1844                     *d++ = '\\';
1845                     *d++ = 'n';
1846                }
1847                else if (ch == '\r') {
1848                     *d++ = '\\';
1849                     *d++ = 'r';
1850                }
1851                else if (ch == '\f') {
1852                     *d++ = '\\';
1853                     *d++ = 'f';
1854                }
1855                else if (ch == '\\') {
1856                     *d++ = '\\';
1857                     *d++ = '\\';
1858                }
1859                else if (ch == '\0') {
1860                     *d++ = '\\';
1861                     *d++ = '0';
1862                }
1863                else if (isPRINT_LC(ch))
1864                     *d++ = ch;
1865                else {
1866                     *d++ = '^';
1867                     *d++ = toCTRL(ch);
1868                }
1869           }
1870           if (s < end) {
1871                *d++ = '.';
1872                *d++ = '.';
1873                *d++ = '.';
1874           }
1875           *d = '\0';
1876           pv = tmpbuf;
1877     }
1878
1879     return pv;
1880 }
1881
1882 /* Print an "isn't numeric" warning, using a cleaned-up,
1883  * printable version of the offending string
1884  */
1885
1886 STATIC void
1887 S_not_a_number(pTHX_ SV *const sv)
1888 {
1889      char tmpbuf[64];
1890      const char *pv;
1891
1892      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1893
1894      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1895
1896     if (PL_op)
1897         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1898                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1899                     "Argument \"%s\" isn't numeric in %s", pv,
1900                     OP_DESC(PL_op));
1901     else
1902         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1903                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1904                     "Argument \"%s\" isn't numeric", pv);
1905 }
1906
1907 STATIC void
1908 S_not_incrementable(pTHX_ SV *const sv) {
1909      char tmpbuf[64];
1910      const char *pv;
1911
1912      PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1913
1914      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1915
1916      Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1917                  "Argument \"%s\" treated as 0 in increment (++)", pv);
1918 }
1919
1920 /*
1921 =for apidoc looks_like_number
1922
1923 Test if the content of an SV looks like a number (or is a number).
1924 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1925 non-numeric warning), even if your atof() doesn't grok them.  Get-magic is
1926 ignored.
1927
1928 =cut
1929 */
1930
1931 I32
1932 Perl_looks_like_number(pTHX_ SV *const sv)
1933 {
1934     const char *sbegin;
1935     STRLEN len;
1936
1937     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1938
1939     if (SvPOK(sv) || SvPOKp(sv)) {
1940         sbegin = SvPV_nomg_const(sv, len);
1941     }
1942     else
1943         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1944     return grok_number(sbegin, len, NULL);
1945 }
1946
1947 STATIC bool
1948 S_glob_2number(pTHX_ GV * const gv)
1949 {
1950     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1951
1952     /* We know that all GVs stringify to something that is not-a-number,
1953         so no need to test that.  */
1954     if (ckWARN(WARN_NUMERIC))
1955     {
1956         SV *const buffer = sv_newmortal();
1957         gv_efullname3(buffer, gv, "*");
1958         not_a_number(buffer);
1959     }
1960     /* We just want something true to return, so that S_sv_2iuv_common
1961         can tail call us and return true.  */
1962     return TRUE;
1963 }
1964
1965 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1966    until proven guilty, assume that things are not that bad... */
1967
1968 /*
1969    NV_PRESERVES_UV:
1970
1971    As 64 bit platforms often have an NV that doesn't preserve all bits of
1972    an IV (an assumption perl has been based on to date) it becomes necessary
1973    to remove the assumption that the NV always carries enough precision to
1974    recreate the IV whenever needed, and that the NV is the canonical form.
1975    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1976    precision as a side effect of conversion (which would lead to insanity
1977    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1978    1) to distinguish between IV/UV/NV slots that have a valid conversion cached
1979       where precision was lost, and IV/UV/NV slots that have a valid conversion
1980       which has lost no precision
1981    2) to ensure that if a numeric conversion to one form is requested that
1982       would lose precision, the precise conversion (or differently
1983       imprecise conversion) is also performed and cached, to prevent
1984       requests for different numeric formats on the same SV causing
1985       lossy conversion chains. (lossless conversion chains are perfectly
1986       acceptable (still))
1987
1988
1989    flags are used:
1990    SvIOKp is true if the IV slot contains a valid value
1991    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1992    SvNOKp is true if the NV slot contains a valid value
1993    SvNOK  is true only if the NV value is accurate
1994
1995    so
1996    while converting from PV to NV, check to see if converting that NV to an
1997    IV(or UV) would lose accuracy over a direct conversion from PV to
1998    IV(or UV). If it would, cache both conversions, return NV, but mark
1999    SV as IOK NOKp (ie not NOK).
2000
2001    While converting from PV to IV, check to see if converting that IV to an
2002    NV would lose accuracy over a direct conversion from PV to NV. If it
2003    would, cache both conversions, flag similarly.
2004
2005    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2006    correctly because if IV & NV were set NV *always* overruled.
2007    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2008    changes - now IV and NV together means that the two are interchangeable:
2009    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
2010
2011    The benefit of this is that operations such as pp_add know that if
2012    SvIOK is true for both left and right operands, then integer addition
2013    can be used instead of floating point (for cases where the result won't
2014    overflow). Before, floating point was always used, which could lead to
2015    loss of precision compared with integer addition.
2016
2017    * making IV and NV equal status should make maths accurate on 64 bit
2018      platforms
2019    * may speed up maths somewhat if pp_add and friends start to use
2020      integers when possible instead of fp. (Hopefully the overhead in
2021      looking for SvIOK and checking for overflow will not outweigh the
2022      fp to integer speedup)
2023    * will slow down integer operations (callers of SvIV) on "inaccurate"
2024      values, as the change from SvIOK to SvIOKp will cause a call into
2025      sv_2iv each time rather than a macro access direct to the IV slot
2026    * should speed up number->string conversion on integers as IV is
2027      favoured when IV and NV are equally accurate
2028
2029    ####################################################################
2030    You had better be using SvIOK_notUV if you want an IV for arithmetic:
2031    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2032    On the other hand, SvUOK is true iff UV.
2033    ####################################################################
2034
2035    Your mileage will vary depending your CPU's relative fp to integer
2036    performance ratio.
2037 */
2038
2039 #ifndef NV_PRESERVES_UV
2040 #  define IS_NUMBER_UNDERFLOW_IV 1
2041 #  define IS_NUMBER_UNDERFLOW_UV 2
2042 #  define IS_NUMBER_IV_AND_UV    2
2043 #  define IS_NUMBER_OVERFLOW_IV  4
2044 #  define IS_NUMBER_OVERFLOW_UV  5
2045
2046 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2047
2048 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
2049 STATIC int
2050 S_sv_2iuv_non_preserve(pTHX_ SV *const sv
2051 #  ifdef DEBUGGING
2052                        , I32 numtype
2053 #  endif
2054                        )
2055 {
2056     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
2057     PERL_UNUSED_CONTEXT;
2058
2059     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));
2060     if (SvNVX(sv) < (NV)IV_MIN) {
2061         (void)SvIOKp_on(sv);
2062         (void)SvNOK_on(sv);
2063         SvIV_set(sv, IV_MIN);
2064         return IS_NUMBER_UNDERFLOW_IV;
2065     }
2066     if (SvNVX(sv) > (NV)UV_MAX) {
2067         (void)SvIOKp_on(sv);
2068         (void)SvNOK_on(sv);
2069         SvIsUV_on(sv);
2070         SvUV_set(sv, UV_MAX);
2071         return IS_NUMBER_OVERFLOW_UV;
2072     }
2073     (void)SvIOKp_on(sv);
2074     (void)SvNOK_on(sv);
2075     /* Can't use strtol etc to convert this string.  (See truth table in
2076        sv_2iv  */
2077     if (SvNVX(sv) <= (UV)IV_MAX) {
2078         SvIV_set(sv, I_V(SvNVX(sv)));
2079         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2080             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2081         } else {
2082             /* Integer is imprecise. NOK, IOKp */
2083         }
2084         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2085     }
2086     SvIsUV_on(sv);
2087     SvUV_set(sv, U_V(SvNVX(sv)));
2088     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2089         if (SvUVX(sv) == UV_MAX) {
2090             /* As we know that NVs don't preserve UVs, UV_MAX cannot
2091                possibly be preserved by NV. Hence, it must be overflow.
2092                NOK, IOKp */
2093             return IS_NUMBER_OVERFLOW_UV;
2094         }
2095         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2096     } else {
2097         /* Integer is imprecise. NOK, IOKp */
2098     }
2099     return IS_NUMBER_OVERFLOW_IV;
2100 }
2101 #endif /* !NV_PRESERVES_UV*/
2102
2103 /* If numtype is infnan, set the NV of the sv accordingly.
2104  * If numtype is anything else, try setting the NV using Atof(PV). */
2105 static void
2106 S_sv_setnv(pTHX_ SV* sv, int numtype)
2107 {
2108     bool pok = cBOOL(SvPOK(sv));
2109     bool nok = FALSE;
2110     if ((numtype & IS_NUMBER_INFINITY)) {
2111         SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
2112         nok = TRUE;
2113     }
2114     else if ((numtype & IS_NUMBER_NAN)) {
2115         SvNV_set(sv, NV_NAN);
2116         nok = TRUE;
2117     }
2118     else if (pok) {
2119         SvNV_set(sv, Atof(SvPVX_const(sv)));
2120         /* Purposefully no true nok here, since we don't want to blow
2121          * away the possible IOK/UV of an existing sv. */
2122     }
2123     if (nok) {
2124         SvNOK_only(sv); /* No IV or UV please, this is pure infnan. */
2125         if (pok)
2126             SvPOK_on(sv); /* PV is okay, though. */
2127     }
2128 }
2129
2130 STATIC bool
2131 S_sv_2iuv_common(pTHX_ SV *const sv)
2132 {
2133     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2134
2135     if (SvNOKp(sv)) {
2136         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2137          * without also getting a cached IV/UV from it at the same time
2138          * (ie PV->NV conversion should detect loss of accuracy and cache
2139          * IV or UV at same time to avoid this. */
2140         /* IV-over-UV optimisation - choose to cache IV if possible */
2141
2142         if (SvTYPE(sv) == SVt_NV)
2143             sv_upgrade(sv, SVt_PVNV);
2144
2145         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2146         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2147            certainly cast into the IV range at IV_MAX, whereas the correct
2148            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2149            cases go to UV */
2150 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2151         if (Perl_isnan(SvNVX(sv))) {
2152             SvUV_set(sv, 0);
2153             SvIsUV_on(sv);
2154             return FALSE;
2155         }
2156 #endif
2157         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2158             SvIV_set(sv, I_V(SvNVX(sv)));
2159             if (SvNVX(sv) == (NV) SvIVX(sv)
2160 #ifndef NV_PRESERVES_UV
2161                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2162                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2163                 /* Don't flag it as "accurately an integer" if the number
2164                    came from a (by definition imprecise) NV operation, and
2165                    we're outside the range of NV integer precision */
2166 #endif
2167                 ) {
2168                 if (SvNOK(sv))
2169                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2170                 else {
2171                     /* scalar has trailing garbage, eg "42a" */
2172                 }
2173                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2174                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2175                                       PTR2UV(sv),
2176                                       SvNVX(sv),
2177                                       SvIVX(sv)));
2178
2179             } else {
2180                 /* IV not precise.  No need to convert from PV, as NV
2181                    conversion would already have cached IV if it detected
2182                    that PV->IV would be better than PV->NV->IV
2183                    flags already correct - don't set public IOK.  */
2184                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2185                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2186                                       PTR2UV(sv),
2187                                       SvNVX(sv),
2188                                       SvIVX(sv)));
2189             }
2190             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2191                but the cast (NV)IV_MIN rounds to a the value less (more
2192                negative) than IV_MIN which happens to be equal to SvNVX ??
2193                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2194                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2195                (NV)UVX == NVX are both true, but the values differ. :-(
2196                Hopefully for 2s complement IV_MIN is something like
2197                0x8000000000000000 which will be exact. NWC */
2198         }
2199         else {
2200             SvUV_set(sv, U_V(SvNVX(sv)));
2201             if (
2202                 (SvNVX(sv) == (NV) SvUVX(sv))
2203 #ifndef  NV_PRESERVES_UV
2204                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2205                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2206                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2207                 /* Don't flag it as "accurately an integer" if the number
2208                    came from a (by definition imprecise) NV operation, and
2209                    we're outside the range of NV integer precision */
2210 #endif
2211                 && SvNOK(sv)
2212                 )
2213                 SvIOK_on(sv);
2214             SvIsUV_on(sv);
2215             DEBUG_c(PerlIO_printf(Perl_debug_log,
2216                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2217                                   PTR2UV(sv),
2218                                   SvUVX(sv),
2219                                   SvUVX(sv)));
2220         }
2221     }
2222     else if (SvPOKp(sv)) {
2223         UV value;
2224         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2225         /* We want to avoid a possible problem when we cache an IV/ a UV which
2226            may be later translated to an NV, and the resulting NV is not
2227            the same as the direct translation of the initial string
2228            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2229            be careful to ensure that the value with the .456 is around if the
2230            NV value is requested in the future).
2231         
2232            This means that if we cache such an IV/a UV, we need to cache the
2233            NV as well.  Moreover, we trade speed for space, and do not
2234            cache the NV if we are sure it's not needed.
2235          */
2236
2237         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2238         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2239              == IS_NUMBER_IN_UV) {
2240             /* It's definitely an integer, only upgrade to PVIV */
2241             if (SvTYPE(sv) < SVt_PVIV)
2242                 sv_upgrade(sv, SVt_PVIV);
2243             (void)SvIOK_on(sv);
2244         } else if (SvTYPE(sv) < SVt_PVNV)
2245             sv_upgrade(sv, SVt_PVNV);
2246
2247         if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
2248             S_sv_setnv(aTHX_ sv, numtype);
2249             return FALSE;
2250         }
2251
2252         /* If NVs preserve UVs then we only use the UV value if we know that
2253            we aren't going to call atof() below. If NVs don't preserve UVs
2254            then the value returned may have more precision than atof() will
2255            return, even though value isn't perfectly accurate.  */
2256         if ((numtype & (IS_NUMBER_IN_UV
2257 #ifdef NV_PRESERVES_UV
2258                         | IS_NUMBER_NOT_INT
2259 #endif
2260             )) == IS_NUMBER_IN_UV) {
2261             /* This won't turn off the public IOK flag if it was set above  */
2262             (void)SvIOKp_on(sv);
2263
2264             if (!(numtype & IS_NUMBER_NEG)) {
2265                 /* positive */;
2266                 if (value <= (UV)IV_MAX) {
2267                     SvIV_set(sv, (IV)value);
2268                 } else {
2269                     /* it didn't overflow, and it was positive. */
2270                     SvUV_set(sv, value);
2271                     SvIsUV_on(sv);
2272                 }
2273             } else {
2274                 /* 2s complement assumption  */
2275                 if (value <= (UV)IV_MIN) {
2276                     SvIV_set(sv, -(IV)value);
2277                 } else {
2278                     /* Too negative for an IV.  This is a double upgrade, but
2279                        I'm assuming it will be rare.  */
2280                     if (SvTYPE(sv) < SVt_PVNV)
2281                         sv_upgrade(sv, SVt_PVNV);
2282                     SvNOK_on(sv);
2283                     SvIOK_off(sv);
2284                     SvIOKp_on(sv);
2285                     SvNV_set(sv, -(NV)value);
2286                     SvIV_set(sv, IV_MIN);
2287                 }
2288             }
2289         }
2290         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2291            will be in the previous block to set the IV slot, and the next
2292            block to set the NV slot.  So no else here.  */
2293         
2294         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2295             != IS_NUMBER_IN_UV) {
2296             /* It wasn't an (integer that doesn't overflow the UV). */
2297             S_sv_setnv(aTHX_ sv, numtype);
2298
2299             if (! numtype && ckWARN(WARN_NUMERIC))
2300                 not_a_number(sv);
2301
2302             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" NVgf ")\n",
2303                                   PTR2UV(sv), SvNVX(sv)));
2304
2305 #ifdef NV_PRESERVES_UV
2306             (void)SvIOKp_on(sv);
2307             (void)SvNOK_on(sv);
2308 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2309             if (Perl_isnan(SvNVX(sv))) {
2310                 SvUV_set(sv, 0);
2311                 SvIsUV_on(sv);
2312                 return FALSE;
2313             }
2314 #endif
2315             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2316                 SvIV_set(sv, I_V(SvNVX(sv)));
2317                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2318                     SvIOK_on(sv);
2319                 } else {
2320                     NOOP;  /* Integer is imprecise. NOK, IOKp */
2321                 }
2322                 /* UV will not work better than IV */
2323             } else {
2324                 if (SvNVX(sv) > (NV)UV_MAX) {
2325                     SvIsUV_on(sv);
2326                     /* Integer is inaccurate. NOK, IOKp, is UV */
2327                     SvUV_set(sv, UV_MAX);
2328                 } else {
2329                     SvUV_set(sv, U_V(SvNVX(sv)));
2330                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2331                        NV preservse UV so can do correct comparison.  */
2332                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2333                         SvIOK_on(sv);
2334                     } else {
2335                         NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
2336                     }
2337                 }
2338                 SvIsUV_on(sv);
2339             }
2340 #else /* NV_PRESERVES_UV */
2341             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2342                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2343                 /* The IV/UV slot will have been set from value returned by
2344                    grok_number above.  The NV slot has just been set using
2345                    Atof.  */
2346                 SvNOK_on(sv);
2347                 assert (SvIOKp(sv));
2348             } else {
2349                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2350                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2351                     /* Small enough to preserve all bits. */
2352                     (void)SvIOKp_on(sv);
2353                     SvNOK_on(sv);
2354                     SvIV_set(sv, I_V(SvNVX(sv)));
2355                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2356                         SvIOK_on(sv);
2357                     /* Assumption: first non-preserved integer is < IV_MAX,
2358                        this NV is in the preserved range, therefore: */
2359                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2360                           < (UV)IV_MAX)) {
2361                         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);
2362                     }
2363                 } else {
2364                     /* IN_UV NOT_INT
2365                          0      0       already failed to read UV.
2366                          0      1       already failed to read UV.
2367                          1      0       you won't get here in this case. IV/UV
2368                                         slot set, public IOK, Atof() unneeded.
2369                          1      1       already read UV.
2370                        so there's no point in sv_2iuv_non_preserve() attempting
2371                        to use atol, strtol, strtoul etc.  */
2372 #  ifdef DEBUGGING
2373                     sv_2iuv_non_preserve (sv, numtype);
2374 #  else
2375                     sv_2iuv_non_preserve (sv);
2376 #  endif
2377                 }
2378             }
2379 #endif /* NV_PRESERVES_UV */
2380         /* It might be more code efficient to go through the entire logic above
2381            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2382            gets complex and potentially buggy, so more programmer efficient
2383            to do it this way, by turning off the public flags:  */
2384         if (!numtype)
2385             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2386         }
2387     }
2388     else  {
2389         if (isGV_with_GP(sv))
2390             return glob_2number(MUTABLE_GV(sv));
2391
2392         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2393                 report_uninit(sv);
2394         if (SvTYPE(sv) < SVt_IV)
2395             /* Typically the caller expects that sv_any is not NULL now.  */
2396             sv_upgrade(sv, SVt_IV);
2397         /* Return 0 from the caller.  */
2398         return TRUE;
2399     }
2400     return FALSE;
2401 }
2402
2403 /*
2404 =for apidoc sv_2iv_flags
2405
2406 Return the integer value of an SV, doing any necessary string
2407 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2408 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2409
2410 =cut
2411 */
2412
2413 IV
2414 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2415 {
2416     PERL_ARGS_ASSERT_SV_2IV_FLAGS;
2417
2418     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2419          && SvTYPE(sv) != SVt_PVFM);
2420
2421     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2422         mg_get(sv);
2423
2424     if (SvROK(sv)) {
2425         if (SvAMAGIC(sv)) {
2426             SV * tmpstr;
2427             if (flags & SV_SKIP_OVERLOAD)
2428                 return 0;
2429             tmpstr = AMG_CALLunary(sv, numer_amg);
2430             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2431                 return SvIV(tmpstr);
2432             }
2433         }
2434         return PTR2IV(SvRV(sv));
2435     }
2436
2437     if (SvVALID(sv) || isREGEXP(sv)) {
2438         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2439            the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2440            In practice they are extremely unlikely to actually get anywhere
2441            accessible by user Perl code - the only way that I'm aware of is when
2442            a constant subroutine which is used as the second argument to index.
2443
2444            Regexps have no SvIVX and SvNVX fields.
2445         */
2446         assert(isREGEXP(sv) || SvPOKp(sv));
2447         {
2448             UV value;
2449             const char * const ptr =
2450                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2451             const int numtype
2452                 = grok_number(ptr, SvCUR(sv), &value);
2453
2454             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2455                 == IS_NUMBER_IN_UV) {
2456                 /* It's definitely an integer */
2457                 if (numtype & IS_NUMBER_NEG) {
2458                     if (value < (UV)IV_MIN)
2459                         return -(IV)value;
2460                 } else {
2461                     if (value < (UV)IV_MAX)
2462                         return (IV)value;
2463                 }
2464             }
2465
2466             /* Quite wrong but no good choices. */
2467             if ((numtype & IS_NUMBER_INFINITY)) {
2468                 return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX;
2469             } else if ((numtype & IS_NUMBER_NAN)) {
2470                 return 0; /* So wrong. */
2471             }
2472
2473             if (!numtype) {
2474                 if (ckWARN(WARN_NUMERIC))
2475                     not_a_number(sv);
2476             }
2477             return I_V(Atof(ptr));
2478         }
2479     }
2480
2481     if (SvTHINKFIRST(sv)) {
2482 #ifdef PERL_OLD_COPY_ON_WRITE
2483         if (SvIsCOW(sv)) {
2484             sv_force_normal_flags(sv, 0);
2485         }
2486 #endif
2487         if (SvREADONLY(sv) && !SvOK(sv)) {
2488             if (ckWARN(WARN_UNINITIALIZED))
2489                 report_uninit(sv);
2490             return 0;
2491         }
2492     }
2493
2494     if (!SvIOKp(sv)) {
2495         if (S_sv_2iuv_common(aTHX_ sv))
2496             return 0;
2497     }
2498
2499     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2500         PTR2UV(sv),SvIVX(sv)));
2501     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2502 }
2503
2504 /*
2505 =for apidoc sv_2uv_flags
2506
2507 Return the unsigned integer value of an SV, doing any necessary string
2508 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2509 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2510
2511 =cut
2512 */
2513
2514 UV
2515 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2516 {
2517     PERL_ARGS_ASSERT_SV_2UV_FLAGS;
2518
2519     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2520         mg_get(sv);
2521
2522     if (SvROK(sv)) {
2523         if (SvAMAGIC(sv)) {
2524             SV *tmpstr;
2525             if (flags & SV_SKIP_OVERLOAD)
2526                 return 0;
2527             tmpstr = AMG_CALLunary(sv, numer_amg);
2528             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2529                 return SvUV(tmpstr);
2530             }
2531         }
2532         return PTR2UV(SvRV(sv));
2533     }
2534
2535     if (SvVALID(sv) || isREGEXP(sv)) {
2536         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2537            the same flag bit as SVf_IVisUV, so must not let them cache IVs.  
2538            Regexps have no SvIVX and SvNVX fields. */
2539         assert(isREGEXP(sv) || SvPOKp(sv));
2540         {
2541             UV value;
2542             const char * const ptr =
2543                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2544             const int numtype
2545                 = grok_number(ptr, SvCUR(sv), &value);
2546
2547             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2548                 == IS_NUMBER_IN_UV) {
2549                 /* It's definitely an integer */
2550                 if (!(numtype & IS_NUMBER_NEG))
2551                     return value;
2552             }
2553
2554             /* Quite wrong but no good choices. */
2555             if ((numtype & IS_NUMBER_INFINITY)) {
2556                 return UV_MAX; /* So wrong. */
2557             } else if ((numtype & IS_NUMBER_NAN)) {
2558                 return 0; /* So wrong. */
2559             }
2560
2561             if (!numtype) {
2562                 if (ckWARN(WARN_NUMERIC))
2563                     not_a_number(sv);
2564             }
2565             return U_V(Atof(ptr));
2566         }
2567     }
2568
2569     if (SvTHINKFIRST(sv)) {
2570 #ifdef PERL_OLD_COPY_ON_WRITE
2571         if (SvIsCOW(sv)) {
2572             sv_force_normal_flags(sv, 0);
2573         }
2574 #endif
2575         if (SvREADONLY(sv) && !SvOK(sv)) {
2576             if (ckWARN(WARN_UNINITIALIZED))
2577                 report_uninit(sv);
2578             return 0;
2579         }
2580     }
2581
2582     if (!SvIOKp(sv)) {
2583         if (S_sv_2iuv_common(aTHX_ sv))
2584             return 0;
2585     }
2586
2587     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2588                           PTR2UV(sv),SvUVX(sv)));
2589     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2590 }
2591
2592 /*
2593 =for apidoc sv_2nv_flags
2594
2595 Return the num value of an SV, doing any necessary string or integer
2596 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2597 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2598
2599 =cut
2600 */
2601
2602 NV
2603 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2604 {
2605     PERL_ARGS_ASSERT_SV_2NV_FLAGS;
2606
2607     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2608          && SvTYPE(sv) != SVt_PVFM);
2609     if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
2610         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2611            the same flag bit as SVf_IVisUV, so must not let them cache NVs.
2612            Regexps have no SvIVX and SvNVX fields.  */
2613         const char *ptr;
2614         if (flags & SV_GMAGIC)
2615             mg_get(sv);
2616         if (SvNOKp(sv))
2617             return SvNVX(sv);
2618         if (SvPOKp(sv) && !SvIOKp(sv)) {
2619             ptr = SvPVX_const(sv);
2620           grokpv:
2621             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2622                 !grok_number(ptr, SvCUR(sv), NULL))
2623                 not_a_number(sv);
2624             return Atof(ptr);
2625         }
2626         if (SvIOKp(sv)) {
2627             if (SvIsUV(sv))
2628                 return (NV)SvUVX(sv);
2629             else
2630                 return (NV)SvIVX(sv);
2631         }
2632         if (SvROK(sv)) {
2633             goto return_rok;
2634         }
2635         if (isREGEXP(sv)) {
2636             ptr = RX_WRAPPED((REGEXP *)sv);
2637             goto grokpv;
2638         }
2639         assert(SvTYPE(sv) >= SVt_PVMG);
2640         /* This falls through to the report_uninit near the end of the
2641            function. */
2642     } else if (SvTHINKFIRST(sv)) {
2643         if (SvROK(sv)) {
2644         return_rok:
2645             if (SvAMAGIC(sv)) {
2646                 SV *tmpstr;
2647                 if (flags & SV_SKIP_OVERLOAD)
2648                     return 0;
2649                 tmpstr = AMG_CALLunary(sv, numer_amg);
2650                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2651                     return SvNV(tmpstr);
2652                 }
2653             }
2654             return PTR2NV(SvRV(sv));
2655         }
2656 #ifdef PERL_OLD_COPY_ON_WRITE
2657         if (SvIsCOW(sv)) {
2658             sv_force_normal_flags(sv, 0);
2659         }
2660 #endif
2661         if (SvREADONLY(sv) && !SvOK(sv)) {
2662             if (ckWARN(WARN_UNINITIALIZED))
2663                 report_uninit(sv);
2664             return 0.0;
2665         }
2666     }
2667     if (SvTYPE(sv) < SVt_NV) {
2668         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2669         sv_upgrade(sv, SVt_NV);
2670         DEBUG_c({
2671             STORE_NUMERIC_LOCAL_SET_STANDARD();
2672             PerlIO_printf(Perl_debug_log,
2673                           "0x%"UVxf" num(%" NVgf ")\n",
2674                           PTR2UV(sv), SvNVX(sv));
2675             RESTORE_NUMERIC_LOCAL();
2676         });
2677     }
2678     else if (SvTYPE(sv) < SVt_PVNV)
2679         sv_upgrade(sv, SVt_PVNV);
2680     if (SvNOKp(sv)) {
2681         return SvNVX(sv);
2682     }
2683     if (SvIOKp(sv)) {
2684         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2685 #ifdef NV_PRESERVES_UV
2686         if (SvIOK(sv))
2687             SvNOK_on(sv);
2688         else
2689             SvNOKp_on(sv);
2690 #else
2691         /* Only set the public NV OK flag if this NV preserves the IV  */
2692         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2693         if (SvIOK(sv) &&
2694             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2695                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2696             SvNOK_on(sv);
2697         else
2698             SvNOKp_on(sv);
2699 #endif
2700     }
2701     else if (SvPOKp(sv)) {
2702         UV value;
2703         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2704         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2705             not_a_number(sv);
2706 #ifdef NV_PRESERVES_UV
2707         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2708             == IS_NUMBER_IN_UV) {
2709             /* It's definitely an integer */
2710             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2711         } else {
2712             S_sv_setnv(aTHX_ sv, numtype);
2713         }
2714         if (numtype)
2715             SvNOK_on(sv);
2716         else
2717             SvNOKp_on(sv);
2718 #else
2719         SvNV_set(sv, Atof(SvPVX_const(sv)));
2720         /* Only set the public NV OK flag if this NV preserves the value in
2721            the PV at least as well as an IV/UV would.
2722            Not sure how to do this 100% reliably. */
2723         /* if that shift count is out of range then Configure's test is
2724            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2725            UV_BITS */
2726         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2727             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2728             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2729         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2730             /* Can't use strtol etc to convert this string, so don't try.
2731                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2732             SvNOK_on(sv);
2733         } else {
2734             /* value has been set.  It may not be precise.  */
2735             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2736                 /* 2s complement assumption for (UV)IV_MIN  */
2737                 SvNOK_on(sv); /* Integer is too negative.  */
2738             } else {
2739                 SvNOKp_on(sv);
2740                 SvIOKp_on(sv);
2741
2742                 if (numtype & IS_NUMBER_NEG) {
2743                     SvIV_set(sv, -(IV)value);
2744                 } else if (value <= (UV)IV_MAX) {
2745                     SvIV_set(sv, (IV)value);
2746                 } else {
2747                     SvUV_set(sv, value);
2748                     SvIsUV_on(sv);
2749                 }
2750
2751                 if (numtype & IS_NUMBER_NOT_INT) {
2752                     /* I believe that even if the original PV had decimals,
2753                        they are lost beyond the limit of the FP precision.
2754                        However, neither is canonical, so both only get p
2755                        flags.  NWC, 2000/11/25 */
2756                     /* Both already have p flags, so do nothing */
2757                 } else {
2758                     const NV nv = SvNVX(sv);
2759                     /* XXX should this spot have NAN_COMPARE_BROKEN, too? */
2760                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2761                         if (SvIVX(sv) == I_V(nv)) {
2762                             SvNOK_on(sv);
2763                         } else {
2764                             /* It had no "." so it must be integer.  */
2765                         }
2766                         SvIOK_on(sv);
2767                     } else {
2768                         /* between IV_MAX and NV(UV_MAX).
2769                            Could be slightly > UV_MAX */
2770
2771                         if (numtype & IS_NUMBER_NOT_INT) {
2772                             /* UV and NV both imprecise.  */
2773                         } else {
2774                             const UV nv_as_uv = U_V(nv);
2775
2776                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2777                                 SvNOK_on(sv);
2778                             }
2779                             SvIOK_on(sv);
2780                         }
2781                     }
2782                 }
2783             }
2784         }
2785         /* It might be more code efficient to go through the entire logic above
2786            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2787            gets complex and potentially buggy, so more programmer efficient
2788            to do it this way, by turning off the public flags:  */
2789         if (!numtype)
2790             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2791 #endif /* NV_PRESERVES_UV */
2792     }
2793     else  {
2794         if (isGV_with_GP(sv)) {
2795             glob_2number(MUTABLE_GV(sv));
2796             return 0.0;
2797         }
2798
2799         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2800             report_uninit(sv);
2801         assert (SvTYPE(sv) >= SVt_NV);
2802         /* Typically the caller expects that sv_any is not NULL now.  */
2803         /* XXX Ilya implies that this is a bug in callers that assume this
2804            and ideally should be fixed.  */
2805         return 0.0;
2806     }
2807     DEBUG_c({
2808         STORE_NUMERIC_LOCAL_SET_STANDARD();
2809         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" NVgf ")\n",
2810                       PTR2UV(sv), SvNVX(sv));
2811         RESTORE_NUMERIC_LOCAL();
2812     });
2813     return SvNVX(sv);
2814 }
2815
2816 /*
2817 =for apidoc sv_2num
2818
2819 Return an SV with the numeric value of the source SV, doing any necessary
2820 reference or overload conversion.  The caller is expected to have handled
2821 get-magic already.
2822
2823 =cut
2824 */
2825
2826 SV *
2827 Perl_sv_2num(pTHX_ SV *const sv)
2828 {
2829     PERL_ARGS_ASSERT_SV_2NUM;
2830
2831     if (!SvROK(sv))
2832         return sv;
2833     if (SvAMAGIC(sv)) {
2834         SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2835         TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2836         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2837             return sv_2num(tmpsv);
2838     }
2839     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2840 }
2841
2842 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2843  * UV as a string towards the end of buf, and return pointers to start and
2844  * end of it.
2845  *
2846  * We assume that buf is at least TYPE_CHARS(UV) long.
2847  */
2848
2849 static char *
2850 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2851 {
2852     char *ptr = buf + TYPE_CHARS(UV);
2853     char * const ebuf = ptr;
2854     int sign;
2855
2856     PERL_ARGS_ASSERT_UIV_2BUF;
2857
2858     if (is_uv)
2859         sign = 0;
2860     else if (iv >= 0) {
2861         uv = iv;
2862         sign = 0;
2863     } else {
2864         uv = -iv;
2865         sign = 1;
2866     }
2867     do {
2868         *--ptr = '0' + (char)(uv % 10);
2869     } while (uv /= 10);
2870     if (sign)
2871         *--ptr = '-';
2872     *peob = ebuf;
2873     return ptr;
2874 }
2875
2876 /* Helper for sv_2pv_flags and sv_vcatpvfn_flags.  If the NV is an
2877  * infinity or a not-a-number, writes the appropriate strings to the
2878  * buffer, including a zero byte.  On success returns the written length,
2879  * excluding the zero byte, on failure (not an infinity, not a nan, or the
2880  * maxlen too small) returns zero.
2881  *
2882  * XXX for "Inf", "-Inf", and "NaN", we could have three read-only
2883  * shared string constants we point to, instead of generating a new
2884  * string for each instance. */
2885 STATIC size_t
2886 S_infnan_2pv(NV nv, char* buffer, size_t maxlen) {
2887     assert(maxlen >= 4);
2888     if (maxlen < 4) /* "Inf\0", "NaN\0" */
2889         return 0;
2890     else {
2891         char* s = buffer;
2892         if (Perl_isinf(nv)) {
2893             if (nv < 0) {
2894                 if (maxlen < 5) /* "-Inf\0"  */
2895                     return 0;
2896                 *s++ = '-';
2897             }
2898             *s++ = 'I';
2899             *s++ = 'n';
2900             *s++ = 'f';
2901         } else if (Perl_isnan(nv)) {
2902             *s++ = 'N';
2903             *s++ = 'a';
2904             *s++ = 'N';
2905             /* XXX optionally output the payload mantissa bits as
2906              * "(unsigned)" (to match the nan("...") C99 function,
2907              * or maybe as "(0xhhh...)"  would make more sense...
2908              * provide a format string so that the user can decide?
2909              * NOTE: would affect the maxlen and assert() logic.*/
2910         }
2911
2912         else
2913             return 0;
2914         assert((s == buffer + 3) || (s == buffer + 4));
2915         *s++ = 0;
2916         return s - buffer - 1; /* -1: excluding the zero byte */
2917     }
2918 }
2919
2920 /*
2921 =for apidoc sv_2pv_flags
2922
2923 Returns a pointer to the string value of an SV, and sets *lp to its length.
2924 If flags includes SV_GMAGIC, does an mg_get() first.  Coerces sv to a
2925 string if necessary.  Normally invoked via the C<SvPV_flags> macro.
2926 C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
2927
2928 =cut
2929 */
2930
2931 char *
2932 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
2933 {
2934     char *s;
2935
2936     PERL_ARGS_ASSERT_SV_2PV_FLAGS;
2937
2938     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2939          && SvTYPE(sv) != SVt_PVFM);
2940     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2941         mg_get(sv);
2942     if (SvROK(sv)) {
2943         if (SvAMAGIC(sv)) {
2944             SV *tmpstr;
2945             if (flags & SV_SKIP_OVERLOAD)
2946                 return NULL;
2947             tmpstr = AMG_CALLunary(sv, string_amg);
2948             TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2949             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2950                 /* Unwrap this:  */
2951                 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2952                  */
2953
2954                 char *pv;
2955                 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2956                     if (flags & SV_CONST_RETURN) {
2957                         pv = (char *) SvPVX_const(tmpstr);
2958                     } else {
2959                         pv = (flags & SV_MUTABLE_RETURN)
2960                             ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2961                     }
2962                     if (lp)
2963                         *lp = SvCUR(tmpstr);
2964                 } else {
2965                     pv = sv_2pv_flags(tmpstr, lp, flags);
2966                 }
2967                 if (SvUTF8(tmpstr))
2968                     SvUTF8_on(sv);
2969                 else
2970                     SvUTF8_off(sv);
2971                 return pv;
2972             }
2973         }
2974         {
2975             STRLEN len;
2976             char *retval;
2977             char *buffer;
2978             SV *const referent = SvRV(sv);
2979
2980             if (!referent) {
2981                 len = 7;
2982                 retval = buffer = savepvn("NULLREF", len);
2983             } else if (SvTYPE(referent) == SVt_REGEXP &&
2984                        (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
2985                         amagic_is_enabled(string_amg))) {
2986                 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2987
2988                 assert(re);
2989                         
2990                 /* If the regex is UTF-8 we want the containing scalar to
2991                    have an UTF-8 flag too */
2992                 if (RX_UTF8(re))
2993                     SvUTF8_on(sv);
2994                 else
2995                     SvUTF8_off(sv);     
2996
2997                 if (lp)
2998                     *lp = RX_WRAPLEN(re);
2999  
3000                 return RX_WRAPPED(re);
3001             } else {
3002                 const char *const typestr = sv_reftype(referent, 0);
3003                 const STRLEN typelen = strlen(typestr);
3004                 UV addr = PTR2UV(referent);
3005                 const char *stashname = NULL;
3006                 STRLEN stashnamelen = 0; /* hush, gcc */
3007                 const char *buffer_end;
3008
3009                 if (SvOBJECT(referent)) {
3010                     const HEK *const name = HvNAME_HEK(SvSTASH(referent));
3011
3012                     if (name) {
3013                         stashname = HEK_KEY(name);
3014                         stashnamelen = HEK_LEN(name);
3015
3016                         if (HEK_UTF8(name)) {
3017                             SvUTF8_on(sv);
3018                         } else {
3019                             SvUTF8_off(sv);
3020                         }
3021                     } else {
3022                         stashname = "__ANON__";
3023                         stashnamelen = 8;
3024                     }
3025                     len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
3026                         + 2 * sizeof(UV) + 2 /* )\0 */;
3027                 } else {
3028                     len = typelen + 3 /* (0x */
3029                         + 2 * sizeof(UV) + 2 /* )\0 */;
3030                 }
3031
3032                 Newx(buffer, len, char);
3033                 buffer_end = retval = buffer + len;
3034
3035                 /* Working backwards  */
3036                 *--retval = '\0';
3037                 *--retval = ')';
3038                 do {
3039                     *--retval = PL_hexdigit[addr & 15];
3040                 } while (addr >>= 4);
3041                 *--retval = 'x';
3042                 *--retval = '0';
3043                 *--retval = '(';
3044
3045                 retval -= typelen;
3046                 memcpy(retval, typestr, typelen);
3047
3048                 if (stashname) {
3049                     *--retval = '=';
3050                     retval -= stashnamelen;
3051                     memcpy(retval, stashname, stashnamelen);
3052                 }
3053                 /* retval may not necessarily have reached the start of the
3054                    buffer here.  */
3055                 assert (retval >= buffer);
3056
3057                 len = buffer_end - retval - 1; /* -1 for that \0  */
3058             }
3059             if (lp)
3060                 *lp = len;
3061             SAVEFREEPV(buffer);
3062             return retval;
3063         }
3064     }
3065
3066     if (SvPOKp(sv)) {
3067         if (lp)
3068             *lp = SvCUR(sv);
3069         if (flags & SV_MUTABLE_RETURN)
3070             return SvPVX_mutable(sv);
3071         if (flags & SV_CONST_RETURN)
3072             return (char *)SvPVX_const(sv);
3073         return SvPVX(sv);
3074     }
3075
3076     if (SvIOK(sv)) {
3077         /* I'm assuming that if both IV and NV are equally valid then
3078            converting the IV is going to be more efficient */
3079         const U32 isUIOK = SvIsUV(sv);
3080         char buf[TYPE_CHARS(UV)];
3081         char *ebuf, *ptr;
3082         STRLEN len;
3083
3084         if (SvTYPE(sv) < SVt_PVIV)
3085             sv_upgrade(sv, SVt_PVIV);
3086         ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
3087         len = ebuf - ptr;
3088         /* inlined from sv_setpvn */
3089         s = SvGROW_mutable(sv, len + 1);
3090         Move(ptr, s, len, char);
3091         s += len;
3092         *s = '\0';
3093         SvPOK_on(sv);
3094     }
3095     else if (SvNOK(sv)) {
3096         if (SvTYPE(sv) < SVt_PVNV)
3097             sv_upgrade(sv, SVt_PVNV);
3098         if (SvNVX(sv) == 0.0
3099 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3100             && !Perl_isnan(SvNVX(sv))
3101 #endif
3102         ) {
3103             s = SvGROW_mutable(sv, 2);
3104             *s++ = '0';
3105             *s = '\0';
3106         } else {
3107             STRLEN len;
3108             STRLEN size = 5; /* "-Inf\0" */
3109
3110             s = SvGROW_mutable(sv, size);
3111             len = S_infnan_2pv(SvNVX(sv), s, size);
3112             if (len > 0) {
3113                 s += len;
3114                 SvPOK_on(sv);
3115             }
3116             else {
3117                 /* some Xenix systems wipe out errno here */
3118                 dSAVE_ERRNO;
3119
3120                 size =
3121                     1 + /* sign */
3122                     1 + /* "." */
3123                     NV_DIG +
3124                     1 + /* "e" */
3125                     1 + /* sign */
3126                     5 + /* exponent digits */
3127                     1 + /* \0 */
3128                     2; /* paranoia */
3129
3130                 s = SvGROW_mutable(sv, size);
3131 #ifndef USE_LOCALE_NUMERIC
3132                 SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3133
3134                 SvPOK_on(sv);
3135 #else
3136                 {
3137                     bool local_radix;
3138                     DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
3139
3140                     local_radix =
3141                         PL_numeric_local &&
3142                         PL_numeric_radix_sv &&
3143                         SvUTF8(PL_numeric_radix_sv);
3144                     if (local_radix && SvLEN(PL_numeric_radix_sv) > 1) {
3145                         size += SvLEN(PL_numeric_radix_sv) - 1;
3146                         s = SvGROW_mutable(sv, size);
3147                     }
3148
3149                     SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3150
3151                     /* If the radix character is UTF-8, and actually is in the
3152                      * output, turn on the UTF-8 flag for the scalar */
3153                     if (local_radix &&
3154                         instr(s, SvPVX_const(PL_numeric_radix_sv))) {
3155                         SvUTF8_on(sv);
3156                     }
3157
3158                     RESTORE_LC_NUMERIC();
3159                 }
3160
3161                 /* We don't call SvPOK_on(), because it may come to
3162                  * pass that the locale changes so that the
3163                  * stringification we just did is no longer correct.  We
3164                  * will have to re-stringify every time it is needed */
3165 #endif
3166                 RESTORE_ERRNO;
3167             }
3168             while (*s) s++;
3169         }
3170     }
3171     else if (isGV_with_GP(sv)) {
3172         GV *const gv = MUTABLE_GV(sv);
3173         SV *const buffer = sv_newmortal();
3174
3175         gv_efullname3(buffer, gv, "*");
3176
3177         assert(SvPOK(buffer));
3178         if (SvUTF8(buffer))
3179             SvUTF8_on(sv);
3180         if (lp)
3181             *lp = SvCUR(buffer);
3182         return SvPVX(buffer);
3183     }
3184     else if (isREGEXP(sv)) {
3185         if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
3186         return RX_WRAPPED((REGEXP *)sv);
3187     }
3188     else {
3189         if (lp)
3190             *lp = 0;
3191         if (flags & SV_UNDEF_RETURNS_NULL)
3192             return NULL;
3193         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3194             report_uninit(sv);
3195         /* Typically the caller expects that sv_any is not NULL now.  */
3196         if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
3197             sv_upgrade(sv, SVt_PV);
3198         return (char *)"";
3199     }
3200
3201     {
3202         const STRLEN len = s - SvPVX_const(sv);
3203         if (lp) 
3204             *lp = len;
3205         SvCUR_set(sv, len);
3206     }
3207     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3208                           PTR2UV(sv),SvPVX_const(sv)));
3209     if (flags & SV_CONST_RETURN)
3210         return (char *)SvPVX_const(sv);
3211     if (flags & SV_MUTABLE_RETURN)
3212         return SvPVX_mutable(sv);
3213     return SvPVX(sv);
3214 }
3215
3216 /*
3217 =for apidoc sv_copypv
3218
3219 Copies a stringified representation of the source SV into the
3220 destination SV.  Automatically performs any necessary mg_get and
3221 coercion of numeric values into strings.  Guaranteed to preserve
3222 UTF8 flag even from overloaded objects.  Similar in nature to
3223 sv_2pv[_flags] but operates directly on an SV instead of just the
3224 string.  Mostly uses sv_2pv_flags to do its work, except when that
3225 would lose the UTF-8'ness of the PV.
3226
3227 =for apidoc sv_copypv_nomg
3228
3229 Like sv_copypv, but doesn't invoke get magic first.
3230
3231 =for apidoc sv_copypv_flags
3232
3233 Implementation of sv_copypv and sv_copypv_nomg.  Calls get magic iff flags
3234 include SV_GMAGIC.
3235
3236 =cut
3237 */
3238
3239 void
3240 Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
3241 {
3242     PERL_ARGS_ASSERT_SV_COPYPV;
3243
3244     sv_copypv_flags(dsv, ssv, 0);
3245 }
3246
3247 void
3248 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3249 {
3250     STRLEN len;
3251     const char *s;
3252
3253     PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3254
3255     s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC));
3256     sv_setpvn(dsv,s,len);
3257     if (SvUTF8(ssv))
3258         SvUTF8_on(dsv);
3259     else
3260         SvUTF8_off(dsv);
3261 }
3262
3263 /*
3264 =for apidoc sv_2pvbyte
3265
3266 Return a pointer to the byte-encoded representation of the SV, and set *lp
3267 to its length.  May cause the SV to be downgraded from UTF-8 as a
3268 side-effect.
3269
3270 Usually accessed via the C<SvPVbyte> macro.
3271
3272 =cut
3273 */
3274
3275 char *
3276 Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
3277 {
3278     PERL_ARGS_ASSERT_SV_2PVBYTE;
3279
3280     SvGETMAGIC(sv);
3281     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3282      || isGV_with_GP(sv) || SvROK(sv)) {
3283         SV *sv2 = sv_newmortal();
3284         sv_copypv_nomg(sv2,sv);
3285         sv = sv2;
3286     }
3287     sv_utf8_downgrade(sv,0);
3288     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3289 }
3290
3291 /*
3292 =for apidoc sv_2pvutf8
3293
3294 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3295 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3296
3297 Usually accessed via the C<SvPVutf8> macro.
3298
3299 =cut
3300 */
3301
3302 char *
3303 Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
3304 {
3305     PERL_ARGS_ASSERT_SV_2PVUTF8;
3306
3307     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3308      || isGV_with_GP(sv) || SvROK(sv))
3309         sv = sv_mortalcopy(sv);
3310     else
3311         SvGETMAGIC(sv);
3312     sv_utf8_upgrade_nomg(sv);
3313     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3314 }
3315
3316
3317 /*
3318 =for apidoc sv_2bool
3319
3320 This macro is only used by sv_true() or its macro equivalent, and only if
3321 the latter's argument is neither SvPOK, SvIOK nor SvNOK.
3322 It calls sv_2bool_flags with the SV_GMAGIC flag.
3323
3324 =for apidoc sv_2bool_flags
3325
3326 This function is only used by sv_true() and friends,  and only if
3327 the latter's argument is neither SvPOK, SvIOK nor SvNOK.  If the flags
3328 contain SV_GMAGIC, then it does an mg_get() first.
3329
3330
3331 =cut
3332 */
3333
3334 bool
3335 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
3336 {
3337     PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3338
3339     restart:
3340     if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3341
3342     if (!SvOK(sv))
3343         return 0;
3344     if (SvROK(sv)) {
3345         if (SvAMAGIC(sv)) {
3346             SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3347             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
3348                 bool svb;
3349                 sv = tmpsv;
3350                 if(SvGMAGICAL(sv)) {
3351                     flags = SV_GMAGIC;
3352                     goto restart; /* call sv_2bool */
3353                 }
3354                 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
3355                 else if(!SvOK(sv)) {
3356                     svb = 0;
3357                 }
3358                 else if(SvPOK(sv)) {
3359                     svb = SvPVXtrue(sv);
3360                 }
3361                 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
3362                     svb = (SvIOK(sv) && SvIVX(sv) != 0)
3363                         || (SvNOK(sv) && SvNVX(sv) != 0.0);
3364                 }
3365                 else {
3366                     flags = 0;
3367                     goto restart; /* call sv_2bool_nomg */
3368                 }
3369                 return cBOOL(svb);
3370             }
3371         }
3372         return SvRV(sv) != 0;
3373     }
3374     if (isREGEXP(sv))
3375         return
3376           RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
3377     return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
3378 }
3379
3380 /*
3381 =for apidoc sv_utf8_upgrade
3382
3383 Converts the PV of an SV to its UTF-8-encoded form.
3384 Forces the SV to string form if it is not already.
3385 Will C<mg_get> on C<sv> if appropriate.
3386 Always sets the SvUTF8 flag to avoid future validity checks even
3387 if the whole string is the same in UTF-8 as not.
3388 Returns the number of bytes in the converted string
3389
3390 This is not a general purpose byte encoding to Unicode interface:
3391 use the Encode extension for that.
3392
3393 =for apidoc sv_utf8_upgrade_nomg
3394
3395 Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
3396
3397 =for apidoc sv_utf8_upgrade_flags
3398
3399 Converts the PV of an SV to its UTF-8-encoded form.
3400 Forces the SV to string form if it is not already.
3401 Always sets the SvUTF8 flag to avoid future validity checks even
3402 if all the bytes are invariant in UTF-8.
3403 If C<flags> has C<SV_GMAGIC> bit set,
3404 will C<mg_get> on C<sv> if appropriate, else not.
3405
3406 If C<flags> has SV_FORCE_UTF8_UPGRADE set, this function assumes that the PV
3407 will expand when converted to UTF-8, and skips the extra work of checking for
3408 that.  Typically this flag is used by a routine that has already parsed the
3409 string and found such characters, and passes this information on so that the
3410 work doesn't have to be repeated.
3411
3412 Returns the number of bytes in the converted string.
3413
3414 This is not a general purpose byte encoding to Unicode interface:
3415 use the Encode extension for that.
3416
3417 =for apidoc sv_utf8_upgrade_flags_grow
3418
3419 Like sv_utf8_upgrade_flags, but has an additional parameter C<extra>, which is
3420 the number of unused bytes the string of 'sv' is guaranteed to have free after
3421 it upon return.  This allows the caller to reserve extra space that it intends
3422 to fill, to avoid extra grows.
3423
3424 C<sv_utf8_upgrade>, C<sv_utf8_upgrade_nomg>, and C<sv_utf8_upgrade_flags>
3425 are implemented in terms of this function.
3426
3427 Returns the number of bytes in the converted string (not including the spares).
3428
3429 =cut
3430
3431 (One might think that the calling routine could pass in the position of the
3432 first variant character when it has set SV_FORCE_UTF8_UPGRADE, so it wouldn't
3433 have to be found again.  But that is not the case, because typically when the
3434 caller is likely to use this flag, it won't be calling this routine unless it
3435 finds something that won't fit into a byte.  Otherwise it tries to not upgrade
3436 and just use bytes.  But some things that do fit into a byte are variants in
3437 utf8, and the caller may not have been keeping track of these.)
3438
3439 If the routine itself changes the string, it adds a trailing C<NUL>.  Such a
3440 C<NUL> isn't guaranteed due to having other routines do the work in some input
3441 cases, or if the input is already flagged as being in utf8.
3442
3443 The speed of this could perhaps be improved for many cases if someone wanted to
3444 write a fast function that counts the number of variant characters in a string,
3445 especially if it could return the position of the first one.
3446
3447 */
3448
3449 STRLEN
3450 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3451 {
3452     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3453
3454     if (sv == &PL_sv_undef)
3455         return 0;
3456     if (!SvPOK_nog(sv)) {
3457         STRLEN len = 0;
3458         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3459             (void) sv_2pv_flags(sv,&len, flags);
3460             if (SvUTF8(sv)) {
3461                 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3462                 return len;
3463             }
3464         } else {
3465             (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3466         }
3467     }
3468
3469     if (SvUTF8(sv)) {
3470         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3471         return SvCUR(sv);
3472     }
3473
3474     if (SvIsCOW(sv)) {
3475         S_sv_uncow(aTHX_ sv, 0);
3476     }
3477
3478     if (IN_ENCODING && !(flags & SV_UTF8_NO_ENCODING)) {
3479         sv_recode_to_utf8(sv, _get_encoding());
3480         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3481         return SvCUR(sv);
3482     }
3483
3484     if (SvCUR(sv) == 0) {
3485         if (extra) SvGROW(sv, extra);
3486     } else { /* Assume Latin-1/EBCDIC */
3487         /* This function could be much more efficient if we
3488          * had a FLAG in SVs to signal if there are any variant
3489          * chars in the PV.  Given that there isn't such a flag
3490          * make the loop as fast as possible (although there are certainly ways
3491          * to speed this up, eg. through vectorization) */
3492         U8 * s = (U8 *) SvPVX_const(sv);
3493         U8 * e = (U8 *) SvEND(sv);
3494         U8 *t = s;
3495         STRLEN two_byte_count = 0;
3496         
3497         if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3498
3499         /* See if really will need to convert to utf8.  We mustn't rely on our
3500          * incoming SV being well formed and having a trailing '\0', as certain
3501          * code in pp_formline can send us partially built SVs. */
3502
3503         while (t < e) {
3504             const U8 ch = *t++;
3505             if (NATIVE_BYTE_IS_INVARIANT(ch)) continue;
3506
3507             t--;    /* t already incremented; re-point to first variant */
3508             two_byte_count = 1;
3509             goto must_be_utf8;
3510         }
3511
3512         /* utf8 conversion not needed because all are invariants.  Mark as
3513          * UTF-8 even if no variant - saves scanning loop */
3514         SvUTF8_on(sv);
3515         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3516         return SvCUR(sv);
3517
3518 must_be_utf8:
3519
3520         /* Here, the string should be converted to utf8, either because of an
3521          * input flag (two_byte_count = 0), or because a character that
3522          * requires 2 bytes was found (two_byte_count = 1).  t points either to
3523          * the beginning of the string (if we didn't examine anything), or to
3524          * the first variant.  In either case, everything from s to t - 1 will
3525          * occupy only 1 byte each on output.
3526          *
3527          * There are two main ways to convert.  One is to create a new string
3528          * and go through the input starting from the beginning, appending each
3529          * converted value onto the new string as we go along.  It's probably
3530          * best to allocate enough space in the string for the worst possible
3531          * case rather than possibly running out of space and having to
3532          * reallocate and then copy what we've done so far.  Since everything
3533          * from s to t - 1 is invariant, the destination can be initialized
3534          * with these using a fast memory copy
3535          *
3536          * The other way is to figure out exactly how big the string should be
3537          * by parsing the entire input.  Then you don't have to make it big
3538          * enough to handle the worst possible case, and more importantly, if
3539          * the string you already have is large enough, you don't have to
3540          * allocate a new string, you can copy the last character in the input
3541          * string to the final position(s) that will be occupied by the
3542          * converted string and go backwards, stopping at t, since everything
3543          * before that is invariant.
3544          *
3545          * There are advantages and disadvantages to each method.
3546          *
3547          * In the first method, we can allocate a new string, do the memory
3548          * copy from the s to t - 1, and then proceed through the rest of the
3549          * string byte-by-byte.
3550          *
3551          * In the second method, we proceed through the rest of the input
3552          * string just calculating how big the converted string will be.  Then
3553          * there are two cases:
3554          *  1)  if the string has enough extra space to handle the converted
3555          *      value.  We go backwards through the string, converting until we
3556          *      get to the position we are at now, and then stop.  If this
3557          *      position is far enough along in the string, this method is
3558          *      faster than the other method.  If the memory copy were the same
3559          *      speed as the byte-by-byte loop, that position would be about
3560          *      half-way, as at the half-way mark, parsing to the end and back
3561          *      is one complete string's parse, the same amount as starting
3562          *      over and going all the way through.  Actually, it would be
3563          *      somewhat less than half-way, as it's faster to just count bytes
3564          *      than to also copy, and we don't have the overhead of allocating
3565          *      a new string, changing the scalar to use it, and freeing the
3566          *      existing one.  But if the memory copy is fast, the break-even
3567          *      point is somewhere after half way.  The counting loop could be
3568          *      sped up by vectorization, etc, to move the break-even point
3569          *      further towards the beginning.
3570          *  2)  if the string doesn't have enough space to handle the converted
3571          *      value.  A new string will have to be allocated, and one might
3572          *      as well, given that, start from the beginning doing the first
3573          *      method.  We've spent extra time parsing the string and in
3574          *      exchange all we've gotten is that we know precisely how big to
3575          *      make the new one.  Perl is more optimized for time than space,
3576          *      so this case is a loser.
3577          * So what I've decided to do is not use the 2nd method unless it is
3578          * guaranteed that a new string won't have to be allocated, assuming
3579          * the worst case.  I also decided not to put any more conditions on it
3580          * than this, for now.  It seems likely that, since the worst case is
3581          * twice as big as the unknown portion of the string (plus 1), we won't
3582          * be guaranteed enough space, causing us to go to the first method,
3583          * unless the string is short, or the first variant character is near
3584          * the end of it.  In either of these cases, it seems best to use the
3585          * 2nd method.  The only circumstance I can think of where this would
3586          * be really slower is if the string had once had much more data in it
3587          * than it does now, but there is still a substantial amount in it  */
3588
3589         {
3590             STRLEN invariant_head = t - s;
3591             STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3592             if (SvLEN(sv) < size) {
3593
3594                 /* Here, have decided to allocate a new string */
3595
3596                 U8 *dst;
3597                 U8 *d;
3598
3599                 Newx(dst, size, U8);
3600
3601                 /* If no known invariants at the beginning of the input string,
3602                  * set so starts from there.  Otherwise, can use memory copy to
3603                  * get up to where we are now, and then start from here */
3604
3605                 if (invariant_head == 0) {
3606                     d = dst;
3607                 } else {
3608                     Copy(s, dst, invariant_head, char);
3609                     d = dst + invariant_head;
3610                 }
3611
3612                 while (t < e) {
3613                     append_utf8_from_native_byte(*t, &d);
3614                     t++;
3615                 }
3616                 *d = '\0';
3617                 SvPV_free(sv); /* No longer using pre-existing string */
3618                 SvPV_set(sv, (char*)dst);
3619                 SvCUR_set(sv, d - dst);
3620                 SvLEN_set(sv, size);
3621             } else {
3622
3623                 /* Here, have decided to get the exact size of the string.
3624                  * Currently this happens only when we know that there is
3625                  * guaranteed enough space to fit the converted string, so
3626                  * don't have to worry about growing.  If two_byte_count is 0,
3627                  * then t points to the first byte of the string which hasn't
3628                  * been examined yet.  Otherwise two_byte_count is 1, and t
3629                  * points to the first byte in the string that will expand to
3630                  * two.  Depending on this, start examining at t or 1 after t.
3631                  * */
3632
3633                 U8 *d = t + two_byte_count;
3634
3635
3636                 /* Count up the remaining bytes that expand to two */
3637
3638                 while (d < e) {
3639                     const U8 chr = *d++;
3640                     if (! NATIVE_BYTE_IS_INVARIANT(chr)) two_byte_count++;
3641                 }
3642
3643                 /* The string will expand by just the number of bytes that
3644                  * occupy two positions.  But we are one afterwards because of
3645                  * the increment just above.  This is the place to put the
3646                  * trailing NUL, and to set the length before we decrement */
3647
3648                 d += two_byte_count;
3649                 SvCUR_set(sv, d - s);
3650                 *d-- = '\0';
3651
3652
3653                 /* Having decremented d, it points to the position to put the
3654                  * very last byte of the expanded string.  Go backwards through
3655                  * the string, copying and expanding as we go, stopping when we
3656                  * get to the part that is invariant the rest of the way down */
3657
3658                 e--;
3659                 while (e >= t) {
3660                     if (NATIVE_BYTE_IS_INVARIANT(*e)) {
3661                         *d-- = *e;
3662                     } else {
3663                         *d-- = UTF8_EIGHT_BIT_LO(*e);
3664                         *d-- = UTF8_EIGHT_BIT_HI(*e);
3665                     }
3666                     e--;
3667                 }
3668             }
3669
3670             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3671                 /* Update pos. We do it at the end rather than during
3672                  * the upgrade, to avoid slowing down the common case
3673                  * (upgrade without pos).
3674                  * pos can be stored as either bytes or characters.  Since
3675                  * this was previously a byte string we can just turn off
3676                  * the bytes flag. */
3677                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3678                 if (mg) {
3679                     mg->mg_flags &= ~MGf_BYTES;
3680                 }
3681                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3682                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3683             }
3684         }
3685     }
3686
3687     /* Mark as UTF-8 even if no variant - saves scanning loop */
3688     SvUTF8_on(sv);
3689     return SvCUR(sv);
3690 }
3691
3692 /*
3693 =for apidoc sv_utf8_downgrade
3694
3695 Attempts to convert the PV of an SV from characters to bytes.
3696 If the PV contains a character that cannot fit
3697 in a byte, this conversion will fail;
3698 in this case, either returns false or, if C<fail_ok> is not
3699 true, croaks.
3700
3701 This is not a general purpose Unicode to byte encoding interface:
3702 use the Encode extension for that.
3703
3704 =cut
3705 */
3706
3707 bool
3708 Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
3709 {
3710     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3711
3712     if (SvPOKp(sv) && SvUTF8(sv)) {
3713         if (SvCUR(sv)) {
3714             U8 *s;
3715             STRLEN len;
3716             int mg_flags = SV_GMAGIC;
3717
3718             if (SvIsCOW(sv)) {
3719                 S_sv_uncow(aTHX_ sv, 0);
3720             }
3721             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3722                 /* update pos */
3723                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3724                 if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
3725                         mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
3726                                                 SV_GMAGIC|SV_CONST_RETURN);
3727                         mg_flags = 0; /* sv_pos_b2u does get magic */
3728                 }
3729                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3730                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3731
3732             }
3733             s = (U8 *) SvPV_flags(sv, len, mg_flags);
3734
3735             if (!utf8_to_bytes(s, &len)) {
3736                 if (fail_ok)
3737                     return FALSE;
3738                 else {
3739                     if (PL_op)
3740                         Perl_croak(aTHX_ "Wide character in %s",
3741                                    OP_DESC(PL_op));
3742                     else
3743                         Perl_croak(aTHX_ "Wide character");
3744                 }
3745             }
3746             SvCUR_set(sv, len);
3747         }
3748     }
3749     SvUTF8_off(sv);
3750     return TRUE;
3751 }
3752
3753 /*
3754 =for apidoc sv_utf8_encode
3755
3756 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3757 flag off so that it looks like octets again.
3758
3759 =cut
3760 */
3761
3762 void
3763 Perl_sv_utf8_encode(pTHX_ SV *const sv)
3764 {
3765     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3766
3767     if (SvREADONLY(sv)) {
3768         sv_force_normal_flags(sv, 0);
3769     }
3770     (void) sv_utf8_upgrade(sv);
3771     SvUTF8_off(sv);
3772 }
3773
3774 /*
3775 =for apidoc sv_utf8_decode
3776
3777 If the PV of the SV is an octet sequence in UTF-8
3778 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3779 so that it looks like a character.  If the PV contains only single-byte
3780 characters, the C<SvUTF8> flag stays off.
3781 Scans PV for validity and returns false if the PV is invalid UTF-8.
3782
3783 =cut
3784 */
3785
3786 bool
3787 Perl_sv_utf8_decode(pTHX_ SV *const sv)
3788 {
3789     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3790
3791     if (SvPOKp(sv)) {
3792         const U8 *start, *c;
3793         const U8 *e;
3794
3795         /* The octets may have got themselves encoded - get them back as
3796          * bytes
3797          */
3798         if (!sv_utf8_downgrade(sv, TRUE))
3799             return FALSE;
3800
3801         /* it is actually just a matter of turning the utf8 flag on, but
3802          * we want to make sure everything inside is valid utf8 first.
3803          */
3804         c = start = (const U8 *) SvPVX_const(sv);
3805         if (!is_utf8_string(c, SvCUR(sv)))
3806             return FALSE;
3807         e = (const U8 *) SvEND(sv);
3808         while (c < e) {
3809             const U8 ch = *c++;
3810             if (!UTF8_IS_INVARIANT(ch)) {
3811                 SvUTF8_on(sv);
3812                 break;
3813             }
3814         }
3815         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3816             /* XXX Is this dead code?  XS_utf8_decode calls SvSETMAGIC
3817                    after this, clearing pos.  Does anything on CPAN
3818                    need this? */
3819             /* adjust pos to the start of a UTF8 char sequence */
3820             MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3821             if (mg) {
3822                 I32 pos = mg->mg_len;
3823                 if (pos > 0) {
3824                     for (c = start + pos; c > start; c--) {
3825                         if (UTF8_IS_START(*c))
3826                             break;
3827                     }
3828                     mg->mg_len  = c - start;
3829                 }
3830             }
3831             if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3832                 magic_setutf8(sv,mg); /* clear UTF8 cache */
3833         }
3834     }
3835     return TRUE;
3836 }
3837
3838 /*
3839 =for apidoc sv_setsv
3840
3841 Copies the contents of the source SV C<ssv> into the destination SV
3842 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3843 function if the source SV needs to be reused.  Does not handle 'set' magic on
3844 destination SV.  Calls 'get' magic on source SV.  Loosely speaking, it
3845 performs a copy-by-value, obliterating any previous content of the
3846 destination.
3847
3848 You probably want to use one of the assortment of wrappers, such as
3849 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3850 C<SvSetMagicSV_nosteal>.
3851
3852 =for apidoc sv_setsv_flags
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.
3857 Loosely speaking, it performs a copy-by-value, obliterating any previous
3858 content of the destination.
3859 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3860 C<ssv> if appropriate, else not.  If the C<flags>
3861 parameter has the C<SV_NOSTEAL> bit set then the
3862 buffers of temps will not be stolen.  <sv_setsv>
3863 and C<sv_setsv_nomg> are implemented in terms of this function.
3864
3865 You probably want to use one of the assortment of wrappers, such as
3866 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3867 C<SvSetMagicSV_nosteal>.
3868
3869 This is the primary function for copying scalars, and most other
3870 copy-ish functions and macros use this underneath.
3871
3872 =cut
3873 */
3874
3875 static void
3876 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3877 {
3878     I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3879     HV *old_stash = NULL;
3880
3881     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3882
3883     if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3884         const char * const name = GvNAME(sstr);
3885         const STRLEN len = GvNAMELEN(sstr);
3886         {
3887             if (dtype >= SVt_PV) {
3888                 SvPV_free(dstr);
3889                 SvPV_set(dstr, 0);
3890                 SvLEN_set(dstr, 0);
3891                 SvCUR_set(dstr, 0);
3892             }
3893             SvUPGRADE(dstr, SVt_PVGV);
3894             (void)SvOK_off(dstr);
3895             isGV_with_GP_on(dstr);
3896         }
3897         GvSTASH(dstr) = GvSTASH(sstr);
3898         if (GvSTASH(dstr))
3899             Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3900         gv_name_set(MUTABLE_GV(dstr), name, len,
3901                         GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
3902         SvFAKE_on(dstr);        /* can coerce to non-glob */
3903     }
3904
3905     if(GvGP(MUTABLE_GV(sstr))) {
3906         /* If source has method cache entry, clear it */
3907         if(GvCVGEN(sstr)) {
3908             SvREFCNT_dec(GvCV(sstr));
3909             GvCV_set(sstr, NULL);
3910             GvCVGEN(sstr) = 0;
3911         }
3912         /* If source has a real method, then a method is
3913            going to change */
3914         else if(
3915          GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3916         ) {
3917             mro_changes = 1;
3918         }
3919     }
3920
3921     /* If dest already had a real method, that's a change as well */
3922     if(
3923         !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3924      && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3925     ) {
3926         mro_changes = 1;
3927     }
3928
3929     /* We don't need to check the name of the destination if it was not a
3930        glob to begin with. */
3931     if(dtype == SVt_PVGV) {
3932         const char * const name = GvNAME((const GV *)dstr);
3933         if(
3934             strEQ(name,"ISA")
3935          /* The stash may have been detached from the symbol table, so
3936             check its name. */
3937          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3938         )
3939             mro_changes = 2;
3940         else {
3941             const STRLEN len = GvNAMELEN(dstr);
3942             if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3943              || (len == 1 && name[0] == ':')) {
3944                 mro_changes = 3;
3945
3946                 /* Set aside the old stash, so we can reset isa caches on
3947                    its subclasses. */
3948                 if((old_stash = GvHV(dstr)))
3949                     /* Make sure we do not lose it early. */
3950                     SvREFCNT_inc_simple_void_NN(
3951                      sv_2mortal((SV *)old_stash)
3952                     );
3953             }
3954         }
3955
3956         SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
3957     }
3958
3959     gp_free(MUTABLE_GV(dstr));
3960     GvINTRO_off(dstr);          /* one-shot flag */
3961     GvGP_set(dstr, gp_ref(GvGP(sstr)));
3962     if (SvTAINTED(sstr))
3963         SvTAINT(dstr);
3964     if (GvIMPORTED(dstr) != GVf_IMPORTED
3965         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3966         {
3967             GvIMPORTED_on(dstr);
3968         }
3969     GvMULTI_on(dstr);
3970     if(mro_changes == 2) {
3971       if (GvAV((const GV *)sstr)) {
3972         MAGIC *mg;
3973         SV * const sref = (SV *)GvAV((const GV *)dstr);
3974         if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3975             if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3976                 AV * const ary = newAV();
3977                 av_push(ary, mg->mg_obj); /* takes the refcount */
3978                 mg->mg_obj = (SV *)ary;
3979             }
3980             av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3981         }
3982         else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3983       }
3984       mro_isa_changed_in(GvSTASH(dstr));
3985     }
3986     else if(mro_changes == 3) {
3987         HV * const stash = GvHV(dstr);
3988         if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3989             mro_package_moved(
3990                 stash, old_stash,
3991                 (GV *)dstr, 0
3992             );
3993     }
3994     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3995     if (GvIO(dstr) && dtype == SVt_PVGV) {
3996         DEBUG_o(Perl_deb(aTHX_
3997                         "glob_assign_glob clearing PL_stashcache\n"));
3998         /* It's a cache. It will rebuild itself quite happily.
3999            It's a lot of effort to work out exactly which key (or keys)
4000            might be invalidated by the creation of the this file handle.
4001          */
4002         hv_clear(PL_stashcache);
4003     }
4004     return;
4005 }
4006
4007 void
4008 Perl_gv_setref(pTHX_ SV *const dstr, SV *const sstr)
4009 {
4010     SV * const sref = SvRV(sstr);
4011     SV *dref;
4012     const int intro = GvINTRO(dstr);
4013     SV **location;
4014     U8 import_flag = 0;
4015     const U32 stype = SvTYPE(sref);
4016
4017     PERL_ARGS_ASSERT_GV_SETREF;
4018
4019     if (intro) {
4020         GvINTRO_off(dstr);      /* one-shot flag */
4021         GvLINE(dstr) = CopLINE(PL_curcop);
4022         GvEGV(dstr) = MUTABLE_GV(dstr);
4023     }
4024     GvMULTI_on(dstr);
4025     switch (stype) {
4026     case SVt_PVCV:
4027         location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
4028         import_flag = GVf_IMPORTED_CV;
4029         goto common;
4030     case SVt_PVHV:
4031         location = (SV **) &GvHV(dstr);
4032         import_flag = GVf_IMPORTED_HV;
4033         goto common;
4034     case SVt_PVAV:
4035         location = (SV **) &GvAV(dstr);
4036         import_flag = GVf_IMPORTED_AV;
4037         goto common;
4038     case SVt_PVIO:
4039         location = (SV **) &GvIOp(dstr);
4040         goto common;
4041     case SVt_PVFM:
4042         location = (SV **) &GvFORM(dstr);
4043         goto common;
4044     default:
4045         location = &GvSV(dstr);
4046         import_flag = GVf_IMPORTED_SV;
4047     common:
4048         if (intro) {
4049             if (stype == SVt_PVCV) {
4050                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
4051                 if (GvCVGEN(dstr)) {
4052                     SvREFCNT_dec(GvCV(dstr));
4053                     GvCV_set(dstr, NULL);
4054                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4055                 }
4056             }
4057             /* SAVEt_GVSLOT takes more room on the savestack and has more
4058                overhead in leave_scope than SAVEt_GENERIC_SV.  But for CVs
4059                leave_scope needs access to the GV so it can reset method
4060                caches.  We must use SAVEt_GVSLOT whenever the type is
4061                SVt_PVCV, even if the stash is anonymous, as the stash may
4062                gain a name somehow before leave_scope. */
4063             if (stype == SVt_PVCV) {
4064                 /* There is no save_pushptrptrptr.  Creating it for this
4065                    one call site would be overkill.  So inline the ss add
4066                    routines here. */
4067                 dSS_ADD;
4068                 SS_ADD_PTR(dstr);
4069                 SS_ADD_PTR(location);
4070                 SS_ADD_PTR(SvREFCNT_inc(*location));
4071                 SS_ADD_UV(SAVEt_GVSLOT);
4072                 SS_ADD_END(4);
4073             }
4074             else SAVEGENERICSV(*location);
4075         }
4076         dref = *location;
4077         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
4078             CV* const cv = MUTABLE_CV(*location);
4079             if (cv) {
4080                 if (!GvCVGEN((const GV *)dstr) &&
4081                     (CvROOT(cv) || CvXSUB(cv)) &&
4082                     /* redundant check that avoids creating the extra SV
4083                        most of the time: */
4084                     (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
4085                     {
4086                         SV * const new_const_sv =
4087                             CvCONST((const CV *)sref)
4088                                  ? cv_const_sv((const CV *)sref)
4089                                  : NULL;
4090                         report_redefined_cv(
4091                            sv_2mortal(Perl_newSVpvf(aTHX_
4092                                 "%"HEKf"::%"HEKf,
4093                                 HEKfARG(
4094                                  HvNAME_HEK(GvSTASH((const GV *)dstr))
4095                                 ),
4096                                 HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
4097                            )),
4098                            cv,
4099                            CvCONST((const CV *)sref) ? &new_const_sv : NULL
4100                         );
4101                     }
4102                 if (!intro)
4103                     cv_ckproto_len_flags(cv, (const GV *)dstr,
4104                                    SvPOK(sref) ? CvPROTO(sref) : NULL,
4105                                    SvPOK(sref) ? CvPROTOLEN(sref) : 0,
4106                                    SvPOK(sref) ? SvUTF8(sref) : 0);
4107             }
4108             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4109             GvASSUMECV_on(dstr);
4110             if(GvSTASH(dstr)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
4111                 if (intro && GvREFCNT(dstr) > 1) {
4112                     /* temporary remove extra savestack's ref */
4113                     --GvREFCNT(dstr);
4114                     gv_method_changed(dstr);
4115                     ++GvREFCNT(dstr);
4116                 }
4117                 else gv_method_changed(dstr);
4118             }
4119         }
4120         *location = SvREFCNT_inc_simple_NN(sref);
4121         if (import_flag && !(GvFLAGS(dstr) & import_flag)
4122             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
4123             GvFLAGS(dstr) |= import_flag;
4124         }
4125         if (import_flag == GVf_IMPORTED_SV) {
4126             if (intro) {
4127                 save_aliased_sv((GV *)dstr);
4128             }
4129             /* Turn off the flag if sref is not referenced elsewhere,
4130                even by weak refs.  (SvRMAGICAL is a pessimistic check for
4131                back refs.)  */
4132             if (SvREFCNT(sref) <= 2 && !SvRMAGICAL(sref))
4133                 GvALIASED_SV_off(dstr);
4134             else
4135                 GvALIASED_SV_on(dstr);
4136         }
4137         if (stype == SVt_PVHV) {
4138             const char * const name = GvNAME((GV*)dstr);
4139             const STRLEN len = GvNAMELEN(dstr);
4140             if (
4141                 (
4142                    (len > 1 && name[len-2] == ':' && name[len-1] == ':')
4143                 || (len == 1 && name[0] == ':')
4144                 )
4145              && (!dref || HvENAME_get(dref))
4146             ) {
4147                 mro_package_moved(
4148                     (HV *)sref, (HV *)dref,
4149                     (GV *)dstr, 0
4150                 );
4151             }
4152         }
4153         else if (
4154             stype == SVt_PVAV && sref != dref
4155          && strEQ(GvNAME((GV*)dstr), "ISA")
4156          /* The stash may have been detached from the symbol table, so
4157             check its name before doing anything. */
4158          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
4159         ) {
4160             MAGIC *mg;
4161             MAGIC * const omg = dref && SvSMAGICAL(dref)
4162                                  ? mg_find(dref, PERL_MAGIC_isa)
4163                                  : NULL;
4164             if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
4165                 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
4166                     AV * const ary = newAV();
4167                     av_push(ary, mg->mg_obj); /* takes the refcount */
4168                     mg->mg_obj = (SV *)ary;
4169                 }
4170                 if (omg) {
4171                     if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
4172                         SV **svp = AvARRAY((AV *)omg->mg_obj);
4173                         I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
4174                         while (items--)
4175                             av_push(
4176                              (AV *)mg->mg_obj,
4177                              SvREFCNT_inc_simple_NN(*svp++)
4178                             );
4179                     }
4180                     else
4181                         av_push(
4182                          (AV *)mg->mg_obj,
4183                          SvREFCNT_inc_simple_NN(omg->mg_obj)
4184                         );
4185                 }
4186                 else
4187                     av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
4188             }
4189             else
4190             {
4191                 sv_magic(
4192                  sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
4193                 );
4194                 mg = mg_find(sref, PERL_MAGIC_isa);
4195             }
4196             /* Since the *ISA assignment could have affected more than
4197                one stash, don't call mro_isa_changed_in directly, but let
4198                magic_clearisa do it for us, as it already has the logic for
4199                dealing with globs vs arrays of globs. */
4200             assert(mg);
4201             Perl_magic_clearisa(aTHX_ NULL, mg);
4202         }
4203         else if (stype == SVt_PVIO) {
4204             DEBUG_o(Perl_deb(aTHX_ "gv_setref clearing PL_stashcache\n"));
4205             /* It's a cache. It will rebuild itself quite happily.
4206                It's a lot of effort to work out exactly which key (or keys)
4207                might be invalidated by the creation of the this file handle.
4208             */
4209             hv_clear(PL_stashcache);
4210         }
4211         break;
4212     }
4213     if (!intro) SvREFCNT_dec(dref);
4214     if (SvTAINTED(sstr))
4215         SvTAINT(dstr);
4216     return;
4217 }
4218
4219
4220
4221
4222 #ifdef PERL_DEBUG_READONLY_COW
4223 # include <sys/mman.h>
4224
4225 # ifndef PERL_MEMORY_DEBUG_HEADER_SIZE
4226 #  define PERL_MEMORY_DEBUG_HEADER_SIZE 0
4227 # endif
4228
4229 void
4230 Perl_sv_buf_to_ro(pTHX_ SV *sv)
4231 {
4232     struct perl_memory_debug_header * const header =
4233         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4234     const MEM_SIZE len = header->size;
4235     PERL_ARGS_ASSERT_SV_BUF_TO_RO;
4236 # ifdef PERL_TRACK_MEMPOOL
4237     if (!header->readonly) header->readonly = 1;
4238 # endif
4239     if (mprotect(header, len, PROT_READ))
4240         Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
4241                          header, len, errno);
4242 }
4243
4244 static void
4245 S_sv_buf_to_rw(pTHX_ SV *sv)
4246 {
4247     struct perl_memory_debug_header * const header =
4248         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4249     const MEM_SIZE len = header->size;
4250     PERL_ARGS_ASSERT_SV_BUF_TO_RW;
4251     if (mprotect(header, len, PROT_READ|PROT_WRITE))
4252         Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
4253                          header, len, errno);
4254 # ifdef PERL_TRACK_MEMPOOL
4255     header->readonly = 0;
4256 # endif
4257 }
4258
4259 #else
4260 # define sv_buf_to_ro(sv)       NOOP
4261 # define sv_buf_to_rw(sv)       NOOP
4262 #endif
4263
4264 void
4265 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
4266 {
4267     U32 sflags;
4268     int dtype;
4269     svtype stype;
4270
4271     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
4272
4273     if (UNLIKELY( sstr == dstr ))
4274         return;
4275
4276     if (SvIS_FREED(dstr)) {
4277         Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
4278                    " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
4279     }
4280     SV_CHECK_THINKFIRST_COW_DROP(dstr);
4281     if (UNLIKELY( !sstr ))
4282         sstr = &PL_sv_undef;
4283     if (SvIS_FREED(sstr)) {
4284         Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
4285                    (void*)sstr, (void*)dstr);
4286     }
4287     stype = SvTYPE(sstr);
4288     dtype = SvTYPE(dstr);
4289
4290     /* There's a lot of redundancy below but we're going for speed here */
4291
4292     switch (stype) {
4293     case SVt_NULL:
4294       undef_sstr:
4295         if (LIKELY( dtype != SVt_PVGV && dtype != SVt_PVLV )) {
4296             (void)SvOK_off(dstr);
4297             return;
4298         }
4299         break;
4300     case SVt_IV:
4301         if (SvIOK(sstr)) {
4302             switch (dtype) {
4303             case SVt_NULL:
4304                 /* For performance, we inline promoting to type SVt_IV. */
4305                 /* We're starting from SVt_NULL, so provided that define is
4306                  * actual 0, we don't have to unset any SV type flags
4307                  * to promote to SVt_IV. */
4308                 STATIC_ASSERT_STMT(SVt_NULL == 0);
4309                 SET_SVANY_FOR_BODYLESS_IV(dstr);
4310                 SvFLAGS(dstr) |= SVt_IV;
4311                 break;
4312             case SVt_NV:
4313             case SVt_PV:
4314                 sv_upgrade(dstr, SVt_PVIV);
4315                 break;
4316             case SVt_PVGV:
4317             case SVt_PVLV:
4318                 goto end_of_first_switch;
4319             }
4320             (void)SvIOK_only(dstr);
4321             SvIV_set(dstr,  SvIVX(sstr));
4322             if (SvIsUV(sstr))
4323                 SvIsUV_on(dstr);
4324             /* SvTAINTED can only be true if the SV has taint magic, which in
4325                turn means that the SV type is PVMG (or greater). This is the
4326                case statement for SVt_IV, so this cannot be true (whatever gcov
4327                may say).  */
4328             assert(!SvTAINTED(sstr));
4329             return;
4330         }
4331         if (!SvROK(sstr))
4332             goto undef_sstr;
4333         if (dtype < SVt_PV && dtype != SVt_IV)
4334             sv_upgrade(dstr, SVt_IV);
4335         break;
4336
4337     case SVt_NV:
4338         if (LIKELY( SvNOK(sstr) )) {
4339             switch (dtype) {
4340             case SVt_NULL:
4341             case SVt_IV:
4342                 sv_upgrade(dstr, SVt_NV);
4343                 break;
4344             case SVt_PV:
4345             case SVt_PVIV:
4346                 sv_upgrade(dstr, SVt_PVNV);
4347                 break;
4348             case SVt_PVGV:
4349             case SVt_PVLV:
4350                 goto end_of_first_switch;
4351             }
4352             SvNV_set(dstr, SvNVX(sstr));
4353             (void)SvNOK_only(dstr);
4354             /* SvTAINTED can only be true if the SV has taint magic, which in
4355                turn means that the SV type is PVMG (or greater). This is the
4356                case statement for SVt_NV, so this cannot be true (whatever gcov
4357                may say).  */
4358             assert(!SvTAINTED(sstr));
4359             return;
4360         }
4361         goto undef_sstr;
4362
4363     case SVt_PV:
4364         if (dtype < SVt_PV)
4365             sv_upgrade(dstr, SVt_PV);
4366         break;
4367     case SVt_PVIV:
4368         if (dtype < SVt_PVIV)
4369             sv_upgrade(dstr, SVt_PVIV);
4370         break;
4371     case SVt_PVNV:
4372         if (dtype < SVt_PVNV)
4373             sv_upgrade(dstr, SVt_PVNV);
4374         break;
4375     default:
4376         {
4377         const char * const type = sv_reftype(sstr,0);
4378         if (PL_op)
4379             /* diag_listed_as: Bizarre copy of %s */
4380             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4381         else
4382             Perl_croak(aTHX_ "Bizarre copy of %s", type);
4383         }
4384         NOT_REACHED; /* NOTREACHED */
4385
4386     case SVt_REGEXP:
4387       upgregexp:
4388         if (dtype < SVt_REGEXP)
4389         {
4390             if (dtype >= SVt_PV) {
4391                 SvPV_free(dstr);
4392                 SvPV_set(dstr, 0);
4393                 SvLEN_set(dstr, 0);
4394                 SvCUR_set(dstr, 0);
4395             }
4396             sv_upgrade(dstr, SVt_REGEXP);
4397         }
4398         break;
4399
4400         case SVt_INVLIST:
4401     case SVt_PVLV:
4402     case SVt_PVGV:
4403     case SVt_PVMG:
4404         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4405             mg_get(sstr);
4406             if (SvTYPE(sstr) != stype)
4407                 stype = SvTYPE(sstr);
4408         }
4409         if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4410                     glob_assign_glob(dstr, sstr, dtype);
4411                     return;
4412         }
4413         if (stype == SVt_PVLV)
4414         {
4415             if (isREGEXP(sstr)) goto upgregexp;
4416             SvUPGRADE(dstr, SVt_PVNV);
4417         }
4418         else
4419             SvUPGRADE(dstr, (svtype)stype);
4420     }
4421  end_of_first_switch:
4422
4423     /* dstr may have been upgraded.  */
4424     dtype = SvTYPE(dstr);
4425     sflags = SvFLAGS(sstr);
4426
4427     if (UNLIKELY( dtype == SVt_PVCV )) {
4428         /* Assigning to a subroutine sets the prototype.  */
4429         if (SvOK(sstr)) {
4430             STRLEN len;
4431             const char *const ptr = SvPV_const(sstr, len);
4432
4433             SvGROW(dstr, len + 1);
4434             Copy(ptr, SvPVX(dstr), len + 1, char);
4435             SvCUR_set(dstr, len);
4436             SvPOK_only(dstr);
4437             SvFLAGS(dstr) |= sflags & SVf_UTF8;
4438             CvAUTOLOAD_off(dstr);
4439         } else {
4440             SvOK_off(dstr);
4441         }
4442     }
4443     else if (UNLIKELY(dtype == SVt_PVAV || dtype == SVt_PVHV
4444              || dtype == SVt_PVFM))
4445     {
4446         const char * const type = sv_reftype(dstr,0);
4447         if (PL_op)
4448             /* diag_listed_as: Cannot copy to %s */
4449             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4450         else
4451             Perl_croak(aTHX_ "Cannot copy to %s", type);
4452     } else if (sflags & SVf_ROK) {
4453         if (isGV_with_GP(dstr)
4454             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4455             sstr = SvRV(sstr);
4456             if (sstr == dstr) {
4457                 if (GvIMPORTED(dstr) != GVf_IMPORTED
4458                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4459                 {
4460                     GvIMPORTED_on(dstr);
4461                 }
4462                 GvMULTI_on(dstr);
4463                 return;
4464             }
4465             glob_assign_glob(dstr, sstr, dtype);
4466             return;
4467         }
4468
4469         if (dtype >= SVt_PV) {
4470             if (isGV_with_GP(dstr)) {
4471                 gv_setref(dstr, sstr);
4472                 return;
4473             }
4474             if (SvPVX_const(dstr)) {
4475                 SvPV_free(dstr);
4476                 SvLEN_set(dstr, 0);
4477                 SvCUR_set(dstr, 0);
4478             }
4479         }
4480         (void)SvOK_off(dstr);
4481         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4482         SvFLAGS(dstr) |= sflags & SVf_ROK;
4483         assert(!(sflags & SVp_NOK));
4484         assert(!(sflags & SVp_IOK));
4485         assert(!(sflags & SVf_NOK));
4486         assert(!(sflags & SVf_IOK));
4487     }
4488     else if (isGV_with_GP(dstr)) {
4489         if (!(sflags & SVf_OK)) {
4490             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4491                            "Undefined value assigned to typeglob");
4492         }
4493         else {
4494             GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
4495             if (dstr != (const SV *)gv) {
4496                 const char * const name = GvNAME((const GV *)dstr);
4497                 const STRLEN len = GvNAMELEN(dstr);
4498                 HV *old_stash = NULL;
4499                 bool reset_isa = FALSE;
4500                 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4501                  || (len == 1 && name[0] == ':')) {
4502                     /* Set aside the old stash, so we can reset isa caches
4503                        on its subclasses. */
4504                     if((old_stash = GvHV(dstr))) {
4505                         /* Make sure we do not lose it early. */
4506                         SvREFCNT_inc_simple_void_NN(
4507                          sv_2mortal((SV *)old_stash)
4508                         );
4509                     }
4510                     reset_isa = TRUE;
4511                 }
4512
4513                 if (GvGP(dstr)) {
4514                     SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
4515                     gp_free(MUTABLE_GV(dstr));
4516                 }
4517                 GvGP_set(dstr, gp_ref(GvGP(gv)));
4518
4519                 if (reset_isa) {
4520                     HV * const stash = GvHV(dstr);
4521                     if(
4522                         old_stash ? (HV *)HvENAME_get(old_stash) : stash
4523                     )
4524                         mro_package_moved(
4525                          stash, old_stash,
4526                          (GV *)dstr, 0
4527                         );
4528                 }
4529             }
4530         }
4531     }
4532     else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4533           && (stype == SVt_REGEXP || isREGEXP(sstr))) {
4534         reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4535     }
4536     else if (sflags & SVp_POK) {
4537         const STRLEN cur = SvCUR(sstr);
4538         const STRLEN len = SvLEN(sstr);
4539
4540         /*
4541          * We have three basic ways to copy the string:
4542          *
4543          *  1. Swipe
4544          *  2. Copy-on-write
4545          *  3. Actual copy
4546          * 
4547          * Which we choose is based on various factors.  The following
4548          * things are listed in order of speed, fastest to slowest:
4549          *  - Swipe
4550          *  - Copying a short string
4551          *  - Copy-on-write bookkeeping
4552          *  - malloc
4553          *  - Copying a long string
4554          * 
4555          * We swipe the string (steal the string buffer) if the SV on the
4556          * rhs is about to be freed anyway (TEMP and refcnt==1).  This is a
4557          * big win on long strings.  It should be a win on short strings if
4558          * SvPVX_const(dstr) has to be allocated.  If not, it should not 
4559          * slow things down, as SvPVX_const(sstr) would have been freed
4560          * soon anyway.
4561          * 
4562          * We also steal the buffer from a PADTMP (operator target) if it
4563          * is ‘long enough’.  For short strings, a swipe does not help
4564          * here, as it causes more malloc calls the next time the target
4565          * is used.  Benchmarks show that even if SvPVX_const(dstr) has to
4566          * be allocated it is still not worth swiping PADTMPs for short
4567          * strings, as the savings here are small.
4568          * 
4569          * If swiping is not an option, then we see whether it is
4570          * worth using copy-on-write.  If the lhs already has a buf-
4571          * fer big enough and the string is short, we skip it and fall back
4572          * to method 3, since memcpy is faster for short strings than the
4573          * later bookkeeping overhead that copy-on-write entails.
4574
4575          * If the rhs is not a copy-on-write string yet, then we also
4576          * consider whether the buffer is too large relative to the string
4577          * it holds.  Some operations such as readline allocate a large
4578          * buffer in the expectation of reusing it.  But turning such into
4579          * a COW buffer is counter-productive because it increases memory
4580          * usage by making readline allocate a new large buffer the sec-
4581          * ond time round.  So, if the buffer is too large, again, we use
4582          * method 3 (copy).
4583          * 
4584          * Finally, if there is no buffer on the left, or the buffer is too 
4585          * small, then we use copy-on-write and make both SVs share the
4586          * string buffer.
4587          *
4588          */
4589
4590         /* Whichever path we take through the next code, we want this true,
4591            and doing it now facilitates the COW check.  */
4592         (void)SvPOK_only(dstr);
4593
4594         if (
4595                  (              /* Either ... */
4596                                 /* slated for free anyway (and not COW)? */
4597                     (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
4598                                 /* or a swipable TARG */
4599                  || ((sflags &
4600                            (SVs_PADTMP|SVf_READONLY|SVf_PROTECT|SVf_IsCOW))
4601                        == SVs_PADTMP
4602                                 /* whose buffer is worth stealing */
4603                      && CHECK_COWBUF_THRESHOLD(cur,len)
4604                     )
4605                  ) &&
4606                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4607                  (!(flags & SV_NOSTEAL)) &&
4608                                         /* and we're allowed to steal temps */
4609                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4610                  len)             /* and really is a string */
4611         {       /* Passes the swipe test.  */
4612             if (SvPVX_const(dstr))      /* we know that dtype >= SVt_PV */
4613                 SvPV_free(dstr);
4614             SvPV_set(dstr, SvPVX_mutable(sstr));
4615             SvLEN_set(dstr, SvLEN(sstr));
4616             SvCUR_set(dstr, SvCUR(sstr));
4617
4618             SvTEMP_off(dstr);
4619             (void)SvOK_off(sstr);       /* NOTE: nukes most SvFLAGS on sstr */
4620             SvPV_set(sstr, NULL);
4621             SvLEN_set(sstr, 0);
4622             SvCUR_set(sstr, 0);
4623             SvTEMP_off(sstr);
4624         }
4625         else if (flags & SV_COW_SHARED_HASH_KEYS
4626               &&
4627 #ifdef PERL_OLD_COPY_ON_WRITE
4628                  (  sflags & SVf_IsCOW
4629                  || (   (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4630                      && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4631                      && SvTYPE(sstr) >= SVt_PVIV && len
4632                     )
4633                  )
4634 #elif defined(PERL_NEW_COPY_ON_WRITE)
4635                  (sflags & SVf_IsCOW
4636                    ? (!len ||
4637                        (  (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
4638                           /* If this is a regular (non-hek) COW, only so
4639                              many COW "copies" are possible. */
4640                        && CowREFCNT(sstr) != SV_COW_REFCNT_MAX  ))
4641                    : (  (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4642                      && !(SvFLAGS(dstr) & SVf_BREAK)
4643                      && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len
4644                      && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
4645                     ))
4646 #else
4647                  sflags & SVf_IsCOW
4648               && !(SvFLAGS(dstr) & SVf_BREAK)
4649 #endif
4650             ) {
4651             /* Either it's a shared hash key, or it's suitable for
4652                copy-on-write.  */
4653             if (DEBUG_C_TEST) {
4654                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4655                 sv_dump(sstr);
4656                 sv_dump(dstr);
4657             }
4658 #ifdef PERL_ANY_COW
4659             if (!(sflags & SVf_IsCOW)) {
4660                     SvIsCOW_on(sstr);
4661 # ifdef PERL_OLD_COPY_ON_WRITE
4662                     /* Make the source SV into a loop of 1.
4663                        (about to become 2) */
4664                     SV_COW_NEXT_SV_SET(sstr, sstr);
4665 # else
4666                     CowREFCNT(sstr) = 0;
4667 # endif
4668             }
4669 #endif
4670             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
4671                 SvPV_free(dstr);
4672             }
4673
4674 #ifdef PERL_ANY_COW
4675             if (len) {
4676 # ifdef PERL_OLD_COPY_ON_WRITE
4677                     assert (SvTYPE(dstr) >= SVt_PVIV);
4678                     /* SvIsCOW_normal */
4679                     /* splice us in between source and next-after-source.  */
4680                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4681                     SV_COW_NEXT_SV_SET(sstr, dstr);
4682 # else
4683                     if (sflags & SVf_IsCOW) {
4684                         sv_buf_to_rw(sstr);
4685                     }
4686                     CowREFCNT(sstr)++;
4687 # endif
4688                     SvPV_set(dstr, SvPVX_mutable(sstr));
4689                     sv_buf_to_ro(sstr);
4690             } else
4691 #endif
4692             {
4693                     /* SvIsCOW_shared_hash */
4694                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4695                                           "Copy on write: Sharing hash\n"));
4696
4697                     assert (SvTYPE(dstr) >= SVt_PV);
4698                     SvPV_set(dstr,
4699                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4700             }
4701             SvLEN_set(dstr, len);
4702             SvCUR_set(dstr, cur);
4703             SvIsCOW_on(dstr);
4704         } else {
4705             /* Failed the swipe test, and we cannot do copy-on-write either.
4706                Have to copy the string.  */
4707             SvGROW(dstr, cur + 1);      /* inlined from sv_setpvn */
4708             Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
4709             SvCUR_set(dstr, cur);
4710             *SvEND(dstr) = '\0';
4711         }
4712         if (sflags & SVp_NOK) {
4713             SvNV_set(dstr, SvNVX(sstr));
4714         }
4715         if (sflags & SVp_IOK) {
4716             SvIV_set(dstr, SvIVX(sstr));
4717             /* Must do this otherwise some other overloaded use of 0x80000000
4718                gets confused. I guess SVpbm_VALID */
4719             if (sflags & SVf_IVisUV)
4720                 SvIsUV_on(dstr);
4721         }
4722         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4723         {
4724             const MAGIC * const smg = SvVSTRING_mg(sstr);
4725             if (smg) {
4726                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4727                          smg->mg_ptr, smg->mg_len);
4728                 SvRMAGICAL_on(dstr);
4729             }
4730         }
4731     }
4732     else if (sflags & (SVp_IOK|SVp_NOK)) {
4733         (void)SvOK_off(dstr);
4734         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4735         if (sflags & SVp_IOK) {
4736             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4737             SvIV_set(dstr, SvIVX(sstr));
4738         }
4739         if (sflags & SVp_NOK) {
4740             SvNV_set(dstr, SvNVX(sstr));
4741         }
4742     }
4743     else {
4744         if (isGV_with_GP(sstr)) {
4745             gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4746         }
4747         else
4748             (void)SvOK_off(dstr);
4749     }
4750     if (SvTAINTED(sstr))
4751         SvTAINT(dstr);
4752 }
4753
4754 /*
4755 =for apidoc sv_setsv_mg
4756
4757 Like C<sv_setsv>, but also handles 'set' magic.
4758
4759 =cut
4760 */
4761
4762 void
4763 Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr)
4764 {
4765     PERL_ARGS_ASSERT_SV_SETSV_MG;
4766
4767     sv_setsv(dstr,sstr);
4768     SvSETMAGIC(dstr);
4769 }
4770
4771 #ifdef PERL_ANY_COW
4772 # ifdef PERL_OLD_COPY_ON_WRITE
4773 #  define SVt_COW SVt_PVIV
4774 # else
4775 #  define SVt_COW SVt_PV
4776 # endif
4777 SV *
4778 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4779 {
4780     STRLEN cur = SvCUR(sstr);
4781     STRLEN len = SvLEN(sstr);
4782     char *new_pv;
4783 #if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_NEW_COPY_ON_WRITE)
4784     const bool already = cBOOL(SvIsCOW(sstr));
4785 #endif
4786
4787     PERL_ARGS_ASSERT_SV_SETSV_COW;
4788
4789     if (DEBUG_C_TEST) {
4790         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4791                       (void*)sstr, (void*)dstr);
4792         sv_dump(sstr);
4793         if (dstr)
4794                     sv_dump(dstr);
4795     }
4796
4797     if (dstr) {
4798         if (SvTHINKFIRST(dstr))
4799             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4800         else if (SvPVX_const(dstr))
4801             Safefree(SvPVX_mutable(dstr));
4802     }
4803     else
4804         new_SV(dstr);
4805     SvUPGRADE(dstr, SVt_COW);
4806
4807     assert (SvPOK(sstr));
4808     assert (SvPOKp(sstr));
4809 # ifdef PERL_OLD_COPY_ON_WRITE
4810     assert (!SvIOK(sstr));
4811     assert (!SvIOKp(sstr));
4812     assert (!SvNOK(sstr));
4813     assert (!SvNOKp(sstr));
4814 # endif
4815
4816     if (SvIsCOW(sstr)) {
4817
4818         if (SvLEN(sstr) == 0) {
4819             /* source is a COW shared hash key.  */
4820             DEBUG_C(PerlIO_printf(Perl_debug_log,
4821                                   "Fast copy on write: Sharing hash\n"));
4822             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4823             goto common_exit;
4824         }
4825 # ifdef PERL_OLD_COPY_ON_WRITE
4826         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4827 # else
4828         assert(SvCUR(sstr)+1 < SvLEN(sstr));
4829         assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX);
4830 # endif
4831     } else {
4832         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4833         SvUPGRADE(sstr, SVt_COW);
4834         SvIsCOW_on(sstr);
4835         DEBUG_C(PerlIO_printf(Perl_debug_log,
4836                               "Fast copy on write: Converting sstr to COW\n"));
4837 # ifdef PERL_OLD_COPY_ON_WRITE
4838         SV_COW_NEXT_SV_SET(dstr, sstr);
4839 # else
4840         CowREFCNT(sstr) = 0;    
4841 # endif
4842     }
4843 # ifdef PERL_OLD_COPY_ON_WRITE
4844     SV_COW_NEXT_SV_SET(sstr, dstr);
4845 # else
4846 #  ifdef PERL_DEBUG_READONLY_COW
4847     if (already) sv_buf_to_rw(sstr);
4848 #  endif
4849     CowREFCNT(sstr)++;  
4850 # endif
4851     new_pv = SvPVX_mutable(sstr);
4852     sv_buf_to_ro(sstr);
4853
4854   common_exit:
4855     SvPV_set(dstr, new_pv);
4856     SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
4857     if (SvUTF8(sstr))
4858         SvUTF8_on(dstr);
4859     SvLEN_set(dstr, len);
4860     SvCUR_set(dstr, cur);
4861     if (DEBUG_C_TEST) {
4862         sv_dump(dstr);
4863     }
4864     return dstr;
4865 }
4866 #endif
4867
4868 /*
4869 =for apidoc sv_setpvn
4870
4871 Copies a string (possibly containing embedded C<NUL> characters) into an SV.
4872 The C<len> parameter indicates the number of
4873 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4874 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4875
4876 =cut
4877 */
4878
4879 void
4880 Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4881 {
4882     char *dptr;
4883
4884     PERL_ARGS_ASSERT_SV_SETPVN;
4885
4886     SV_CHECK_THINKFIRST_COW_DROP(sv);
4887     if (!ptr) {
4888         (void)SvOK_off(sv);
4889         return;
4890     }
4891     else {
4892         /* len is STRLEN which is unsigned, need to copy to signed */
4893         const IV iv = len;
4894         if (iv < 0)
4895             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
4896                        IVdf, iv);
4897     }
4898     SvUPGRADE(sv, SVt_PV);
4899
4900     dptr = SvGROW(sv, len + 1);
4901     Move(ptr,dptr,len,char);
4902     dptr[len] = '\0';
4903     SvCUR_set(sv, len);
4904     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4905     SvTAINT(sv);
4906     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4907 }
4908
4909 /*
4910 =for apidoc sv_setpvn_mg
4911
4912 Like C<sv_setpvn>, but also handles 'set' magic.
4913
4914 =cut
4915 */
4916
4917 void
4918 Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4919 {
4920     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4921
4922     sv_setpvn(sv,ptr,len);
4923     SvSETMAGIC(sv);
4924 }
4925
4926 /*
4927 =for apidoc sv_setpv
4928
4929 Copies a string into an SV.  The string must be terminated with a C<NUL>
4930 character.
4931 Does not handle 'set' magic.  See C<sv_setpv_mg>.
4932
4933 =cut
4934 */
4935
4936 void
4937 Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
4938 {
4939     STRLEN len;
4940
4941     PERL_ARGS_ASSERT_SV_SETPV;
4942
4943     SV_CHECK_THINKFIRST_COW_DROP(sv);
4944     if (!ptr) {
4945         (void)SvOK_off(sv);
4946         return;
4947     }
4948     len = strlen(ptr);
4949     SvUPGRADE(sv, SVt_PV);
4950
4951     SvGROW(sv, len + 1);
4952     Move(ptr,SvPVX(sv),len+1,char);
4953     SvCUR_set(sv, len);
4954     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4955     SvTAINT(sv);
4956     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4957 }
4958
4959 /*
4960 =for apidoc sv_setpv_mg
4961
4962 Like C<sv_setpv>, but also handles 'set' magic.
4963
4964 =cut
4965 */
4966
4967 void
4968 Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
4969 {
4970     PERL_ARGS_ASSERT_SV_SETPV_MG;
4971
4972     sv_setpv(sv,ptr);
4973     SvSETMAGIC(sv);
4974 }
4975
4976 void
4977 Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
4978 {
4979     PERL_ARGS_ASSERT_SV_SETHEK;
4980
4981     if (!hek) {
4982         return;
4983     }
4984
4985     if (HEK_LEN(hek) == HEf_SVKEY) {
4986         sv_setsv(sv, *(SV**)HEK_KEY(hek));
4987         return;
4988     } else {
4989         const int flags = HEK_FLAGS(hek);
4990         if (flags & HVhek_WASUTF8) {
4991             STRLEN utf8_len = HEK_LEN(hek);
4992             char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
4993             sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
4994             SvUTF8_on(sv);
4995             return;
4996         } else if (flags & HVhek_UNSHARED) {
4997             sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
4998             if (HEK_UTF8(hek))
4999                 SvUTF8_on(sv);
5000             else SvUTF8_off(sv);
5001             return;
5002         }
5003         {
5004             SV_CHECK_THINKFIRST_COW_DROP(sv);
5005             SvUPGRADE(sv, SVt_PV);
5006             SvPV_free(sv);
5007             SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
5008             SvCUR_set(sv, HEK_LEN(hek));
5009             SvLEN_set(sv, 0);
5010             SvIsCOW_on(sv);
5011             SvPOK_on(sv);
5012             if (HEK_UTF8(hek))
5013                 SvUTF8_on(sv);
5014             else SvUTF8_off(sv);
5015             return;
5016         }
5017     }
5018 }
5019
5020
5021 /*
5022 =for apidoc sv_usepvn_flags
5023
5024 Tells an SV to use C<ptr> to find its string value.  Normally the
5025 string is stored inside the SV, but sv_usepvn allows the SV to use an
5026 outside string.  The C<ptr> should point to memory that was allocated
5027 by L<Newx|perlclib/Memory Management and String Handling>.  It must be
5028 the start of a Newx-ed block of memory, and not a pointer to the
5029 middle of it (beware of L<OOK|perlguts/Offsets> and copy-on-write),
5030 and not be from a non-Newx memory allocator like C<malloc>.  The
5031 string length, C<len>, must be supplied.  By default this function
5032 will C<Renew> (i.e. realloc, move) the memory pointed to by C<ptr>,
5033 so that pointer should not be freed or used by the programmer after
5034 giving it to sv_usepvn, and neither should any pointers from "behind"
5035 that pointer (e.g. ptr + 1) be used.
5036
5037 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC.  If C<flags> &
5038 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be C<NUL>, and the realloc
5039 will be skipped (i.e. the buffer is actually at least 1 byte longer than
5040 C<len>, and already meets the requirements for storing in C<SvPVX>).
5041
5042 =cut
5043 */
5044
5045 void
5046 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
5047 {
5048     STRLEN allocate;
5049
5050     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
5051
5052     SV_CHECK_THINKFIRST_COW_DROP(sv);
5053     SvUPGRADE(sv, SVt_PV);
5054     if (!ptr) {
5055         (void)SvOK_off(sv);
5056         if (flags & SV_SMAGIC)
5057             SvSETMAGIC(sv);
5058         return;
5059     }
5060     if (SvPVX_const(sv))
5061         SvPV_free(sv);
5062
5063 #ifdef DEBUGGING
5064     if (flags & SV_HAS_TRAILING_NUL)
5065         assert(ptr[len] == '\0');
5066 #endif
5067
5068     allocate = (flags & SV_HAS_TRAILING_NUL)
5069         ? len + 1 :
5070 #ifdef Perl_safesysmalloc_size
5071         len + 1;
5072 #else 
5073         PERL_STRLEN_ROUNDUP(len + 1);
5074 #endif
5075     if (flags & SV_HAS_TRAILING_NUL) {
5076         /* It's long enough - do nothing.
5077            Specifically Perl_newCONSTSUB is relying on this.  */
5078     } else {
5079 #ifdef DEBUGGING
5080         /* Force a move to shake out bugs in callers.  */
5081         char *new_ptr = (char*)safemalloc(allocate);
5082         Copy(ptr, new_ptr, len, char);
5083         PoisonFree(ptr,len,char);
5084         Safefree(ptr);
5085         ptr = new_ptr;
5086 #else
5087         ptr = (char*) saferealloc (ptr, allocate);
5088 #endif
5089     }
5090 #ifdef Perl_safesysmalloc_size
5091     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
5092 #else
5093     SvLEN_set(sv, allocate);
5094 #endif
5095     SvCUR_set(sv, len);
5096     SvPV_set(sv, ptr);
5097     if (!(flags & SV_HAS_TRAILING_NUL)) {
5098         ptr[len] = '\0';
5099     }
5100     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5101     SvTAINT(sv);
5102     if (flags & SV_SMAGIC)
5103         SvSETMAGIC(sv);
5104 }
5105
5106 #ifdef PERL_OLD_COPY_ON_WRITE
5107 /* Need to do this *after* making the SV normal, as we need the buffer
5108    pointer to remain valid until after we've copied it.  If we let go too early,
5109    another thread could invalidate it by unsharing last of the same hash key
5110    (which it can do by means other than releasing copy-on-write Svs)
5111    or by changing the other copy-on-write SVs in the loop.  */
5112 STATIC void
5113 S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after)
5114 {
5115     PERL_ARGS_ASSERT_SV_RELEASE_COW;
5116
5117     { /* this SV was SvIsCOW_normal(sv) */
5118          /* we need to find the SV pointing to us.  */
5119         SV *current = SV_COW_NEXT_SV(after);
5120
5121         if (current == sv) {
5122             /* The SV we point to points back to us (there were only two of us
5123                in the loop.)
5124                Hence other SV is no longer copy on write either.  */
5125             SvIsCOW_off(after);
5126             sv_buf_to_rw(after);
5127         } else {
5128             /* We need to follow the pointers around the loop.  */
5129             SV *next;
5130             while ((next = SV_COW_NEXT_SV(current)) != sv) {
5131                 assert (next);
5132                 current = next;
5133                  /* don't loop forever if the structure is bust, and we have
5134                     a pointer into a closed loop.  */
5135                 assert (current != after);
5136                 assert (SvPVX_const(current) == pvx);
5137             }
5138             /* Make the SV before us point to the SV after us.  */
5139             SV_COW_NEXT_SV_SET(current, after);
5140         }
5141     }
5142 }
5143 #endif
5144 /*
5145 =for apidoc sv_force_normal_flags
5146
5147 Undo various types of fakery on an SV, where fakery means
5148 "more than" a string: if the PV is a shared string, make
5149 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5150 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
5151 we do the copy, and is also used locally; if this is a
5152 vstring, drop the vstring magic.  If C<SV_COW_DROP_PV> is set
5153 then a copy-on-write scalar drops its PV buffer (if any) and becomes
5154 SvPOK_off rather than making a copy.  (Used where this
5155 scalar is about to be set to some other value.)  In addition,
5156 the C<flags> parameter gets passed to C<sv_unref_flags()>
5157 when unreffing.  C<sv_force_normal> calls this function
5158 with flags set to 0.
5159
5160 This function is expected to be used to signal to perl that this SV is
5161 about to be written to, and any extra book-keeping needs to be taken care
5162 of.  Hence, it croaks on read-only values.
5163
5164 =cut
5165 */
5166
5167 static void
5168 S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
5169 {
5170     assert(SvIsCOW(sv));
5171     {
5172 #ifdef PERL_ANY_COW
5173         const char * const pvx = SvPVX_const(sv);
5174         const STRLEN len = SvLEN(sv);
5175         const STRLEN cur = SvCUR(sv);
5176 # ifdef PERL_OLD_COPY_ON_WRITE
5177         /* next COW sv in the loop.  If len is 0 then this is a shared-hash
5178            key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
5179            we'll fail an assertion.  */
5180         SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
5181 # endif
5182
5183         if (DEBUG_C_TEST) {
5184                 PerlIO_printf(Perl_debug_log,
5185                               "Copy on write: Force normal %ld\n",
5186                               (long) flags);
5187                 sv_dump(sv);
5188         }
5189         SvIsCOW_off(sv);
5190 # ifdef PERL_NEW_COPY_ON_WRITE
5191         if (len) {
5192             /* Must do this first, since the CowREFCNT uses SvPVX and
5193             we need to write to CowREFCNT, or de-RO the whole buffer if we are
5194             the only owner left of the buffer. */
5195             sv_buf_to_rw(sv); /* NOOP if RO-ing not supported */
5196             {
5197                 U8 cowrefcnt = CowREFCNT(sv);
5198                 if(cowrefcnt != 0) {
5199                     cowrefcnt--;
5200                     CowREFCNT(sv) = cowrefcnt;
5201                     sv_buf_to_ro(sv);
5202                     goto copy_over;
5203                 }
5204             }
5205             /* Else we are the only owner of the buffer. */
5206         }
5207         else
5208 # endif
5209         {
5210             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
5211             copy_over:
5212             SvPV_set(sv, NULL);
5213             SvCUR_set(sv, 0);
5214             SvLEN_set(sv, 0);
5215             if (flags & SV_COW_DROP_PV) {
5216                 /* OK, so we don't need to copy our buffer.  */
5217                 SvPOK_off(sv);
5218             } else {
5219                 SvGROW(sv, cur + 1);
5220                 Move(pvx,SvPVX(sv),cur,char);
5221                 SvCUR_set(sv, cur);
5222                 *SvEND(sv) = '\0';
5223             }
5224             if (len) {
5225 # ifdef PERL_OLD_COPY_ON_WRITE
5226                 sv_release_COW(sv, pvx, next);
5227 # endif
5228             } else {
5229                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5230             }
5231             if (DEBUG_C_TEST) {
5232                 sv_dump(sv);
5233             }
5234         }
5235 #else
5236             const char * const pvx = SvPVX_const(sv);
5237             const STRLEN len = SvCUR(sv);
5238             SvIsCOW_off(sv);
5239             SvPV_set(sv, NULL);
5240             SvLEN_set(sv, 0);
5241             if (flags & SV_COW_DROP_PV) {
5242                 /* OK, so we don't need to copy our buffer.  */
5243                 SvPOK_off(sv);
5244             } else {
5245                 SvGROW(sv, len + 1);
5246                 Move(pvx,SvPVX(sv),len,char);
5247                 *SvEND(sv) = '\0';
5248             }
5249             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5250 #endif
5251     }
5252 }
5253
5254 void
5255 Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
5256 {
5257     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
5258
5259     if (SvREADONLY(sv))
5260         Perl_croak_no_modify();
5261     else if (SvIsCOW(sv) && LIKELY(SvTYPE(sv) != SVt_PVHV))
5262         S_sv_uncow(aTHX_ sv, flags);
5263     if (SvROK(sv))
5264         sv_unref_flags(sv, flags);
5265     else if (SvFAKE(sv) && isGV_with_GP(sv))
5266         sv_unglob(sv, flags);
5267     else if (SvFAKE(sv) && isREGEXP(sv)) {
5268         /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
5269            to sv_unglob. We only need it here, so inline it.  */
5270         const bool islv = SvTYPE(sv) == SVt_PVLV;
5271         const svtype new_type =
5272           islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
5273         SV *const temp = newSV_type(new_type);
5274         regexp *const temp_p = ReANY((REGEXP *)sv);
5275
5276         if (new_type == SVt_PVMG) {
5277             SvMAGIC_set(temp, SvMAGIC(sv));
5278             SvMAGIC_set(sv, NULL);
5279             SvSTASH_set(temp, SvSTASH(sv));
5280             SvSTASH_set(sv, NULL);
5281         }
5282         if (!islv) SvCUR_set(temp, SvCUR(sv));
5283         /* Remember that SvPVX is in the head, not the body.  But
5284            RX_WRAPPED is in the body. */
5285         assert(ReANY((REGEXP *)sv)->mother_re);
5286         /* Their buffer is already owned by someone else. */
5287         if (flags & SV_COW_DROP_PV) {
5288             /* SvLEN is already 0.  For SVt_REGEXP, we have a brand new
5289                zeroed body.  For SVt_PVLV, it should have been set to 0
5290                before turning into a regexp. */
5291             assert(!SvLEN(islv ? sv : temp));
5292             sv->sv_u.svu_pv = 0;
5293         }
5294         else {
5295             sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
5296             SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
5297             SvPOK_on(sv);
5298         }
5299
5300         /* Now swap the rest of the bodies. */
5301
5302         SvFAKE_off(sv);
5303         if (!islv) {
5304             SvFLAGS(sv) &= ~SVTYPEMASK;
5305             SvFLAGS(sv) |= new_type;
5306             SvANY(sv) = SvANY(temp);
5307         }
5308
5309         SvFLAGS(temp) &= ~(SVTYPEMASK);
5310         SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
5311         SvANY(temp) = temp_p;
5312         temp->sv_u.svu_rx = (regexp *)temp_p;
5313
5314         SvREFCNT_dec_NN(temp);
5315     }
5316     else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
5317 }
5318
5319 /*
5320 =for apidoc sv_chop
5321
5322 Efficient removal of characters from the beginning of the string buffer.
5323 SvPOK(sv), or at least SvPOKp(sv), must be true and the C<ptr> must be a
5324 pointer to somewhere inside the string buffer.  The C<ptr> becomes the first
5325 character of the adjusted string.  Uses the "OOK hack".  On return, only
5326 SvPOK(sv) and SvPOKp(sv) among the OK flags will be true.
5327
5328 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
5329 refer to the same chunk of data.
5330
5331 The unfortunate similarity of this function's name to that of Perl's C<chop>
5332 operator is strictly coincidental.  This function works from the left;
5333 C<chop> works from the right.
5334
5335 =cut
5336 */
5337
5338 void
5339 Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
5340 {
5341     STRLEN delta;
5342     STRLEN old_delta;
5343     U8 *p;
5344 #ifdef DEBUGGING
5345     const U8 *evacp;
5346     STRLEN evacn;
5347 #endif
5348     STRLEN max_delta;
5349
5350     PERL_ARGS_ASSERT_SV_CHOP;
5351
5352     if (!ptr || !SvPOKp(sv))
5353         return;
5354     delta = ptr - SvPVX_const(sv);
5355     if (!delta) {
5356         /* Nothing to do.  */
5357         return;
5358     }
5359     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
5360     if (delta > max_delta)
5361         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
5362                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
5363     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
5364     SV_CHECK_THINKFIRST(sv);
5365     SvPOK_only_UTF8(sv);
5366
5367     if (!SvOOK(sv)) {
5368         if (!SvLEN(sv)) { /* make copy of shared string */
5369             const char *pvx = SvPVX_const(sv);
5370             const STRLEN len = SvCUR(sv);
5371             SvGROW(sv, len + 1);
5372             Move(pvx,SvPVX(sv),len,char);
5373             *SvEND(sv) = '\0';
5374         }
5375         SvOOK_on(sv);
5376         old_delta = 0;
5377     } else {
5378         SvOOK_offset(sv, old_delta);
5379     }
5380     SvLEN_set(sv, SvLEN(sv) - delta);
5381     SvCUR_set(sv, SvCUR(sv) - delta);
5382     SvPV_set(sv, SvPVX(sv) + delta);
5383
5384     p = (U8 *)SvPVX_const(sv);
5385
5386 #ifdef DEBUGGING
5387     /* how many bytes were evacuated?  we will fill them with sentinel
5388        bytes, except for the part holding the new offset of course. */
5389     evacn = delta;
5390     if (old_delta)
5391         evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
5392     assert(evacn);
5393     assert(evacn <= delta + old_delta);
5394     evacp = p - evacn;
5395 #endif
5396
5397     /* This sets 'delta' to the accumulated value of all deltas so far */
5398     delta += old_delta;
5399     assert(delta);
5400
5401     /* If 'delta' fits in a byte, store it just prior to the new beginning of
5402      * the string; otherwise store a 0 byte there and store 'delta' just prior
5403      * to that, using as many bytes as a STRLEN occupies.  Thus it overwrites a
5404      * portion of the chopped part of the string */
5405     if (delta < 0x100) {
5406         *--p = (U8) delta;
5407     } else {
5408         *--p = 0;
5409         p -= sizeof(STRLEN);
5410         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
5411     }
5412
5413 #ifdef DEBUGGING
5414     /* Fill the preceding buffer with sentinals to verify that no-one is
5415        using it.  */
5416     while (p > evacp) {
5417         --p;
5418         *p = (U8)PTR2UV(p);
5419     }
5420 #endif
5421 }
5422
5423 /*
5424 =for apidoc sv_catpvn
5425
5426 Concatenates the string onto the end of the string which is in the SV.  The
5427 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
5428 status set, then the bytes appended should be valid UTF-8.
5429 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
5430
5431 =for apidoc sv_catpvn_flags
5432
5433 Concatenates the string onto the end of the string which is in the SV.  The
5434 C<len> indicates number of bytes to copy.
5435
5436 By default, the string appended is assumed to be valid UTF-8 if the SV has
5437 the UTF-8 status set, and a string of bytes otherwise.  One can force the
5438 appended string to be interpreted as UTF-8 by supplying the C<SV_CATUTF8>
5439 flag, and as bytes by supplying the C<SV_CATBYTES> flag; the SV or the
5440 string appended will be upgraded to UTF-8 if necessary.
5441
5442 If C<flags> has the C<SV_SMAGIC> bit set, will
5443 C<mg_set> on C<dsv> afterwards if appropriate.
5444 C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5445 in terms of this function.
5446
5447 =cut
5448 */
5449
5450 void
5451 Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
5452 {
5453     STRLEN dlen;
5454     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5455
5456     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5457     assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5458
5459     if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
5460       if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
5461          sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5462          dlen = SvCUR(dsv);
5463       }
5464       else SvGROW(dsv, dlen + slen + 1);
5465       if (sstr == dstr)
5466         sstr = SvPVX_const(dsv);
5467       Move(sstr, SvPVX(dsv) + dlen, slen, char);
5468       SvCUR_set(dsv, SvCUR(dsv) + slen);
5469     }
5470     else {
5471         /* We inline bytes_to_utf8, to avoid an extra malloc. */
5472         const char * const send = sstr + slen;
5473         U8 *d;
5474
5475         /* Something this code does not account for, which I think is
5476            impossible; it would require the same pv to be treated as
5477            bytes *and* utf8, which would indicate a bug elsewhere. */
5478         assert(sstr != dstr);
5479
5480         SvGROW(dsv, dlen + slen * 2 + 1);
5481         d = (U8 *)SvPVX(dsv) + dlen;
5482
5483         while (sstr < send) {
5484             append_utf8_from_native_byte(*sstr, &d);
5485             sstr++;
5486         }
5487         SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5488     }
5489     *SvEND(dsv) = '\0';
5490     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
5491     SvTAINT(dsv);
5492     if (flags & SV_SMAGIC)
5493         SvSETMAGIC(dsv);
5494 }
5495
5496 /*
5497 =for apidoc sv_catsv
5498
5499 Concatenates the string from SV C<ssv> onto the end of the string in SV
5500 C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5501 Handles 'get' magic on both SVs, but no 'set' magic.  See C<sv_catsv_mg> and
5502 C<sv_catsv_nomg>.
5503
5504 =for apidoc sv_catsv_flags
5505
5506 Concatenates the string from SV C<ssv> onto the end of the string in SV
5507 C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5508 If C<flags> include C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if
5509 appropriate.  If C<flags> include C<SV_SMAGIC>, C<mg_set> will be called on
5510 the modified SV afterward, if appropriate.  C<sv_catsv>, C<sv_catsv_nomg>,
5511 and C<sv_catsv_mg> are implemented in terms of this function.
5512
5513 =cut */
5514
5515 void
5516 Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
5517 {
5518     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5519
5520     if (ssv) {
5521         STRLEN slen;
5522         const char *spv = SvPV_flags_const(ssv, slen, flags);
5523         if (flags & SV_GMAGIC)
5524                 SvGETMAGIC(dsv);
5525         sv_catpvn_flags(dsv, spv, slen,
5526                             DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
5527         if (flags & SV_SMAGIC)
5528                 SvSETMAGIC(dsv);
5529     }
5530 }
5531
5532 /*
5533 =for apidoc sv_catpv
5534
5535 Concatenates the C<NUL>-terminated string onto the end of the string which is
5536 in the SV.
5537 If the SV has the UTF-8 status set, then the bytes appended should be
5538 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
5539
5540 =cut */
5541
5542 void
5543 Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
5544 {
5545     STRLEN len;
5546     STRLEN tlen;
5547     char *junk;
5548
5549     PERL_ARGS_ASSERT_SV_CATPV;
5550
5551     if (!ptr)
5552         return;
5553     junk = SvPV_force(sv, tlen);
5554     len = strlen(ptr);
5555     SvGROW(sv, tlen + len + 1);
5556     if (ptr == junk)
5557         ptr = SvPVX_const(sv);
5558     Move(ptr,SvPVX(sv)+tlen,len+1,char);
5559     SvCUR_set(sv, SvCUR(sv) + len);
5560     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5561     SvTAINT(sv);
5562 }
5563
5564 /*
5565 =for apidoc sv_catpv_flags
5566
5567 Concatenates the C<NUL>-terminated string onto the end of the string which is
5568 in the SV.
5569 If the SV has the UTF-8 status set, then the bytes appended should
5570 be valid UTF-8.  If C<flags> has the C<SV_SMAGIC> bit set, will C<mg_set>
5571 on the modified SV if appropriate.
5572
5573 =cut
5574 */
5575
5576 void
5577 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
5578 {
5579     PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5580     sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
5581 }
5582
5583 /*
5584 =for apidoc sv_catpv_mg
5585
5586 Like C<sv_catpv>, but also handles 'set' magic.
5587
5588 =cut
5589 */
5590
5591 void
5592 Perl_sv_catpv_mg(pTHX_ SV *const sv, const char *const ptr)
5593 {
5594     PERL_ARGS_ASSERT_SV_CATPV_MG;
5595
5596     sv_catpv(sv,ptr);
5597     SvSETMAGIC(sv);
5598 }
5599
5600 /*
5601 =for apidoc newSV
5602
5603 Creates a new SV.  A non-zero C<len> parameter indicates the number of
5604 bytes of preallocated string space the SV should have.  An extra byte for a
5605 trailing C<NUL> is also reserved.  (SvPOK is not set for the SV even if string
5606 space is allocated.)  The reference count for the new SV is set to 1.
5607
5608 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
5609 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5610 This aid has been superseded by a new build option, PERL_MEM_LOG (see
5611 L<perlhacktips/PERL_MEM_LOG>).  The older API is still there for use in XS
5612 modules supporting older perls.
5613
5614 =cut
5615 */
5616
5617 SV *
5618 Perl_newSV(pTHX_ const STRLEN len)
5619 {
5620     SV *sv;
5621
5622     new_SV(sv);
5623     if (len) {
5624         sv_grow(sv, len + 1);
5625     }
5626     return sv;
5627 }
5628 /*
5629 =for apidoc sv_magicext
5630
5631 Adds magic to an SV, upgrading it if necessary.  Applies the
5632 supplied vtable and returns a pointer to the magic added.
5633
5634 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5635 In particular, you can add magic to SvREADONLY SVs, and add more than
5636 one instance of the same 'how'.
5637
5638 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5639 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5640 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5641 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5642
5643 (This is now used as a subroutine by C<sv_magic>.)
5644
5645 =cut
5646 */
5647 MAGIC * 
5648 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, 
5649                 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5650 {
5651     MAGIC* mg;
5652
5653     PERL_ARGS_ASSERT_SV_MAGICEXT;
5654
5655     SvUPGRADE(sv, SVt_PVMG);
5656     Newxz(mg, 1, MAGIC);
5657     mg->mg_moremagic = SvMAGIC(sv);
5658     SvMAGIC_set(sv, mg);
5659
5660     /* Sometimes a magic contains a reference loop, where the sv and
5661        object refer to each other.  To prevent a reference loop that
5662        would prevent such objects being freed, we look for such loops
5663        and if we find one we avoid incrementing the object refcount.
5664
5665        Note we cannot do this to avoid self-tie loops as intervening RV must
5666        have its REFCNT incremented to keep it in existence.
5667
5668     */
5669     if (!obj || obj == sv ||
5670         how == PERL_MAGIC_arylen ||
5671         how == PERL_MAGIC_symtab ||
5672         (SvTYPE(obj) == SVt_PVGV &&
5673             (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5674              || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5675              || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5676     {
5677         mg->mg_obj = obj;
5678     }
5679     else {
5680         mg->mg_obj = SvREFCNT_inc_simple(obj);
5681         mg->mg_flags |= MGf_REFCOUNTED;
5682     }
5683
5684     /* Normal self-ties simply pass a null object, and instead of
5685        using mg_obj directly, use the SvTIED_obj macro to produce a
5686        new RV as needed.  For glob "self-ties", we are tieing the PVIO
5687        with an RV obj pointing to the glob containing the PVIO.  In
5688        this case, to avoid a reference loop, we need to weaken the
5689        reference.
5690     */
5691
5692     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5693         obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5694     {
5695       sv_rvweaken(obj);
5696     }
5697
5698     mg->mg_type = how;
5699     mg->mg_len = namlen;
5700     if (name) {
5701         if (namlen > 0)
5702             mg->mg_ptr = savepvn(name, namlen);
5703         else if (namlen == HEf_SVKEY) {
5704             /* Yes, this is casting away const. This is only for the case of
5705                HEf_SVKEY. I think we need to document this aberation of the
5706                constness of the API, rather than making name non-const, as
5707                that change propagating outwards a long way.  */
5708             mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5709         } else
5710             mg->mg_ptr = (char *) name;
5711     }
5712     mg->mg_virtual = (MGVTBL *) vtable;
5713
5714     mg_magical(sv);
5715     return mg;
5716 }
5717
5718 MAGIC *
5719 Perl_sv_magicext_mglob(pTHX_ SV *sv)
5720 {
5721     PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB;
5722     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
5723         /* This sv is only a delegate.  //g magic must be attached to
5724            its target. */
5725         vivify_defelem(sv);
5726         sv = LvTARG(sv);
5727     }
5728 #ifdef PERL_OLD_COPY_ON_WRITE
5729     if (SvIsCOW(sv))
5730         sv_force_normal_flags(sv, 0);
5731 #endif
5732     return sv_magicext(sv, NULL, PERL_MAGIC_regex_global,
5733                        &PL_vtbl_mglob, 0, 0);
5734 }
5735
5736 /*
5737 =for apidoc sv_magic
5738
5739 Adds magic to an SV.  First upgrades C<sv> to type C<SVt_PVMG> if
5740 necessary, then adds a new magic item of type C<how> to the head of the
5741 magic list.
5742
5743 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5744 handling of the C<name> and C<namlen> arguments.
5745
5746 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5747 to add more than one instance of the same 'how'.
5748
5749 =cut
5750 */
5751
5752 void
5753 Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
5754              const char *const name, const I32 namlen)
5755 {
5756     const MGVTBL *vtable;
5757     MAGIC* mg;
5758     unsigned int flags;
5759     unsigned int vtable_index;
5760
5761     PERL_ARGS_ASSERT_SV_MAGIC;
5762
5763     if (how < 0 || (unsigned)how >= C_ARRAY_LENGTH(PL_magic_data)
5764         || ((flags = PL_magic_data[how]),
5765             (vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
5766             > magic_vtable_max))
5767         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5768
5769     /* PERL_MAGIC_ext is reserved for use by extensions not perl internals.
5770        Useful for attaching extension internal data to perl vars.
5771        Note that multiple extensions may clash if magical scalars
5772        etc holding private data from one are passed to another. */
5773
5774     vtable = (vtable_index == magic_vtable_max)
5775         ? NULL : PL_magic_vtables + vtable_index;
5776
5777 #ifdef PERL_OLD_COPY_ON_WRITE
5778     if (SvIsCOW(sv))
5779         sv_force_normal_flags(sv, 0);
5780 #endif
5781     if (SvREADONLY(sv)) {
5782         if (
5783             !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
5784            )
5785         {
5786             Perl_croak_no_modify();
5787         }
5788     }
5789     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5790         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5791             /* sv_magic() refuses to add a magic of the same 'how' as an
5792                existing one
5793              */
5794             if (how == PERL_MAGIC_taint)
5795                 mg->mg_len |= 1;
5796             return;
5797         }
5798     }
5799
5800     /* Force pos to be stored as characters, not bytes. */
5801     if (SvMAGICAL(sv) && DO_UTF8(sv)
5802       && (mg = mg_find(sv, PERL_MAGIC_regex_global))
5803       && mg->mg_len != -1
5804       && mg->mg_flags & MGf_BYTES) {
5805         mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len,
5806                                                SV_CONST_RETURN);
5807         mg->mg_flags &= ~MGf_BYTES;
5808     }
5809
5810     /* Rest of work is done else where */
5811     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5812
5813     switch (how) {
5814     case PERL_MAGIC_taint:
5815         mg->mg_len = 1;
5816         break;
5817     case PERL_MAGIC_ext:
5818     case PERL_MAGIC_dbfile:
5819         SvRMAGICAL_on(sv);
5820         break;
5821     }
5822 }
5823
5824 static int
5825 S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
5826 {
5827     MAGIC* mg;
5828     MAGIC** mgp;
5829
5830     assert(flags <= 1);
5831
5832     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5833         return 0;
5834     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5835     for (mg = *mgp; mg; mg = *mgp) {
5836         const MGVTBL* const virt = mg->mg_virtual;
5837         if (mg->mg_type == type && (!flags || virt == vtbl)) {
5838             *mgp = mg->mg_moremagic;
5839             if (virt && virt->svt_free)
5840                 virt->svt_free(aTHX_ sv, mg);
5841             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5842                 if (mg->mg_len > 0)
5843                     Safefree(mg->mg_ptr);
5844                 else if (mg->mg_len == HEf_SVKEY)
5845                     SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5846                 else if (mg->mg_type == PERL_MAGIC_utf8)
5847                     Safefree(mg->mg_ptr);
5848             }
5849             if (mg->mg_flags & MGf_REFCOUNTED)
5850                 SvREFCNT_dec(mg->mg_obj);
5851             Safefree(mg);
5852         }
5853         else
5854             mgp = &mg->mg_moremagic;
5855     }
5856     if (SvMAGIC(sv)) {
5857         if (SvMAGICAL(sv))      /* if we're under save_magic, wait for restore_magic; */
5858             mg_magical(sv);     /*    else fix the flags now */
5859     }
5860     else {
5861         SvMAGICAL_off(sv);
5862         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5863     }
5864     return 0;
5865 }
5866
5867 /*
5868 =for apidoc sv_unmagic
5869
5870 Removes all magic of type C<type> from an SV.
5871
5872 =cut
5873 */
5874
5875 int
5876 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5877 {
5878     PERL_ARGS_ASSERT_SV_UNMAGIC;
5879     return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
5880 }
5881
5882 /*
5883 =for apidoc sv_unmagicext
5884
5885 Removes all magic of type C<type> with the specified C<vtbl> from an SV.
5886
5887 =cut
5888 */
5889
5890 int
5891 Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
5892 {
5893     PERL_ARGS_ASSERT_SV_UNMAGICEXT;
5894     return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
5895 }
5896
5897 /*
5898 =for apidoc sv_rvweaken
5899
5900 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5901 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5902 push a back-reference to this RV onto the array of backreferences
5903 associated with that magic.  If the RV is magical, set magic will be
5904 called after the RV is cleared.
5905
5906 =cut
5907 */
5908
5909 SV *
5910 Perl_sv_rvweaken(pTHX_ SV *const sv)
5911 {
5912     SV *tsv;
5913
5914     PERL_ARGS_ASSERT_SV_RVWEAKEN;
5915
5916     if (!SvOK(sv))  /* let undefs pass */
5917         return sv;
5918     if (!SvROK(sv))
5919         Perl_croak(aTHX_ "Can't weaken a nonreference");
5920     else if (SvWEAKREF(sv)) {
5921         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5922         return sv;
5923     }
5924     else if (SvREADONLY(sv)) croak_no_modify();
5925     tsv = SvRV(sv);
5926     Perl_sv_add_backref(aTHX_ tsv, sv);
5927     SvWEAKREF_on(sv);
5928     SvREFCNT_dec_NN(tsv);
5929     return sv;
5930 }
5931
5932 /* Give tsv backref magic if it hasn't already got it, then push a
5933  * back-reference to sv onto the array associated with the backref magic.
5934  *
5935  * As an optimisation, if there's only one backref and it's not an AV,
5936  * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5937  * allocate an AV. (Whether the slot holds an AV tells us whether this is
5938  * active.)
5939  */
5940
5941 /* A discussion about the backreferences array and its refcount:
5942  *
5943  * The AV holding the backreferences is pointed to either as the mg_obj of
5944  * PERL_MAGIC_backref, or in the specific case of a HV, from the
5945  * xhv_backreferences field. The array is created with a refcount
5946  * of 2. This means that if during global destruction the array gets
5947  * picked on before its parent to have its refcount decremented by the
5948  * random zapper, it won't actually be freed, meaning it's still there for
5949  * when its parent gets freed.
5950  *
5951  * When the parent SV is freed, the extra ref is killed by
5952  * Perl_sv_kill_backrefs.  The other ref is killed, in the case of magic,
5953  * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5954  *
5955  * When a single backref SV is stored directly, it is not reference
5956  * counted.
5957  */
5958
5959 void
5960 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5961 {
5962     SV **svp;
5963     AV *av = NULL;
5964     MAGIC *mg = NULL;
5965
5966     PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5967
5968     /* find slot to store array or singleton backref */
5969
5970     if (SvTYPE(tsv) == SVt_PVHV) {
5971         svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5972     } else {
5973         if (SvMAGICAL(tsv))
5974             mg = mg_find(tsv, PERL_MAGIC_backref);
5975         if (!mg)
5976             mg = sv_magicext(tsv, NULL, PERL_MAGIC_backref, &PL_vtbl_backref, NULL, 0);
5977         svp = &(mg->mg_obj);
5978     }
5979
5980     /* create or retrieve the array */
5981
5982     if (   (!*svp && SvTYPE(sv) == SVt_PVAV)
5983         || (*svp && SvTYPE(*svp) != SVt_PVAV)
5984     ) {
5985         /* create array */
5986         if (mg)
5987             mg->mg_flags |= MGf_REFCOUNTED;
5988         av = newAV();
5989         AvREAL_off(av);
5990         SvREFCNT_inc_simple_void_NN(av);
5991         /* av now has a refcnt of 2; see discussion above */
5992         av_extend(av, *svp ? 2 : 1);
5993         if (*svp) {
5994             /* move single existing backref to the array */
5995             AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5996         }
5997         *svp = (SV*)av;
5998     }
5999     else {
6000         av = MUTABLE_AV(*svp);
6001         if (!av) {
6002             /* optimisation: store single backref directly in HvAUX or mg_obj */
6003             *svp = sv;
6004             return;
6005         }
6006         assert(SvTYPE(av) == SVt_PVAV);
6007         if (AvFILLp(av) >= AvMAX(av)) {
6008             av_extend(av, AvFILLp(av)+1);
6009         }
6010     }
6011     /* push new backref */
6012     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
6013 }
6014
6015 /* delete a back-reference to ourselves from the backref magic associated
6016  * with the SV we point to.
6017  */
6018
6019 void
6020 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
6021 {
6022     SV **svp = NULL;
6023
6024     PERL_ARGS_ASSERT_SV_DEL_BACKREF;
6025
6026     if (SvTYPE(tsv) == SVt_PVHV) {
6027         if (SvOOK(tsv))
6028             svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
6029     }
6030     else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) {
6031         /* It's possible for the the last (strong) reference to tsv to have
6032            become freed *before* the last thing holding a weak reference.
6033            If both survive longer than the backreferences array, then when
6034            the referent's reference count drops to 0 and it is freed, it's
6035            not able to chase the backreferences, so they aren't NULLed.
6036
6037            For example, a CV holds a weak reference to its stash. If both the
6038            CV and the stash survive longer than the backreferences array,
6039            and the CV gets picked for the SvBREAK() treatment first,
6040            *and* it turns out that the stash is only being kept alive because
6041            of an our variable in the pad of the CV, then midway during CV
6042            destruction the stash gets freed, but CvSTASH() isn't set to NULL.
6043            It ends up pointing to the freed HV. Hence it's chased in here, and
6044            if this block wasn't here, it would hit the !svp panic just below.
6045
6046            I don't believe that "better" destruction ordering is going to help
6047            here - during global destruction there's always going to be the
6048            chance that something goes out of order. We've tried to make it
6049            foolproof before, and it only resulted in evolutionary pressure on
6050            fools. Which made us look foolish for our hubris. :-(
6051         */
6052         return;
6053     }
6054     else {
6055         MAGIC *const mg
6056             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
6057         svp =  mg ? &(mg->mg_obj) : NULL;
6058     }
6059
6060     if (!svp)
6061         Perl_croak(aTHX_ "panic: del_backref, svp=0");
6062     if (!*svp) {
6063         /* It's possible that sv is being freed recursively part way through the
6064            freeing of tsv. If this happens, the backreferences array of tsv has
6065            already been freed, and so svp will be NULL. If this is the case,
6066            we should not panic. Instead, nothing needs doing, so return.  */
6067         if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
6068             return;
6069         Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
6070                    (void*)*svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
6071     }
6072
6073     if (SvTYPE(*svp) == SVt_PVAV) {
6074 #ifdef DEBUGGING
6075         int count = 1;
6076 #endif
6077         AV * const av = (AV*)*svp;
6078         SSize_t fill;
6079         assert(!SvIS_FREED(av));
6080         fill = AvFILLp(av);
6081         assert(fill > -1);
6082         svp = AvARRAY(av);
6083         /* for an SV with N weak references to it, if all those
6084          * weak refs are deleted, then sv_del_backref will be called
6085          * N times and O(N^2) compares will be done within the backref
6086          * array. To ameliorate this potential slowness, we:
6087          * 1) make sure this code is as tight as possible;
6088          * 2) when looking for SV, look for it at both the head and tail of the
6089          *    array first before searching the rest, since some create/destroy
6090          *    patterns will cause the backrefs to be freed in order.
6091          */
6092         if (*svp == sv) {
6093             AvARRAY(av)++;
6094             AvMAX(av)--;
6095         }
6096         else {
6097             SV **p = &svp[fill];
6098             SV *const topsv = *p;
6099             if (topsv != sv) {
6100 #ifdef DEBUGGING
6101                 count = 0;
6102 #endif
6103                 while (--p > svp) {
6104                     if (*p == sv) {
6105                         /* We weren't the last entry.
6106                            An unordered list has this property that you
6107                            can take the last element off the end to fill
6108                            the hole, and it's still an unordered list :-)
6109                         */
6110                         *p = topsv;
6111 #ifdef DEBUGGING
6112                         count++;
6113 #else
6114                         break; /* should only be one */
6115 #endif
6116                     }
6117                 }
6118             }
6119         }
6120         assert(count ==1);
6121         AvFILLp(av) = fill-1;
6122     }
6123     else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) {
6124         /* freed AV; skip */
6125     }
6126     else {
6127         /* optimisation: only a single backref, stored directly */
6128         if (*svp != sv)
6129             Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p",
6130                        (void*)*svp, (void*)sv);
6131         *svp = NULL;
6132     }
6133
6134 }
6135
6136 void
6137 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
6138 {
6139     SV **svp;
6140     SV **last;
6141     bool is_array;
6142
6143     PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
6144
6145     if (!av)
6146         return;
6147
6148     /* after multiple passes through Perl_sv_clean_all() for a thingy
6149      * that has badly leaked, the backref array may have gotten freed,
6150      * since we only protect it against 1 round of cleanup */
6151     if (SvIS_FREED(av)) {
6152         if (PL_in_clean_all) /* All is fair */
6153             return;
6154         Perl_croak(aTHX_
6155                    "panic: magic_killbackrefs (freed backref AV/SV)");
6156     }
6157
6158
6159     is_array = (SvTYPE(av) == SVt_PVAV);
6160     if (is_array) {
6161         assert(!SvIS_FREED(av));
6162         svp = AvARRAY(av);
6163         if (svp)
6164             last = svp + AvFILLp(av);
6165     }
6166     else {
6167         /* optimisation: only a single backref, stored directly */
6168         svp = (SV**)&av;
6169         last = svp;
6170     }
6171
6172     if (svp) {
6173         while (svp <= last) {
6174             if (*svp) {
6175                 SV *const referrer = *svp;
6176                 if (SvWEAKREF(referrer)) {
6177                     /* XXX Should we check that it hasn't changed? */
6178                     assert(SvROK(referrer));
6179                     SvRV_set(referrer, 0);
6180                     SvOK_off(referrer);
6181                     SvWEAKREF_off(referrer);
6182                     SvSETMAGIC(referrer);
6183                 } else if (SvTYPE(referrer) == SVt_PVGV ||
6184                            SvTYPE(referrer) == SVt_PVLV) {
6185                     assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
6186                     /* You lookin' at me?  */
6187                     assert(GvSTASH(referrer));
6188                     assert(GvSTASH(referrer) == (const HV *)sv);
6189                     GvSTASH(referrer) = 0;
6190                 } else if (SvTYPE(referrer) == SVt_PVCV ||
6191                            SvTYPE(referrer) == SVt_PVFM) {
6192                     if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
6193                         /* You lookin' at me?  */
6194                         assert(CvSTASH(referrer));
6195                         assert(CvSTASH(referrer) == (const HV *)sv);
6196                         SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
6197                     }
6198                     else {
6199                         assert(SvTYPE(sv) == SVt_PVGV);
6200                         /* You lookin' at me?  */
6201                         assert(CvGV(referrer));
6202                         assert(CvGV(referrer) == (const GV *)sv);
6203                         anonymise_cv_maybe(MUTABLE_GV(sv),
6204                                                 MUTABLE_CV(referrer));
6205                     }
6206
6207                 } else {
6208                     Perl_croak(aTHX_
6209                                "panic: magic_killbackrefs (flags=%"UVxf")",
6210                                (UV)SvFLAGS(referrer));
6211                 }
6212
6213                 if (is_array)
6214                     *svp = NULL;
6215             }
6216             svp++;
6217         }
6218     }
6219     if (is_array) {
6220         AvFILLp(av) = -1;
6221         SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */
6222     }
6223     return;
6224 }
6225
6226 /*
6227 =for apidoc sv_insert
6228
6229 Inserts a string at the specified offset/length within the SV.  Similar to
6230 the Perl substr() function.  Handles get magic.
6231
6232 =for apidoc sv_insert_flags
6233
6234 Same as C<sv_insert>, but the extra C<flags> are passed to the
6235 C<SvPV_force_flags> that applies to C<bigstr>.
6236
6237 =cut
6238 */
6239
6240 void
6241 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
6242 {
6243     char *big;
6244     char *mid;
6245     char *midend;
6246     char *bigend;
6247     SSize_t i;          /* better be sizeof(STRLEN) or bad things happen */
6248     STRLEN curlen;
6249
6250     PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
6251
6252     if (!bigstr)
6253         Perl_croak(aTHX_ "Can't modify nonexistent substring");
6254     SvPV_force_flags(bigstr, curlen, flags);
6255     (void)SvPOK_only_UTF8(bigstr);
6256     if (offset + len > curlen) {
6257         SvGROW(bigstr, offset+len+1);
6258         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
6259         SvCUR_set(bigstr, offset+len);
6260     }
6261
6262     SvTAINT(bigstr);
6263     i = littlelen - len;
6264     if (i > 0) {                        /* string might grow */
6265         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
6266         mid = big + offset + len;
6267         midend = bigend = big + SvCUR(bigstr);
6268         bigend += i;
6269         *bigend = '\0';
6270         while (midend > mid)            /* shove everything down */
6271             *--bigend = *--midend;
6272         Move(little,big+offset,littlelen,char);
6273         SvCUR_set(bigstr, SvCUR(bigstr) + i);
6274         SvSETMAGIC(bigstr);
6275         return;
6276     }
6277     else if (i == 0) {
6278         Move(little,SvPVX(bigstr)+offset,len,char);
6279         SvSETMAGIC(bigstr);
6280         return;
6281     }
6282
6283     big = SvPVX(bigstr);
6284     mid = big + offset;
6285     midend = mid + len;
6286     bigend = big + SvCUR(bigstr);
6287
6288     if (midend > bigend)
6289         Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p",
6290                    midend, bigend);
6291
6292     if (mid - big > bigend - midend) {  /* faster to shorten from end */
6293         if (littlelen) {
6294             Move(little, mid, littlelen,char);
6295             mid += littlelen;
6296         }
6297         i = bigend - midend;
6298         if (i > 0) {
6299             Move(midend, mid, i,char);
6300             mid += i;
6301         }
6302         *mid = '\0';
6303         SvCUR_set(bigstr, mid - big);
6304     }
6305     else if ((i = mid - big)) { /* faster from front */
6306         midend -= littlelen;
6307         mid = midend;
6308         Move(big, midend - i, i, char);
6309         sv_chop(bigstr,midend-i);
6310         if (littlelen)
6311             Move(little, mid, littlelen,char);
6312     }
6313     else if (littlelen) {
6314         midend -= littlelen;
6315         sv_chop(bigstr,midend);
6316         Move(little,midend,littlelen,char);
6317     }
6318     else {
6319         sv_chop(bigstr,midend);
6320     }
6321     SvSETMAGIC(bigstr);
6322 }
6323
6324 /*
6325 =for apidoc sv_replace
6326
6327 Make the first argument a copy of the second, then delete the original.
6328 The target SV physically takes over ownership of the body of the source SV
6329 and inherits its flags; however, the target keeps any magic it owns,
6330 and any magic in the source is discarded.
6331 Note that this is a rather specialist SV copying operation; most of the
6332 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
6333
6334 =cut
6335 */
6336
6337 void
6338 Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv)
6339 {
6340     const U32 refcnt = SvREFCNT(sv);
6341
6342     PERL_ARGS_ASSERT_SV_REPLACE;
6343
6344     SV_CHECK_THINKFIRST_COW_DROP(sv);
6345     if (SvREFCNT(nsv) != 1) {
6346         Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
6347                    " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
6348     }
6349     if (SvMAGICAL(sv)) {
6350         if (SvMAGICAL(nsv))
6351             mg_free(nsv);
6352         else
6353             sv_upgrade(nsv, SVt_PVMG);
6354         SvMAGIC_set(nsv, SvMAGIC(sv));
6355         SvFLAGS(nsv) |= SvMAGICAL(sv);
6356         SvMAGICAL_off(sv);
6357         SvMAGIC_set(sv, NULL);
6358     }
6359     SvREFCNT(sv) = 0;
6360     sv_clear(sv);
6361     assert(!SvREFCNT(sv));
6362 #ifdef DEBUG_LEAKING_SCALARS
6363     sv->sv_flags  = nsv->sv_flags;
6364     sv->sv_any    = nsv->sv_any;
6365     sv->sv_refcnt = nsv->sv_refcnt;
6366     sv->sv_u      = nsv->sv_u;
6367 #else
6368     StructCopy(nsv,sv,SV);
6369 #endif
6370     if(SvTYPE(sv) == SVt_IV) {
6371         SET_SVANY_FOR_BODYLESS_IV(sv);
6372     }
6373         
6374
6375 #ifdef PERL_OLD_COPY_ON_WRITE
6376     if (SvIsCOW_normal(nsv)) {
6377         /* We need to follow the pointers around the loop to make the
6378            previous SV point to sv, rather than nsv.  */
6379         SV *next;
6380         SV *current = nsv;
6381         while ((next = SV_COW_NEXT_SV(current)) != nsv) {
6382             assert(next);
6383             current = next;
6384             assert(SvPVX_const(current) == SvPVX_const(nsv));
6385         }
6386         /* Make the SV before us point to the SV after us.  */
6387         if (DEBUG_C_TEST) {
6388             PerlIO_printf(Perl_debug_log, "previous is\n");
6389             sv_dump(current);
6390             PerlIO_printf(Perl_debug_log,
6391                           "move it from 0x%"UVxf" to 0x%"UVxf"\n",
6392                           (UV) SV_COW_NEXT_SV(current), (UV) sv);
6393         }
6394         SV_COW_NEXT_SV_SET(current, sv);
6395     }
6396 #endif
6397     SvREFCNT(sv) = refcnt;
6398     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
6399     SvREFCNT(nsv) = 0;
6400     del_SV(nsv);
6401 }
6402
6403 /* We're about to free a GV which has a CV that refers back to us.
6404  * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
6405  * field) */
6406
6407 STATIC void
6408 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
6409 {
6410     SV *gvname;
6411     GV *anongv;
6412
6413     PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
6414
6415     /* be assertive! */
6416     assert(SvREFCNT(gv) == 0);
6417     assert(isGV(gv) && isGV_with_GP(gv));
6418     assert(GvGP(gv));
6419     assert(!CvANON(cv));
6420     assert(CvGV(cv) == gv);
6421     assert(!CvNAMED(cv));
6422
6423     /* will the CV shortly be freed by gp_free() ? */
6424     if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
6425         SvANY(cv)->xcv_gv_u.xcv_gv = NULL;
6426         return;
6427     }
6428
6429     /* if not, anonymise: */
6430     gvname = (GvSTASH(gv) && HvNAME(GvSTASH(gv)) && HvENAME(GvSTASH(gv)))
6431                     ? newSVhek(HvENAME_HEK(GvSTASH(gv)))
6432                     : newSVpvn_flags( "__ANON__", 8, 0 );
6433     sv_catpvs(gvname, "::__ANON__");
6434     anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
6435     SvREFCNT_dec_NN(gvname);
6436
6437     CvANON_on(cv);
6438     CvCVGV_RC_on(cv);
6439     SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
6440 }
6441
6442
6443 /*
6444 =for apidoc sv_clear
6445
6446 Clear an SV: call any destructors, free up any memory used by the body,
6447 and free the body itself.  The SV's head is I<not> freed, although
6448 its type is set to all 1's so that it won't inadvertently be assumed
6449 to be live during global destruction etc.
6450 This function should only be called when REFCNT is zero.  Most of the time
6451 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
6452 instead.
6453
6454 =cut
6455 */
6456
6457 void
6458 Perl_sv_clear(pTHX_ SV *const orig_sv)
6459 {
6460     dVAR;
6461     HV *stash;
6462     U32 type;
6463     const struct body_details *sv_type_details;
6464     SV* iter_sv = NULL;
6465     SV* next_sv = NULL;
6466     SV *sv = orig_sv;
6467     STRLEN hash_index;
6468
6469     PERL_ARGS_ASSERT_SV_CLEAR;
6470
6471     /* within this loop, sv is the SV currently being freed, and
6472      * iter_sv is the most recent AV or whatever that's being iterated
6473      * over to provide more SVs */
6474
6475     while (sv) {
6476
6477         type = SvTYPE(sv);
6478
6479         assert(SvREFCNT(sv) == 0);
6480         assert(SvTYPE(sv) != (svtype)SVTYPEMASK);
6481
6482         if (type <= SVt_IV) {
6483             /* See the comment in sv.h about the collusion between this
6484              * early return and the overloading of the NULL slots in the
6485              * size table.  */
6486             if (SvROK(sv))
6487                 goto free_rv;
6488             SvFLAGS(sv) &= SVf_BREAK;
6489             SvFLAGS(sv) |= SVTYPEMASK;
6490             goto free_head;
6491         }
6492
6493         /* objs are always >= MG, but pad names use the SVs_OBJECT flag
6494            for another purpose  */
6495         assert(!SvOBJECT(sv) || type >= SVt_PVMG);
6496
6497         if (type >= SVt_PVMG) {
6498             if (SvOBJECT(sv)) {
6499                 if (!curse(sv, 1)) goto get_next_sv;
6500                 type = SvTYPE(sv); /* destructor may have changed it */
6501             }
6502             /* Free back-references before magic, in case the magic calls
6503              * Perl code that has weak references to sv. */
6504             if (type == SVt_PVHV) {
6505                 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
6506                 if (SvMAGIC(sv))
6507                     mg_free(sv);
6508             }
6509             else if (SvMAGIC(sv)) {
6510                 /* Free back-references before other types of magic. */
6511                 sv_unmagic(sv, PERL_MAGIC_backref);
6512                 mg_free(sv);
6513             }
6514             SvMAGICAL_off(sv);
6515         }
6516         switch (type) {
6517             /* case SVt_INVLIST: */
6518         case SVt_PVIO:
6519             if (IoIFP(sv) &&
6520                 IoIFP(sv) != PerlIO_stdin() &&
6521