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