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