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