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