corelist: fix a typo
[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 < 0x1000 || (newlen & (newlen - 1)))
1577         && newlen != MEM_SIZE_MAX
1578     )
1579         newlen++;
1580 #endif
1581
1582 #if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size)
1583 #define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1584 #endif
1585
1586     if (newlen > SvLEN(sv)) {           /* need more room? */
1587         STRLEN minlen = SvCUR(sv);
1588         minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1589         if (newlen < minlen)
1590             newlen = minlen;
1591 #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1592
1593         /* Don't round up on the first allocation, as odds are pretty good that
1594          * the initial request is accurate as to what is really needed */
1595         if (SvLEN(sv)) {
1596             STRLEN rounded = PERL_STRLEN_ROUNDUP(newlen);
1597             if (rounded > newlen)
1598                 newlen = rounded;
1599         }
1600 #endif
1601         if (SvLEN(sv) && s) {
1602             s = (char*)saferealloc(s, newlen);
1603         }
1604         else {
1605             s = (char*)safemalloc(newlen);
1606             if (SvPVX_const(sv) && SvCUR(sv)) {
1607                 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1608             }
1609         }
1610         SvPV_set(sv, s);
1611 #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1612         /* Do this here, do it once, do it right, and then we will never get
1613            called back into sv_grow() unless there really is some growing
1614            needed.  */
1615         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1616 #else
1617         SvLEN_set(sv, newlen);
1618 #endif
1619     }
1620     return s;
1621 }
1622
1623 /*
1624 =for apidoc sv_setiv
1625
1626 Copies an integer into the given SV, upgrading first if necessary.
1627 Does not handle 'set' magic.  See also C<L</sv_setiv_mg>>.
1628
1629 =cut
1630 */
1631
1632 void
1633 Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
1634 {
1635     PERL_ARGS_ASSERT_SV_SETIV;
1636
1637     SV_CHECK_THINKFIRST_COW_DROP(sv);
1638     switch (SvTYPE(sv)) {
1639     case SVt_NULL:
1640     case SVt_NV:
1641         sv_upgrade(sv, SVt_IV);
1642         break;
1643     case SVt_PV:
1644         sv_upgrade(sv, SVt_PVIV);
1645         break;
1646
1647     case SVt_PVGV:
1648         if (!isGV_with_GP(sv))
1649             break;
1650     case SVt_PVAV:
1651     case SVt_PVHV:
1652     case SVt_PVCV:
1653     case SVt_PVFM:
1654     case SVt_PVIO:
1655         /* diag_listed_as: Can't coerce %s to %s in %s */
1656         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1657                    OP_DESC(PL_op));
1658         break;
1659     default: NOOP;
1660     }
1661     (void)SvIOK_only(sv);                       /* validate number */
1662     SvIV_set(sv, i);
1663     SvTAINT(sv);
1664 }
1665
1666 /*
1667 =for apidoc sv_setiv_mg
1668
1669 Like C<sv_setiv>, but also handles 'set' magic.
1670
1671 =cut
1672 */
1673
1674 void
1675 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1676 {
1677     PERL_ARGS_ASSERT_SV_SETIV_MG;
1678
1679     sv_setiv(sv,i);
1680     SvSETMAGIC(sv);
1681 }
1682
1683 /*
1684 =for apidoc sv_setuv
1685
1686 Copies an unsigned integer into the given SV, upgrading first if necessary.
1687 Does not handle 'set' magic.  See also C<L</sv_setuv_mg>>.
1688
1689 =cut
1690 */
1691
1692 void
1693 Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1694 {
1695     PERL_ARGS_ASSERT_SV_SETUV;
1696
1697     /* With the if statement to ensure that integers are stored as IVs whenever
1698        possible:
1699        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1700
1701        without
1702        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1703
1704        If you wish to remove the following if statement, so that this routine
1705        (and its callers) always return UVs, please benchmark to see what the
1706        effect is. Modern CPUs may be different. Or may not :-)
1707     */
1708     if (u <= (UV)IV_MAX) {
1709        sv_setiv(sv, (IV)u);
1710        return;
1711     }
1712     sv_setiv(sv, 0);
1713     SvIsUV_on(sv);
1714     SvUV_set(sv, u);
1715 }
1716
1717 /*
1718 =for apidoc sv_setuv_mg
1719
1720 Like C<sv_setuv>, but also handles 'set' magic.
1721
1722 =cut
1723 */
1724
1725 void
1726 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1727 {
1728     PERL_ARGS_ASSERT_SV_SETUV_MG;
1729
1730     sv_setuv(sv,u);
1731     SvSETMAGIC(sv);
1732 }
1733
1734 /*
1735 =for apidoc sv_setnv
1736
1737 Copies a double into the given SV, upgrading first if necessary.
1738 Does not handle 'set' magic.  See also C<L</sv_setnv_mg>>.
1739
1740 =cut
1741 */
1742
1743 void
1744 Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1745 {
1746     PERL_ARGS_ASSERT_SV_SETNV;
1747
1748     SV_CHECK_THINKFIRST_COW_DROP(sv);
1749     switch (SvTYPE(sv)) {
1750     case SVt_NULL:
1751     case SVt_IV:
1752         sv_upgrade(sv, SVt_NV);
1753         break;
1754     case SVt_PV:
1755     case SVt_PVIV:
1756         sv_upgrade(sv, SVt_PVNV);
1757         break;
1758
1759     case SVt_PVGV:
1760         if (!isGV_with_GP(sv))
1761             break;
1762     case SVt_PVAV:
1763     case SVt_PVHV:
1764     case SVt_PVCV:
1765     case SVt_PVFM:
1766     case SVt_PVIO:
1767         /* diag_listed_as: Can't coerce %s to %s in %s */
1768         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1769                    OP_DESC(PL_op));
1770         break;
1771     default: NOOP;
1772     }
1773     SvNV_set(sv, num);
1774     (void)SvNOK_only(sv);                       /* validate number */
1775     SvTAINT(sv);
1776 }
1777
1778 /*
1779 =for apidoc sv_setnv_mg
1780
1781 Like C<sv_setnv>, but also handles 'set' magic.
1782
1783 =cut
1784 */
1785
1786 void
1787 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1788 {
1789     PERL_ARGS_ASSERT_SV_SETNV_MG;
1790
1791     sv_setnv(sv,num);
1792     SvSETMAGIC(sv);
1793 }
1794
1795 /* Return a cleaned-up, printable version of sv, for non-numeric, or
1796  * not incrementable warning display.
1797  * Originally part of S_not_a_number().
1798  * The return value may be != tmpbuf.
1799  */
1800
1801 STATIC const char *
1802 S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1803     const char *pv;
1804
1805      PERL_ARGS_ASSERT_SV_DISPLAY;
1806
1807      if (DO_UTF8(sv)) {
1808           SV *dsv = newSVpvs_flags("", SVs_TEMP);
1809           pv = sv_uni_display(dsv, sv, 32, UNI_DISPLAY_ISPRINT);
1810      } else {
1811           char *d = tmpbuf;
1812           const char * const limit = tmpbuf + tmpbuf_size - 8;
1813           /* each *s can expand to 4 chars + "...\0",
1814              i.e. need room for 8 chars */
1815         
1816           const char *s = SvPVX_const(sv);
1817           const char * const end = s + SvCUR(sv);
1818           for ( ; s < end && d < limit; s++ ) {
1819                int ch = *s & 0xFF;
1820                if (! isASCII(ch) && !isPRINT_LC(ch)) {
1821                     *d++ = 'M';
1822                     *d++ = '-';
1823
1824                     /* Map to ASCII "equivalent" of Latin1 */
1825                     ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1826                }
1827                if (ch == '\n') {
1828                     *d++ = '\\';
1829                     *d++ = 'n';
1830                }
1831                else if (ch == '\r') {
1832                     *d++ = '\\';
1833                     *d++ = 'r';
1834                }
1835                else if (ch == '\f') {
1836                     *d++ = '\\';
1837                     *d++ = 'f';
1838                }
1839                else if (ch == '\\') {
1840                     *d++ = '\\';
1841                     *d++ = '\\';
1842                }
1843                else if (ch == '\0') {
1844                     *d++ = '\\';
1845                     *d++ = '0';
1846                }
1847                else if (isPRINT_LC(ch))
1848                     *d++ = ch;
1849                else {
1850                     *d++ = '^';
1851                     *d++ = toCTRL(ch);
1852                }
1853           }
1854           if (s < end) {
1855                *d++ = '.';
1856                *d++ = '.';
1857                *d++ = '.';
1858           }
1859           *d = '\0';
1860           pv = tmpbuf;
1861     }
1862
1863     return pv;
1864 }
1865
1866 /* Print an "isn't numeric" warning, using a cleaned-up,
1867  * printable version of the offending string
1868  */
1869
1870 STATIC void
1871 S_not_a_number(pTHX_ SV *const sv)
1872 {
1873      char tmpbuf[64];
1874      const char *pv;
1875
1876      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1877
1878      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1879
1880     if (PL_op)
1881         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1882                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1883                     "Argument \"%s\" isn't numeric in %s", pv,
1884                     OP_DESC(PL_op));
1885     else
1886         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1887                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1888                     "Argument \"%s\" isn't numeric", pv);
1889 }
1890
1891 STATIC void
1892 S_not_incrementable(pTHX_ SV *const sv) {
1893      char tmpbuf[64];
1894      const char *pv;
1895
1896      PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1897
1898      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1899
1900      Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1901                  "Argument \"%s\" treated as 0 in increment (++)", pv);
1902 }
1903
1904 /*
1905 =for apidoc looks_like_number
1906
1907 Test if the content of an SV looks like a number (or is a number).
1908 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1909 non-numeric warning), even if your C<atof()> doesn't grok them.  Get-magic is
1910 ignored.
1911
1912 =cut
1913 */
1914
1915 I32
1916 Perl_looks_like_number(pTHX_ SV *const sv)
1917 {
1918     const char *sbegin;
1919     STRLEN len;
1920     int numtype;
1921
1922     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1923
1924     if (SvPOK(sv) || SvPOKp(sv)) {
1925         sbegin = SvPV_nomg_const(sv, len);
1926     }
1927     else
1928         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1929     numtype = grok_number(sbegin, len, NULL);
1930     return ((numtype & IS_NUMBER_TRAILING)) ? 0 : numtype;
1931 }
1932
1933 STATIC bool
1934 S_glob_2number(pTHX_ GV * const gv)
1935 {
1936     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1937
1938     /* We know that all GVs stringify to something that is not-a-number,
1939         so no need to test that.  */
1940     if (ckWARN(WARN_NUMERIC))
1941     {
1942         SV *const buffer = sv_newmortal();
1943         gv_efullname3(buffer, gv, "*");
1944         not_a_number(buffer);
1945     }
1946     /* We just want something true to return, so that S_sv_2iuv_common
1947         can tail call us and return true.  */
1948     return TRUE;
1949 }
1950
1951 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1952    until proven guilty, assume that things are not that bad... */
1953
1954 /*
1955    NV_PRESERVES_UV:
1956
1957    As 64 bit platforms often have an NV that doesn't preserve all bits of
1958    an IV (an assumption perl has been based on to date) it becomes necessary
1959    to remove the assumption that the NV always carries enough precision to
1960    recreate the IV whenever needed, and that the NV is the canonical form.
1961    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1962    precision as a side effect of conversion (which would lead to insanity
1963    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1964    1) to distinguish between IV/UV/NV slots that have a valid conversion cached
1965       where precision was lost, and IV/UV/NV slots that have a valid conversion
1966       which has lost no precision
1967    2) to ensure that if a numeric conversion to one form is requested that
1968       would lose precision, the precise conversion (or differently
1969       imprecise conversion) is also performed and cached, to prevent
1970       requests for different numeric formats on the same SV causing
1971       lossy conversion chains. (lossless conversion chains are perfectly
1972       acceptable (still))
1973
1974
1975    flags are used:
1976    SvIOKp is true if the IV slot contains a valid value
1977    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1978    SvNOKp is true if the NV slot contains a valid value
1979    SvNOK  is true only if the NV value is accurate
1980
1981    so
1982    while converting from PV to NV, check to see if converting that NV to an
1983    IV(or UV) would lose accuracy over a direct conversion from PV to
1984    IV(or UV). If it would, cache both conversions, return NV, but mark
1985    SV as IOK NOKp (ie not NOK).
1986
1987    While converting from PV to IV, check to see if converting that IV to an
1988    NV would lose accuracy over a direct conversion from PV to NV. If it
1989    would, cache both conversions, flag similarly.
1990
1991    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1992    correctly because if IV & NV were set NV *always* overruled.
1993    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1994    changes - now IV and NV together means that the two are interchangeable:
1995    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1996
1997    The benefit of this is that operations such as pp_add know that if
1998    SvIOK is true for both left and right operands, then integer addition
1999    can be used instead of floating point (for cases where the result won't
2000    overflow). Before, floating point was always used, which could lead to
2001    loss of precision compared with integer addition.
2002
2003    * making IV and NV equal status should make maths accurate on 64 bit
2004      platforms
2005    * may speed up maths somewhat if pp_add and friends start to use
2006      integers when possible instead of fp. (Hopefully the overhead in
2007      looking for SvIOK and checking for overflow will not outweigh the
2008      fp to integer speedup)
2009    * will slow down integer operations (callers of SvIV) on "inaccurate"
2010      values, as the change from SvIOK to SvIOKp will cause a call into
2011      sv_2iv each time rather than a macro access direct to the IV slot
2012    * should speed up number->string conversion on integers as IV is
2013      favoured when IV and NV are equally accurate
2014
2015    ####################################################################
2016    You had better be using SvIOK_notUV if you want an IV for arithmetic:
2017    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2018    On the other hand, SvUOK is true iff UV.
2019    ####################################################################
2020
2021    Your mileage will vary depending your CPU's relative fp to integer
2022    performance ratio.
2023 */
2024
2025 #ifndef NV_PRESERVES_UV
2026 #  define IS_NUMBER_UNDERFLOW_IV 1
2027 #  define IS_NUMBER_UNDERFLOW_UV 2
2028 #  define IS_NUMBER_IV_AND_UV    2
2029 #  define IS_NUMBER_OVERFLOW_IV  4
2030 #  define IS_NUMBER_OVERFLOW_UV  5
2031
2032 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2033
2034 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
2035 STATIC int
2036 S_sv_2iuv_non_preserve(pTHX_ SV *const sv
2037 #  ifdef DEBUGGING
2038                        , I32 numtype
2039 #  endif
2040                        )
2041 {
2042     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
2043     PERL_UNUSED_CONTEXT;
2044
2045     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));
2046     if (SvNVX(sv) < (NV)IV_MIN) {
2047         (void)SvIOKp_on(sv);
2048         (void)SvNOK_on(sv);
2049         SvIV_set(sv, IV_MIN);
2050         return IS_NUMBER_UNDERFLOW_IV;
2051     }
2052     if (SvNVX(sv) > (NV)UV_MAX) {
2053         (void)SvIOKp_on(sv);
2054         (void)SvNOK_on(sv);
2055         SvIsUV_on(sv);
2056         SvUV_set(sv, UV_MAX);
2057         return IS_NUMBER_OVERFLOW_UV;
2058     }
2059     (void)SvIOKp_on(sv);
2060     (void)SvNOK_on(sv);
2061     /* Can't use strtol etc to convert this string.  (See truth table in
2062        sv_2iv  */
2063     if (SvNVX(sv) <= (UV)IV_MAX) {
2064         SvIV_set(sv, I_V(SvNVX(sv)));
2065         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2066             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2067         } else {
2068             /* Integer is imprecise. NOK, IOKp */
2069         }
2070         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2071     }
2072     SvIsUV_on(sv);
2073     SvUV_set(sv, U_V(SvNVX(sv)));
2074     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2075         if (SvUVX(sv) == UV_MAX) {
2076             /* As we know that NVs don't preserve UVs, UV_MAX cannot
2077                possibly be preserved by NV. Hence, it must be overflow.
2078                NOK, IOKp */
2079             return IS_NUMBER_OVERFLOW_UV;
2080         }
2081         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2082     } else {
2083         /* Integer is imprecise. NOK, IOKp */
2084     }
2085     return IS_NUMBER_OVERFLOW_IV;
2086 }
2087 #endif /* !NV_PRESERVES_UV*/
2088
2089 /* If numtype is infnan, set the NV of the sv accordingly.
2090  * If numtype is anything else, try setting the NV using Atof(PV). */
2091 #ifdef USING_MSVC6
2092 #  pragma warning(push)
2093 #  pragma warning(disable:4756;disable:4056)
2094 #endif
2095 static void
2096 S_sv_setnv(pTHX_ SV* sv, int numtype)
2097 {
2098     bool pok = cBOOL(SvPOK(sv));
2099     bool nok = FALSE;
2100     if ((numtype & IS_NUMBER_INFINITY)) {
2101         SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
2102         nok = TRUE;
2103     }
2104     else if ((numtype & IS_NUMBER_NAN)) {
2105         SvNV_set(sv, NV_NAN);
2106         nok = TRUE;
2107     }
2108     else if (pok) {
2109         SvNV_set(sv, Atof(SvPVX_const(sv)));
2110         /* Purposefully no true nok here, since we don't want to blow
2111          * away the possible IOK/UV of an existing sv. */
2112     }
2113     if (nok) {
2114         SvNOK_only(sv); /* No IV or UV please, this is pure infnan. */
2115         if (pok)
2116             SvPOK_on(sv); /* PV is okay, though. */
2117     }
2118 }
2119 #ifdef USING_MSVC6
2120 #  pragma warning(pop)
2121 #endif
2122
2123 STATIC bool
2124 S_sv_2iuv_common(pTHX_ SV *const sv)
2125 {
2126     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2127
2128     if (SvNOKp(sv)) {
2129         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2130          * without also getting a cached IV/UV from it at the same time
2131          * (ie PV->NV conversion should detect loss of accuracy and cache
2132          * IV or UV at same time to avoid this. */
2133         /* IV-over-UV optimisation - choose to cache IV if possible */
2134
2135         if (SvTYPE(sv) == SVt_NV)
2136             sv_upgrade(sv, SVt_PVNV);
2137
2138         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2139         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2140            certainly cast into the IV range at IV_MAX, whereas the correct
2141            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2142            cases go to UV */
2143 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2144         if (Perl_isnan(SvNVX(sv))) {
2145             SvUV_set(sv, 0);
2146             SvIsUV_on(sv);
2147             return FALSE;
2148         }
2149 #endif
2150         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2151             SvIV_set(sv, I_V(SvNVX(sv)));
2152             if (SvNVX(sv) == (NV) SvIVX(sv)
2153 #ifndef NV_PRESERVES_UV
2154                 && SvIVX(sv) != IV_MIN /* avoid negating IV_MIN below */
2155                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2156                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2157                 /* Don't flag it as "accurately an integer" if the number
2158                    came from a (by definition imprecise) NV operation, and
2159                    we're outside the range of NV integer precision */
2160 #endif
2161                 ) {
2162                 if (SvNOK(sv))
2163                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2164                 else {
2165                     /* scalar has trailing garbage, eg "42a" */
2166                 }
2167                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2168                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2169                                       PTR2UV(sv),
2170                                       SvNVX(sv),
2171                                       SvIVX(sv)));
2172
2173             } else {
2174                 /* IV not precise.  No need to convert from PV, as NV
2175                    conversion would already have cached IV if it detected
2176                    that PV->IV would be better than PV->NV->IV
2177                    flags already correct - don't set public IOK.  */
2178                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2179                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2180                                       PTR2UV(sv),
2181                                       SvNVX(sv),
2182                                       SvIVX(sv)));
2183             }
2184             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2185                but the cast (NV)IV_MIN rounds to a the value less (more
2186                negative) than IV_MIN which happens to be equal to SvNVX ??
2187                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2188                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2189                (NV)UVX == NVX are both true, but the values differ. :-(
2190                Hopefully for 2s complement IV_MIN is something like
2191                0x8000000000000000 which will be exact. NWC */
2192         }
2193         else {
2194             SvUV_set(sv, U_V(SvNVX(sv)));
2195             if (
2196                 (SvNVX(sv) == (NV) SvUVX(sv))
2197 #ifndef  NV_PRESERVES_UV
2198                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2199                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2200                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2201                 /* Don't flag it as "accurately an integer" if the number
2202                    came from a (by definition imprecise) NV operation, and
2203                    we're outside the range of NV integer precision */
2204 #endif
2205                 && SvNOK(sv)
2206                 )
2207                 SvIOK_on(sv);
2208             SvIsUV_on(sv);
2209             DEBUG_c(PerlIO_printf(Perl_debug_log,
2210                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2211                                   PTR2UV(sv),
2212                                   SvUVX(sv),
2213                                   SvUVX(sv)));
2214         }
2215     }
2216     else if (SvPOKp(sv)) {
2217         UV value;
2218         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2219         /* We want to avoid a possible problem when we cache an IV/ a UV which
2220            may be later translated to an NV, and the resulting NV is not
2221            the same as the direct translation of the initial string
2222            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2223            be careful to ensure that the value with the .456 is around if the
2224            NV value is requested in the future).
2225         
2226            This means that if we cache such an IV/a UV, we need to cache the
2227            NV as well.  Moreover, we trade speed for space, and do not
2228            cache the NV if we are sure it's not needed.
2229          */
2230
2231         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2232         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2233              == IS_NUMBER_IN_UV) {
2234             /* It's definitely an integer, only upgrade to PVIV */
2235             if (SvTYPE(sv) < SVt_PVIV)
2236                 sv_upgrade(sv, SVt_PVIV);
2237             (void)SvIOK_on(sv);
2238         } else if (SvTYPE(sv) < SVt_PVNV)
2239             sv_upgrade(sv, SVt_PVNV);
2240
2241         if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
2242             if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING)))
2243                 not_a_number(sv);
2244             S_sv_setnv(aTHX_ sv, numtype);
2245             return FALSE;
2246         }
2247
2248         /* If NVs preserve UVs then we only use the UV value if we know that
2249            we aren't going to call atof() below. If NVs don't preserve UVs
2250            then the value returned may have more precision than atof() will
2251            return, even though value isn't perfectly accurate.  */
2252         if ((numtype & (IS_NUMBER_IN_UV
2253 #ifdef NV_PRESERVES_UV
2254                         | IS_NUMBER_NOT_INT
2255 #endif
2256             )) == IS_NUMBER_IN_UV) {
2257             /* This won't turn off the public IOK flag if it was set above  */
2258             (void)SvIOKp_on(sv);
2259
2260             if (!(numtype & IS_NUMBER_NEG)) {
2261                 /* positive */;
2262                 if (value <= (UV)IV_MAX) {
2263                     SvIV_set(sv, (IV)value);
2264                 } else {
2265                     /* it didn't overflow, and it was positive. */
2266                     SvUV_set(sv, value);
2267                     SvIsUV_on(sv);
2268                 }
2269             } else {
2270                 /* 2s complement assumption  */
2271                 if (value <= (UV)IV_MIN) {
2272                     SvIV_set(sv, value == (UV)IV_MIN
2273                                     ? IV_MIN : -(IV)value);
2274                 } else {
2275                     /* Too negative for an IV.  This is a double upgrade, but
2276                        I'm assuming it will be rare.  */
2277                     if (SvTYPE(sv) < SVt_PVNV)
2278                         sv_upgrade(sv, SVt_PVNV);
2279                     SvNOK_on(sv);
2280                     SvIOK_off(sv);
2281                     SvIOKp_on(sv);
2282                     SvNV_set(sv, -(NV)value);
2283                     SvIV_set(sv, IV_MIN);
2284                 }
2285             }
2286         }
2287         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2288            will be in the previous block to set the IV slot, and the next
2289            block to set the NV slot.  So no else here.  */
2290         
2291         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2292             != IS_NUMBER_IN_UV) {
2293             /* It wasn't an (integer that doesn't overflow the UV). */
2294             S_sv_setnv(aTHX_ sv, numtype);
2295
2296             if (! numtype && ckWARN(WARN_NUMERIC))
2297                 not_a_number(sv);
2298
2299             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" NVgf ")\n",
2300                                   PTR2UV(sv), SvNVX(sv)));
2301
2302 #ifdef NV_PRESERVES_UV
2303             (void)SvIOKp_on(sv);
2304             (void)SvNOK_on(sv);
2305 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2306             if (Perl_isnan(SvNVX(sv))) {
2307                 SvUV_set(sv, 0);
2308                 SvIsUV_on(sv);
2309                 return FALSE;
2310             }
2311 #endif
2312             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2313                 SvIV_set(sv, I_V(SvNVX(sv)));
2314                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2315                     SvIOK_on(sv);
2316                 } else {
2317                     NOOP;  /* Integer is imprecise. NOK, IOKp */
2318                 }
2319                 /* UV will not work better than IV */
2320             } else {
2321                 if (SvNVX(sv) > (NV)UV_MAX) {
2322                     SvIsUV_on(sv);
2323                     /* Integer is inaccurate. NOK, IOKp, is UV */
2324                     SvUV_set(sv, UV_MAX);
2325                 } else {
2326                     SvUV_set(sv, U_V(SvNVX(sv)));
2327                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2328                        NV preservse UV so can do correct comparison.  */
2329                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2330                         SvIOK_on(sv);
2331                     } else {
2332                         NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
2333                     }
2334                 }
2335                 SvIsUV_on(sv);
2336             }
2337 #else /* NV_PRESERVES_UV */
2338             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2339                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2340                 /* The IV/UV slot will have been set from value returned by
2341                    grok_number above.  The NV slot has just been set using
2342                    Atof.  */
2343                 SvNOK_on(sv);
2344                 assert (SvIOKp(sv));
2345             } else {
2346                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2347                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2348                     /* Small enough to preserve all bits. */
2349                     (void)SvIOKp_on(sv);
2350                     SvNOK_on(sv);
2351                     SvIV_set(sv, I_V(SvNVX(sv)));
2352                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2353                         SvIOK_on(sv);
2354                     /* Assumption: first non-preserved integer is < IV_MAX,
2355                        this NV is in the preserved range, therefore: */
2356                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2357                           < (UV)IV_MAX)) {
2358                         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);
2359                     }
2360                 } else {
2361                     /* IN_UV NOT_INT
2362                          0      0       already failed to read UV.
2363                          0      1       already failed to read UV.
2364                          1      0       you won't get here in this case. IV/UV
2365                                         slot set, public IOK, Atof() unneeded.
2366                          1      1       already read UV.
2367                        so there's no point in sv_2iuv_non_preserve() attempting
2368                        to use atol, strtol, strtoul etc.  */
2369 #  ifdef DEBUGGING
2370                     sv_2iuv_non_preserve (sv, numtype);
2371 #  else
2372                     sv_2iuv_non_preserve (sv);
2373 #  endif
2374                 }
2375             }
2376 #endif /* NV_PRESERVES_UV */
2377         /* It might be more code efficient to go through the entire logic above
2378            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2379            gets complex and potentially buggy, so more programmer efficient
2380            to do it this way, by turning off the public flags:  */
2381         if (!numtype)
2382             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2383         }
2384     }
2385     else  {
2386         if (isGV_with_GP(sv))
2387             return glob_2number(MUTABLE_GV(sv));
2388
2389         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2390                 report_uninit(sv);
2391         if (SvTYPE(sv) < SVt_IV)
2392             /* Typically the caller expects that sv_any is not NULL now.  */
2393             sv_upgrade(sv, SVt_IV);
2394         /* Return 0 from the caller.  */
2395         return TRUE;
2396     }
2397     return FALSE;
2398 }
2399
2400 /*
2401 =for apidoc sv_2iv_flags
2402
2403 Return the integer value of an SV, doing any necessary string
2404 conversion.  If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2405 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2406
2407 =cut
2408 */
2409
2410 IV
2411 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2412 {
2413     PERL_ARGS_ASSERT_SV_2IV_FLAGS;
2414
2415     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2416          && SvTYPE(sv) != SVt_PVFM);
2417
2418     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2419         mg_get(sv);
2420
2421     if (SvROK(sv)) {
2422         if (SvAMAGIC(sv)) {
2423             SV * tmpstr;
2424             if (flags & SV_SKIP_OVERLOAD)
2425                 return 0;
2426             tmpstr = AMG_CALLunary(sv, numer_amg);
2427             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2428                 return SvIV(tmpstr);
2429             }
2430         }
2431         return PTR2IV(SvRV(sv));
2432     }
2433
2434     if (SvVALID(sv) || isREGEXP(sv)) {
2435         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2436            the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2437            In practice they are extremely unlikely to actually get anywhere
2438            accessible by user Perl code - the only way that I'm aware of is when
2439            a constant subroutine which is used as the second argument to index.
2440
2441            Regexps have no SvIVX and SvNVX fields.
2442         */
2443         assert(isREGEXP(sv) || SvPOKp(sv));
2444         {
2445             UV value;
2446             const char * const ptr =
2447                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2448             const int numtype
2449                 = grok_number(ptr, SvCUR(sv), &value);
2450
2451             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2452                 == IS_NUMBER_IN_UV) {
2453                 /* It's definitely an integer */
2454                 if (numtype & IS_NUMBER_NEG) {
2455                     if (value < (UV)IV_MIN)
2456                         return -(IV)value;
2457                 } else {
2458                     if (value < (UV)IV_MAX)
2459                         return (IV)value;
2460                 }
2461             }
2462
2463             /* Quite wrong but no good choices. */
2464             if ((numtype & IS_NUMBER_INFINITY)) {
2465                 return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX;
2466             } else if ((numtype & IS_NUMBER_NAN)) {
2467                 return 0; /* So wrong. */
2468             }
2469
2470             if (!numtype) {
2471                 if (ckWARN(WARN_NUMERIC))
2472                     not_a_number(sv);
2473             }
2474             return I_V(Atof(ptr));
2475         }
2476     }
2477
2478     if (SvTHINKFIRST(sv)) {
2479         if (SvREADONLY(sv) && !SvOK(sv)) {
2480             if (ckWARN(WARN_UNINITIALIZED))
2481                 report_uninit(sv);
2482             return 0;
2483         }
2484     }
2485
2486     if (!SvIOKp(sv)) {
2487         if (S_sv_2iuv_common(aTHX_ sv))
2488             return 0;
2489     }
2490
2491     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2492         PTR2UV(sv),SvIVX(sv)));
2493     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2494 }
2495
2496 /*
2497 =for apidoc sv_2uv_flags
2498
2499 Return the unsigned integer value of an SV, doing any necessary string
2500 conversion.  If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2501 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2502
2503 =cut
2504 */
2505
2506 UV
2507 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2508 {
2509     PERL_ARGS_ASSERT_SV_2UV_FLAGS;
2510
2511     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2512         mg_get(sv);
2513
2514     if (SvROK(sv)) {
2515         if (SvAMAGIC(sv)) {
2516             SV *tmpstr;
2517             if (flags & SV_SKIP_OVERLOAD)
2518                 return 0;
2519             tmpstr = AMG_CALLunary(sv, numer_amg);
2520             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2521                 return SvUV(tmpstr);
2522             }
2523         }
2524         return PTR2UV(SvRV(sv));
2525     }
2526
2527     if (SvVALID(sv) || isREGEXP(sv)) {
2528         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2529            the same flag bit as SVf_IVisUV, so must not let them cache IVs.  
2530            Regexps have no SvIVX and SvNVX fields. */
2531         assert(isREGEXP(sv) || SvPOKp(sv));
2532         {
2533             UV value;
2534             const char * const ptr =
2535                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2536             const int numtype
2537                 = grok_number(ptr, SvCUR(sv), &value);
2538
2539             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2540                 == IS_NUMBER_IN_UV) {
2541                 /* It's definitely an integer */
2542                 if (!(numtype & IS_NUMBER_NEG))
2543                     return value;
2544             }
2545
2546             /* Quite wrong but no good choices. */
2547             if ((numtype & IS_NUMBER_INFINITY)) {
2548                 return UV_MAX; /* So wrong. */
2549             } else if ((numtype & IS_NUMBER_NAN)) {
2550                 return 0; /* So wrong. */
2551             }
2552
2553             if (!numtype) {
2554                 if (ckWARN(WARN_NUMERIC))
2555                     not_a_number(sv);
2556             }
2557             return U_V(Atof(ptr));
2558         }
2559     }
2560
2561     if (SvTHINKFIRST(sv)) {
2562         if (SvREADONLY(sv) && !SvOK(sv)) {
2563             if (ckWARN(WARN_UNINITIALIZED))
2564                 report_uninit(sv);
2565             return 0;
2566         }
2567     }
2568
2569     if (!SvIOKp(sv)) {
2570         if (S_sv_2iuv_common(aTHX_ sv))
2571             return 0;
2572     }
2573
2574     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2575                           PTR2UV(sv),SvUVX(sv)));
2576     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2577 }
2578
2579 /*
2580 =for apidoc sv_2nv_flags
2581
2582 Return the num value of an SV, doing any necessary string or integer
2583 conversion.  If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2584 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2585
2586 =cut
2587 */
2588
2589 NV
2590 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2591 {
2592     PERL_ARGS_ASSERT_SV_2NV_FLAGS;
2593
2594     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2595          && SvTYPE(sv) != SVt_PVFM);
2596     if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
2597         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2598            the same flag bit as SVf_IVisUV, so must not let them cache NVs.
2599            Regexps have no SvIVX and SvNVX fields.  */
2600         const char *ptr;
2601         if (flags & SV_GMAGIC)
2602             mg_get(sv);
2603         if (SvNOKp(sv))
2604             return SvNVX(sv);
2605         if (SvPOKp(sv) && !SvIOKp(sv)) {
2606             ptr = SvPVX_const(sv);
2607           grokpv:
2608             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2609                 !grok_number(ptr, SvCUR(sv), NULL))
2610                 not_a_number(sv);
2611             return Atof(ptr);
2612         }
2613         if (SvIOKp(sv)) {
2614             if (SvIsUV(sv))
2615                 return (NV)SvUVX(sv);
2616             else
2617                 return (NV)SvIVX(sv);
2618         }
2619         if (SvROK(sv)) {
2620             goto return_rok;
2621         }
2622         if (isREGEXP(sv)) {
2623             ptr = RX_WRAPPED((REGEXP *)sv);
2624             goto grokpv;
2625         }
2626         assert(SvTYPE(sv) >= SVt_PVMG);
2627         /* This falls through to the report_uninit near the end of the
2628            function. */
2629     } else if (SvTHINKFIRST(sv)) {
2630         if (SvROK(sv)) {
2631         return_rok:
2632             if (SvAMAGIC(sv)) {
2633                 SV *tmpstr;
2634                 if (flags & SV_SKIP_OVERLOAD)
2635                     return 0;
2636                 tmpstr = AMG_CALLunary(sv, numer_amg);
2637                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2638                     return SvNV(tmpstr);
2639                 }
2640             }
2641             return PTR2NV(SvRV(sv));
2642         }
2643         if (SvREADONLY(sv) && !SvOK(sv)) {
2644             if (ckWARN(WARN_UNINITIALIZED))
2645                 report_uninit(sv);
2646             return 0.0;
2647         }
2648     }
2649     if (SvTYPE(sv) < SVt_NV) {
2650         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2651         sv_upgrade(sv, SVt_NV);
2652         DEBUG_c({
2653             STORE_NUMERIC_LOCAL_SET_STANDARD();
2654             PerlIO_printf(Perl_debug_log,
2655                           "0x%"UVxf" num(%" NVgf ")\n",
2656                           PTR2UV(sv), SvNVX(sv));
2657             RESTORE_NUMERIC_LOCAL();
2658         });
2659     }
2660     else if (SvTYPE(sv) < SVt_PVNV)
2661         sv_upgrade(sv, SVt_PVNV);
2662     if (SvNOKp(sv)) {
2663         return SvNVX(sv);
2664     }
2665     if (SvIOKp(sv)) {
2666         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2667 #ifdef NV_PRESERVES_UV
2668         if (SvIOK(sv))
2669             SvNOK_on(sv);
2670         else
2671             SvNOKp_on(sv);
2672 #else
2673         /* Only set the public NV OK flag if this NV preserves the IV  */
2674         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2675         if (SvIOK(sv) &&
2676             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2677                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2678             SvNOK_on(sv);
2679         else
2680             SvNOKp_on(sv);
2681 #endif
2682     }
2683     else if (SvPOKp(sv)) {
2684         UV value;
2685         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2686         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2687             not_a_number(sv);
2688 #ifdef NV_PRESERVES_UV
2689         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2690             == IS_NUMBER_IN_UV) {
2691             /* It's definitely an integer */
2692             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2693         } else {
2694             S_sv_setnv(aTHX_ sv, numtype);
2695         }
2696         if (numtype)
2697             SvNOK_on(sv);
2698         else
2699             SvNOKp_on(sv);
2700 #else
2701         SvNV_set(sv, Atof(SvPVX_const(sv)));
2702         /* Only set the public NV OK flag if this NV preserves the value in
2703            the PV at least as well as an IV/UV would.
2704            Not sure how to do this 100% reliably. */
2705         /* if that shift count is out of range then Configure's test is
2706            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2707            UV_BITS */
2708         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2709             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2710             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2711         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2712             /* Can't use strtol etc to convert this string, so don't try.
2713                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2714             SvNOK_on(sv);
2715         } else {
2716             /* value has been set.  It may not be precise.  */
2717             if ((numtype & IS_NUMBER_NEG) && (value >= (UV)IV_MIN)) {
2718                 /* 2s complement assumption for (UV)IV_MIN  */
2719                 SvNOK_on(sv); /* Integer is too negative.  */
2720             } else {
2721                 SvNOKp_on(sv);
2722                 SvIOKp_on(sv);
2723
2724                 if (numtype & IS_NUMBER_NEG) {
2725                     /* -IV_MIN is undefined, but we should never reach
2726                      * this point with both IS_NUMBER_NEG and value ==
2727                      * (UV)IV_MIN */
2728                     assert(value != (UV)IV_MIN);
2729                     SvIV_set(sv, -(IV)value);
2730                 } else if (value <= (UV)IV_MAX) {
2731                     SvIV_set(sv, (IV)value);
2732                 } else {
2733                     SvUV_set(sv, value);
2734                     SvIsUV_on(sv);
2735                 }
2736
2737                 if (numtype & IS_NUMBER_NOT_INT) {
2738                     /* I believe that even if the original PV had decimals,
2739                        they are lost beyond the limit of the FP precision.
2740                        However, neither is canonical, so both only get p
2741                        flags.  NWC, 2000/11/25 */
2742                     /* Both already have p flags, so do nothing */
2743                 } else {
2744                     const NV nv = SvNVX(sv);
2745                     /* XXX should this spot have NAN_COMPARE_BROKEN, too? */
2746                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2747                         if (SvIVX(sv) == I_V(nv)) {
2748                             SvNOK_on(sv);
2749                         } else {
2750                             /* It had no "." so it must be integer.  */
2751                         }
2752                         SvIOK_on(sv);
2753                     } else {
2754                         /* between IV_MAX and NV(UV_MAX).
2755                            Could be slightly > UV_MAX */
2756
2757                         if (numtype & IS_NUMBER_NOT_INT) {
2758                             /* UV and NV both imprecise.  */
2759                         } else {
2760                             const UV nv_as_uv = U_V(nv);
2761
2762                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2763                                 SvNOK_on(sv);
2764                             }
2765                             SvIOK_on(sv);
2766                         }
2767                     }
2768                 }
2769             }
2770         }
2771         /* It might be more code efficient to go through the entire logic above
2772            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2773            gets complex and potentially buggy, so more programmer efficient
2774            to do it this way, by turning off the public flags:  */
2775         if (!numtype)
2776             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2777 #endif /* NV_PRESERVES_UV */
2778     }
2779     else  {
2780         if (isGV_with_GP(sv)) {
2781             glob_2number(MUTABLE_GV(sv));
2782             return 0.0;
2783         }
2784
2785         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2786             report_uninit(sv);
2787         assert (SvTYPE(sv) >= SVt_NV);
2788         /* Typically the caller expects that sv_any is not NULL now.  */
2789         /* XXX Ilya implies that this is a bug in callers that assume this
2790            and ideally should be fixed.  */
2791         return 0.0;
2792     }
2793     DEBUG_c({
2794         STORE_NUMERIC_LOCAL_SET_STANDARD();
2795         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" NVgf ")\n",
2796                       PTR2UV(sv), SvNVX(sv));
2797         RESTORE_NUMERIC_LOCAL();
2798     });
2799     return SvNVX(sv);
2800 }
2801
2802 /*
2803 =for apidoc sv_2num
2804
2805 Return an SV with the numeric value of the source SV, doing any necessary
2806 reference or overload conversion.  The caller is expected to have handled
2807 get-magic already.
2808
2809 =cut
2810 */
2811
2812 SV *
2813 Perl_sv_2num(pTHX_ SV *const sv)
2814 {
2815     PERL_ARGS_ASSERT_SV_2NUM;
2816
2817     if (!SvROK(sv))
2818         return sv;
2819     if (SvAMAGIC(sv)) {
2820         SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2821         TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2822         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2823             return sv_2num(tmpsv);
2824     }
2825     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2826 }
2827
2828 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2829  * UV as a string towards the end of buf, and return pointers to start and
2830  * end of it.
2831  *
2832  * We assume that buf is at least TYPE_CHARS(UV) long.
2833  */
2834
2835 static char *
2836 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2837 {
2838     char *ptr = buf + TYPE_CHARS(UV);
2839     char * const ebuf = ptr;
2840     int sign;
2841
2842     PERL_ARGS_ASSERT_UIV_2BUF;
2843
2844     if (is_uv)
2845         sign = 0;
2846     else if (iv >= 0) {
2847         uv = iv;
2848         sign = 0;
2849     } else {
2850         uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv);
2851         sign = 1;
2852     }
2853     do {
2854         *--ptr = '0' + (char)(uv % 10);
2855     } while (uv /= 10);
2856     if (sign)
2857         *--ptr = '-';
2858     *peob = ebuf;
2859     return ptr;
2860 }
2861
2862 /* Helper for sv_2pv_flags and sv_vcatpvfn_flags.  If the NV is an
2863  * infinity or a not-a-number, writes the appropriate strings to the
2864  * buffer, including a zero byte.  On success returns the written length,
2865  * excluding the zero byte, on failure (not an infinity, not a nan)
2866  * returns zero, assert-fails on maxlen being too short.
2867  *
2868  * XXX for "Inf", "-Inf", and "NaN", we could have three read-only
2869  * shared string constants we point to, instead of generating a new
2870  * string for each instance. */
2871 STATIC size_t
2872 S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char plus) {
2873     char* s = buffer;
2874     assert(maxlen >= 4);
2875     if (Perl_isinf(nv)) {
2876         if (nv < 0) {
2877             if (maxlen < 5) /* "-Inf\0"  */
2878                 return 0;
2879             *s++ = '-';
2880         } else if (plus) {
2881             *s++ = '+';
2882         }
2883         *s++ = 'I';
2884         *s++ = 'n';
2885         *s++ = 'f';
2886     }
2887     else if (Perl_isnan(nv)) {
2888         *s++ = 'N';
2889         *s++ = 'a';
2890         *s++ = 'N';
2891         /* XXX optionally output the payload mantissa bits as
2892          * "(unsigned)" (to match the nan("...") C99 function,
2893          * or maybe as "(0xhhh...)"  would make more sense...
2894          * provide a format string so that the user can decide?
2895          * NOTE: would affect the maxlen and assert() logic.*/
2896     }
2897     else {
2898       return 0;
2899     }
2900     assert((s == buffer + 3) || (s == buffer + 4));
2901     *s++ = 0;
2902     return s - buffer - 1; /* -1: excluding the zero byte */
2903 }
2904
2905 /*
2906 =for apidoc sv_2pv_flags
2907
2908 Returns a pointer to the string value of an SV, and sets C<*lp> to its length.
2909 If flags has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.  Coerces C<sv> to a
2910 string if necessary.  Normally invoked via the C<SvPV_flags> macro.
2911 C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
2912
2913 =cut
2914 */
2915
2916 char *
2917 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
2918 {
2919     char *s;
2920
2921     PERL_ARGS_ASSERT_SV_2PV_FLAGS;
2922
2923     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2924          && SvTYPE(sv) != SVt_PVFM);
2925     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2926         mg_get(sv);
2927     if (SvROK(sv)) {
2928         if (SvAMAGIC(sv)) {
2929             SV *tmpstr;
2930             if (flags & SV_SKIP_OVERLOAD)
2931                 return NULL;
2932             tmpstr = AMG_CALLunary(sv, string_amg);
2933             TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2934             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2935                 /* Unwrap this:  */
2936                 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2937                  */
2938
2939                 char *pv;
2940                 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2941                     if (flags & SV_CONST_RETURN) {
2942                         pv = (char *) SvPVX_const(tmpstr);
2943                     } else {
2944                         pv = (flags & SV_MUTABLE_RETURN)
2945                             ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2946                     }
2947                     if (lp)
2948                         *lp = SvCUR(tmpstr);
2949                 } else {
2950                     pv = sv_2pv_flags(tmpstr, lp, flags);
2951                 }
2952                 if (SvUTF8(tmpstr))
2953                     SvUTF8_on(sv);
2954                 else
2955                     SvUTF8_off(sv);
2956                 return pv;
2957             }
2958         }
2959         {
2960             STRLEN len;
2961             char *retval;
2962             char *buffer;
2963             SV *const referent = SvRV(sv);
2964
2965             if (!referent) {
2966                 len = 7;
2967                 retval = buffer = savepvn("NULLREF", len);
2968             } else if (SvTYPE(referent) == SVt_REGEXP &&
2969                        (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
2970                         amagic_is_enabled(string_amg))) {
2971                 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2972
2973                 assert(re);
2974                         
2975                 /* If the regex is UTF-8 we want the containing scalar to
2976                    have an UTF-8 flag too */
2977                 if (RX_UTF8(re))
2978                     SvUTF8_on(sv);
2979                 else
2980                     SvUTF8_off(sv);     
2981
2982                 if (lp)
2983                     *lp = RX_WRAPLEN(re);
2984  
2985                 return RX_WRAPPED(re);
2986             } else {
2987                 const char *const typestr = sv_reftype(referent, 0);
2988                 const STRLEN typelen = strlen(typestr);
2989                 UV addr = PTR2UV(referent);
2990                 const char *stashname = NULL;
2991                 STRLEN stashnamelen = 0; /* hush, gcc */
2992                 const char *buffer_end;
2993
2994                 if (SvOBJECT(referent)) {
2995                     const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2996
2997                     if (name) {
2998                         stashname = HEK_KEY(name);
2999                         stashnamelen = HEK_LEN(name);
3000
3001                         if (HEK_UTF8(name)) {
3002                             SvUTF8_on(sv);
3003                         } else {
3004                             SvUTF8_off(sv);
3005                         }
3006                     } else {
3007                         stashname = "__ANON__";
3008                         stashnamelen = 8;
3009                     }
3010                     len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
3011                         + 2 * sizeof(UV) + 2 /* )\0 */;
3012                 } else {
3013                     len = typelen + 3 /* (0x */
3014                         + 2 * sizeof(UV) + 2 /* )\0 */;
3015                 }
3016
3017                 Newx(buffer, len, char);
3018                 buffer_end = retval = buffer + len;
3019
3020                 /* Working backwards  */
3021                 *--retval = '\0';
3022                 *--retval = ')';
3023                 do {
3024                     *--retval = PL_hexdigit[addr & 15];
3025                 } while (addr >>= 4);
3026                 *--retval = 'x';
3027                 *--retval = '0';
3028                 *--retval = '(';
3029
3030                 retval -= typelen;
3031                 memcpy(retval, typestr, typelen);
3032
3033                 if (stashname) {
3034                     *--retval = '=';
3035                     retval -= stashnamelen;
3036                     memcpy(retval, stashname, stashnamelen);
3037                 }
3038                 /* retval may not necessarily have reached the start of the
3039                    buffer here.  */
3040                 assert (retval >= buffer);
3041
3042                 len = buffer_end - retval - 1; /* -1 for that \0  */
3043             }
3044             if (lp)
3045                 *lp = len;
3046             SAVEFREEPV(buffer);
3047             return retval;
3048         }
3049     }
3050
3051     if (SvPOKp(sv)) {
3052         if (lp)
3053             *lp = SvCUR(sv);
3054         if (flags & SV_MUTABLE_RETURN)
3055             return SvPVX_mutable(sv);
3056         if (flags & SV_CONST_RETURN)
3057             return (char *)SvPVX_const(sv);
3058         return SvPVX(sv);
3059     }
3060
3061     if (SvIOK(sv)) {
3062         /* I'm assuming that if both IV and NV are equally valid then
3063            converting the IV is going to be more efficient */
3064         const U32 isUIOK = SvIsUV(sv);
3065         char buf[TYPE_CHARS(UV)];
3066         char *ebuf, *ptr;
3067         STRLEN len;
3068
3069         if (SvTYPE(sv) < SVt_PVIV)
3070             sv_upgrade(sv, SVt_PVIV);
3071         ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
3072         len = ebuf - ptr;
3073         /* inlined from sv_setpvn */
3074         s = SvGROW_mutable(sv, len + 1);
3075         Move(ptr, s, len, char);
3076         s += len;
3077         *s = '\0';
3078         SvPOK_on(sv);
3079     }
3080     else if (SvNOK(sv)) {
3081         if (SvTYPE(sv) < SVt_PVNV)
3082             sv_upgrade(sv, SVt_PVNV);
3083         if (SvNVX(sv) == 0.0
3084 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3085             && !Perl_isnan(SvNVX(sv))
3086 #endif
3087         ) {
3088             s = SvGROW_mutable(sv, 2);
3089             *s++ = '0';
3090             *s = '\0';
3091         } else {
3092             STRLEN len;
3093             STRLEN size = 5; /* "-Inf\0" */
3094
3095             s = SvGROW_mutable(sv, size);
3096             len = S_infnan_2pv(SvNVX(sv), s, size, 0);
3097             if (len > 0) {
3098                 s += len;
3099                 SvPOK_on(sv);
3100             }
3101             else {
3102                 /* some Xenix systems wipe out errno here */
3103                 dSAVE_ERRNO;
3104
3105                 size =
3106                     1 + /* sign */
3107                     1 + /* "." */
3108                     NV_DIG +
3109                     1 + /* "e" */
3110                     1 + /* sign */
3111                     5 + /* exponent digits */
3112                     1 + /* \0 */
3113                     2; /* paranoia */
3114
3115                 s = SvGROW_mutable(sv, size);
3116 #ifndef USE_LOCALE_NUMERIC
3117                 SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3118
3119                 SvPOK_on(sv);
3120 #else
3121                 {
3122                     bool local_radix;
3123                     DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3124                     STORE_LC_NUMERIC_SET_TO_NEEDED();
3125
3126                     local_radix = PL_numeric_local && PL_numeric_radix_sv;
3127                     if (local_radix && SvLEN(PL_numeric_radix_sv) > 1) {
3128                         size += SvLEN(PL_numeric_radix_sv) - 1;
3129                         s = SvGROW_mutable(sv, size);
3130                     }
3131
3132                     SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3133
3134                     /* If the radix character is UTF-8, and actually is in the
3135                      * output, turn on the UTF-8 flag for the scalar */
3136                     if (   local_radix
3137                         && SvUTF8(PL_numeric_radix_sv)
3138                         && instr(s, SvPVX_const(PL_numeric_radix_sv)))
3139                     {
3140                         SvUTF8_on(sv);
3141                     }
3142
3143                     RESTORE_LC_NUMERIC();
3144                 }
3145
3146                 /* We don't call SvPOK_on(), because it may come to
3147                  * pass that the locale changes so that the
3148                  * stringification we just did is no longer correct.  We
3149                  * will have to re-stringify every time it is needed */
3150 #endif
3151                 RESTORE_ERRNO;
3152             }
3153             while (*s) s++;
3154         }
3155     }
3156     else if (isGV_with_GP(sv)) {
3157         GV *const gv = MUTABLE_GV(sv);
3158         SV *const buffer = sv_newmortal();
3159
3160         gv_efullname3(buffer, gv, "*");
3161
3162         assert(SvPOK(buffer));
3163         if (SvUTF8(buffer))
3164             SvUTF8_on(sv);
3165         if (lp)
3166             *lp = SvCUR(buffer);
3167         return SvPVX(buffer);
3168     }
3169     else if (isREGEXP(sv)) {
3170         if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
3171         return RX_WRAPPED((REGEXP *)sv);
3172     }
3173     else {
3174         if (lp)
3175             *lp = 0;
3176         if (flags & SV_UNDEF_RETURNS_NULL)
3177             return NULL;
3178         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3179             report_uninit(sv);
3180         /* Typically the caller expects that sv_any is not NULL now.  */
3181         if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
3182             sv_upgrade(sv, SVt_PV);
3183         return (char *)"";
3184     }
3185
3186     {
3187         const STRLEN len = s - SvPVX_const(sv);
3188         if (lp) 
3189             *lp = len;
3190         SvCUR_set(sv, len);
3191     }
3192     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3193                           PTR2UV(sv),SvPVX_const(sv)));
3194     if (flags & SV_CONST_RETURN)
3195         return (char *)SvPVX_const(sv);
3196     if (flags & SV_MUTABLE_RETURN)
3197         return SvPVX_mutable(sv);
3198     return SvPVX(sv);
3199 }
3200
3201 /*
3202 =for apidoc sv_copypv
3203
3204 Copies a stringified representation of the source SV into the
3205 destination SV.  Automatically performs any necessary C<mg_get> and
3206 coercion of numeric values into strings.  Guaranteed to preserve
3207 C<UTF8> flag even from overloaded objects.  Similar in nature to
3208 C<sv_2pv[_flags]> but operates directly on an SV instead of just the
3209 string.  Mostly uses C<sv_2pv_flags> to do its work, except when that
3210 would lose the UTF-8'ness of the PV.
3211
3212 =for apidoc sv_copypv_nomg
3213
3214 Like C<sv_copypv>, but doesn't invoke get magic first.
3215
3216 =for apidoc sv_copypv_flags
3217
3218 Implementation of C<sv_copypv> and C<sv_copypv_nomg>.  Calls get magic iff flags
3219 has the C<SV_GMAGIC> bit set.
3220
3221 =cut
3222 */
3223
3224 void
3225 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3226 {
3227     STRLEN len;
3228     const char *s;
3229
3230     PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3231
3232     s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC));
3233     sv_setpvn(dsv,s,len);
3234     if (SvUTF8(ssv))
3235         SvUTF8_on(dsv);
3236     else
3237         SvUTF8_off(dsv);
3238 }
3239
3240 /*
3241 =for apidoc sv_2pvbyte
3242
3243 Return a pointer to the byte-encoded representation of the SV, and set C<*lp>
3244 to its length.  May cause the SV to be downgraded from UTF-8 as a
3245 side-effect.
3246
3247 Usually accessed via the C<SvPVbyte> macro.
3248
3249 =cut
3250 */
3251
3252 char *
3253 Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
3254 {
3255     PERL_ARGS_ASSERT_SV_2PVBYTE;
3256
3257     SvGETMAGIC(sv);
3258     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3259      || isGV_with_GP(sv) || SvROK(sv)) {
3260         SV *sv2 = sv_newmortal();
3261         sv_copypv_nomg(sv2,sv);
3262         sv = sv2;
3263     }
3264     sv_utf8_downgrade(sv,0);
3265     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3266 }
3267
3268 /*
3269 =for apidoc sv_2pvutf8
3270
3271 Return a pointer to the UTF-8-encoded representation of the SV, and set C<*lp>
3272 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3273
3274 Usually accessed via the C<SvPVutf8> macro.
3275
3276 =cut
3277 */
3278
3279 char *
3280 Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
3281 {
3282     PERL_ARGS_ASSERT_SV_2PVUTF8;
3283
3284     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3285      || isGV_with_GP(sv) || SvROK(sv))
3286         sv = sv_mortalcopy(sv);
3287     else
3288         SvGETMAGIC(sv);
3289     sv_utf8_upgrade_nomg(sv);
3290     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3291 }
3292
3293
3294 /*
3295 =for apidoc sv_2bool
3296
3297 This macro is only used by C<sv_true()> or its macro equivalent, and only if
3298 the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>.
3299 It calls C<sv_2bool_flags> with the C<SV_GMAGIC> flag.
3300
3301 =for apidoc sv_2bool_flags
3302
3303 This function is only used by C<sv_true()> and friends,  and only if
3304 the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>.  If the flags
3305 contain C<SV_GMAGIC>, then it does an C<mg_get()> first.
3306
3307
3308 =cut
3309 */
3310
3311 bool
3312 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
3313 {
3314     PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3315
3316     restart:
3317     if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3318
3319     if (!SvOK(sv))
3320         return 0;
3321     if (SvROK(sv)) {
3322         if (SvAMAGIC(sv)) {
3323             SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3324             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
3325                 bool svb;
3326                 sv = tmpsv;
3327                 if(SvGMAGICAL(sv)) {
3328                     flags = SV_GMAGIC;
3329                     goto restart; /* call sv_2bool */
3330                 }
3331                 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
3332                 else if(!SvOK(sv)) {
3333                     svb = 0;
3334                 }
3335                 else if(SvPOK(sv)) {
3336                     svb = SvPVXtrue(sv);
3337                 }
3338                 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
3339                     svb = (SvIOK(sv) && SvIVX(sv) != 0)
3340                         || (SvNOK(sv) && SvNVX(sv) != 0.0);
3341                 }
3342                 else {
3343                     flags = 0;
3344                     goto restart; /* call sv_2bool_nomg */
3345                 }
3346                 return cBOOL(svb);
3347             }
3348         }
3349         return SvRV(sv) != 0;
3350     }
3351     if (isREGEXP(sv))
3352         return
3353           RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
3354     return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
3355 }
3356
3357 /*
3358 =for apidoc sv_utf8_upgrade
3359
3360 Converts the PV of an SV to its UTF-8-encoded form.
3361 Forces the SV to string form if it is not already.
3362 Will C<mg_get> on C<sv> if appropriate.
3363 Always sets the C<SvUTF8> flag to avoid future validity checks even
3364 if the whole string is the same in UTF-8 as not.
3365 Returns the number of bytes in the converted string
3366
3367 This is not a general purpose byte encoding to Unicode interface:
3368 use the Encode extension for that.
3369
3370 =for apidoc sv_utf8_upgrade_nomg
3371
3372 Like C<sv_utf8_upgrade>, but doesn't do magic on C<sv>.
3373
3374 =for apidoc sv_utf8_upgrade_flags
3375
3376 Converts the PV of an SV to its UTF-8-encoded form.
3377 Forces the SV to string form if it is not already.
3378 Always sets the SvUTF8 flag to avoid future validity checks even
3379 if all the bytes are invariant in UTF-8.
3380 If C<flags> has C<SV_GMAGIC> bit set,
3381 will C<mg_get> on C<sv> if appropriate, else not.
3382
3383 If C<flags> has C<SV_FORCE_UTF8_UPGRADE> set, this function assumes that the PV
3384 will expand when converted to UTF-8, and skips the extra work of checking for
3385 that.  Typically this flag is used by a routine that has already parsed the
3386 string and found such characters, and passes this information on so that the
3387 work doesn't have to be repeated.
3388
3389 Returns the number of bytes in the converted string.
3390
3391 This is not a general purpose byte encoding to Unicode interface:
3392 use the Encode extension for that.
3393
3394 =for apidoc sv_utf8_upgrade_flags_grow
3395
3396 Like C<sv_utf8_upgrade_flags>, but has an additional parameter C<extra>, which is
3397 the number of unused bytes the string of C<sv> is guaranteed to have free after
3398 it upon return.  This allows the caller to reserve extra space that it intends
3399 to fill, to avoid extra grows.
3400
3401 C<sv_utf8_upgrade>, C<sv_utf8_upgrade_nomg>, and C<sv_utf8_upgrade_flags>
3402 are implemented in terms of this function.
3403
3404 Returns the number of bytes in the converted string (not including the spares).
3405
3406 =cut
3407
3408 (One might think that the calling routine could pass in the position of the
3409 first variant character when it has set SV_FORCE_UTF8_UPGRADE, so it wouldn't
3410 have to be found again.  But that is not the case, because typically when the
3411 caller is likely to use this flag, it won't be calling this routine unless it
3412 finds something that won't fit into a byte.  Otherwise it tries to not upgrade
3413 and just use bytes.  But some things that do fit into a byte are variants in
3414 utf8, and the caller may not have been keeping track of these.)
3415
3416 If the routine itself changes the string, it adds a trailing C<NUL>.  Such a
3417 C<NUL> isn't guaranteed due to having other routines do the work in some input
3418 cases, or if the input is already flagged as being in utf8.
3419
3420 The speed of this could perhaps be improved for many cases if someone wanted to
3421 write a fast function that counts the number of variant characters in a string,
3422 especially if it could return the position of the first one.
3423
3424 */
3425
3426 STRLEN
3427 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3428 {
3429     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3430
3431     if (sv == &PL_sv_undef)
3432         return 0;
3433     if (!SvPOK_nog(sv)) {
3434         STRLEN len = 0;
3435         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3436             (void) sv_2pv_flags(sv,&len, flags);
3437             if (SvUTF8(sv)) {
3438                 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3439                 return len;
3440             }
3441         } else {
3442             (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3443         }
3444     }
3445
3446     if (SvUTF8(sv)) {
3447         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3448         return SvCUR(sv);
3449     }
3450
3451     if (SvIsCOW(sv)) {
3452         S_sv_uncow(aTHX_ sv, 0);
3453     }
3454
3455     if (IN_ENCODING && !(flags & SV_UTF8_NO_ENCODING)) {
3456         sv_recode_to_utf8(sv, _get_encoding());
3457         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3458         return SvCUR(sv);
3459     }
3460
3461     if (SvCUR(sv) == 0) {
3462         if (extra) SvGROW(sv, extra);
3463     } else { /* Assume Latin-1/EBCDIC */
3464         /* This function could be much more efficient if we
3465          * had a FLAG in SVs to signal if there are any variant
3466          * chars in the PV.  Given that there isn't such a flag
3467          * make the loop as fast as possible (although there are certainly ways
3468          * to speed this up, eg. through vectorization) */
3469         U8 * s = (U8 *) SvPVX_const(sv);
3470         U8 * e = (U8 *) SvEND(sv);
3471         U8 *t = s;
3472         STRLEN two_byte_count = 0;
3473         
3474         if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3475
3476         /* See if really will need to convert to utf8.  We mustn't rely on our
3477          * incoming SV being well formed and having a trailing '\0', as certain
3478          * code in pp_formline can send us partially built SVs. */
3479
3480         while (t < e) {
3481             const U8 ch = *t++;
3482             if (NATIVE_BYTE_IS_INVARIANT(ch)) continue;
3483
3484             t--;    /* t already incremented; re-point to first variant */
3485             two_byte_count = 1;
3486             goto must_be_utf8;
3487         }
3488
3489         /* utf8 conversion not needed because all are invariants.  Mark as
3490          * UTF-8 even if no variant - saves scanning loop */
3491         SvUTF8_on(sv);
3492         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3493         return SvCUR(sv);
3494
3495       must_be_utf8:
3496
3497         /* Here, the string should be converted to utf8, either because of an
3498          * input flag (two_byte_count = 0), or because a character that
3499          * requires 2 bytes was found (two_byte_count = 1).  t points either to
3500          * the beginning of the string (if we didn't examine anything), or to
3501          * the first variant.  In either case, everything from s to t - 1 will
3502          * occupy only 1 byte each on output.
3503          *
3504          * There are two main ways to convert.  One is to create a new string
3505          * and go through the input starting from the beginning, appending each
3506          * converted value onto the new string as we go along.  It's probably
3507          * best to allocate enough space in the string for the worst possible
3508          * case rather than possibly running out of space and having to
3509          * reallocate and then copy what we've done so far.  Since everything
3510          * from s to t - 1 is invariant, the destination can be initialized
3511          * with these using a fast memory copy
3512          *
3513          * The other way is to figure out exactly how big the string should be
3514          * by parsing the entire input.  Then you don't have to make it big
3515          * enough to handle the worst possible case, and more importantly, if
3516          * the string you already have is large enough, you don't have to
3517          * allocate a new string, you can copy the last character in the input
3518          * string to the final position(s) that will be occupied by the
3519          * converted string and go backwards, stopping at t, since everything
3520          * before that is invariant.
3521          *
3522          * There are advantages and disadvantages to each method.
3523          *
3524          * In the first method, we can allocate a new string, do the memory
3525          * copy from the s to t - 1, and then proceed through the rest of the
3526          * string byte-by-byte.
3527          *
3528          * In the second method, we proceed through the rest of the input
3529          * string just calculating how big the converted string will be.  Then
3530          * there are two cases:
3531          *  1)  if the string has enough extra space to handle the converted
3532          *      value.  We go backwards through the string, converting until we
3533          *      get to the position we are at now, and then stop.  If this
3534          *      position is far enough along in the string, this method is
3535          *      faster than the other method.  If the memory copy were the same
3536          *      speed as the byte-by-byte loop, that position would be about
3537          *      half-way, as at the half-way mark, parsing to the end and back
3538          *      is one complete string's parse, the same amount as starting
3539          *      over and going all the way through.  Actually, it would be
3540          *      somewhat less than half-way, as it's faster to just count bytes
3541          *      than to also copy, and we don't have the overhead of allocating
3542          *      a new string, changing the scalar to use it, and freeing the
3543          *      existing one.  But if the memory copy is fast, the break-even
3544          *      point is somewhere after half way.  The counting loop could be
3545          *      sped up by vectorization, etc, to move the break-even point
3546          *      further towards the beginning.
3547          *  2)  if the string doesn't have enough space to handle the converted
3548          *      value.  A new string will have to be allocated, and one might
3549          *      as well, given that, start from the beginning doing the first
3550          *      method.  We've spent extra time parsing the string and in
3551          *      exchange all we've gotten is that we know precisely how big to
3552          *      make the new one.  Perl is more optimized for time than space,
3553          *      so this case is a loser.
3554          * So what I've decided to do is not use the 2nd method unless it is
3555          * guaranteed that a new string won't have to be allocated, assuming
3556          * the worst case.  I also decided not to put any more conditions on it
3557          * than this, for now.  It seems likely that, since the worst case is
3558          * twice as big as the unknown portion of the string (plus 1), we won't
3559          * be guaranteed enough space, causing us to go to the first method,
3560          * unless the string is short, or the first variant character is near
3561          * the end of it.  In either of these cases, it seems best to use the
3562          * 2nd method.  The only circumstance I can think of where this would
3563          * be really slower is if the string had once had much more data in it
3564          * than it does now, but there is still a substantial amount in it  */
3565
3566         {
3567             STRLEN invariant_head = t - s;
3568             STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3569             if (SvLEN(sv) < size) {
3570
3571                 /* Here, have decided to allocate a new string */
3572
3573                 U8 *dst;
3574                 U8 *d;
3575
3576                 Newx(dst, size, U8);
3577
3578                 /* If no known invariants at the beginning of the input string,
3579                  * set so starts from there.  Otherwise, can use memory copy to
3580                  * get up to where we are now, and then start from here */
3581
3582                 if (invariant_head == 0) {
3583                     d = dst;
3584                 } else {
3585                     Copy(s, dst, invariant_head, char);
3586                     d = dst + invariant_head;
3587                 }
3588
3589                 while (t < e) {
3590                     append_utf8_from_native_byte(*t, &d);
3591                     t++;
3592                 }
3593                 *d = '\0';
3594                 SvPV_free(sv); /* No longer using pre-existing string */
3595                 SvPV_set(sv, (char*)dst);
3596                 SvCUR_set(sv, d - dst);
3597                 SvLEN_set(sv, size);
3598             } else {
3599
3600                 /* Here, have decided to get the exact size of the string.
3601                  * Currently this happens only when we know that there is
3602                  * guaranteed enough space to fit the converted string, so
3603                  * don't have to worry about growing.  If two_byte_count is 0,
3604                  * then t points to the first byte of the string which hasn't
3605                  * been examined yet.  Otherwise two_byte_count is 1, and t
3606                  * points to the first byte in the string that will expand to
3607                  * two.  Depending on this, start examining at t or 1 after t.
3608                  * */
3609
3610                 U8 *d = t + two_byte_count;
3611
3612
3613                 /* Count up the remaining bytes that expand to two */
3614
3615                 while (d < e) {
3616                     const U8 chr = *d++;
3617                     if (! NATIVE_BYTE_IS_INVARIANT(chr)) two_byte_count++;
3618                 }
3619
3620                 /* The string will expand by just the number of bytes that
3621                  * occupy two positions.  But we are one afterwards because of
3622                  * the increment just above.  This is the place to put the
3623                  * trailing NUL, and to set the length before we decrement */
3624
3625                 d += two_byte_count;
3626                 SvCUR_set(sv, d - s);
3627                 *d-- = '\0';
3628
3629
3630                 /* Having decremented d, it points to the position to put the
3631                  * very last byte of the expanded string.  Go backwards through
3632                  * the string, copying and expanding as we go, stopping when we
3633                  * get to the part that is invariant the rest of the way down */
3634
3635                 e--;
3636                 while (e >= t) {
3637                     if (NATIVE_BYTE_IS_INVARIANT(*e)) {
3638                         *d-- = *e;
3639                     } else {
3640                         *d-- = UTF8_EIGHT_BIT_LO(*e);
3641                         *d-- = UTF8_EIGHT_BIT_HI(*e);
3642                     }
3643                     e--;
3644                 }
3645             }
3646
3647             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3648                 /* Update pos. We do it at the end rather than during
3649                  * the upgrade, to avoid slowing down the common case
3650                  * (upgrade without pos).
3651                  * pos can be stored as either bytes or characters.  Since
3652                  * this was previously a byte string we can just turn off
3653                  * the bytes flag. */
3654                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3655                 if (mg) {
3656                     mg->mg_flags &= ~MGf_BYTES;
3657                 }
3658                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3659                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3660             }
3661         }
3662     }
3663
3664     /* Mark as UTF-8 even if no variant - saves scanning loop */
3665     SvUTF8_on(sv);
3666     return SvCUR(sv);
3667 }
3668
3669 /*
3670 =for apidoc sv_utf8_downgrade
3671
3672 Attempts to convert the PV of an SV from characters to bytes.
3673 If the PV contains a character that cannot fit
3674 in a byte, this conversion will fail;
3675 in this case, either returns false or, if C<fail_ok> is not
3676 true, croaks.
3677
3678 This is not a general purpose Unicode to byte encoding interface:
3679 use the C<Encode> extension for that.
3680
3681 =cut
3682 */
3683
3684 bool
3685 Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
3686 {
3687     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3688
3689     if (SvPOKp(sv) && SvUTF8(sv)) {
3690         if (SvCUR(sv)) {
3691             U8 *s;
3692             STRLEN len;
3693             int mg_flags = SV_GMAGIC;
3694
3695             if (SvIsCOW(sv)) {
3696                 S_sv_uncow(aTHX_ sv, 0);
3697             }
3698             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3699                 /* update pos */
3700                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3701                 if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
3702                         mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
3703                                                 SV_GMAGIC|SV_CONST_RETURN);
3704                         mg_flags = 0; /* sv_pos_b2u does get magic */
3705                 }
3706                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3707                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3708
3709             }
3710             s = (U8 *) SvPV_flags(sv, len, mg_flags);
3711
3712             if (!utf8_to_bytes(s, &len)) {
3713                 if (fail_ok)
3714                     return FALSE;
3715                 else {
3716                     if (PL_op)
3717                         Perl_croak(aTHX_ "Wide character in %s",
3718                                    OP_DESC(PL_op));
3719                     else
3720                         Perl_croak(aTHX_ "Wide character");
3721                 }
3722             }
3723             SvCUR_set(sv, len);
3724         }
3725     }
3726     SvUTF8_off(sv);
3727     return TRUE;
3728 }
3729
3730 /*
3731 =for apidoc sv_utf8_encode
3732
3733 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3734 flag off so that it looks like octets again.
3735
3736 =cut
3737 */
3738
3739 void
3740 Perl_sv_utf8_encode(pTHX_ SV *const sv)
3741 {
3742     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3743
3744     if (SvREADONLY(sv)) {
3745         sv_force_normal_flags(sv, 0);
3746     }
3747     (void) sv_utf8_upgrade(sv);
3748     SvUTF8_off(sv);
3749 }
3750
3751 /*
3752 =for apidoc sv_utf8_decode
3753
3754 If the PV of the SV is an octet sequence in UTF-8
3755 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3756 so that it looks like a character.  If the PV contains only single-byte
3757 characters, the C<SvUTF8> flag stays off.
3758 Scans PV for validity and returns false if the PV is invalid UTF-8.
3759
3760 =cut
3761 */
3762
3763 bool
3764 Perl_sv_utf8_decode(pTHX_ SV *const sv)
3765 {
3766     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3767
3768     if (SvPOKp(sv)) {
3769         const U8 *start, *c;
3770         const U8 *e;
3771
3772         /* The octets may have got themselves encoded - get them back as
3773          * bytes
3774          */
3775         if (!sv_utf8_downgrade(sv, TRUE))
3776             return FALSE;
3777
3778         /* it is actually just a matter of turning the utf8 flag on, but
3779          * we want to make sure everything inside is valid utf8 first.
3780          */
3781         c = start = (const U8 *) SvPVX_const(sv);
3782         if (!is_utf8_string(c, SvCUR(sv)))
3783             return FALSE;
3784         e = (const U8 *) SvEND(sv);
3785         while (c < e) {
3786             const U8 ch = *c++;
3787             if (!UTF8_IS_INVARIANT(ch)) {
3788                 SvUTF8_on(sv);
3789                 break;
3790             }
3791         }
3792         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3793             /* XXX Is this dead code?  XS_utf8_decode calls SvSETMAGIC
3794                    after this, clearing pos.  Does anything on CPAN
3795                    need this? */
3796             /* adjust pos to the start of a UTF8 char sequence */
3797             MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3798             if (mg) {
3799                 I32 pos = mg->mg_len;
3800                 if (pos > 0) {
3801                     for (c = start + pos; c > start; c--) {
3802                         if (UTF8_IS_START(*c))
3803                             break;
3804                     }
3805                     mg->mg_len  = c - start;
3806                 }
3807             }
3808             if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3809                 magic_setutf8(sv,mg); /* clear UTF8 cache */
3810         }
3811     }
3812     return TRUE;
3813 }
3814
3815 /*
3816 =for apidoc sv_setsv
3817
3818 Copies the contents of the source SV C<ssv> into the destination SV
3819 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3820 function if the source SV needs to be reused.  Does not handle 'set' magic on
3821 destination SV.  Calls 'get' magic on source SV.  Loosely speaking, it
3822 performs a copy-by-value, obliterating any previous content of the
3823 destination.
3824
3825 You probably want to use one of the assortment of wrappers, such as
3826 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3827 C<SvSetMagicSV_nosteal>.
3828
3829 =for apidoc sv_setsv_flags
3830
3831 Copies the contents of the source SV C<ssv> into the destination SV
3832 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3833 function if the source SV needs to be reused.  Does not handle 'set' magic.
3834 Loosely speaking, it performs a copy-by-value, obliterating any previous
3835 content of the destination.
3836 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3837 C<ssv> if appropriate, else not.  If the C<flags>
3838 parameter has the C<SV_NOSTEAL> bit set then the
3839 buffers of temps will not be stolen.  C<sv_setsv>
3840 and C<sv_setsv_nomg> are implemented in terms of this function.
3841
3842 You probably want to use one of the assortment of wrappers, such as
3843 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3844 C<SvSetMagicSV_nosteal>.
3845
3846 This is the primary function for copying scalars, and most other
3847 copy-ish functions and macros use this underneath.
3848
3849 =cut
3850 */
3851
3852 static void
3853 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3854 {
3855     I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3856     HV *old_stash = NULL;
3857
3858     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3859
3860     if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3861         const char * const name = GvNAME(sstr);
3862         const STRLEN len = GvNAMELEN(sstr);
3863         {
3864             if (dtype >= SVt_PV) {
3865                 SvPV_free(dstr);
3866                 SvPV_set(dstr, 0);
3867                 SvLEN_set(dstr, 0);
3868                 SvCUR_set(dstr, 0);
3869             }
3870             SvUPGRADE(dstr, SVt_PVGV);
3871             (void)SvOK_off(dstr);
3872             isGV_with_GP_on(dstr);
3873         }
3874         GvSTASH(dstr) = GvSTASH(sstr);
3875         if (GvSTASH(dstr))
3876             Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3877         gv_name_set(MUTABLE_GV(dstr), name, len,
3878                         GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
3879         SvFAKE_on(dstr);        /* can coerce to non-glob */
3880     }
3881
3882     if(GvGP(MUTABLE_GV(sstr))) {
3883         /* If source has method cache entry, clear it */
3884         if(GvCVGEN(sstr)) {
3885             SvREFCNT_dec(GvCV(sstr));
3886             GvCV_set(sstr, NULL);
3887             GvCVGEN(sstr) = 0;
3888         }
3889         /* If source has a real method, then a method is
3890            going to change */
3891         else if(
3892          GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3893         ) {
3894             mro_changes = 1;
3895         }
3896     }
3897
3898     /* If dest already had a real method, that's a change as well */
3899     if(
3900         !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3901      && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3902     ) {
3903         mro_changes = 1;
3904     }
3905
3906     /* We don't need to check the name of the destination if it was not a
3907        glob to begin with. */
3908     if(dtype == SVt_PVGV) {
3909         const char * const name = GvNAME((const GV *)dstr);
3910         if(
3911             strEQ(name,"ISA")
3912          /* The stash may have been detached from the symbol table, so
3913             check its name. */
3914          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3915         )
3916             mro_changes = 2;
3917         else {
3918             const STRLEN len = GvNAMELEN(dstr);
3919             if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3920              || (len == 1 && name[0] == ':')) {
3921                 mro_changes = 3;
3922
3923                 /* Set aside the old stash, so we can reset isa caches on
3924                    its subclasses. */
3925                 if((old_stash = GvHV(dstr)))
3926                     /* Make sure we do not lose it early. */
3927                     SvREFCNT_inc_simple_void_NN(
3928                      sv_2mortal((SV *)old_stash)
3929                     );
3930             }
3931         }
3932
3933         SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
3934     }
3935
3936     /* freeing dstr's GP might free sstr (e.g. *x = $x),
3937      * so temporarily protect it */
3938     ENTER;
3939     SAVEFREESV(SvREFCNT_inc_simple_NN(sstr));
3940     gp_free(MUTABLE_GV(dstr));
3941     GvINTRO_off(dstr);          /* one-shot flag */
3942     GvGP_set(dstr, gp_ref(GvGP(sstr)));
3943     LEAVE;
3944
3945     if (SvTAINTED(sstr))
3946         SvTAINT(dstr);
3947     if (GvIMPORTED(dstr) != GVf_IMPORTED
3948         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3949         {
3950             GvIMPORTED_on(dstr);
3951         }
3952     GvMULTI_on(dstr);
3953     if(mro_changes == 2) {
3954       if (GvAV((const GV *)sstr)) {
3955         MAGIC *mg;
3956         SV * const sref = (SV *)GvAV((const GV *)dstr);
3957         if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3958             if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3959                 AV * const ary = newAV();
3960                 av_push(ary, mg->mg_obj); /* takes the refcount */
3961                 mg->mg_obj = (SV *)ary;
3962             }
3963             av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3964         }
3965         else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3966       }
3967       mro_isa_changed_in(GvSTASH(dstr));
3968     }
3969     else if(mro_changes == 3) {
3970         HV * const stash = GvHV(dstr);
3971         if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3972             mro_package_moved(
3973                 stash, old_stash,
3974                 (GV *)dstr, 0
3975             );
3976     }
3977     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3978     if (GvIO(dstr) && dtype == SVt_PVGV) {
3979         DEBUG_o(Perl_deb(aTHX_
3980                         "glob_assign_glob clearing PL_stashcache\n"));
3981         /* It's a cache. It will rebuild itself quite happily.
3982            It's a lot of effort to work out exactly which key (or keys)
3983            might be invalidated by the creation of the this file handle.
3984          */
3985         hv_clear(PL_stashcache);
3986     }
3987     return;
3988 }
3989
3990 void
3991 Perl_gv_setref(pTHX_ SV *const dstr, SV *const sstr)
3992 {
3993     SV * const sref = SvRV(sstr);
3994     SV *dref;
3995     const int intro = GvINTRO(dstr);
3996     SV **location;
3997     U8 import_flag = 0;
3998     const U32 stype = SvTYPE(sref);
3999
4000     PERL_ARGS_ASSERT_GV_SETREF;
4001
4002     if (intro) {
4003         GvINTRO_off(dstr);      /* one-shot flag */
4004         GvLINE(dstr) = CopLINE(PL_curcop);
4005         GvEGV(dstr) = MUTABLE_GV(dstr);
4006     }
4007     GvMULTI_on(dstr);
4008     switch (stype) {
4009     case SVt_PVCV:
4010         location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
4011         import_flag = GVf_IMPORTED_CV;
4012         goto common;
4013     case SVt_PVHV:
4014         location = (SV **) &GvHV(dstr);
4015         import_flag = GVf_IMPORTED_HV;
4016         goto common;
4017     case SVt_PVAV:
4018         location = (SV **) &GvAV(dstr);
4019         import_flag = GVf_IMPORTED_AV;
4020         goto common;
4021     case SVt_PVIO:
4022         location = (SV **) &GvIOp(dstr);
4023         goto common;
4024     case SVt_PVFM:
4025         location = (SV **) &GvFORM(dstr);
4026         goto common;
4027     default:
4028         location = &GvSV(dstr);
4029         import_flag = GVf_IMPORTED_SV;
4030     common:
4031         if (intro) {
4032             if (stype == SVt_PVCV) {
4033                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
4034                 if (GvCVGEN(dstr)) {
4035                     SvREFCNT_dec(GvCV(dstr));
4036                     GvCV_set(dstr, NULL);
4037                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4038                 }
4039             }
4040             /* SAVEt_GVSLOT takes more room on the savestack and has more
4041                overhead in leave_scope than SAVEt_GENERIC_SV.  But for CVs
4042                leave_scope needs access to the GV so it can reset method
4043                caches.  We must use SAVEt_GVSLOT whenever the type is
4044                SVt_PVCV, even if the stash is anonymous, as the stash may
4045                gain a name somehow before leave_scope. */
4046             if (stype == SVt_PVCV) {
4047                 /* There is no save_pushptrptrptr.  Creating it for this
4048                    one call site would be overkill.  So inline the ss add
4049                    routines here. */
4050                 dSS_ADD;
4051                 SS_ADD_PTR(dstr);
4052                 SS_ADD_PTR(location);
4053                 SS_ADD_PTR(SvREFCNT_inc(*location));
4054                 SS_ADD_UV(SAVEt_GVSLOT);
4055                 SS_ADD_END(4);
4056             }
4057             else SAVEGENERICSV(*location);
4058         }
4059         dref = *location;
4060         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
4061             CV* const cv = MUTABLE_CV(*location);
4062             if (cv) {
4063                 if (!GvCVGEN((const GV *)dstr) &&
4064                     (CvROOT(cv) || CvXSUB(cv)) &&
4065                     /* redundant check that avoids creating the extra SV
4066                        most of the time: */
4067                     (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
4068                     {
4069                         SV * const new_const_sv =
4070                             CvCONST((const CV *)sref)
4071                                  ? cv_const_sv((const CV *)sref)
4072                                  : NULL;
4073                         report_redefined_cv(
4074                            sv_2mortal(Perl_newSVpvf(aTHX_
4075                                 "%"HEKf"::%"HEKf,
4076                                 HEKfARG(
4077                                  HvNAME_HEK(GvSTASH((const GV *)dstr))
4078                                 ),
4079                                 HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
4080                            )),
4081                            cv,
4082                            CvCONST((const CV *)sref) ? &new_const_sv : NULL
4083                         );
4084                     }
4085                 if (!intro)
4086                     cv_ckproto_len_flags(cv, (const GV *)dstr,
4087                                    SvPOK(sref) ? CvPROTO(sref) : NULL,
4088                                    SvPOK(sref) ? CvPROTOLEN(sref) : 0,
4089                                    SvPOK(sref) ? SvUTF8(sref) : 0);
4090             }
4091             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4092             GvASSUMECV_on(dstr);
4093             if(GvSTASH(dstr)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
4094                 if (intro && GvREFCNT(dstr) > 1) {
4095                     /* temporary remove extra savestack's ref */
4096                     --GvREFCNT(dstr);
4097                     gv_method_changed(dstr);
4098                     ++GvREFCNT(dstr);
4099                 }
4100                 else gv_method_changed(dstr);
4101             }
4102         }
4103         *location = SvREFCNT_inc_simple_NN(sref);
4104         if (import_flag && !(GvFLAGS(dstr) & import_flag)
4105             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
4106             GvFLAGS(dstr) |= import_flag;
4107         }
4108
4109         if (stype == SVt_PVHV) {
4110             const char * const name = GvNAME((GV*)dstr);
4111             const STRLEN len = GvNAMELEN(dstr);
4112             if (
4113                 (
4114                    (len > 1 && name[len-2] == ':' && name[len-1] == ':')
4115                 || (len == 1 && name[0] == ':')
4116                 )
4117              && (!dref || HvENAME_get(dref))
4118             ) {
4119                 mro_package_moved(
4120                     (HV *)sref, (HV *)dref,
4121                     (GV *)dstr, 0
4122                 );
4123             }
4124         }
4125         else if (
4126             stype == SVt_PVAV && sref != dref
4127          && strEQ(GvNAME((GV*)dstr), "ISA")
4128          /* The stash may have been detached from the symbol table, so
4129             check its name before doing anything. */
4130          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
4131         ) {
4132             MAGIC *mg;
4133             MAGIC * const omg = dref && SvSMAGICAL(dref)
4134                                  ? mg_find(dref, PERL_MAGIC_isa)
4135                                  : NULL;
4136             if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
4137                 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
4138                     AV * const ary = newAV();
4139                     av_push(ary, mg->mg_obj); /* takes the refcount */
4140                     mg->mg_obj = (SV *)ary;
4141                 }
4142                 if (omg) {
4143                     if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
4144                         SV **svp = AvARRAY((AV *)omg->mg_obj);
4145                         I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
4146                         while (items--)
4147                             av_push(
4148                              (AV *)mg->mg_obj,
4149                              SvREFCNT_inc_simple_NN(*svp++)
4150                             );
4151                     }
4152                     else
4153                         av_push(
4154                          (AV *)mg->mg_obj,
4155                          SvREFCNT_inc_simple_NN(omg->mg_obj)
4156                         );
4157                 }
4158                 else
4159                     av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
4160             }
4161             else
4162             {
4163                 SSize_t i;
4164                 sv_magic(
4165                  sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
4166                 );
4167                 for (i = 0; i <= AvFILL(sref); ++i) {
4168                     SV **elem = av_fetch ((AV*)sref, i, 0);
4169                     if (elem) {
4170                         sv_magic(
4171                           *elem, sref, PERL_MAGIC_isaelem, NULL, i
4172                         );
4173                     }
4174                 }
4175                 mg = mg_find(sref, PERL_MAGIC_isa);
4176             }
4177             /* Since the *ISA assignment could have affected more than
4178                one stash, don't call mro_isa_changed_in directly, but let
4179                magic_clearisa do it for us, as it already has the logic for
4180                dealing with globs vs arrays of globs. */
4181             assert(mg);
4182             Perl_magic_clearisa(aTHX_ NULL, mg);
4183         }
4184         else if (stype == SVt_PVIO) {
4185             DEBUG_o(Perl_deb(aTHX_ "gv_setref clearing PL_stashcache\n"));
4186             /* It's a cache. It will rebuild itself quite happily.
4187                It's a lot of effort to work out exactly which key (or keys)
4188                might be invalidated by the creation of the this file handle.
4189             */
4190             hv_clear(PL_stashcache);
4191         }
4192         break;
4193     }
4194     if (!intro) SvREFCNT_dec(dref);
4195     if (SvTAINTED(sstr))
4196         SvTAINT(dstr);
4197     return;
4198 }
4199
4200
4201
4202
4203 #ifdef PERL_DEBUG_READONLY_COW
4204 # include <sys/mman.h>
4205
4206 # ifndef PERL_MEMORY_DEBUG_HEADER_SIZE
4207 #  define PERL_MEMORY_DEBUG_HEADER_SIZE 0
4208 # endif
4209
4210 void
4211 Perl_sv_buf_to_ro(pTHX_ SV *sv)
4212 {
4213     struct perl_memory_debug_header * const header =
4214         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4215     const MEM_SIZE len = header->size;
4216     PERL_ARGS_ASSERT_SV_BUF_TO_RO;
4217 # ifdef PERL_TRACK_MEMPOOL
4218     if (!header->readonly) header->readonly = 1;
4219 # endif
4220     if (mprotect(header, len, PROT_READ))
4221         Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
4222                          header, len, errno);
4223 }
4224
4225 static void
4226 S_sv_buf_to_rw(pTHX_ SV *sv)
4227 {
4228     struct perl_memory_debug_header * const header =
4229         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4230     const MEM_SIZE len = header->size;
4231     PERL_ARGS_ASSERT_SV_BUF_TO_RW;
4232     if (mprotect(header, len, PROT_READ|PROT_WRITE))
4233         Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
4234                          header, len, errno);
4235 # ifdef PERL_TRACK_MEMPOOL
4236     header->readonly = 0;
4237 # endif
4238 }
4239
4240 #else
4241 # define sv_buf_to_ro(sv)       NOOP
4242 # define sv_buf_to_rw(sv)       NOOP
4243 #endif
4244
4245 void
4246 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
4247 {
4248     U32 sflags;
4249     int dtype;
4250     svtype stype;
4251     unsigned int both_type;
4252
4253     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
4254
4255     if (UNLIKELY( sstr == dstr ))
4256         return;
4257
4258     if (UNLIKELY( !sstr ))
4259         sstr = &PL_sv_undef;
4260
4261     stype = SvTYPE(sstr);
4262     dtype = SvTYPE(dstr);
4263     both_type = (stype | dtype);
4264
4265     /* with these values, we can check that both SVs are NULL/IV (and not
4266      * freed) just by testing the or'ed types */
4267     STATIC_ASSERT_STMT(SVt_NULL == 0);
4268     STATIC_ASSERT_STMT(SVt_IV   == 1);
4269     if (both_type <= 1) {
4270         /* both src and dst are UNDEF/IV/RV, so we can do a lot of
4271          * special-casing */
4272         U32 sflags;
4273         U32 new_dflags;
4274
4275         /* minimal subset of SV_CHECK_THINKFIRST_COW_DROP(dstr) */
4276         if (SvREADONLY(dstr))
4277             Perl_croak_no_modify();
4278         if (SvROK(dstr))
4279             sv_unref_flags(dstr, 0);
4280
4281         assert(!SvGMAGICAL(sstr));
4282         assert(!SvGMAGICAL(dstr));
4283
4284         sflags = SvFLAGS(sstr);
4285         if (sflags & (SVf_IOK|SVf_ROK)) {
4286             SET_SVANY_FOR_BODYLESS_IV(dstr);
4287             new_dflags = SVt_IV;
4288
4289             if (sflags & SVf_ROK) {
4290                 dstr->sv_u.svu_rv = SvREFCNT_inc(SvRV(sstr));
4291                 new_dflags |= SVf_ROK;
4292             }
4293             else {
4294                 /* both src and dst are <= SVt_IV, so sv_any points to the
4295                  * head; so access the head directly
4296                  */
4297                 assert(    &(sstr->sv_u.svu_iv)
4298                         == &(((XPVIV*) SvANY(sstr))->xiv_iv));
4299                 assert(    &(dstr->sv_u.svu_iv)
4300                         == &(((XPVIV*) SvANY(dstr))->xiv_iv));
4301                 dstr->sv_u.svu_iv = sstr->sv_u.svu_iv;
4302                 new_dflags |= (SVf_IOK|SVp_IOK|(sflags & SVf_IVisUV));
4303             }
4304         }
4305         else {
4306             new_dflags = dtype; /* turn off everything except the type */
4307         }
4308         SvFLAGS(dstr) = new_dflags;
4309
4310         return;
4311     }
4312
4313     if (UNLIKELY(both_type == SVTYPEMASK)) {
4314         if (SvIS_FREED(dstr)) {
4315             Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
4316                        " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
4317         }
4318         if (SvIS_FREED(sstr)) {
4319             Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
4320                        (void*)sstr, (void*)dstr);
4321         }
4322     }
4323
4324
4325
4326     SV_CHECK_THINKFIRST_COW_DROP(dstr);
4327     dtype = SvTYPE(dstr); /* THINKFIRST may have changed type */
4328
4329     /* There's a lot of redundancy below but we're going for speed here */
4330
4331     switch (stype) {
4332     case SVt_NULL:
4333       undef_sstr:
4334         if (LIKELY( dtype != SVt_PVGV && dtype != SVt_PVLV )) {
4335             (void)SvOK_off(dstr);
4336             return;
4337         }
4338         break;
4339     case SVt_IV:
4340         if (SvIOK(sstr)) {
4341             switch (dtype) {
4342             case SVt_NULL:
4343                 /* For performance, we inline promoting to type SVt_IV. */
4344                 /* We're starting from SVt_NULL, so provided that define is
4345                  * actual 0, we don't have to unset any SV type flags
4346                  * to promote to SVt_IV. */
4347                 STATIC_ASSERT_STMT(SVt_NULL == 0);
4348                 SET_SVANY_FOR_BODYLESS_IV(dstr);
4349                 SvFLAGS(dstr) |= SVt_IV;
4350                 break;
4351             case SVt_NV:
4352             case SVt_PV:
4353                 sv_upgrade(dstr, SVt_PVIV);
4354                 break;
4355             case SVt_PVGV:
4356             case SVt_PVLV:
4357                 goto end_of_first_switch;
4358             }
4359             (void)SvIOK_only(dstr);
4360             SvIV_set(dstr,  SvIVX(sstr));
4361             if (SvIsUV(sstr))
4362                 SvIsUV_on(dstr);
4363             /* SvTAINTED can only be true if the SV has taint magic, which in
4364                turn means that the SV type is PVMG (or greater). This is the
4365                case statement for SVt_IV, so this cannot be true (whatever gcov
4366                may say).  */
4367             assert(!SvTAINTED(sstr));
4368             return;
4369         }
4370         if (!SvROK(sstr))
4371             goto undef_sstr;
4372         if (dtype < SVt_PV && dtype != SVt_IV)
4373             sv_upgrade(dstr, SVt_IV);
4374         break;
4375
4376     case SVt_NV:
4377         if (LIKELY( SvNOK(sstr) )) {
4378             switch (dtype) {
4379             case SVt_NULL:
4380             case SVt_IV:
4381                 sv_upgrade(dstr, SVt_NV);
4382                 break;
4383             case SVt_PV:
4384             case SVt_PVIV:
4385                 sv_upgrade(dstr, SVt_PVNV);
4386                 break;
4387             case SVt_PVGV:
4388             case SVt_PVLV:
4389                 goto end_of_first_switch;
4390             }
4391             SvNV_set(dstr, SvNVX(sstr));
4392             (void)SvNOK_only(dstr);
4393             /* SvTAINTED can only be true if the SV has taint magic, which in
4394                turn means that the SV type is PVMG (or greater). This is the
4395                case statement for SVt_NV, so this cannot be true (whatever gcov
4396                may say).  */
4397             assert(!SvTAINTED(sstr));
4398             return;
4399         }
4400         goto undef_sstr;
4401
4402     case SVt_PV:
4403         if (dtype < SVt_PV)
4404             sv_upgrade(dstr, SVt_PV);
4405         break;
4406     case SVt_PVIV:
4407         if (dtype < SVt_PVIV)
4408             sv_upgrade(dstr, SVt_PVIV);
4409         break;
4410     case SVt_PVNV:
4411         if (dtype < SVt_PVNV)
4412             sv_upgrade(dstr, SVt_PVNV);
4413         break;
4414     default:
4415         {
4416         const char * const type = sv_reftype(sstr,0);
4417         if (PL_op)
4418             /* diag_listed_as: Bizarre copy of %s */
4419             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4420         else
4421             Perl_croak(aTHX_ "Bizarre copy of %s", type);
4422         }
4423         NOT_REACHED; /* NOTREACHED */
4424
4425     case SVt_REGEXP:
4426       upgregexp:
4427         if (dtype < SVt_REGEXP)
4428         {
4429             if (dtype >= SVt_PV) {
4430                 SvPV_free(dstr);
4431                 SvPV_set(dstr, 0);
4432                 SvLEN_set(dstr, 0);
4433                 SvCUR_set(dstr, 0);
4434             }
4435             sv_upgrade(dstr, SVt_REGEXP);
4436         }
4437         break;
4438
4439         case SVt_INVLIST:
4440     case SVt_PVLV:
4441     case SVt_PVGV:
4442     case SVt_PVMG:
4443         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4444             mg_get(sstr);
4445             if (SvTYPE(sstr) != stype)
4446                 stype = SvTYPE(sstr);
4447         }
4448         if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4449                     glob_assign_glob(dstr, sstr, dtype);
4450                     return;
4451         }
4452         if (stype == SVt_PVLV)
4453         {
4454             if (isREGEXP(sstr)) goto upgregexp;
4455             SvUPGRADE(dstr, SVt_PVNV);
4456         }
4457         else
4458             SvUPGRADE(dstr, (svtype)stype);
4459     }
4460  end_of_first_switch:
4461
4462     /* dstr may have been upgraded.  */
4463     dtype = SvTYPE(dstr);
4464     sflags = SvFLAGS(sstr);
4465
4466     if (UNLIKELY( dtype == SVt_PVCV )) {
4467         /* Assigning to a subroutine sets the prototype.  */
4468         if (SvOK(sstr)) {
4469             STRLEN len;
4470             const char *const ptr = SvPV_const(sstr, len);
4471
4472             SvGROW(dstr, len + 1);
4473             Copy(ptr, SvPVX(dstr), len + 1, char);
4474             SvCUR_set(dstr, len);
4475             SvPOK_only(dstr);
4476             SvFLAGS(dstr) |= sflags & SVf_UTF8;
4477             CvAUTOLOAD_off(dstr);
4478         } else {
4479             SvOK_off(dstr);
4480         }
4481     }
4482     else if (UNLIKELY(dtype == SVt_PVAV || dtype == SVt_PVHV
4483              || dtype == SVt_PVFM))
4484     {
4485         const char * const type = sv_reftype(dstr,0);
4486         if (PL_op)
4487             /* diag_listed_as: Cannot copy to %s */
4488             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4489         else
4490             Perl_croak(aTHX_ "Cannot copy to %s", type);
4491     } else if (sflags & SVf_ROK) {
4492         if (isGV_with_GP(dstr)
4493             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4494             sstr = SvRV(sstr);
4495             if (sstr == dstr) {
4496                 if (GvIMPORTED(dstr) != GVf_IMPORTED
4497                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4498                 {
4499                     GvIMPORTED_on(dstr);
4500                 }
4501                 GvMULTI_on(dstr);
4502                 return;
4503             }
4504             glob_assign_glob(dstr, sstr, dtype);
4505             return;
4506         }
4507
4508         if (dtype >= SVt_PV) {
4509             if (isGV_with_GP(dstr)) {
4510                 gv_setref(dstr, sstr);
4511                 return;
4512             }
4513             if (SvPVX_const(dstr)) {
4514                 SvPV_free(dstr);
4515                 SvLEN_set(dstr, 0);
4516                 SvCUR_set(dstr, 0);
4517             }
4518         }
4519         (void)SvOK_off(dstr);
4520         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4521         SvFLAGS(dstr) |= sflags & SVf_ROK;
4522         assert(!(sflags & SVp_NOK));
4523         assert(!(sflags & SVp_IOK));
4524         assert(!(sflags & SVf_NOK));
4525         assert(!(sflags & SVf_IOK));
4526     }
4527     else if (isGV_with_GP(dstr)) {
4528         if (!(sflags & SVf_OK)) {
4529             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4530                            "Undefined value assigned to typeglob");
4531         }
4532         else {
4533             GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
4534             if (dstr != (const SV *)gv) {
4535                 const char * const name = GvNAME((const GV *)dstr);
4536                 const STRLEN len = GvNAMELEN(dstr);
4537                 HV *old_stash = NULL;
4538                 bool reset_isa = FALSE;
4539                 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4540                  || (len == 1 && name[0] == ':')) {
4541                     /* Set aside the old stash, so we can reset isa caches
4542                        on its subclasses. */
4543                     if((old_stash = GvHV(dstr))) {
4544                         /* Make sure we do not lose it early. */
4545                         SvREFCNT_inc_simple_void_NN(
4546                          sv_2mortal((SV *)old_stash)
4547                         );
4548                     }
4549                     reset_isa = TRUE;
4550                 }
4551
4552                 if (GvGP(dstr)) {
4553                     SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
4554                     gp_free(MUTABLE_GV(dstr));
4555                 }
4556                 GvGP_set(dstr, gp_ref(GvGP(gv)));
4557
4558                 if (reset_isa) {
4559                     HV * const stash = GvHV(dstr);
4560                     if(
4561                         old_stash ? (HV *)HvENAME_get(old_stash) : stash
4562                     )
4563                         mro_package_moved(
4564                          stash, old_stash,
4565                          (GV *)dstr, 0
4566                         );
4567                 }
4568             }
4569         }
4570     }
4571     else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4572           && (stype == SVt_REGEXP || isREGEXP(sstr))) {
4573         reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4574     }
4575     else if (sflags & SVp_POK) {
4576         const STRLEN cur = SvCUR(sstr);
4577         const STRLEN len = SvLEN(sstr);
4578
4579         /*
4580          * We have three basic ways to copy the string:
4581          *
4582          *  1. Swipe
4583          *  2. Copy-on-write
4584          *  3. Actual copy
4585          * 
4586          * Which we choose is based on various factors.  The following
4587          * things are listed in order of speed, fastest to slowest:
4588          *  - Swipe
4589          *  - Copying a short string
4590          *  - Copy-on-write bookkeeping
4591          *  - malloc
4592          *  - Copying a long string
4593          * 
4594          * We swipe the string (steal the string buffer) if the SV on the
4595          * rhs is about to be freed anyway (TEMP and refcnt==1).  This is a
4596          * big win on long strings.  It should be a win on short strings if
4597          * SvPVX_const(dstr) has to be allocated.  If not, it should not 
4598          * slow things down, as SvPVX_const(sstr) would have been freed
4599          * soon anyway.
4600          * 
4601          * We also steal the buffer from a PADTMP (operator target) if it
4602          * is ‘long enough’.  For short strings, a swipe does not help
4603          * here, as it causes more malloc calls the next time the target
4604          * is used.  Benchmarks show that even if SvPVX_const(dstr) has to
4605          * be allocated it is still not worth swiping PADTMPs for short
4606          * strings, as the savings here are small.
4607          * 
4608          * If swiping is not an option, then we see whether it is
4609          * worth using copy-on-write.  If the lhs already has a buf-
4610          * fer big enough and the string is short, we skip it and fall back
4611          * to method 3, since memcpy is faster for short strings than the
4612          * later bookkeeping overhead that copy-on-write entails.
4613
4614          * If the rhs is not a copy-on-write string yet, then we also
4615          * consider whether the buffer is too large relative to the string
4616          * it holds.  Some operations such as readline allocate a large
4617          * buffer in the expectation of reusing it.  But turning such into
4618          * a COW buffer is counter-productive because it increases memory
4619          * usage by making readline allocate a new large buffer the sec-
4620          * ond time round.  So, if the buffer is too large, again, we use
4621          * method 3 (copy).
4622          * 
4623          * Finally, if there is no buffer on the left, or the buffer is too 
4624          * small, then we use copy-on-write and make both SVs share the
4625          * string buffer.
4626          *
4627          */
4628
4629         /* Whichever path we take through the next code, we want this true,
4630            and doing it now facilitates the COW check.  */
4631         (void)SvPOK_only(dstr);
4632
4633         if (
4634                  (              /* Either ... */
4635                                 /* slated for free anyway (and not COW)? */
4636                     (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
4637                                 /* or a swipable TARG */
4638                  || ((sflags &
4639                            (SVs_PADTMP|SVf_READONLY|SVf_PROTECT|SVf_IsCOW))
4640                        == SVs_PADTMP
4641                                 /* whose buffer is worth stealing */
4642                      && CHECK_COWBUF_THRESHOLD(cur,len)
4643                     )
4644                  ) &&
4645                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4646                  (!(flags & SV_NOSTEAL)) &&
4647                                         /* and we're allowed to steal temps */
4648                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4649                  len)             /* and really is a string */
4650         {       /* Passes the swipe test.  */
4651             if (SvPVX_const(dstr))      /* we know that dtype >= SVt_PV */
4652                 SvPV_free(dstr);
4653             SvPV_set(dstr, SvPVX_mutable(sstr));
4654             SvLEN_set(dstr, SvLEN(sstr));
4655             SvCUR_set(dstr, SvCUR(sstr));
4656
4657             SvTEMP_off(dstr);
4658             (void)SvOK_off(sstr);       /* NOTE: nukes most SvFLAGS on sstr */
4659             SvPV_set(sstr, NULL);
4660             SvLEN_set(sstr, 0);
4661             SvCUR_set(sstr, 0);
4662             SvTEMP_off(sstr);
4663         }
4664         else if (flags & SV_COW_SHARED_HASH_KEYS
4665               &&
4666 #ifdef PERL_COPY_ON_WRITE
4667                  (sflags & SVf_IsCOW
4668                    ? (!len ||
4669                        (  (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
4670                           /* If this is a regular (non-hek) COW, only so
4671                              many COW "copies" are possible. */
4672                        && CowREFCNT(sstr) != SV_COW_REFCNT_MAX  ))
4673                    : (  (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4674                      && !(SvFLAGS(dstr) & SVf_BREAK)
4675                      && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len
4676                      && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
4677                     ))
4678 #else
4679                  sflags & SVf_IsCOW
4680               && !(SvFLAGS(dstr) & SVf_BREAK)
4681 #endif
4682             ) {
4683             /* Either it's a shared hash key, or it's suitable for
4684                copy-on-write.  */
4685             if (DEBUG_C_TEST) {
4686                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4687                 sv_dump(sstr);
4688                 sv_dump(dstr);
4689             }
4690 #ifdef PERL_ANY_COW
4691             if (!(sflags & SVf_IsCOW)) {
4692                     SvIsCOW_on(sstr);
4693                     CowREFCNT(sstr) = 0;
4694             }
4695 #endif
4696             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
4697                 SvPV_free(dstr);
4698             }
4699
4700 #ifdef PERL_ANY_COW
4701             if (len) {
4702                     if (sflags & SVf_IsCOW) {
4703                         sv_buf_to_rw(sstr);
4704                     }
4705                     CowREFCNT(sstr)++;
4706                     SvPV_set(dstr, SvPVX_mutable(sstr));
4707                     sv_buf_to_ro(sstr);
4708             } else
4709 #endif
4710             {
4711                     /* SvIsCOW_shared_hash */
4712                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4713                                           "Copy on write: Sharing hash\n"));
4714
4715                     assert (SvTYPE(dstr) >= SVt_PV);
4716                     SvPV_set(dstr,
4717                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4718             }
4719             SvLEN_set(dstr, len);
4720             SvCUR_set(dstr, cur);
4721             SvIsCOW_on(dstr);
4722         } else {
4723             /* Failed the swipe test, and we cannot do copy-on-write either.
4724                Have to copy the string.  */
4725             SvGROW(dstr, cur + 1);      /* inlined from sv_setpvn */
4726             Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
4727             SvCUR_set(dstr, cur);
4728             *SvEND(dstr) = '\0';
4729         }
4730         if (sflags & SVp_NOK) {
4731             SvNV_set(dstr, SvNVX(sstr));
4732         }
4733         if (sflags & SVp_IOK) {
4734             SvIV_set(dstr, SvIVX(sstr));
4735             /* Must do this otherwise some other overloaded use of 0x80000000
4736                gets confused. I guess SVpbm_VALID */
4737             if (sflags & SVf_IVisUV)
4738                 SvIsUV_on(dstr);
4739         }
4740         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4741         {
4742             const MAGIC * const smg = SvVSTRING_mg(sstr);
4743             if (smg) {
4744                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4745                          smg->mg_ptr, smg->mg_len);
4746                 SvRMAGICAL_on(dstr);
4747             }
4748         }
4749     }
4750     else if (sflags & (SVp_IOK|SVp_NOK)) {
4751         (void)SvOK_off(dstr);
4752         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4753         if (sflags & SVp_IOK) {
4754             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4755             SvIV_set(dstr, SvIVX(sstr));
4756         }
4757         if (sflags & SVp_NOK) {
4758             SvNV_set(dstr, SvNVX(sstr));
4759         }
4760     }
4761     else {
4762         if (isGV_with_GP(sstr)) {
4763             gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4764         }
4765         else
4766             (void)SvOK_off(dstr);
4767     }
4768     if (SvTAINTED(sstr))
4769         SvTAINT(dstr);
4770 }
4771
4772 /*
4773 =for apidoc sv_setsv_mg
4774
4775 Like C<sv_setsv>, but also handles 'set' magic.
4776
4777 =cut
4778 */
4779
4780 void
4781 Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr)
4782 {
4783     PERL_ARGS_ASSERT_SV_SETSV_MG;
4784
4785     sv_setsv(dstr,sstr);
4786     SvSETMAGIC(dstr);
4787 }
4788
4789 #ifdef PERL_ANY_COW
4790 #  define SVt_COW SVt_PV
4791 SV *
4792 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4793 {
4794     STRLEN cur = SvCUR(sstr);
4795     STRLEN len = SvLEN(sstr);
4796     char *new_pv;
4797 #if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_COPY_ON_WRITE)
4798     const bool already = cBOOL(SvIsCOW(sstr));
4799 #endif
4800
4801     PERL_ARGS_ASSERT_SV_SETSV_COW;
4802
4803     if (DEBUG_C_TEST) {
4804         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4805                       (void*)sstr, (void*)dstr);
4806         sv_dump(sstr);
4807         if (dstr)
4808                     sv_dump(dstr);
4809     }
4810
4811     if (dstr) {
4812         if (SvTHINKFIRST(dstr))
4813             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4814         else if (SvPVX_const(dstr))
4815             Safefree(SvPVX_mutable(dstr));
4816     }
4817     else
4818         new_SV(dstr);
4819     SvUPGRADE(dstr, SVt_COW);
4820
4821     assert (SvPOK(sstr));
4822     assert (SvPOKp(sstr));
4823
4824     if (SvIsCOW(sstr)) {
4825
4826         if (SvLEN(sstr) == 0) {
4827             /* source is a COW shared hash key.  */
4828             DEBUG_C(PerlIO_printf(Perl_debug_log,
4829                                   "Fast copy on write: Sharing hash\n"));
4830             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4831             goto common_exit;
4832         }
4833         assert(SvCUR(sstr)+1 < SvLEN(sstr));
4834         assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX);
4835     } else {
4836         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4837         SvUPGRADE(sstr, SVt_COW);
4838         SvIsCOW_on(sstr);
4839         DEBUG_C(PerlIO_printf(Perl_debug_log,
4840                               "Fast copy on write: Converting sstr to COW\n"));
4841         CowREFCNT(sstr) = 0;    
4842     }
4843 #  ifdef PERL_DEBUG_READONLY_COW
4844     if (already) sv_buf_to_rw(sstr);
4845 #  endif
4846     CowREFCNT(sstr)++;  
4847     new_pv = SvPVX_mutable(sstr);
4848     sv_buf_to_ro(sstr);
4849
4850   common_exit:
4851     SvPV_set(dstr, new_pv);
4852     SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
4853     if (SvUTF8(sstr))
4854         SvUTF8_on(dstr);
4855     SvLEN_set(dstr, len);
4856     SvCUR_set(dstr, cur);
4857     if (DEBUG_C_TEST) {
4858         sv_dump(dstr);
4859     }
4860     return dstr;
4861 }
4862 #endif
4863
4864 /*
4865 =for apidoc sv_setpvn
4866
4867 Copies a string (possibly containing embedded C<NUL> characters) into an SV.
4868 The C<len> parameter indicates the number of
4869 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4870 undefined.  Does not handle 'set' magic.  See C<L</sv_setpvn_mg>>.
4871
4872 =cut
4873 */
4874
4875 void
4876 Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4877 {
4878     char *dptr;
4879
4880     PERL_ARGS_ASSERT_SV_SETPVN;
4881
4882     SV_CHECK_THINKFIRST_COW_DROP(sv);
4883     if (!ptr) {
4884         (void)SvOK_off(sv);
4885         return;
4886     }
4887     else {
4888         /* len is STRLEN which is unsigned, need to copy to signed */
4889         const IV iv = len;
4890         if (iv < 0)
4891             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
4892                        IVdf, iv);
4893     }
4894     SvUPGRADE(sv, SVt_PV);
4895
4896     dptr = SvGROW(sv, len + 1);
4897     Move(ptr,dptr,len,char);
4898     dptr[len] = '\0';
4899     SvCUR_set(sv, len);
4900     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4901     SvTAINT(sv);
4902     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4903 }
4904
4905 /*
4906 =for apidoc sv_setpvn_mg
4907
4908 Like C<sv_setpvn>, but also handles 'set' magic.
4909
4910 =cut
4911 */
4912
4913 void
4914 Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4915 {
4916     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4917
4918     sv_setpvn(sv,ptr,len);
4919     SvSETMAGIC(sv);
4920 }
4921
4922 /*
4923 =for apidoc sv_setpv
4924
4925 Copies a string into an SV.  The string must be terminated with a C<NUL>
4926 character.
4927 Does not handle 'set' magic.  See C<L</sv_setpv_mg>>.
4928
4929 =cut
4930 */
4931
4932 void
4933 Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
4934 {
4935     STRLEN len;
4936
4937     PERL_ARGS_ASSERT_SV_SETPV;
4938
4939     SV_CHECK_THINKFIRST_COW_DROP(sv);
4940     if (!ptr) {
4941         (void)SvOK_off(sv);
4942         return;
4943     }
4944     len = strlen(ptr);
4945     SvUPGRADE(sv, SVt_PV);
4946
4947     SvGROW(sv, len + 1);
4948     Move(ptr,SvPVX(sv),len+1,char);
4949     SvCUR_set(sv, len);
4950     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4951     SvTAINT(sv);
4952     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4953 }
4954
4955 /*
4956 =for apidoc sv_setpv_mg
4957
4958 Like C<sv_setpv>, but also handles 'set' magic.
4959
4960 =cut
4961 */
4962
4963 void
4964 Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
4965 {
4966     PERL_ARGS_ASSERT_SV_SETPV_MG;
4967
4968     sv_setpv(sv,ptr);
4969     SvSETMAGIC(sv);
4970 }
4971
4972 void
4973 Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
4974 {
4975     PERL_ARGS_ASSERT_SV_SETHEK;
4976
4977     if (!hek) {
4978         return;
4979     }
4980
4981     if (HEK_LEN(hek) == HEf_SVKEY) {
4982         sv_setsv(sv, *(SV**)HEK_KEY(hek));
4983         return;
4984     } else {
4985         const int flags = HEK_FLAGS(hek);
4986         if (flags & HVhek_WASUTF8) {
4987             STRLEN utf8_len = HEK_LEN(hek);
4988             char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
4989             sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
4990             SvUTF8_on(sv);
4991             return;
4992         } else if (flags & HVhek_UNSHARED) {
4993             sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
4994             if (HEK_UTF8(hek))
4995                 SvUTF8_on(sv);
4996             else SvUTF8_off(sv);
4997             return;
4998         }
4999         {
5000             SV_CHECK_THINKFIRST_COW_DROP(sv);
5001             SvUPGRADE(sv, SVt_PV);
5002             SvPV_free(sv);
5003             SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
5004             SvCUR_set(sv, HEK_LEN(hek));
5005             SvLEN_set(sv, 0);
5006             SvIsCOW_on(sv);
5007             SvPOK_on(sv);
5008             if (HEK_UTF8(hek))
5009                 SvUTF8_on(sv);
5010             else SvUTF8_off(sv);
5011             return;
5012         }
5013     }
5014 }
5015
5016
5017 /*
5018 =for apidoc sv_usepvn_flags
5019
5020 Tells an SV to use C<ptr> to find its string value.  Normally the
5021 string is stored inside the SV, but sv_usepvn allows the SV to use an
5022 outside string.  C<ptr> should point to memory that was allocated
5023 by L<C<Newx>|perlclib/Memory Management and String Handling>.  It must be
5024 the start of a C<Newx>-ed block of memory, and not a pointer to the
5025 middle of it (beware of L<C<OOK>|perlguts/Offsets> and copy-on-write),
5026 and not be from a non-C<Newx> memory allocator like C<malloc>.  The
5027 string length, C<len>, must be supplied.  By default this function
5028 will C<Renew> (i.e. realloc, move) the memory pointed to by C<ptr>,
5029 so that pointer should not be freed or used by the programmer after
5030 giving it to C<sv_usepvn>, and neither should any pointers from "behind"
5031 that pointer (e.g. ptr + 1) be used.
5032
5033 If S<C<flags & SV_SMAGIC>> is true, will call C<SvSETMAGIC>.  If
5034 S<C<flags> & SV_HAS_TRAILING_NUL>> is true, then C<ptr[len]> must be C<NUL>,
5035 and the realloc
5036 will be skipped (i.e. the buffer is actually at least 1 byte longer than
5037 C<len>, and already meets the requirements for storing in C<SvPVX>).
5038
5039 =cut
5040 */
5041
5042 void
5043 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
5044 {
5045     STRLEN allocate;
5046
5047     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
5048
5049     SV_CHECK_THINKFIRST_COW_DROP(sv);
5050     SvUPGRADE(sv, SVt_PV);
5051     if (!ptr) {
5052         (void)SvOK_off(sv);
5053         if (flags & SV_SMAGIC)
5054             SvSETMAGIC(sv);
5055         return;
5056     }
5057     if (SvPVX_const(sv))
5058         SvPV_free(sv);
5059
5060 #ifdef DEBUGGING
5061     if (flags & SV_HAS_TRAILING_NUL)
5062         assert(ptr[len] == '\0');
5063 #endif
5064
5065     allocate = (flags & SV_HAS_TRAILING_NUL)
5066         ? len + 1 :
5067 #ifdef Perl_safesysmalloc_size
5068         len + 1;
5069 #else 
5070         PERL_STRLEN_ROUNDUP(len + 1);
5071 #endif
5072     if (flags & SV_HAS_TRAILING_NUL) {
5073         /* It's long enough - do nothing.
5074            Specifically Perl_newCONSTSUB is relying on this.  */
5075     } else {
5076 #ifdef DEBUGGING
5077         /* Force a move to shake out bugs in callers.  */
5078         char *new_ptr = (char*)safemalloc(allocate);
5079         Copy(ptr, new_ptr, len, char);
5080         PoisonFree(ptr,len,char);
5081         Safefree(ptr);
5082         ptr = new_ptr;
5083 #else
5084         ptr = (char*) saferealloc (ptr, allocate);
5085 #endif
5086     }
5087 #ifdef Perl_safesysmalloc_size
5088     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
5089 #else
5090     SvLEN_set(sv, allocate);
5091 #endif
5092     SvCUR_set(sv, len);
5093     SvPV_set(sv, ptr);
5094     if (!(flags & SV_HAS_TRAILING_NUL)) {
5095         ptr[len] = '\0';
5096     }
5097     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5098     SvTAINT(sv);
5099     if (flags & SV_SMAGIC)
5100         SvSETMAGIC(sv);
5101 }
5102
5103 /*
5104 =for apidoc sv_force_normal_flags
5105
5106 Undo various types of fakery on an SV, where fakery means
5107 "more than" a string: if the PV is a shared string, make
5108 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5109 an C<xpvmg>; if we're a copy-on-write scalar, this is the on-write time when
5110 we do the copy, and is also used locally; if this is a
5111 vstring, drop the vstring magic.  If C<SV_COW_DROP_PV> is set
5112 then a copy-on-write scalar drops its PV buffer (if any) and becomes
5113 C<SvPOK_off> rather than making a copy.  (Used where this
5114 scalar is about to be set to some other value.)  In addition,
5115 the C<flags> parameter gets passed to C<sv_unref_flags()>
5116 when unreffing.  C<sv_force_normal> calls this function
5117 with flags set to 0.
5118
5119 This function is expected to be used to signal to perl that this SV is
5120 about to be written to, and any extra book-keeping needs to be taken care
5121 of.  Hence, it croaks on read-only values.
5122
5123 =cut
5124 */
5125
5126 static void
5127 S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
5128 {
5129     assert(SvIsCOW(sv));
5130     {
5131 #ifdef PERL_ANY_COW
5132         const char * const pvx = SvPVX_const(sv);
5133         const STRLEN len = SvLEN(sv);
5134         const STRLEN cur = SvCUR(sv);
5135
5136         if (DEBUG_C_TEST) {
5137                 PerlIO_printf(Perl_debug_log,
5138                               "Copy on write: Force normal %ld\n",
5139                               (long) flags);
5140                 sv_dump(sv);
5141         }
5142         SvIsCOW_off(sv);
5143 # ifdef PERL_COPY_ON_WRITE
5144         if (len) {
5145             /* Must do this first, since the CowREFCNT uses SvPVX and
5146             we need to write to CowREFCNT, or de-RO the whole buffer if we are
5147             the only owner left of the buffer. */
5148             sv_buf_to_rw(sv); /* NOOP if RO-ing not supported */
5149             {
5150                 U8 cowrefcnt = CowREFCNT(sv);
5151                 if(cowrefcnt != 0) {
5152                     cowrefcnt--;
5153                     CowREFCNT(sv) = cowrefcnt;
5154                     sv_buf_to_ro(sv);
5155                     goto copy_over;
5156                 }
5157             }
5158             /* Else we are the only owner of the buffer. */
5159         }
5160         else
5161 # endif
5162         {
5163             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
5164             copy_over:
5165             SvPV_set(sv, NULL);
5166             SvCUR_set(sv, 0);
5167             SvLEN_set(sv, 0);
5168             if (flags & SV_COW_DROP_PV) {
5169                 /* OK, so we don't need to copy our buffer.  */
5170                 SvPOK_off(sv);
5171             } else {
5172                 SvGROW(sv, cur + 1);
5173                 Move(pvx,SvPVX(sv),cur,char);
5174                 SvCUR_set(sv, cur);
5175                 *SvEND(sv) = '\0';
5176             }
5177             if (len) {
5178             } else {
5179                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5180             }
5181             if (DEBUG_C_TEST) {
5182                 sv_dump(sv);
5183             }
5184         }
5185 #else
5186             const char * const pvx = SvPVX_const(sv);
5187             const STRLEN len = SvCUR(sv);
5188             SvIsCOW_off(sv);
5189             SvPV_set(sv, NULL);
5190             SvLEN_set(sv, 0);
5191             if (flags & SV_COW_DROP_PV) {
5192                 /* OK, so we don't need to copy our buffer.  */
5193                 SvPOK_off(sv);
5194             } else {
5195                 SvGROW(sv, len + 1);
5196                 Move(pvx,SvPVX(sv),len,char);
5197                 *SvEND(sv) = '\0';
5198             }
5199             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5200 #endif
5201     }
5202 }
5203
5204 void
5205 Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
5206 {
5207     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
5208
5209     if (SvREADONLY(sv))
5210         Perl_croak_no_modify();
5211     else if (SvIsCOW(sv) && LIKELY(SvTYPE(sv) != SVt_PVHV))
5212         S_sv_uncow(aTHX_ sv, flags);
5213     if (SvROK(sv))
5214         sv_unref_flags(sv, flags);
5215     else if (SvFAKE(sv) && isGV_with_GP(sv))
5216         sv_unglob(sv, flags);
5217     else if (SvFAKE(sv) && isREGEXP(sv)) {
5218         /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
5219            to sv_unglob. We only need it here, so inline it.  */
5220         const bool islv = SvTYPE(sv) == SVt_PVLV;
5221         const svtype new_type =
5222           islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
5223         SV *const temp = newSV_type(new_type);
5224         regexp *const temp_p = ReANY((REGEXP *)sv);
5225
5226         if (new_type == SVt_PVMG) {
5227             SvMAGIC_set(temp, SvMAGIC(sv));
5228             SvMAGIC_set(sv, NULL);
5229             SvSTASH_set(temp, SvSTASH(sv));
5230             SvSTASH_set(sv, NULL);
5231         }
5232         if (!islv) SvCUR_set(temp, SvCUR(sv));
5233         /* Remember that SvPVX is in the head, not the body.  But
5234            RX_WRAPPED is in the body. */
5235         assert(ReANY((REGEXP *)sv)->mother_re);
5236         /* Their buffer is already owned by someone else. */
5237         if (flags & SV_COW_DROP_PV) {
5238             /* SvLEN is already 0.  For SVt_REGEXP, we have a brand new
5239                zeroed body.  For SVt_PVLV, it should have been set to 0
5240                before turning into a regexp. */
5241             assert(!SvLEN(islv ? sv : temp));
5242             sv->sv_u.svu_pv = 0;
5243         }
5244         else {
5245             sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
5246             SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
5247             SvPOK_on(sv);
5248         }
5249
5250         /* Now swap the rest of the bodies. */
5251
5252         SvFAKE_off(sv);
5253         if (!islv) {
5254             SvFLAGS(sv) &= ~SVTYPEMASK;
5255             SvFLAGS(sv) |= new_type;
5256             SvANY(sv) = SvANY(temp);
5257         }
5258
5259         SvFLAGS(temp) &= ~(SVTYPEMASK);
5260         SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
5261         SvANY(temp) = temp_p;
5262         temp->sv_u.svu_rx = (regexp *)temp_p;
5263
5264         SvREFCNT_dec_NN(temp);
5265     }
5266     else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
5267 }
5268
5269 /*
5270 =for apidoc sv_chop
5271
5272 Efficient removal of characters from the beginning of the string buffer.
5273 C<SvPOK(sv)>, or at least C<SvPOKp(sv)>, must be true and C<ptr> must be a
5274 pointer to somewhere inside the string buffer.  C<ptr> becomes the first
5275 character of the adjusted string.  Uses the C<OOK> hack.  On return, only
5276 C<SvPOK(sv)> and C<SvPOKp(sv)> among the C<OK> flags will be true.
5277
5278 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
5279 refer to the same chunk of data.
5280
5281 The unfortunate similarity of this function's name to that of Perl's C<chop>
5282 operator is strictly coincidental.  This function works from the left;
5283 C<chop> works from the right.
5284
5285 =cut
5286 */
5287
5288 void
5289 Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
5290 {
5291     STRLEN delta;
5292     STRLEN old_delta;
5293     U8 *p;
5294 #ifdef DEBUGGING
5295     const U8 *evacp;
5296     STRLEN evacn;
5297 #endif
5298     STRLEN max_delta;
5299
5300     PERL_ARGS_ASSERT_SV_CHOP;
5301
5302     if (!ptr || !SvPOKp(sv))
5303         return;
5304     delta = ptr - SvPVX_const(sv);
5305     if (!delta) {
5306         /* Nothing to do.  */
5307         return;
5308     }
5309     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
5310     if (delta > max_delta)
5311         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
5312                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
5313     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
5314     SV_CHECK_THINKFIRST(sv);
5315     SvPOK_only_UTF8(sv);
5316
5317     if (!SvOOK(sv)) {
5318         if (!SvLEN(sv)) { /* make copy of shared string */
5319             const char *pvx = SvPVX_const(sv);
5320             const STRLEN len = SvCUR(sv);
5321             SvGROW(sv, len + 1);
5322             Move(pvx,SvPVX(sv),len,char);
5323             *SvEND(sv) = '\0';
5324         }
5325         SvOOK_on(sv);
5326         old_delta = 0;
5327     } else {
5328         SvOOK_offset(sv, old_delta);
5329     }
5330     SvLEN_set(sv, SvLEN(sv) - delta);
5331     SvCUR_set(sv, SvCUR(sv) - delta);
5332     SvPV_set(sv, SvPVX(sv) + delta);
5333
5334     p = (U8 *)SvPVX_const(sv);
5335
5336 #ifdef DEBUGGING
5337     /* how many bytes were evacuated?  we will fill them with sentinel
5338        bytes, except for the part holding the new offset of course. */
5339     evacn = delta;
5340     if (old_delta)
5341         evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
5342     assert(evacn);
5343     assert(evacn <= delta + old_delta);
5344     evacp = p - evacn;
5345 #endif
5346
5347     /* This sets 'delta' to the accumulated value of all deltas so far */
5348     delta += old_delta;
5349     assert(delta);
5350
5351     /* If 'delta' fits in a byte, store it just prior to the new beginning of
5352      * the string; otherwise store a 0 byte there and store 'delta' just prior
5353      * to that, using as many bytes as a STRLEN occupies.  Thus it overwrites a
5354      * portion of the chopped part of the string */
5355     if (delta < 0x100) {
5356         *--p = (U8) delta;
5357     } else {
5358         *--p = 0;
5359         p -= sizeof(STRLEN);
5360         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
5361     }
5362
5363 #ifdef DEBUGGING
5364     /* Fill the preceding buffer with sentinals to verify that no-one is
5365        using it.  */
5366     while (p > evacp) {
5367         --p;
5368         *p = (U8)PTR2UV(p);
5369     }
5370 #endif
5371 }
5372
5373 /*
5374 =for apidoc sv_catpvn
5375
5376 Concatenates the string onto the end of the string which is in the SV.
5377 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
5378 status set, then the bytes appended should be valid UTF-8.
5379 Handles 'get' magic, but not 'set' magic.  See C<L</sv_catpvn_mg>>.
5380
5381 =for apidoc sv_catpvn_flags
5382
5383 Concatenates the string onto the end of the string which is in the SV.  The
5384 C<len> indicates number of bytes to copy.
5385
5386 By default, the string appended is assumed to be valid UTF-8 if the SV has
5387 the UTF-8 status set, and a string of bytes otherwise.  One can force the
5388 appended string to be interpreted as UTF-8 by supplying the C<SV_CATUTF8>
5389 flag, and as bytes by supplying the C<SV_CATBYTES> flag; the SV or the
5390 string appended will be upgraded to UTF-8 if necessary.
5391
5392 If C<flags> has the C<SV_SMAGIC> bit set, will
5393 C<mg_set> on C<dsv> afterwards if appropriate.
5394 C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5395 in terms of this function.
5396
5397 =cut
5398 */
5399
5400 void
5401 Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
5402 {
5403     STRLEN dlen;
5404     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5405
5406     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5407     assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5408
5409     if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
5410       if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
5411          sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5412          dlen = SvCUR(dsv);
5413       }
5414       else SvGROW(dsv, dlen + slen + 1);
5415       if (sstr == dstr)
5416         sstr = SvPVX_const(dsv);
5417       Move(sstr, SvPVX(dsv) + dlen, slen, char);
5418       SvCUR_set(dsv, SvCUR(dsv) + slen);
5419     }
5420     else {
5421         /* We inline bytes_to_utf8, to avoid an extra malloc. */
5422         const char * const send = sstr + slen;
5423         U8 *d;
5424
5425         /* Something this code does not account for, which I think is
5426            impossible; it would require the same pv to be treated as
5427            bytes *and* utf8, which would indicate a bug elsewhere. */
5428         assert(sstr != dstr);
5429
5430         SvGROW(dsv, dlen + slen * 2 + 1);
5431         d = (U8 *)SvPVX(dsv) + dlen;
5432
5433         while (sstr < send) {
5434             append_utf8_from_native_byte(*sstr, &d);
5435             sstr++;
5436         }
5437         SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5438     }
5439     *SvEND(dsv) = '\0';
5440     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
5441     SvTAINT(dsv);
5442     if (flags & SV_SMAGIC)
5443         SvSETMAGIC(dsv);
5444 }
5445
5446 /*
5447 =for apidoc sv_catsv
5448
5449 Concatenates the string from SV C<ssv> onto the end of the string in SV
5450 C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5451 Handles 'get' magic on both SVs, but no 'set' magic.  See C<L</sv_catsv_mg>>
5452 and C<L</sv_catsv_nomg>>.
5453
5454 =for apidoc sv_catsv_flags
5455
5456 Concatenates the string from SV C<ssv> onto the end of the string in SV
5457 C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5458 If C<flags> has the C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if
5459 appropriate.  If C<flags> has the C<SV_SMAGIC> bit set, C<mg_set> will be called on
5460 the modified SV afterward, if appropriate.  C<sv_catsv>, C<sv_catsv_nomg>,
5461 and C<sv_catsv_mg> are implemented in terms of this function.
5462
5463 =cut */
5464
5465 void
5466 Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
5467 {
5468     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5469
5470     if (ssv) {
5471         STRLEN slen;
5472         const char *spv = SvPV_flags_const(ssv, slen, flags);
5473         if (flags & SV_GMAGIC)
5474                 SvGETMAGIC(dsv);
5475         sv_catpvn_flags(dsv, spv, slen,
5476                             DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
5477         if (flags & SV_SMAGIC)
5478                 SvSETMAGIC(dsv);
5479     }
5480 }
5481
5482 /*
5483 =for apidoc sv_catpv
5484
5485 Concatenates the C<NUL>-terminated string onto the end of the string which is
5486 in the SV.
5487 If the SV has the UTF-8 status set, then the bytes appended should be
5488 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See
5489 C<L</sv_catpv_mg>>.
5490
5491 =cut */
5492
5493 void
5494 Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
5495 {
5496     STRLEN len;
5497     STRLEN tlen;
5498     char *junk;
5499
5500     PERL_ARGS_ASSERT_SV_CATPV;
5501
5502     if (!ptr)
5503         return;
5504     junk = SvPV_force(sv, tlen);
5505     len = strlen(ptr);
5506     SvGROW(sv, tlen + len + 1);
5507     if (ptr == junk)
5508         ptr = SvPVX_const(sv);
5509     Move(ptr,SvPVX(sv)+tlen,len+1,char);
5510     SvCUR_set(sv, SvCUR(sv) + len);
5511     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5512     SvTAINT(sv);
5513 }
5514
5515 /*
5516 =for apidoc sv_catpv_flags
5517
5518 Concatenates the C<NUL>-terminated string onto the end of the string which is
5519 in the SV.
5520 If the SV has the UTF-8 status set, then the bytes appended should
5521 be valid UTF-8.  If C<flags> has the C<SV_SMAGIC> bit set, will C<mg_set>
5522 on the modified SV if appropriate.
5523
5524 =cut
5525 */
5526
5527 void
5528 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
5529 {
5530     PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5531     sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
5532 }
5533
5534 /*
5535 =for apidoc sv_catpv_mg
5536
5537 Like C<sv_catpv>, but also handles 'set' magic.
5538
5539 =cut
5540 */
5541
5542 void
5543 Perl_sv_catpv_mg(pTHX_ SV *const sv, const char *const ptr)
5544 {
5545     PERL_ARGS_ASSERT_SV_CATPV_MG;
5546
5547     sv_catpv(sv,ptr);
5548     SvSETMAGIC(sv);
5549 }
5550
5551 /*
5552 =for apidoc newSV
5553
5554 Creates a new SV.  A non-zero C<len> parameter indicates the number of
5555 bytes of preallocated string space the SV should have.  An extra byte for a
5556 trailing C<NUL> is also reserved.  (C<SvPOK> is not set for the SV even if string
5557 space is allocated.)  The reference count for the new SV is set to 1.
5558
5559 In 5.9.3, C<newSV()> replaces the older C<NEWSV()> API, and drops the first
5560 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5561 This aid has been superseded by a new build option, C<PERL_MEM_LOG> (see
5562 L<perlhacktips/PERL_MEM_LOG>).  The older API is still there for use in XS
5563 modules supporting older perls.
5564
5565 =cut
5566 */
5567
5568 SV *
5569 Perl_newSV(pTHX_ const STRLEN len)
5570 {
5571     SV *sv;
5572
5573     new_SV(sv);
5574     if (len) {
5575         sv_grow(sv, len + 1);
5576     }
5577     return sv;
5578 }
5579 /*
5580 =for apidoc sv_magicext
5581
5582 Adds magic to an SV, upgrading it if necessary.  Applies the
5583 supplied C<vtable> and returns a pointer to the magic added.
5584
5585 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5586 In particular, you can add magic to C<SvREADONLY> SVs, and add more than
5587 one instance of the same C<how>.
5588
5589 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5590 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5591 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5592 to contain an SV* and is stored as-is with its C<REFCNT> incremented.
5593
5594 (This is now used as a subroutine by C<sv_magic>.)
5595
5596 =cut
5597 */
5598 MAGIC * 
5599 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, 
5600                 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5601 {
5602     MAGIC* mg;
5603
5604     PERL_ARGS_ASSERT_SV_MAGICEXT;
5605
5606     SvUPGRADE(sv, SVt_PVMG);
5607     Newxz(mg, 1, MAGIC);
5608     mg->mg_moremagic = SvMAGIC(sv);
5609     SvMAGIC_set(sv, mg);
5610
5611     /* Sometimes a magic contains a reference loop, where the sv and
5612        object refer to each other.  To prevent a reference loop that
5613        would prevent such objects being freed, we look for such loops
5614        and if we find one we avoid incrementing the object refcount.
5615
5616        Note we cannot do this to avoid self-tie loops as intervening RV must
5617        have its REFCNT incremented to keep it in existence.
5618
5619     */
5620     if (!obj || obj == sv ||
5621         how == PERL_MAGIC_arylen ||
5622         how == PERL_MAGIC_symtab ||
5623         (SvTYPE(obj) == SVt_PVGV &&
5624             (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5625              || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5626              || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5627     {
5628         mg->mg_obj = obj;
5629     }
5630     else {
5631         mg->mg_obj = SvREFCNT_inc_simple(obj);
5632         mg->mg_flags |= MGf_REFCOUNTED;
5633     }
5634
5635     /* Normal self-ties simply pass a null object, and instead of
5636        using mg_obj directly, use the SvTIED_obj macro to produce a
5637        new RV as needed.  For glob "self-ties", we are tieing the PVIO
5638        with an RV obj pointing to the glob containing the PVIO.  In
5639        this case, to avoid a reference loop, we need to weaken the
5640        reference.
5641     */
5642
5643     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5644         obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5645     {
5646       sv_rvweaken(obj);
5647     }
5648
5649     mg->mg_type = how;
5650     mg->mg_len = namlen;
5651     if (name) {
5652         if (namlen > 0)
5653             mg->mg_ptr = savepvn(name, namlen);
5654         else if (namlen == HEf_SVKEY) {
5655             /* Yes, this is casting away const. This is only for the case of
5656                HEf_SVKEY. I think we need to document this aberation of the
5657                constness of the API, rather than making name non-const, as
5658                that change propagating outwards a long way.  */
5659             mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5660         } else
5661             mg->mg_ptr = (char *) name;
5662     }
5663     mg->mg_virtual = (MGVTBL *) vtable;
5664
5665     mg_magical(sv);
5666     return mg;
5667 }
5668
5669 MAGIC *
5670 Perl_sv_magicext_mglob(pTHX_ SV *sv)
5671 {
5672     PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB;
5673     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
5674         /* This sv is only a delegate.  //g magic must be attached to
5675            its target. */
5676         vivify_defelem(sv);
5677         sv = LvTARG(sv);
5678     }
5679     return sv_magicext(sv, NULL, PERL_MAGIC_regex_global,
5680                        &PL_vtbl_mglob, 0, 0);
5681 }
5682
5683 /*
5684 =for apidoc sv_magic
5685
5686 Adds magic to an SV.  First upgrades C<sv> to type C<SVt_PVMG> if
5687 necessary, then adds a new magic item of type C<how> to the head of the
5688 magic list.
5689
5690 See C<L</sv_magicext>> (which C<sv_magic> now calls) for a description of the
5691 handling of the C<name> and C<namlen> arguments.
5692
5693 You need to use C<sv_magicext> to add magic to C<SvREADONLY> SVs and also
5694 to add more than one instance of the same C<how>.
5695
5696 =cut
5697 */
5698
5699 void
5700 Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
5701              const char *const name, const I32 namlen)
5702 {
5703     const MGVTBL *vtable;
5704     MAGIC* mg;
5705     unsigned int flags;
5706     unsigned int vtable_index;
5707
5708     PERL_ARGS_ASSERT_SV_MAGIC;
5709
5710     if (how < 0 || (unsigned)how >= C_ARRAY_LENGTH(PL_magic_data)
5711         || ((flags = PL_magic_data[how]),
5712             (vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
5713             > magic_vtable_max))
5714         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5715
5716     /* PERL_MAGIC_ext is reserved for use by extensions not perl internals.
5717        Useful for attaching extension internal data to perl vars.
5718        Note that multiple extensions may clash if magical scalars
5719        etc holding private data from one are passed to another. */
5720
5721     vtable = (vtable_index == magic_vtable_max)
5722         ? NULL : PL_magic_vtables + vtable_index;
5723
5724     if (SvREADONLY(sv)) {
5725         if (
5726             !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
5727            )
5728         {
5729             Perl_croak_no_modify();
5730         }
5731     }
5732     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5733         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5734             /* sv_magic() refuses to add a magic of the same 'how' as an
5735                existing one
5736              */
5737             if (how == PERL_MAGIC_taint)
5738                 mg->mg_len |= 1;
5739             return;
5740         }
5741     }
5742
5743     /* Force pos to be stored as characters, not bytes. */
5744     if (SvMAGICAL(sv) && DO_UTF8(sv)
5745       && (mg = mg_find(sv, PERL_MAGIC_regex_global))
5746       && mg->mg_len != -1
5747       && mg->mg_flags & MGf_BYTES) {
5748         mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len,
5749                                                SV_CONST_RETURN);
5750         mg->mg_flags &= ~MGf_BYTES;
5751     }
5752
5753     /* Rest of work is done else where */
5754     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5755
5756     switch (how) {
5757     case PERL_MAGIC_taint:
5758         mg->mg_len = 1;
5759         break;
5760     case PERL_MAGIC_ext:
5761     case PERL_MAGIC_dbfile:
5762         SvRMAGICAL_on(sv);
5763         break;
5764     }
5765 }
5766
5767 static int
5768 S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
5769 {
5770     MAGIC* mg;
5771     MAGIC** mgp;
5772
5773     assert(flags <= 1);
5774
5775     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5776         return 0;
5777     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5778     for (mg = *mgp; mg; mg = *mgp) {
5779         const MGVTBL* const virt = mg->mg_virtual;
5780         if (mg->mg_type == type && (!flags || virt == vtbl)) {
5781             *mgp = mg->mg_moremagic;
5782             if (virt && virt->svt_free)
5783                 virt->svt_free(aTHX_ sv, mg);
5784             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5785                 if (mg->mg_len > 0)
5786                     Safefree(mg->mg_ptr);
5787                 else if (mg->mg_len == HEf_SVKEY)
5788                     SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5789                 else if (mg->mg_type == PERL_MAGIC_utf8)
5790                     Safefree(mg->mg_ptr);
5791             }
5792             if (mg->mg_flags & MGf_REFCOUNTED)
5793                 SvREFCNT_dec(mg->mg_obj);
5794             Safefree(mg);
5795         }
5796         else
5797             mgp = &mg->mg_moremagic;
5798     }
5799     if (SvMAGIC(sv)) {
5800         if (SvMAGICAL(sv))      /* if we're under save_magic, wait for restore_magic; */
5801             mg_magical(sv);     /*    else fix the flags now */
5802     }
5803     else
5804         SvMAGICAL_off(sv);
5805
5806     return 0;
5807 }
5808
5809 /*
5810 =for apidoc sv_unmagic
5811
5812 Removes all magic of type C<type> from an SV.
5813
5814 =cut
5815 */
5816
5817 int
5818 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5819 {
5820     PERL_ARGS_ASSERT_SV_UNMAGIC;
5821     return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
5822 }
5823
5824 /*
5825 =for apidoc sv_unmagicext
5826
5827 Removes all magic of type C<type> with the specified C<vtbl> from an SV.
5828
5829 =cut
5830 */
5831
5832 int
5833 Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
5834 {
5835     PERL_ARGS_ASSERT_SV_UNMAGICEXT;
5836     return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
5837 }
5838
5839 /*
5840 =for apidoc sv_rvweaken
5841
5842 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5843 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5844 push a back-reference to this RV onto the array of backreferences
5845 associated with that magic.  If the RV is magical, set magic will be
5846 called after the RV is cleared.
5847
5848 =cut
5849 */
5850
5851 SV *
5852 Perl_sv_rvweaken(pTHX_ SV *const sv)
5853 {
5854     SV *tsv;
5855
5856     PERL_ARGS_ASSERT_SV_RVWEAKEN;
5857
5858     if (!SvOK(sv))  /* let undefs pass */
5859         return sv;
5860     if (!SvROK(sv))
5861         Perl_croak(aTHX_ "Can't weaken a nonreference");
5862     else if (SvWEAKREF(sv)) {
5863         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5864         return sv;
5865     }
5866     else if (SvREADONLY(sv)) croak_no_modify();
5867     tsv = SvRV(sv);
5868     Perl_sv_add_backref(aTHX_ tsv, sv);
5869     SvWEAKREF_on(sv);
5870     SvREFCNT_dec_NN(tsv);
5871     return sv;
5872 }
5873
5874 /*
5875 =for apidoc sv_get_backrefs
5876
5877 If C<sv> is the target of a weak reference then it returns the back
5878 references structure associated with the sv; otherwise return C<NULL>.
5879
5880 When returning a non-null result the type of the return is relevant. If it
5881 is an AV then the elements of the AV are the weak reference RVs which
5882 point at this item. If it is any other type then the item itself is the
5883 weak reference.
5884
5885 See also C<Perl_sv_add_backref()>, C<Perl_sv_del_backref()>,
5886 C<Perl_sv_kill_backrefs()>
5887
5888 =cut
5889 */
5890
5891 SV *
5892 Perl_sv_get_backrefs(SV *const sv)
5893 {
5894     SV *backrefs= NULL;
5895
5896     PERL_ARGS_ASSERT_SV_GET_BACKREFS;
5897
5898     /* find slot to store array or singleton backref */
5899
5900     if (SvTYPE(sv) == SVt_PVHV) {
5901         if (SvOOK(sv)) {
5902             struct xpvhv_aux * const iter = HvAUX((HV *)sv);
5903             backrefs = (SV *)iter->xhv_backreferences;
5904         }
5905     } else if (SvMAGICAL(sv)) {
5906         MAGIC *mg = mg_find(sv, PERL_MAGIC_backref);
5907         if (mg)
5908             backrefs = mg->mg_obj;
5909     }
5910     return backrefs;
5911 }
5912
5913 /* Give tsv backref magic if it hasn't already got it, then push a
5914  * back-reference to sv onto the array associated with the backref magic.
5915  *
5916  * As an optimisation, if there's only one backref and it's not an AV,
5917  * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5918  * allocate an AV. (Whether the slot holds an AV tells us whether this is
5919  * active.)
5920  */
5921
5922 /* A discussion about the backreferences array and its refcount:
5923  *
5924  * The AV holding the backreferences is pointed to either as the mg_obj of
5925  * PERL_MAGIC_backref, or in the specific case of a HV, from the
5926  * xhv_backreferences field. The array is created with a refcount
5927  * of 2. This means that if during global destruction the array gets
5928  * picked on before its parent to have its refcount decremented by the
5929  * random zapper, it won't actually be freed, meaning it's still there for
5930  * when its parent gets freed.
5931  *
5932  * When the parent SV is freed, the extra ref is killed by
5933  * Perl_sv_kill_backrefs.  The other ref is killed, in the case of magic,
5934  * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5935  *
5936  * When a single backref SV is stored directly, it is not reference
5937  * counted.
5938  */
5939
5940 void
5941 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5942 {
5943     SV **svp;
5944     AV *av = NULL;
5945     MAGIC *mg = NULL;
5946
5947     PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5948
5949     /* find slot to store array or singleton backref */
5950
5951     if (SvTYPE(tsv) == SVt_PVHV) {
5952         svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5953     } else {
5954         if (SvMAGICAL(tsv))
5955             mg = mg_find(tsv, PERL_MAGIC_backref);
5956         if (!mg)
5957             mg = sv_magicext(tsv, NULL, PERL_MAGIC_backref, &PL_vtbl_backref, NULL, 0);
5958         svp = &(mg->mg_obj);
5959     }
5960
5961     /* create or retrieve the array */
5962
5963     if (   (!*svp && SvTYPE(sv) == SVt_PVAV)
5964         || (*svp && SvTYPE(*svp) != SVt_PVAV)
5965     ) {
5966         /* create array */
5967         if (mg)
5968             mg->mg_flags |= MGf_REFCOUNTED;
5969         av = newAV();
5970         AvREAL_off(av);
5971         SvREFCNT_inc_simple_void_NN(av);
5972         /* av now has a refcnt of 2; see discussion above */
5973         av_extend(av, *svp ? 2 : 1);
5974         if (*svp) {
5975             /* move single existing backref to the array */
5976             AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5977         }
5978         *svp = (SV*)av;
5979     }
5980     else {
5981         av = MUTABLE_AV(*svp);
5982         if (!av) {
5983             /* optimisation: store single backref directly in HvAUX or mg_obj */
5984             *svp = sv;
5985             return;
5986         }
5987         assert(SvTYPE(av) == SVt_PVAV);
5988         if (AvFILLp(av) >= AvMAX(av)) {
5989             av_extend(av, AvFILLp(av)+1);
5990         }
5991     }
5992     /* push new backref */
5993     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5994 }
5995
5996 /* delete a back-reference to ourselves from the backref magic associated
5997  * with the SV we point to.
5998  */
5999
6000 void
6001 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
6002 {
6003     SV **svp = NULL;
6004
6005     PERL_ARGS_ASSERT_SV_DEL_BACKREF;
6006
6007     if (SvTYPE(tsv) == SVt_PVHV) {
6008         if (SvOOK(tsv))
6009             svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
6010     }
6011     else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) {
6012         /* It's possible for the the last (strong) reference to tsv to have
6013            become freed *before* the last thing holding a weak reference.
6014            If both survive longer than the backreferences array, then when
6015            the referent's reference count drops to 0 and it is freed, it's
6016            not able to chase the backreferences, so they aren't NULLed.
6017
6018            For example, a CV holds a weak reference to its stash. If both the
6019            CV and the stash survive longer than the backreferences array,
6020            and the CV gets picked for the SvBREAK() treatment first,
6021            *and* it turns out that the stash is only being kept alive because
6022            of an our variable in the pad of the CV, then midway during CV
6023            destruction the stash gets freed, but CvSTASH() isn't set to NULL.
6024            It ends up pointing to the freed HV. Hence it's chased in here, and
6025            if this block wasn't here, it would hit the !svp panic just below.
6026
6027            I don't believe that "better" destruction ordering is going to help
6028            here - during global destruction there's always going to be the
6029            chance that something goes out of order. We've tried to make it
6030            foolproof before, and it only resulted in evolutionary pressure on
6031            fools. Which made us look foolish for our hubris. :-(
6032         */
6033         return;
6034     }
6035     else {
6036         MAGIC *const mg
6037             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
6038         svp =  mg ? &(mg->mg_obj) : NULL;
6039     }
6040
6041     if (!svp)
6042         Perl_croak(aTHX_ "panic: del_backref, svp=0");
6043     if (!*svp) {
6044         /* It's possible that sv is being freed recursively part way through the
6045            freeing of tsv. If this happens, the backreferences array of tsv has
6046            already been freed, and so svp will be NULL. If this is the case,
6047            we should not panic. Instead, nothing needs doing, so return.  */
6048         if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
6049             return;
6050         Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
6051                    (void*)*svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
6052     }
6053
6054     if (SvTYPE(*svp) == SVt_PVAV) {
6055 #ifdef DEBUGGING
6056         int count = 1;
6057 #endif
6058         AV * const av = (AV*)*svp;
6059         SSize_t fill;
6060         assert(!SvIS_FREED(av));
6061         fill = AvFILLp(av);
6062         assert(fill > -1);
6063         svp = AvARRAY(av);
6064         /* for an SV with N weak references to it, if all those
6065          * weak refs are deleted, then sv_del_backref will be called
6066          * N times and O(N^2) compares will be done within the backref
6067          * array. To ameliorate this potential slowness, we:
6068          * 1) make sure this code is as tight as possible;
6069          * 2) when looking for SV, look for it at both the head and tail of the
6070          *    array first before searching the rest, since some create/destroy
6071          *    patterns will cause the backrefs to be freed in order.
6072          */
6073         if (*svp == sv) {
6074             AvARRAY(av)++;
6075             AvMAX(av)--;
6076         }
6077         else {
6078             SV **p = &svp[fill];
6079             SV *const topsv = *p;
6080             if (topsv != sv) {
6081 #ifdef DEBUGGING
6082                 count = 0;
6083 #endif
6084                 while (--p > svp) {
6085                     if (*p == sv) {
6086                         /* We weren't the last entry.
6087                            An unordered list has this property that you
6088                            can take the last element off the end to fill
6089                            the hole, and it's still an unordered list :-)
6090                         */
6091                         *p = topsv;
6092 #ifdef DEBUGGING
6093                         count++;
6094 #else
6095                         break; /* should only be one */
6096 #endif
6097                     }
6098                 }
6099             }
6100         }
6101         assert(count ==1);
6102         AvFILLp(av) = fill-1;
6103     }
6104     else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) {
6105         /* freed AV; skip */
6106     }
6107     else {
6108         /* optimisation: only a single backref, stored directly */
6109         if (*svp != sv)
6110             Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p",
6111                        (void*)*svp, (void*)sv);
6112         *svp = NULL;
6113     }
6114
6115 }
6116
6117 void
6118 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
6119 {
6120     SV **svp;
6121     SV **last;
6122     bool is_array;
6123
6124     PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
6125
6126     if (!av)
6127         return;
6128
6129     /* after multiple passes through Perl_sv_clean_all() for a thingy
6130      * that has badly leaked, the backref array may have gotten freed,
6131      * since we only protect it against 1 round of cleanup */
6132     if (SvIS_FREED(av)) {
6133         if (PL_in_clean_all) /* All is fair */
6134             return;
6135         Perl_croak(aTHX_
6136                    "panic: magic_killbackrefs (freed backref AV/SV)");
6137     }
6138
6139
6140     is_array = (SvTYPE(av) == SVt_PVAV);
6141     if (is_array) {
6142         assert(!SvIS_FREED(av));
6143         svp = AvARRAY(av);
6144         if (svp)
6145             last = svp + AvFILLp(av);
6146     }
6147     else {
6148         /* optimisation: only a single backref, stored directly */
6149         svp = (SV**)&av;
6150         last = svp;
6151     }
6152
6153     if (svp) {
6154         while (svp <= last) {
6155             if (*svp) {
6156                 SV *const referrer = *svp;
6157                 if (SvWEAKREF(referrer)) {
6158                     /* XXX Should we check that it hasn't changed? */
6159                     assert(SvROK(referrer));
6160                     SvRV_set(referrer, 0);
6161                     SvOK_off(referrer);
6162                     SvWEAKREF_off(referrer);
6163                     SvSETMAGIC(referrer);
6164                 } else if (SvTYPE(referrer) == SVt_PVGV ||
6165                            SvTYPE(referrer) == SVt_PVLV) {
6166                     assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
6167                     /* You lookin' at me?  */
6168                     assert(GvSTASH(referrer));
6169                     assert(GvSTASH(referrer) == (const HV *)sv);
6170                     GvSTASH(referrer) = 0;
6171                 } else if (SvTYPE(referrer) == SVt_PVCV ||
6172                            SvTYPE(referrer) == SVt_PVFM) {
6173                     if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
6174                         /* You lookin' at me?  */
6175                         assert(CvSTASH(referrer));
6176                         assert(CvSTASH(referrer) == (const HV *)sv);
6177                         SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
6178                     }
6179                     else {
6180                         assert(SvTYPE(sv) == SVt_PVGV);
6181                         /* You lookin' at me?  */
6182                         assert(CvGV(referrer));
6183                         assert(CvGV(referrer) == (const GV *)sv);
6184                         anonymise_cv_maybe(MUTABLE_GV(sv),
6185                                                 MUTABLE_CV(referrer));
6186                     }
6187
6188                 } else {
6189                     Perl_croak(aTHX_
6190                                "panic: magic_killbackrefs (flags=%"UVxf")",
6191                                (UV)SvFLAGS(referrer));
6192                 }
6193
6194                 if (is_array)
6195                     *svp = NULL;
6196             }
6197             svp++;
6198         }
6199     }
6200     if (is_array) {
6201         AvFILLp(av) = -1;
6202         SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */
6203     }
6204     return;
6205 }
6206
6207 /*
6208 =for apidoc sv_insert
6209
6210 Inserts a string at the specified offset/length within the SV.  Similar to
6211 the Perl C<substr()> function.  Handles get magic.
6212
6213 =for apidoc sv_insert_flags
6214
6215 Same as C<sv_insert>, but the extra C<flags> are passed to the
6216 C<SvPV_force_flags> that applies to C<bigstr>.
6217
6218 =cut
6219 */
6220
6221 void
6222 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
6223 {
6224     char *big;
6225     char *mid;
6226     char *midend;
6227     char *bigend;
6228     SSize_t i;          /* better be sizeof(STRLEN) or bad things happen */
6229     STRLEN curlen;
6230
6231     PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
6232
6233     SvPV_force_flags(bigstr, curlen, flags);
6234     (void)SvPOK_only_UTF8(bigstr);
6235     if (offset + len > curlen) {
6236         SvGROW(bigstr, offset+len+1);
6237         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
6238         SvCUR_set(bigstr, offset+len);
6239     }
6240
6241     SvTAINT(bigstr);
6242     i = littlelen - len;
6243     if (i > 0) {                        /* string might grow */
6244         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
6245         mid = big + offset + len;
6246         midend = bigend = big + SvCUR(bigstr);
6247         bigend += i;
6248         *bigend = '\0';
6249         while (midend > mid)            /* shove everything down */
6250             *--bigend = *--midend;
6251         Move(little,big+offset,littlelen,char);
6252         SvCUR_set(bigstr, SvCUR(bigstr) + i);
6253         SvSETMAGIC(bigstr);
6254         return;
6255     }
6256     else if (i == 0) {
6257         Move(little,SvPVX(bigstr)+offset,len,char);
6258         SvSETMAGIC(bigstr);
6259         return;
6260     }
6261
6262     big = SvPVX(bigstr);
6263     mid = big + offset;
6264     midend = mid + len;
6265     bigend = big + SvCUR(bigstr);
6266
6267     if (midend > bigend)
6268         Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p",
6269                    midend, bigend);
6270
6271     if (mid - big > bigend - midend) {  /* faster to shorten from end */
6272         if (littlelen) {
6273             Move(little, mid, littlelen,char);
6274             mid += littlelen;
6275         }
6276         i = bigend - midend;
6277         if (i > 0) {
6278             Move(midend, mid, i,char);
6279             mid += i;
6280         }
6281         *mid = '\0';
6282         SvCUR_set(bigstr, mid - big);
6283     }
6284     else if ((i = mid - big)) { /* faster from front */
6285         midend -= littlelen;
6286         mid = midend;
6287         Move(big, midend - i, i, char);
6288         sv_chop(bigstr,midend-i);
6289         if (littlelen)
6290             Move(little, mid, littlelen,char);
6291     }
6292     else if (littlelen) {
6293         midend -= littlelen;
6294         sv_chop(bigstr,midend);
6295         Move(little,midend,littlelen,char);
6296     }
6297     else {
6298         sv_chop(bigstr,midend);
6299     }
6300     SvSETMAGIC(bigstr);
6301 }
6302
6303 /*
6304 =for apidoc sv_replace
6305
6306 Make the first argument a copy of the second, then delete the original.
6307 The target SV physically takes over ownership of the body of the source SV
6308 and inherits its flags; however, the target keeps any magic it owns,
6309 and any magic in the source is discarded.
6310 Note that this is a rather specialist SV copying operation; most of the
6311 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
6312
6313 =cut
6314 */
6315
6316 void
6317 Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv)
6318 {
6319     const U32 refcnt = SvREFCNT(sv);
6320
6321     PERL_ARGS_ASSERT_SV_REPLACE;
6322
6323     SV_CHECK_THINKFIRST_COW_DROP(sv);
6324     if (SvREFCNT(nsv) != 1) {
6325         Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
6326                    " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
6327     }
6328     if (SvMAGICAL(sv)) {
6329         if (SvMAGICAL(nsv))
6330             mg_free(nsv);
6331         else
6332             sv_upgrade(nsv, SVt_PVMG);
6333         SvMAGIC_set(nsv, SvMAGIC(sv));
6334         SvFLAGS(nsv) |= SvMAGICAL(sv);
6335         SvMAGICAL_off(sv);
6336         SvMAGIC_set(sv, NULL);
6337     }
6338     SvREFCNT(sv) = 0;
6339     sv_clear(sv);
6340     assert(!SvREFCNT(sv));
6341 #ifdef DEBUG_LEAKING_SCALARS
6342     sv->sv_flags  = nsv->sv_flags;
6343     sv->sv_any    = nsv->sv_any;
6344     sv->sv_refcnt = nsv->sv_refcnt;
6345     sv->sv_u      = nsv->sv_u;
6346 #else
6347     StructCopy(nsv,sv,SV);
6348 #endif
6349     if(SvTYPE(sv) == SVt_IV) {
6350         SET_SVANY_FOR_BODYLESS_IV(sv);
6351     }
6352         
6353
6354     SvREFCNT(sv) = refcnt;
6355     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
6356     SvREFCNT(nsv) = 0;
6357     del_SV(nsv);
6358 }
6359
6360 /* We're about to free a GV which has a CV that refers back to us.
6361  * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
6362  * field) */
6363
6364 STATIC void
6365 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
6366 {
6367     SV *gvname;
6368     GV *anongv;
6369
6370     PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
6371
6372     /* be assertive! */
6373     assert(SvREFCNT(gv) == 0);
6374     assert(isGV(gv) && isGV_with_GP(gv));
6375     assert(GvGP(gv));
6376     assert(!CvANON(cv));
6377     assert(CvGV(cv) == gv);
6378     assert(!CvNAMED(cv));
6379
6380     /* will the CV shortly be freed by gp_free() ? */
6381     if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
6382         SvANY(cv)->xcv_gv_u.xcv_gv = NULL;
6383         return;
6384     }
6385
6386     /* if not, anonymise: */
6387     gvname = (GvSTASH(gv) && HvNAME(GvSTASH(gv)) && HvENAME(GvSTASH(gv)))
6388                     ? newSVhek(HvENAME_HEK(GvSTASH(gv)))
6389                     : newSVpvn_flags( "__ANON__", 8, 0 );
6390     sv_catpvs(gvname, "::__ANON__");
6391     anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
6392     SvREFCNT_dec_NN(gvname);
6393
6394     CvANON_on(cv);
6395     CvCVGV_RC_on(cv);
6396     SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
6397 }
6398
6399
6400 /*
6401 =for apidoc sv_clear
6402
6403 Clear an SV: call any destructors, free up any memory used by the body,
6404 and free the body itself.  The SV's head is I<not> freed, although
6405 its type is set to all 1's so that it won't inadvertently be assumed
6406 to be live during global destruction etc.
6407 This function should only be called when C<REFCNT> is zero.  Most of the time
6408 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
6409 instead.
6410
6411 =cut
6412 */
6413
6414 void
6415 Perl_sv_clear(pTHX_ SV *const orig_sv)
6416 {
6417     dVAR;
6418     HV *stash;
6419     U32 type;
6420     const struct body_details *sv_type_details;
6421     SV* iter_sv = NULL;
6422     SV* next_sv = NULL;
6423     SV *sv = orig_sv;
6424     STRLEN hash_index = 0; /* initialise to make Coverity et al happy.
6425                               Not strictly necessary */
6426
6427     PERL_ARGS_ASSERT_SV_CLEAR;
6428
6429     /* within this loop, sv is the SV currently being freed, and
6430      * iter_sv is the most recent AV or whatever that's being iterated
6431      * over to provide more SVs */
6432
6433     while (sv) {
6434
6435         type = SvTYPE(sv);
6436
6437         assert(SvREFCNT(sv) == 0);
6438         assert(SvTYPE(sv) != (svtype)SVTYPEMASK);
6439
6440         if (type <= SVt_IV) {
6441             /* See the comment in sv.h about the collusion between this
6442              * early return and the overloading of the NULL slots in the
6443              * size table.  */
6444             if (SvROK(sv))
6445                 goto free_rv;
6446             SvFLAGS(sv) &= SVf_BREAK;
6447             SvFLAGS(sv) |= SVTYPEMASK;
6448             goto free_head;
6449         }
6450
6451         /* objs are always >= MG, but pad names use the SVs_OBJECT flag
6452            for another purpose  */
6453         assert(!SvOBJECT(sv) || type >= SVt_PVMG);
6454
6455         if (type >= SVt_PVMG) {
6456             if (SvOBJECT(sv)) {
6457                 if (!curse(sv, 1)) goto get_next_sv;
6458                 type = SvTYPE(sv); /* destructor may have changed it */
6459             }
6460             /* Free back-references before magic, in case the magic calls
6461              * Perl code that has weak references to sv. */
6462             if (type == SVt_PVHV) {
6463                 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
6464                 if (SvMAGIC(sv))
6465                     mg_free(sv);
6466             }
6467             else if (SvMAGIC(sv)) {
6468                 /* Free back-references before other types of magic. */
6469                 sv_unmagic(sv, PERL_MAGIC_backref);
6470                 mg_free(sv);
6471             }
6472             SvMAGICAL_off(sv);
6473         }
6474         switch (type) {
6475             /* case SVt_INVLIST: */
6476         case SVt_PVIO:
6477             if (IoIFP(sv) &&
6478                 IoIFP(sv) != PerlIO_stdin() &&
6479                 IoIFP(sv) != PerlIO_stdout() &&
6480                 IoIFP(sv) != PerlIO_stderr() &&
6481                 !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6482             {
6483                 io_close(MUTABLE_IO(sv), NULL, FALSE,
6484                          (IoTYPE(sv) == IoTYPE_WRONLY ||
6485                           IoTYPE(sv) == IoTYPE_RDWR   ||
6486                           IoTYPE(sv) == IoTYPE_APPEND));
6487             }
6488             if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6489                 PerlDir_close(IoDIRP(sv));
6490             IoDIRP(sv) = (DIR*)NULL;
6491             Safefree(IoTOP_NAME(sv));
6492             Safefree(IoFMT_NAME(sv));
6493             Safefree(IoBOTTOM_NAME(sv));
6494             if ((const GV *)sv == PL_statgv)
6495                 PL_statgv = NULL;
6496             goto freescalar;
6497         case SVt_REGEXP:
6498             /* FIXME for plugins */
6499           freeregexp:
6500             pregfree2((REGEXP*) sv);
6501             goto freescalar;
6502         case SVt_PVCV:
6503         case SVt_PVFM:
6504             cv_undef(MUTABLE_CV(sv));
6505             /* If we're in a stash, we don't own a reference to it.
6506              * However it does have a back reference to