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