Releaser for 5.29.2
[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 =cut
795
796 Allocation of SV-bodies is similar to SV-heads, differing as follows;
797 the allocation mechanism is used for many body types, so is somewhat
798 more complicated, it uses arena-sets, and has no need for still-live
799 SV detection.
800
801 At the outermost level, (new|del)_X*V macros return bodies of the
802 appropriate type.  These macros call either (new|del)_body_type or
803 (new|del)_body_allocated macro pairs, depending on specifics of the
804 type.  Most body types use the former pair, the latter pair is used to
805 allocate body types with "ghost fields".
806
807 "ghost fields" are fields that are unused in certain types, and
808 consequently don't need to actually exist.  They are declared because
809 they're part of a "base type", which allows use of functions as
810 methods.  The simplest examples are AVs and HVs, 2 aggregate types
811 which don't use the fields which support SCALAR semantics.
812
813 For these types, the arenas are carved up into appropriately sized
814 chunks, we thus avoid wasted memory for those unaccessed members.
815 When bodies are allocated, we adjust the pointer back in memory by the
816 size of the part not allocated, so it's as if we allocated the full
817 structure.  (But things will all go boom if you write to the part that
818 is "not there", because you'll be overwriting the last members of the
819 preceding structure in memory.)
820
821 We calculate the correction using the STRUCT_OFFSET macro on the first
822 member present.  If the allocated structure is smaller (no initial NV
823 actually allocated) then the net effect is to subtract the size of the NV
824 from the pointer, to return a new pointer as if an initial NV were actually
825 allocated.  (We were using structures named *_allocated for this, but
826 this turned out to be a subtle bug, because a structure without an NV
827 could have a lower alignment constraint, but the compiler is allowed to
828 optimised accesses based on the alignment constraint of the actual pointer
829 to the full structure, for example, using a single 64 bit load instruction
830 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
831
832 This is the same trick as was used for NV and IV bodies.  Ironically it
833 doesn't need to be used for NV bodies any more, because NV is now at
834 the start of the structure.  IV bodies, and also in some builds NV bodies,
835 don't need it either, because they are no longer allocated.
836
837 In turn, the new_body_* allocators call S_new_body(), which invokes
838 new_body_inline macro, which takes a lock, and takes a body off the
839 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
840 necessary to refresh an empty list.  Then the lock is released, and
841 the body is returned.
842
843 Perl_more_bodies allocates a new arena, and carves it up into an array of N
844 bodies, which it strings into a linked list.  It looks up arena-size
845 and body-size from the body_details table described below, thus
846 supporting the multiple body-types.
847
848 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
849 the (new|del)_X*V macros are mapped directly to malloc/free.
850
851 For each sv-type, struct body_details bodies_by_type[] carries
852 parameters which control these aspects of SV handling:
853
854 Arena_size determines whether arenas are used for this body type, and if
855 so, how big they are.  PURIFY or PERL_ARENA_SIZE=0 set this field to
856 zero, forcing individual mallocs and frees.
857
858 Body_size determines how big a body is, and therefore how many fit into
859 each arena.  Offset carries the body-pointer adjustment needed for
860 "ghost fields", and is used in *_allocated macros.
861
862 But its main purpose is to parameterize info needed in
863 Perl_sv_upgrade().  The info here dramatically simplifies the function
864 vs the implementation in 5.8.8, making it table-driven.  All fields
865 are used for this, except for arena_size.
866
867 For the sv-types that have no bodies, arenas are not used, so those
868 PL_body_roots[sv_type] are unused, and can be overloaded.  In
869 something of a special case, SVt_NULL is borrowed for HE arenas;
870 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
871 bodies_by_type[SVt_NULL] slot is not used, as the table is not
872 available in hv.c.
873
874 */
875
876 struct body_details {
877     U8 body_size;       /* Size to allocate  */
878     U8 copy;            /* Size of structure to copy (may be shorter)  */
879     U8 offset;          /* Size of unalloced ghost fields to first alloced field*/
880     PERL_BITFIELD8 type : 4;        /* We have space for a sanity check. */
881     PERL_BITFIELD8 cant_upgrade : 1;/* Cannot upgrade this type */
882     PERL_BITFIELD8 zero_nv : 1;     /* zero the NV when upgrading from this */
883     PERL_BITFIELD8 arena : 1;       /* Allocated from an arena */
884     U32 arena_size;                 /* Size of arena to allocate */
885 };
886
887 #define HADNV FALSE
888 #define NONV TRUE
889
890
891 #ifdef PURIFY
892 /* With -DPURFIY we allocate everything directly, and don't use arenas.
893    This seems a rather elegant way to simplify some of the code below.  */
894 #define HASARENA FALSE
895 #else
896 #define HASARENA TRUE
897 #endif
898 #define NOARENA FALSE
899
900 /* Size the arenas to exactly fit a given number of bodies.  A count
901    of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
902    simplifying the default.  If count > 0, the arena is sized to fit
903    only that many bodies, allowing arenas to be used for large, rare
904    bodies (XPVFM, XPVIO) without undue waste.  The arena size is
905    limited by PERL_ARENA_SIZE, so we can safely oversize the
906    declarations.
907  */
908 #define FIT_ARENA0(body_size)                           \
909     ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
910 #define FIT_ARENAn(count,body_size)                     \
911     ( count * body_size <= PERL_ARENA_SIZE)             \
912     ? count * body_size                                 \
913     : FIT_ARENA0 (body_size)
914 #define FIT_ARENA(count,body_size)                      \
915    (U32)(count                                          \
916     ? FIT_ARENAn (count, body_size)                     \
917     : FIT_ARENA0 (body_size))
918
919 /* Calculate the length to copy. Specifically work out the length less any
920    final padding the compiler needed to add.  See the comment in sv_upgrade
921    for why copying the padding proved to be a bug.  */
922
923 #define copy_length(type, last_member) \
924         STRUCT_OFFSET(type, last_member) \
925         + sizeof (((type*)SvANY((const SV *)0))->last_member)
926
927 static const struct body_details bodies_by_type[] = {
928     /* HEs use this offset for their arena.  */
929     { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
930
931     /* IVs are in the head, so the allocation size is 0.  */
932     { 0,
933       sizeof(IV), /* This is used to copy out the IV body.  */
934       STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
935       NOARENA /* IVS don't need an arena  */, 0
936     },
937
938 #if NVSIZE <= IVSIZE
939     { 0, sizeof(NV),
940       STRUCT_OFFSET(XPVNV, xnv_u),
941       SVt_NV, FALSE, HADNV, NOARENA, 0 },
942 #else
943     { sizeof(NV), sizeof(NV),
944       STRUCT_OFFSET(XPVNV, xnv_u),
945       SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
946 #endif
947
948     { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
949       copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
950       + STRUCT_OFFSET(XPV, xpv_cur),
951       SVt_PV, FALSE, NONV, HASARENA,
952       FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
953
954     { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur),
955       copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur),
956       + STRUCT_OFFSET(XPV, xpv_cur),
957       SVt_INVLIST, TRUE, NONV, HASARENA,
958       FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) },
959
960     { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
961       copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
962       + STRUCT_OFFSET(XPV, xpv_cur),
963       SVt_PVIV, FALSE, NONV, HASARENA,
964       FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
965
966     { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
967       copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
968       + STRUCT_OFFSET(XPV, xpv_cur),
969       SVt_PVNV, FALSE, HADNV, HASARENA,
970       FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
971
972     { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
973       HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
974
975     { sizeof(regexp),
976       sizeof(regexp),
977       0,
978       SVt_REGEXP, TRUE, NONV, HASARENA,
979       FIT_ARENA(0, sizeof(regexp))
980     },
981
982     { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
983       HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
984     
985     { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
986       HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
987
988     { sizeof(XPVAV),
989       copy_length(XPVAV, xav_alloc),
990       0,
991       SVt_PVAV, TRUE, NONV, HASARENA,
992       FIT_ARENA(0, sizeof(XPVAV)) },
993
994     { sizeof(XPVHV),
995       copy_length(XPVHV, xhv_max),
996       0,
997       SVt_PVHV, TRUE, NONV, HASARENA,
998       FIT_ARENA(0, sizeof(XPVHV)) },
999
1000     { sizeof(XPVCV),
1001       sizeof(XPVCV),
1002       0,
1003       SVt_PVCV, TRUE, NONV, HASARENA,
1004       FIT_ARENA(0, sizeof(XPVCV)) },
1005
1006     { sizeof(XPVFM),
1007       sizeof(XPVFM),
1008       0,
1009       SVt_PVFM, TRUE, NONV, NOARENA,
1010       FIT_ARENA(20, sizeof(XPVFM)) },
1011
1012     { sizeof(XPVIO),
1013       sizeof(XPVIO),
1014       0,
1015       SVt_PVIO, TRUE, NONV, HASARENA,
1016       FIT_ARENA(24, sizeof(XPVIO)) },
1017 };
1018
1019 #define new_body_allocated(sv_type)             \
1020     (void *)((char *)S_new_body(aTHX_ sv_type)  \
1021              - bodies_by_type[sv_type].offset)
1022
1023 /* return a thing to the free list */
1024
1025 #define del_body(thing, root)                           \
1026     STMT_START {                                        \
1027         void ** const thing_copy = (void **)thing;      \
1028         *thing_copy = *root;                            \
1029         *root = (void*)thing_copy;                      \
1030     } STMT_END
1031
1032 #ifdef PURIFY
1033 #if !(NVSIZE <= IVSIZE)
1034 #  define new_XNV()     safemalloc(sizeof(XPVNV))
1035 #endif
1036 #define new_XPVNV()     safemalloc(sizeof(XPVNV))
1037 #define new_XPVMG()     safemalloc(sizeof(XPVMG))
1038
1039 #define del_XPVGV(p)    safefree(p)
1040
1041 #else /* !PURIFY */
1042
1043 #if !(NVSIZE <= IVSIZE)
1044 #  define new_XNV()     new_body_allocated(SVt_NV)
1045 #endif
1046 #define new_XPVNV()     new_body_allocated(SVt_PVNV)
1047 #define new_XPVMG()     new_body_allocated(SVt_PVMG)
1048
1049 #define del_XPVGV(p)    del_body(p + bodies_by_type[SVt_PVGV].offset,   \
1050                                  &PL_body_roots[SVt_PVGV])
1051
1052 #endif /* PURIFY */
1053
1054 /* no arena for you! */
1055
1056 #define new_NOARENA(details) \
1057         safemalloc((details)->body_size + (details)->offset)
1058 #define new_NOARENAZ(details) \
1059         safecalloc((details)->body_size + (details)->offset, 1)
1060
1061 void *
1062 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
1063                   const size_t arena_size)
1064 {
1065     void ** const root = &PL_body_roots[sv_type];
1066     struct arena_desc *adesc;
1067     struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1068     unsigned int curr;
1069     char *start;
1070     const char *end;
1071     const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1072 #if defined(DEBUGGING) && defined(PERL_GLOBAL_STRUCT)
1073     dVAR;
1074 #endif
1075 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1076     static bool done_sanity_check;
1077
1078     /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1079      * variables like done_sanity_check. */
1080     if (!done_sanity_check) {
1081         unsigned int i = SVt_LAST;
1082
1083         done_sanity_check = TRUE;
1084
1085         while (i--)
1086             assert (bodies_by_type[i].type == i);
1087     }
1088 #endif
1089
1090     assert(arena_size);
1091
1092     /* may need new arena-set to hold new arena */
1093     if (!aroot || aroot->curr >= aroot->set_size) {
1094         struct arena_set *newroot;
1095         Newxz(newroot, 1, struct arena_set);
1096         newroot->set_size = ARENAS_PER_SET;
1097         newroot->next = aroot;
1098         aroot = newroot;
1099         PL_body_arenas = (void *) newroot;
1100         DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1101     }
1102
1103     /* ok, now have arena-set with at least 1 empty/available arena-desc */
1104     curr = aroot->curr++;
1105     adesc = &(aroot->set[curr]);
1106     assert(!adesc->arena);
1107     
1108     Newx(adesc->arena, good_arena_size, char);
1109     adesc->size = good_arena_size;
1110     adesc->utype = sv_type;
1111     DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %" UVuf "\n",
1112                           curr, (void*)adesc->arena, (UV)good_arena_size));
1113
1114     start = (char *) adesc->arena;
1115
1116     /* Get the address of the byte after the end of the last body we can fit.
1117        Remember, this is integer division:  */
1118     end = start + good_arena_size / body_size * body_size;
1119
1120     /* computed count doesn't reflect the 1st slot reservation */
1121 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1122     DEBUG_m(PerlIO_printf(Perl_debug_log,
1123                           "arena %p end %p arena-size %d (from %d) type %d "
1124                           "size %d ct %d\n",
1125                           (void*)start, (void*)end, (int)good_arena_size,
1126                           (int)arena_size, sv_type, (int)body_size,
1127                           (int)good_arena_size / (int)body_size));
1128 #else
1129     DEBUG_m(PerlIO_printf(Perl_debug_log,
1130                           "arena %p end %p arena-size %d type %d size %d ct %d\n",
1131                           (void*)start, (void*)end,
1132                           (int)arena_size, sv_type, (int)body_size,
1133                           (int)good_arena_size / (int)body_size));
1134 #endif
1135     *root = (void *)start;
1136
1137     while (1) {
1138         /* Where the next body would start:  */
1139         char * const next = start + body_size;
1140
1141         if (next >= end) {
1142             /* This is the last body:  */
1143             assert(next == end);
1144
1145             *(void **)start = 0;
1146             return *root;
1147         }
1148
1149         *(void**) start = (void *)next;
1150         start = next;
1151     }
1152 }
1153
1154 /* grab a new thing from the free list, allocating more if necessary.
1155    The inline version is used for speed in hot routines, and the
1156    function using it serves the rest (unless PURIFY).
1157 */
1158 #define new_body_inline(xpv, sv_type) \
1159     STMT_START { \
1160         void ** const r3wt = &PL_body_roots[sv_type]; \
1161         xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \
1162           ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1163                                              bodies_by_type[sv_type].body_size,\
1164                                              bodies_by_type[sv_type].arena_size)); \
1165         *(r3wt) = *(void**)(xpv); \
1166     } STMT_END
1167
1168 #ifndef PURIFY
1169
1170 STATIC void *
1171 S_new_body(pTHX_ const svtype sv_type)
1172 {
1173     void *xpv;
1174     new_body_inline(xpv, sv_type);
1175     return xpv;
1176 }
1177
1178 #endif
1179
1180 static const struct body_details fake_rv =
1181     { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1182
1183 /*
1184 =for apidoc sv_upgrade
1185
1186 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1187 SV, then copies across as much information as possible from the old body.
1188 It croaks if the SV is already in a more complex form than requested.  You
1189 generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
1190 before calling C<sv_upgrade>, and hence does not croak.  See also
1191 C<L</svtype>>.
1192
1193 =cut
1194 */
1195
1196 void
1197 Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
1198 {
1199     void*       old_body;
1200     void*       new_body;
1201     const svtype old_type = SvTYPE(sv);
1202     const struct body_details *new_type_details;
1203     const struct body_details *old_type_details
1204         = bodies_by_type + old_type;
1205     SV *referent = NULL;
1206
1207     PERL_ARGS_ASSERT_SV_UPGRADE;
1208
1209     if (old_type == new_type)
1210         return;
1211
1212     /* This clause was purposefully added ahead of the early return above to
1213        the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1214        inference by Nick I-S that it would fix other troublesome cases. See
1215        changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1216
1217        Given that shared hash key scalars are no longer PVIV, but PV, there is
1218        no longer need to unshare so as to free up the IVX slot for its proper
1219        purpose. So it's safe to move the early return earlier.  */
1220
1221     if (new_type > SVt_PVMG && SvIsCOW(sv)) {
1222         sv_force_normal_flags(sv, 0);
1223     }
1224
1225     old_body = SvANY(sv);
1226
1227     /* Copying structures onto other structures that have been neatly zeroed
1228        has a subtle gotcha. Consider XPVMG
1229
1230        +------+------+------+------+------+-------+-------+
1231        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
1232        +------+------+------+------+------+-------+-------+
1233        0      4      8     12     16     20      24      28
1234
1235        where NVs are aligned to 8 bytes, so that sizeof that structure is
1236        actually 32 bytes long, with 4 bytes of padding at the end:
1237
1238        +------+------+------+------+------+-------+-------+------+
1239        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
1240        +------+------+------+------+------+-------+-------+------+
1241        0      4      8     12     16     20      24      28     32
1242
1243        so what happens if you allocate memory for this structure:
1244
1245        +------+------+------+------+------+-------+-------+------+------+...
1246        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
1247        +------+------+------+------+------+-------+-------+------+------+...
1248        0      4      8     12     16     20      24      28     32     36
1249
1250        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1251        expect, because you copy the area marked ??? onto GP. Now, ??? may have
1252        started out as zero once, but it's quite possible that it isn't. So now,
1253        rather than a nicely zeroed GP, you have it pointing somewhere random.
1254        Bugs ensue.
1255
1256        (In fact, GP ends up pointing at a previous GP structure, because the
1257        principle cause of the padding in XPVMG getting garbage is a copy of
1258        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1259        this happens to be moot because XPVGV has been re-ordered, with GP
1260        no longer after STASH)
1261
1262        So we are careful and work out the size of used parts of all the
1263        structures.  */
1264
1265     switch (old_type) {
1266     case SVt_NULL:
1267         break;
1268     case SVt_IV:
1269         if (SvROK(sv)) {
1270             referent = SvRV(sv);
1271             old_type_details = &fake_rv;
1272             if (new_type == SVt_NV)
1273                 new_type = SVt_PVNV;
1274         } else {
1275             if (new_type < SVt_PVIV) {
1276                 new_type = (new_type == SVt_NV)
1277                     ? SVt_PVNV : SVt_PVIV;
1278             }
1279         }
1280         break;
1281     case SVt_NV:
1282         if (new_type < SVt_PVNV) {
1283             new_type = SVt_PVNV;
1284         }
1285         break;
1286     case SVt_PV:
1287         assert(new_type > SVt_PV);
1288         STATIC_ASSERT_STMT(SVt_IV < SVt_PV);
1289         STATIC_ASSERT_STMT(SVt_NV < SVt_PV);
1290         break;
1291     case SVt_PVIV:
1292         break;
1293     case SVt_PVNV:
1294         break;
1295     case SVt_PVMG:
1296         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1297            there's no way that it can be safely upgraded, because perl.c
1298            expects to Safefree(SvANY(PL_mess_sv))  */
1299         assert(sv != PL_mess_sv);
1300         break;
1301     default:
1302         if (UNLIKELY(old_type_details->cant_upgrade))
1303             Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1304                        sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1305     }
1306
1307     if (UNLIKELY(old_type > new_type))
1308         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1309                 (int)old_type, (int)new_type);
1310
1311     new_type_details = bodies_by_type + new_type;
1312
1313     SvFLAGS(sv) &= ~SVTYPEMASK;
1314     SvFLAGS(sv) |= new_type;
1315
1316     /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1317        the return statements above will have triggered.  */
1318     assert (new_type != SVt_NULL);
1319     switch (new_type) {
1320     case SVt_IV:
1321         assert(old_type == SVt_NULL);
1322         SET_SVANY_FOR_BODYLESS_IV(sv);
1323         SvIV_set(sv, 0);
1324         return;
1325     case SVt_NV:
1326         assert(old_type == SVt_NULL);
1327 #if NVSIZE <= IVSIZE
1328         SET_SVANY_FOR_BODYLESS_NV(sv);
1329 #else
1330         SvANY(sv) = new_XNV();
1331 #endif
1332         SvNV_set(sv, 0);
1333         return;
1334     case SVt_PVHV:
1335     case SVt_PVAV:
1336         assert(new_type_details->body_size);
1337
1338 #ifndef PURIFY  
1339         assert(new_type_details->arena);
1340         assert(new_type_details->arena_size);
1341         /* This points to the start of the allocated area.  */
1342         new_body_inline(new_body, new_type);
1343         Zero(new_body, new_type_details->body_size, char);
1344         new_body = ((char *)new_body) - new_type_details->offset;
1345 #else
1346         /* We always allocated the full length item with PURIFY. To do this
1347            we fake things so that arena is false for all 16 types..  */
1348         new_body = new_NOARENAZ(new_type_details);
1349 #endif
1350         SvANY(sv) = new_body;
1351         if (new_type == SVt_PVAV) {
1352             AvMAX(sv)   = -1;
1353             AvFILLp(sv) = -1;
1354             AvREAL_only(sv);
1355             if (old_type_details->body_size) {
1356                 AvALLOC(sv) = 0;
1357             } else {
1358                 /* It will have been zeroed when the new body was allocated.
1359                    Lets not write to it, in case it confuses a write-back
1360                    cache.  */
1361             }
1362         } else {
1363             assert(!SvOK(sv));
1364             SvOK_off(sv);
1365 #ifndef NODEFAULT_SHAREKEYS
1366             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
1367 #endif
1368             /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
1369             HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
1370         }
1371
1372         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1373            The target created by newSVrv also is, and it can have magic.
1374            However, it never has SvPVX set.
1375         */
1376         if (old_type == SVt_IV) {
1377             assert(!SvROK(sv));
1378         } else if (old_type >= SVt_PV) {
1379             assert(SvPVX_const(sv) == 0);
1380         }
1381
1382         if (old_type >= SVt_PVMG) {
1383             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1384             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1385         } else {
1386             sv->sv_u.svu_array = NULL; /* or svu_hash  */
1387         }
1388         break;
1389
1390     case SVt_PVIV:
1391         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1392            no route from NV to PVIV, NOK can never be true  */
1393         assert(!SvNOKp(sv));
1394         assert(!SvNOK(sv));
1395         /* FALLTHROUGH */
1396     case SVt_PVIO:
1397     case SVt_PVFM:
1398     case SVt_PVGV:
1399     case SVt_PVCV:
1400     case SVt_PVLV:
1401     case SVt_INVLIST:
1402     case SVt_REGEXP:
1403     case SVt_PVMG:
1404     case SVt_PVNV:
1405     case SVt_PV:
1406
1407         assert(new_type_details->body_size);
1408         /* We always allocated the full length item with PURIFY. To do this
1409            we fake things so that arena is false for all 16 types..  */
1410         if(new_type_details->arena) {
1411             /* This points to the start of the allocated area.  */
1412             new_body_inline(new_body, new_type);
1413             Zero(new_body, new_type_details->body_size, char);
1414             new_body = ((char *)new_body) - new_type_details->offset;
1415         } else {
1416             new_body = new_NOARENAZ(new_type_details);
1417         }
1418         SvANY(sv) = new_body;
1419
1420         if (old_type_details->copy) {
1421             /* There is now the potential for an upgrade from something without
1422                an offset (PVNV or PVMG) to something with one (PVCV, PVFM)  */
1423             int offset = old_type_details->offset;
1424             int length = old_type_details->copy;
1425
1426             if (new_type_details->offset > old_type_details->offset) {
1427                 const int difference
1428                     = new_type_details->offset - old_type_details->offset;
1429                 offset += difference;
1430                 length -= difference;
1431             }
1432             assert (length >= 0);
1433                 
1434             Copy((char *)old_body + offset, (char *)new_body + offset, length,
1435                  char);
1436         }
1437
1438 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1439         /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1440          * correct 0.0 for us.  Otherwise, if the old body didn't have an
1441          * NV slot, but the new one does, then we need to initialise the
1442          * freshly created NV slot with whatever the correct bit pattern is
1443          * for 0.0  */
1444         if (old_type_details->zero_nv && !new_type_details->zero_nv
1445             && !isGV_with_GP(sv))
1446             SvNV_set(sv, 0);
1447 #endif
1448
1449         if (UNLIKELY(new_type == SVt_PVIO)) {
1450             IO * const io = MUTABLE_IO(sv);
1451             GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1452
1453             SvOBJECT_on(io);
1454             /* Clear the stashcache because a new IO could overrule a package
1455                name */
1456             DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
1457             hv_clear(PL_stashcache);
1458
1459             SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1460             IoPAGE_LEN(sv) = 60;
1461         }
1462         if (old_type < SVt_PV) {
1463             /* referent will be NULL unless the old type was SVt_IV emulating
1464                SVt_RV */
1465             sv->sv_u.svu_rv = referent;
1466         }
1467         break;
1468     default:
1469         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1470                    (unsigned long)new_type);
1471     }
1472
1473     /* if this is zero, this is a body-less SVt_NULL, SVt_IV/SVt_RV,
1474        and sometimes SVt_NV */
1475     if (old_type_details->body_size) {
1476 #ifdef PURIFY
1477         safefree(old_body);
1478 #else
1479         /* Note that there is an assumption that all bodies of types that
1480            can be upgraded came from arenas. Only the more complex non-
1481            upgradable types are allowed to be directly malloc()ed.  */
1482         assert(old_type_details->arena);
1483         del_body((void*)((char*)old_body + old_type_details->offset),
1484                  &PL_body_roots[old_type]);
1485 #endif
1486     }
1487 }
1488
1489 /*
1490 =for apidoc sv_backoff
1491
1492 Remove any string offset.  You should normally use the C<SvOOK_off> macro
1493 wrapper instead.
1494
1495 =cut
1496 */
1497
1498 /* prior to 5.000 stable, this function returned the new OOK-less SvFLAGS
1499    prior to 5.23.4 this function always returned 0
1500 */
1501
1502 void
1503 Perl_sv_backoff(SV *const sv)
1504 {
1505     STRLEN delta;
1506     const char * const s = SvPVX_const(sv);
1507
1508     PERL_ARGS_ASSERT_SV_BACKOFF;
1509
1510     assert(SvOOK(sv));
1511     assert(SvTYPE(sv) != SVt_PVHV);
1512     assert(SvTYPE(sv) != SVt_PVAV);
1513
1514     SvOOK_offset(sv, delta);
1515     
1516     SvLEN_set(sv, SvLEN(sv) + delta);
1517     SvPV_set(sv, SvPVX(sv) - delta);
1518     SvFLAGS(sv) &= ~SVf_OOK;
1519     Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1520     return;
1521 }
1522
1523
1524 /* forward declaration */
1525 static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
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
1539 char *
1540 Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
1541 {
1542     char *s;
1543
1544     PERL_ARGS_ASSERT_SV_GROW;
1545
1546     if (SvROK(sv))
1547         sv_unref(sv);
1548     if (SvTYPE(sv) < SVt_PV) {
1549         sv_upgrade(sv, SVt_PV);
1550         s = SvPVX_mutable(sv);
1551     }
1552     else if (SvOOK(sv)) {       /* pv is offset? */
1553         sv_backoff(sv);
1554         s = SvPVX_mutable(sv);
1555         if (newlen > SvLEN(sv))
1556             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1557     }
1558     else
1559     {
1560         if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0);
1561         s = SvPVX_mutable(sv);
1562     }
1563
1564 #ifdef PERL_COPY_ON_WRITE
1565     /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1566      * to store the COW count. So in general, allocate one more byte than
1567      * asked for, to make it likely this byte is always spare: and thus
1568      * make more strings COW-able.
1569      *
1570      * Only increment if the allocation isn't MEM_SIZE_MAX,
1571      * otherwise it will wrap to 0.
1572      */
1573     if ( newlen != MEM_SIZE_MAX )
1574         newlen++;
1575 #endif
1576
1577 #if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size)
1578 #define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1579 #endif
1580
1581     if (newlen > SvLEN(sv)) {           /* need more room? */
1582         STRLEN minlen = SvCUR(sv);
1583         minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1584         if (newlen < minlen)
1585             newlen = minlen;
1586 #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1587
1588         /* Don't round up on the first allocation, as odds are pretty good that
1589          * the initial request is accurate as to what is really needed */
1590         if (SvLEN(sv)) {
1591             STRLEN rounded = PERL_STRLEN_ROUNDUP(newlen);
1592             if (rounded > newlen)
1593                 newlen = rounded;
1594         }
1595 #endif
1596         if (SvLEN(sv) && s) {
1597             s = (char*)saferealloc(s, newlen);
1598         }
1599         else {
1600             s = (char*)safemalloc(newlen);
1601             if (SvPVX_const(sv) && SvCUR(sv)) {
1602                 Move(SvPVX_const(sv), s, SvCUR(sv), char);
1603             }
1604         }
1605         SvPV_set(sv, s);
1606 #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1607         /* Do this here, do it once, do it right, and then we will never get
1608            called back into sv_grow() unless there really is some growing
1609            needed.  */
1610         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1611 #else
1612         SvLEN_set(sv, newlen);
1613 #endif
1614     }
1615     return s;
1616 }
1617
1618 /*
1619 =for apidoc sv_setiv
1620
1621 Copies an integer into the given SV, upgrading first if necessary.
1622 Does not handle 'set' magic.  See also C<L</sv_setiv_mg>>.
1623
1624 =cut
1625 */
1626
1627 void
1628 Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
1629 {
1630     PERL_ARGS_ASSERT_SV_SETIV;
1631
1632     SV_CHECK_THINKFIRST_COW_DROP(sv);
1633     switch (SvTYPE(sv)) {
1634     case SVt_NULL:
1635     case SVt_NV:
1636         sv_upgrade(sv, SVt_IV);
1637         break;
1638     case SVt_PV:
1639         sv_upgrade(sv, SVt_PVIV);
1640         break;
1641
1642     case SVt_PVGV:
1643         if (!isGV_with_GP(sv))
1644             break;
1645         /* FALLTHROUGH */
1646     case SVt_PVAV:
1647     case SVt_PVHV:
1648     case SVt_PVCV:
1649     case SVt_PVFM:
1650     case SVt_PVIO:
1651         /* diag_listed_as: Can't coerce %s to %s in %s */
1652         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1653                    OP_DESC(PL_op));
1654         NOT_REACHED; /* NOTREACHED */
1655         break;
1656     default: NOOP;
1657     }
1658     (void)SvIOK_only(sv);                       /* validate number */
1659     SvIV_set(sv, i);
1660     SvTAINT(sv);
1661 }
1662
1663 /*
1664 =for apidoc sv_setiv_mg
1665
1666 Like C<sv_setiv>, but also handles 'set' magic.
1667
1668 =cut
1669 */
1670
1671 void
1672 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1673 {
1674     PERL_ARGS_ASSERT_SV_SETIV_MG;
1675
1676     sv_setiv(sv,i);
1677     SvSETMAGIC(sv);
1678 }
1679
1680 /*
1681 =for apidoc sv_setuv
1682
1683 Copies an unsigned integer into the given SV, upgrading first if necessary.
1684 Does not handle 'set' magic.  See also C<L</sv_setuv_mg>>.
1685
1686 =cut
1687 */
1688
1689 void
1690 Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1691 {
1692     PERL_ARGS_ASSERT_SV_SETUV;
1693
1694     /* With the if statement to ensure that integers are stored as IVs whenever
1695        possible:
1696        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1697
1698        without
1699        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1700
1701        If you wish to remove the following if statement, so that this routine
1702        (and its callers) always return UVs, please benchmark to see what the
1703        effect is. Modern CPUs may be different. Or may not :-)
1704     */
1705     if (u <= (UV)IV_MAX) {
1706        sv_setiv(sv, (IV)u);
1707        return;
1708     }
1709     sv_setiv(sv, 0);
1710     SvIsUV_on(sv);
1711     SvUV_set(sv, u);
1712 }
1713
1714 /*
1715 =for apidoc sv_setuv_mg
1716
1717 Like C<sv_setuv>, but also handles 'set' magic.
1718
1719 =cut
1720 */
1721
1722 void
1723 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1724 {
1725     PERL_ARGS_ASSERT_SV_SETUV_MG;
1726
1727     sv_setuv(sv,u);
1728     SvSETMAGIC(sv);
1729 }
1730
1731 /*
1732 =for apidoc sv_setnv
1733
1734 Copies a double into the given SV, upgrading first if necessary.
1735 Does not handle 'set' magic.  See also C<L</sv_setnv_mg>>.
1736
1737 =cut
1738 */
1739
1740 void
1741 Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1742 {
1743     PERL_ARGS_ASSERT_SV_SETNV;
1744
1745     SV_CHECK_THINKFIRST_COW_DROP(sv);
1746     switch (SvTYPE(sv)) {
1747     case SVt_NULL:
1748     case SVt_IV:
1749         sv_upgrade(sv, SVt_NV);
1750         break;
1751     case SVt_PV:
1752     case SVt_PVIV:
1753         sv_upgrade(sv, SVt_PVNV);
1754         break;
1755
1756     case SVt_PVGV:
1757         if (!isGV_with_GP(sv))
1758             break;
1759         /* FALLTHROUGH */
1760     case SVt_PVAV:
1761     case SVt_PVHV:
1762     case SVt_PVCV:
1763     case SVt_PVFM:
1764     case SVt_PVIO:
1765         /* diag_listed_as: Can't coerce %s to %s in %s */
1766         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1767                    OP_DESC(PL_op));
1768         NOT_REACHED; /* NOTREACHED */
1769         break;
1770     default: NOOP;
1771     }
1772     SvNV_set(sv, num);
1773     (void)SvNOK_only(sv);                       /* validate number */
1774     SvTAINT(sv);
1775 }
1776
1777 /*
1778 =for apidoc sv_setnv_mg
1779
1780 Like C<sv_setnv>, but also handles 'set' magic.
1781
1782 =cut
1783 */
1784
1785 void
1786 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1787 {
1788     PERL_ARGS_ASSERT_SV_SETNV_MG;
1789
1790     sv_setnv(sv,num);
1791     SvSETMAGIC(sv);
1792 }
1793
1794 /* Return a cleaned-up, printable version of sv, for non-numeric, or
1795  * not incrementable warning display.
1796  * Originally part of S_not_a_number().
1797  * The return value may be != tmpbuf.
1798  */
1799
1800 STATIC const char *
1801 S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1802     const char *pv;
1803
1804      PERL_ARGS_ASSERT_SV_DISPLAY;
1805
1806      if (DO_UTF8(sv)) {
1807           SV *dsv = newSVpvs_flags("", SVs_TEMP);
1808           pv = sv_uni_display(dsv, sv, 32, UNI_DISPLAY_ISPRINT);
1809      } else {
1810           char *d = tmpbuf;
1811           const char * const limit = tmpbuf + tmpbuf_size - 8;
1812           /* each *s can expand to 4 chars + "...\0",
1813              i.e. need room for 8 chars */
1814         
1815           const char *s = SvPVX_const(sv);
1816           const char * const end = s + SvCUR(sv);
1817           for ( ; s < end && d < limit; s++ ) {
1818                int ch = *s & 0xFF;
1819                if (! isASCII(ch) && !isPRINT_LC(ch)) {
1820                     *d++ = 'M';
1821                     *d++ = '-';
1822
1823                     /* Map to ASCII "equivalent" of Latin1 */
1824                     ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1825                }
1826                if (ch == '\n') {
1827                     *d++ = '\\';
1828                     *d++ = 'n';
1829                }
1830                else if (ch == '\r') {
1831                     *d++ = '\\';
1832                     *d++ = 'r';
1833                }
1834                else if (ch == '\f') {
1835                     *d++ = '\\';
1836                     *d++ = 'f';
1837                }
1838                else if (ch == '\\') {
1839                     *d++ = '\\';
1840                     *d++ = '\\';
1841                }
1842                else if (ch == '\0') {
1843                     *d++ = '\\';
1844                     *d++ = '0';
1845                }
1846                else if (isPRINT_LC(ch))
1847                     *d++ = ch;
1848                else {
1849                     *d++ = '^';
1850                     *d++ = toCTRL(ch);
1851                }
1852           }
1853           if (s < end) {
1854                *d++ = '.';
1855                *d++ = '.';
1856                *d++ = '.';
1857           }
1858           *d = '\0';
1859           pv = tmpbuf;
1860     }
1861
1862     return pv;
1863 }
1864
1865 /* Print an "isn't numeric" warning, using a cleaned-up,
1866  * printable version of the offending string
1867  */
1868
1869 STATIC void
1870 S_not_a_number(pTHX_ SV *const sv)
1871 {
1872      char tmpbuf[64];
1873      const char *pv;
1874
1875      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1876
1877      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1878
1879     if (PL_op)
1880         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1881                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1882                     "Argument \"%s\" isn't numeric in %s", pv,
1883                     OP_DESC(PL_op));
1884     else
1885         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1886                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1887                     "Argument \"%s\" isn't numeric", pv);
1888 }
1889
1890 STATIC void
1891 S_not_incrementable(pTHX_ SV *const sv) {
1892      char tmpbuf[64];
1893      const char *pv;
1894
1895      PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1896
1897      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1898
1899      Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1900                  "Argument \"%s\" treated as 0 in increment (++)", pv);
1901 }
1902
1903 /*
1904 =for apidoc looks_like_number
1905
1906 Test if the content of an SV looks like a number (or is a number).
1907 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1908 non-numeric warning), even if your C<atof()> doesn't grok them.  Get-magic is
1909 ignored.
1910
1911 =cut
1912 */
1913
1914 I32
1915 Perl_looks_like_number(pTHX_ SV *const sv)
1916 {
1917     const char *sbegin;
1918     STRLEN len;
1919     int numtype;
1920
1921     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1922
1923     if (SvPOK(sv) || SvPOKp(sv)) {
1924         sbegin = SvPV_nomg_const(sv, len);
1925     }
1926     else
1927         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1928     numtype = grok_number(sbegin, len, NULL);
1929     return ((numtype & IS_NUMBER_TRAILING)) ? 0 : numtype;
1930 }
1931
1932 STATIC bool
1933 S_glob_2number(pTHX_ GV * const gv)
1934 {
1935     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1936
1937     /* We know that all GVs stringify to something that is not-a-number,
1938         so no need to test that.  */
1939     if (ckWARN(WARN_NUMERIC))
1940     {
1941         SV *const buffer = sv_newmortal();
1942         gv_efullname3(buffer, gv, "*");
1943         not_a_number(buffer);
1944     }
1945     /* We just want something true to return, so that S_sv_2iuv_common
1946         can tail call us and return true.  */
1947     return TRUE;
1948 }
1949
1950 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1951    until proven guilty, assume that things are not that bad... */
1952
1953 /*
1954    NV_PRESERVES_UV:
1955
1956    As 64 bit platforms often have an NV that doesn't preserve all bits of
1957    an IV (an assumption perl has been based on to date) it becomes necessary
1958    to remove the assumption that the NV always carries enough precision to
1959    recreate the IV whenever needed, and that the NV is the canonical form.
1960    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1961    precision as a side effect of conversion (which would lead to insanity
1962    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1963    1) to distinguish between IV/UV/NV slots that have a valid conversion cached
1964       where precision was lost, and IV/UV/NV slots that have a valid conversion
1965       which has lost no precision
1966    2) to ensure that if a numeric conversion to one form is requested that
1967       would lose precision, the precise conversion (or differently
1968       imprecise conversion) is also performed and cached, to prevent
1969       requests for different numeric formats on the same SV causing
1970       lossy conversion chains. (lossless conversion chains are perfectly
1971       acceptable (still))
1972
1973
1974    flags are used:
1975    SvIOKp is true if the IV slot contains a valid value
1976    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1977    SvNOKp is true if the NV slot contains a valid value
1978    SvNOK  is true only if the NV value is accurate
1979
1980    so
1981    while converting from PV to NV, check to see if converting that NV to an
1982    IV(or UV) would lose accuracy over a direct conversion from PV to
1983    IV(or UV). If it would, cache both conversions, return NV, but mark
1984    SV as IOK NOKp (ie not NOK).
1985
1986    While converting from PV to IV, check to see if converting that IV to an
1987    NV would lose accuracy over a direct conversion from PV to NV. If it
1988    would, cache both conversions, flag similarly.
1989
1990    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1991    correctly because if IV & NV were set NV *always* overruled.
1992    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1993    changes - now IV and NV together means that the two are interchangeable:
1994    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1995
1996    The benefit of this is that operations such as pp_add know that if
1997    SvIOK is true for both left and right operands, then integer addition
1998    can be used instead of floating point (for cases where the result won't
1999    overflow). Before, floating point was always used, which could lead to
2000    loss of precision compared with integer addition.
2001
2002    * making IV and NV equal status should make maths accurate on 64 bit
2003      platforms
2004    * may speed up maths somewhat if pp_add and friends start to use
2005      integers when possible instead of fp. (Hopefully the overhead in
2006      looking for SvIOK and checking for overflow will not outweigh the
2007      fp to integer speedup)
2008    * will slow down integer operations (callers of SvIV) on "inaccurate"
2009      values, as the change from SvIOK to SvIOKp will cause a call into
2010      sv_2iv each time rather than a macro access direct to the IV slot
2011    * should speed up number->string conversion on integers as IV is
2012      favoured when IV and NV are equally accurate
2013
2014    ####################################################################
2015    You had better be using SvIOK_notUV if you want an IV for arithmetic:
2016    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2017    On the other hand, SvUOK is true iff UV.
2018    ####################################################################
2019
2020    Your mileage will vary depending your CPU's relative fp to integer
2021    performance ratio.
2022 */
2023
2024 #ifndef NV_PRESERVES_UV
2025 #  define IS_NUMBER_UNDERFLOW_IV 1
2026 #  define IS_NUMBER_UNDERFLOW_UV 2
2027 #  define IS_NUMBER_IV_AND_UV    2
2028 #  define IS_NUMBER_OVERFLOW_IV  4
2029 #  define IS_NUMBER_OVERFLOW_UV  5
2030
2031 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2032
2033 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
2034 STATIC int
2035 S_sv_2iuv_non_preserve(pTHX_ SV *const sv
2036 #  ifdef DEBUGGING
2037                        , I32 numtype
2038 #  endif
2039                        )
2040 {
2041     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
2042     PERL_UNUSED_CONTEXT;
2043
2044     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));
2045     if (SvNVX(sv) < (NV)IV_MIN) {
2046         (void)SvIOKp_on(sv);
2047         (void)SvNOK_on(sv);
2048         SvIV_set(sv, IV_MIN);
2049         return IS_NUMBER_UNDERFLOW_IV;
2050     }
2051     if (SvNVX(sv) > (NV)UV_MAX) {
2052         (void)SvIOKp_on(sv);
2053         (void)SvNOK_on(sv);
2054         SvIsUV_on(sv);
2055         SvUV_set(sv, UV_MAX);
2056         return IS_NUMBER_OVERFLOW_UV;
2057     }
2058     (void)SvIOKp_on(sv);
2059     (void)SvNOK_on(sv);
2060     /* Can't use strtol etc to convert this string.  (See truth table in
2061        sv_2iv  */
2062     if (SvNVX(sv) <= (UV)IV_MAX) {
2063         SvIV_set(sv, I_V(SvNVX(sv)));
2064         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2065             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2066         } else {
2067             /* Integer is imprecise. NOK, IOKp */
2068         }
2069         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2070     }
2071     SvIsUV_on(sv);
2072     SvUV_set(sv, U_V(SvNVX(sv)));
2073     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2074         if (SvUVX(sv) == UV_MAX) {
2075             /* As we know that NVs don't preserve UVs, UV_MAX cannot
2076                possibly be preserved by NV. Hence, it must be overflow.
2077                NOK, IOKp */
2078             return IS_NUMBER_OVERFLOW_UV;
2079         }
2080         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2081     } else {
2082         /* Integer is imprecise. NOK, IOKp */
2083     }
2084     return IS_NUMBER_OVERFLOW_IV;
2085 }
2086 #endif /* !NV_PRESERVES_UV*/
2087
2088 /* If numtype is infnan, set the NV of the sv accordingly.
2089  * If numtype is anything else, try setting the NV using Atof(PV). */
2090 #ifdef USING_MSVC6
2091 #  pragma warning(push)
2092 #  pragma warning(disable:4756;disable:4056)
2093 #endif
2094 static void
2095 S_sv_setnv(pTHX_ SV* sv, int numtype)
2096 {
2097     bool pok = cBOOL(SvPOK(sv));
2098     bool nok = FALSE;
2099 #ifdef NV_INF
2100     if ((numtype & IS_NUMBER_INFINITY)) {
2101         SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
2102         nok = TRUE;
2103     } else
2104 #endif
2105 #ifdef NV_NAN
2106     if ((numtype & IS_NUMBER_NAN)) {
2107         SvNV_set(sv, NV_NAN);
2108         nok = TRUE;
2109     } else
2110 #endif
2111     if (pok) {
2112         SvNV_set(sv, Atof(SvPVX_const(sv)));
2113         /* Purposefully no true nok here, since we don't want to blow
2114          * away the possible IOK/UV of an existing sv. */
2115     }
2116     if (nok) {
2117         SvNOK_only(sv); /* No IV or UV please, this is pure infnan. */
2118         if (pok)
2119             SvPOK_on(sv); /* PV is okay, though. */
2120     }
2121 }
2122 #ifdef USING_MSVC6
2123 #  pragma warning(pop)
2124 #endif
2125
2126 STATIC bool
2127 S_sv_2iuv_common(pTHX_ SV *const sv)
2128 {
2129     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2130
2131     if (SvNOKp(sv)) {
2132         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2133          * without also getting a cached IV/UV from it at the same time
2134          * (ie PV->NV conversion should detect loss of accuracy and cache
2135          * IV or UV at same time to avoid this. */
2136         /* IV-over-UV optimisation - choose to cache IV if possible */
2137
2138         if (SvTYPE(sv) == SVt_NV)
2139             sv_upgrade(sv, SVt_PVNV);
2140
2141         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2142         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2143            certainly cast into the IV range at IV_MAX, whereas the correct
2144            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2145            cases go to UV */
2146 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2147         if (Perl_isnan(SvNVX(sv))) {
2148             SvUV_set(sv, 0);
2149             SvIsUV_on(sv);
2150             return FALSE;
2151         }
2152 #endif
2153         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2154             SvIV_set(sv, I_V(SvNVX(sv)));
2155             if (SvNVX(sv) == (NV) SvIVX(sv)
2156 #ifndef NV_PRESERVES_UV
2157                 && SvIVX(sv) != IV_MIN /* avoid negating IV_MIN below */
2158                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2159                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2160                 /* Don't flag it as "accurately an integer" if the number
2161                    came from a (by definition imprecise) NV operation, and
2162                    we're outside the range of NV integer precision */
2163 #endif
2164                 ) {
2165                 if (SvNOK(sv))
2166                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2167                 else {
2168                     /* scalar has trailing garbage, eg "42a" */
2169                 }
2170                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2171                                       "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (precise)\n",
2172                                       PTR2UV(sv),
2173                                       SvNVX(sv),
2174                                       SvIVX(sv)));
2175
2176             } else {
2177                 /* IV not precise.  No need to convert from PV, as NV
2178                    conversion would already have cached IV if it detected
2179                    that PV->IV would be better than PV->NV->IV
2180                    flags already correct - don't set public IOK.  */
2181                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2182                                       "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (imprecise)\n",
2183                                       PTR2UV(sv),
2184                                       SvNVX(sv),
2185                                       SvIVX(sv)));
2186             }
2187             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2188                but the cast (NV)IV_MIN rounds to a the value less (more
2189                negative) than IV_MIN which happens to be equal to SvNVX ??
2190                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2191                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2192                (NV)UVX == NVX are both true, but the values differ. :-(
2193                Hopefully for 2s complement IV_MIN is something like
2194                0x8000000000000000 which will be exact. NWC */
2195         }
2196         else {
2197             SvUV_set(sv, U_V(SvNVX(sv)));
2198             if (
2199                 (SvNVX(sv) == (NV) SvUVX(sv))
2200 #ifndef  NV_PRESERVES_UV
2201                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2202                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2203                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2204                 /* Don't flag it as "accurately an integer" if the number
2205                    came from a (by definition imprecise) NV operation, and
2206                    we're outside the range of NV integer precision */
2207 #endif
2208                 && SvNOK(sv)
2209                 )
2210                 SvIOK_on(sv);
2211             SvIsUV_on(sv);
2212             DEBUG_c(PerlIO_printf(Perl_debug_log,
2213                                   "0x%" UVxf " 2iv(%" UVuf " => %" IVdf ") (as unsigned)\n",
2214                                   PTR2UV(sv),
2215                                   SvUVX(sv),
2216                                   SvUVX(sv)));
2217         }
2218     }
2219     else if (SvPOKp(sv)) {
2220         UV value;
2221         int numtype;
2222         const char *s = SvPVX_const(sv);
2223         const STRLEN cur = SvCUR(sv);
2224
2225         /* short-cut for a single digit string like "1" */
2226
2227         if (cur == 1) {
2228             char c = *s;
2229             if (isDIGIT(c)) {
2230                 if (SvTYPE(sv) < SVt_PVIV)
2231                     sv_upgrade(sv, SVt_PVIV);
2232                 (void)SvIOK_on(sv);
2233                 SvIV_set(sv, (IV)(c - '0'));
2234                 return FALSE;
2235             }
2236         }
2237
2238         numtype = grok_number(s, cur, &value);
2239         /* We want to avoid a possible problem when we cache an IV/ a UV which
2240            may be later translated to an NV, and the resulting NV is not
2241            the same as the direct translation of the initial string
2242            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2243            be careful to ensure that the value with the .456 is around if the
2244            NV value is requested in the future).
2245         
2246            This means that if we cache such an IV/a UV, we need to cache the
2247            NV as well.  Moreover, we trade speed for space, and do not
2248            cache the NV if we are sure it's not needed.
2249          */
2250
2251         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2252         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2253              == IS_NUMBER_IN_UV) {
2254             /* It's definitely an integer, only upgrade to PVIV */
2255             if (SvTYPE(sv) < SVt_PVIV)
2256                 sv_upgrade(sv, SVt_PVIV);
2257             (void)SvIOK_on(sv);
2258         } else if (SvTYPE(sv) < SVt_PVNV)
2259             sv_upgrade(sv, SVt_PVNV);
2260
2261         if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
2262             if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING)))
2263                 not_a_number(sv);
2264             S_sv_setnv(aTHX_ sv, numtype);
2265             return FALSE;
2266         }
2267
2268         /* If NVs preserve UVs then we only use the UV value if we know that
2269            we aren't going to call atof() below. If NVs don't preserve UVs
2270            then the value returned may have more precision than atof() will
2271            return, even though value isn't perfectly accurate.  */
2272         if ((numtype & (IS_NUMBER_IN_UV
2273 #ifdef NV_PRESERVES_UV
2274                         | IS_NUMBER_NOT_INT
2275 #endif
2276             )) == IS_NUMBER_IN_UV) {
2277             /* This won't turn off the public IOK flag if it was set above  */
2278             (void)SvIOKp_on(sv);
2279
2280             if (!(numtype & IS_NUMBER_NEG)) {
2281                 /* positive */;
2282                 if (value <= (UV)IV_MAX) {
2283                     SvIV_set(sv, (IV)value);
2284                 } else {
2285                     /* it didn't overflow, and it was positive. */
2286                     SvUV_set(sv, value);
2287                     SvIsUV_on(sv);
2288                 }
2289             } else {
2290                 /* 2s complement assumption  */
2291                 if (value <= (UV)IV_MIN) {
2292                     SvIV_set(sv, value == (UV)IV_MIN
2293                                     ? IV_MIN : -(IV)value);
2294                 } else {
2295                     /* Too negative for an IV.  This is a double upgrade, but
2296                        I'm assuming it will be rare.  */
2297                     if (SvTYPE(sv) < SVt_PVNV)
2298                         sv_upgrade(sv, SVt_PVNV);
2299                     SvNOK_on(sv);
2300                     SvIOK_off(sv);
2301                     SvIOKp_on(sv);
2302                     SvNV_set(sv, -(NV)value);
2303                     SvIV_set(sv, IV_MIN);
2304                 }
2305             }
2306         }
2307         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2308            will be in the previous block to set the IV slot, and the next
2309            block to set the NV slot.  So no else here.  */
2310         
2311         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2312             != IS_NUMBER_IN_UV) {
2313             /* It wasn't an (integer that doesn't overflow the UV). */
2314             S_sv_setnv(aTHX_ sv, numtype);
2315
2316             if (! numtype && ckWARN(WARN_NUMERIC))
2317                 not_a_number(sv);
2318
2319             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" NVgf ")\n",
2320                                   PTR2UV(sv), SvNVX(sv)));
2321
2322 #ifdef NV_PRESERVES_UV
2323             (void)SvIOKp_on(sv);
2324             (void)SvNOK_on(sv);
2325 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2326             if (Perl_isnan(SvNVX(sv))) {
2327                 SvUV_set(sv, 0);
2328                 SvIsUV_on(sv);
2329                 return FALSE;
2330             }
2331 #endif
2332             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2333                 SvIV_set(sv, I_V(SvNVX(sv)));
2334                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2335                     SvIOK_on(sv);
2336                 } else {
2337                     NOOP;  /* Integer is imprecise. NOK, IOKp */
2338                 }
2339                 /* UV will not work better than IV */
2340             } else {
2341                 if (SvNVX(sv) > (NV)UV_MAX) {
2342                     SvIsUV_on(sv);
2343                     /* Integer is inaccurate. NOK, IOKp, is UV */
2344                     SvUV_set(sv, UV_MAX);
2345                 } else {
2346                     SvUV_set(sv, U_V(SvNVX(sv)));
2347                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2348                        NV preservse UV so can do correct comparison.  */
2349                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2350                         SvIOK_on(sv);
2351                     } else {
2352                         NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
2353                     }
2354                 }
2355                 SvIsUV_on(sv);
2356             }
2357 #else /* NV_PRESERVES_UV */
2358             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2359                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2360                 /* The IV/UV slot will have been set from value returned by
2361                    grok_number above.  The NV slot has just been set using
2362                    Atof.  */
2363                 SvNOK_on(sv);
2364                 assert (SvIOKp(sv));
2365             } else {
2366                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2367                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2368                     /* Small enough to preserve all bits. */
2369                     (void)SvIOKp_on(sv);
2370                     SvNOK_on(sv);
2371                     SvIV_set(sv, I_V(SvNVX(sv)));
2372                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2373                         SvIOK_on(sv);
2374                     /* Assumption: first non-preserved integer is < IV_MAX,
2375                        this NV is in the preserved range, therefore: */
2376                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2377                           < (UV)IV_MAX)) {
2378                         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);
2379                     }
2380                 } else {
2381                     /* IN_UV NOT_INT
2382                          0      0       already failed to read UV.
2383                          0      1       already failed to read UV.
2384                          1      0       you won't get here in this case. IV/UV
2385                                         slot set, public IOK, Atof() unneeded.
2386                          1      1       already read UV.
2387                        so there's no point in sv_2iuv_non_preserve() attempting
2388                        to use atol, strtol, strtoul etc.  */
2389 #  ifdef DEBUGGING
2390                     sv_2iuv_non_preserve (sv, numtype);
2391 #  else
2392                     sv_2iuv_non_preserve (sv);
2393 #  endif
2394                 }
2395             }
2396 #endif /* NV_PRESERVES_UV */
2397         /* It might be more code efficient to go through the entire logic above
2398            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2399            gets complex and potentially buggy, so more programmer efficient
2400            to do it this way, by turning off the public flags:  */
2401         if (!numtype)
2402             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2403         }
2404     }
2405     else  {
2406         if (isGV_with_GP(sv))
2407             return glob_2number(MUTABLE_GV(sv));
2408
2409         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2410                 report_uninit(sv);
2411         if (SvTYPE(sv) < SVt_IV)
2412             /* Typically the caller expects that sv_any is not NULL now.  */
2413             sv_upgrade(sv, SVt_IV);
2414         /* Return 0 from the caller.  */
2415         return TRUE;
2416     }
2417     return FALSE;
2418 }
2419
2420 /*
2421 =for apidoc sv_2iv_flags
2422
2423 Return the integer value of an SV, doing any necessary string
2424 conversion.  If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2425 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2426
2427 =cut
2428 */
2429
2430 IV
2431 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2432 {
2433     PERL_ARGS_ASSERT_SV_2IV_FLAGS;
2434
2435     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2436          && SvTYPE(sv) != SVt_PVFM);
2437
2438     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2439         mg_get(sv);
2440
2441     if (SvROK(sv)) {
2442         if (SvAMAGIC(sv)) {
2443             SV * tmpstr;
2444             if (flags & SV_SKIP_OVERLOAD)
2445                 return 0;
2446             tmpstr = AMG_CALLunary(sv, numer_amg);
2447             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2448                 return SvIV(tmpstr);
2449             }
2450         }
2451         return PTR2IV(SvRV(sv));
2452     }
2453
2454     if (SvVALID(sv) || isREGEXP(sv)) {
2455         /* FBMs use the space for SvIVX and SvNVX for other purposes, so
2456            must not let them cache IVs.
2457            In practice they are extremely unlikely to actually get anywhere
2458            accessible by user Perl code - the only way that I'm aware of is when
2459            a constant subroutine which is used as the second argument to index.
2460
2461            Regexps have no SvIVX and SvNVX fields.
2462         */
2463         assert(SvPOKp(sv));
2464         {
2465             UV value;
2466             const char * const ptr =
2467                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2468             const int numtype
2469                 = grok_number(ptr, SvCUR(sv), &value);
2470
2471             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2472                 == IS_NUMBER_IN_UV) {
2473                 /* It's definitely an integer */
2474                 if (numtype & IS_NUMBER_NEG) {
2475                     if (value < (UV)IV_MIN)
2476                         return -(IV)value;
2477                 } else {
2478                     if (value < (UV)IV_MAX)
2479                         return (IV)value;
2480                 }
2481             }
2482
2483             /* Quite wrong but no good choices. */
2484             if ((numtype & IS_NUMBER_INFINITY)) {
2485                 return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX;
2486             } else if ((numtype & IS_NUMBER_NAN)) {
2487                 return 0; /* So wrong. */
2488             }
2489
2490             if (!numtype) {
2491                 if (ckWARN(WARN_NUMERIC))
2492                     not_a_number(sv);
2493             }
2494             return I_V(Atof(ptr));
2495         }
2496     }
2497
2498     if (SvTHINKFIRST(sv)) {
2499         if (SvREADONLY(sv) && !SvOK(sv)) {
2500             if (ckWARN(WARN_UNINITIALIZED))
2501                 report_uninit(sv);
2502             return 0;
2503         }
2504     }
2505
2506     if (!SvIOKp(sv)) {
2507         if (S_sv_2iuv_common(aTHX_ sv))
2508             return 0;
2509     }
2510
2511     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" IVdf ")\n",
2512         PTR2UV(sv),SvIVX(sv)));
2513     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2514 }
2515
2516 /*
2517 =for apidoc sv_2uv_flags
2518
2519 Return the unsigned integer value of an SV, doing any necessary string
2520 conversion.  If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2521 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2522
2523 =cut
2524 */
2525
2526 UV
2527 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2528 {
2529     PERL_ARGS_ASSERT_SV_2UV_FLAGS;
2530
2531     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2532         mg_get(sv);
2533
2534     if (SvROK(sv)) {
2535         if (SvAMAGIC(sv)) {
2536             SV *tmpstr;
2537             if (flags & SV_SKIP_OVERLOAD)
2538                 return 0;
2539             tmpstr = AMG_CALLunary(sv, numer_amg);
2540             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2541                 return SvUV(tmpstr);
2542             }
2543         }
2544         return PTR2UV(SvRV(sv));
2545     }
2546
2547     if (SvVALID(sv) || isREGEXP(sv)) {
2548         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2549            the same flag bit as SVf_IVisUV, so must not let them cache IVs.  
2550            Regexps have no SvIVX and SvNVX fields. */
2551         assert(SvPOKp(sv));
2552         {
2553             UV value;
2554             const char * const ptr =
2555                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2556             const int numtype
2557                 = grok_number(ptr, SvCUR(sv), &value);
2558
2559             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2560                 == IS_NUMBER_IN_UV) {
2561                 /* It's definitely an integer */
2562                 if (!(numtype & IS_NUMBER_NEG))
2563                     return value;
2564             }
2565
2566             /* Quite wrong but no good choices. */
2567             if ((numtype & IS_NUMBER_INFINITY)) {
2568                 return UV_MAX; /* So wrong. */
2569             } else if ((numtype & IS_NUMBER_NAN)) {
2570                 return 0; /* So wrong. */
2571             }
2572
2573             if (!numtype) {
2574                 if (ckWARN(WARN_NUMERIC))
2575                     not_a_number(sv);
2576             }
2577             return U_V(Atof(ptr));
2578         }
2579     }
2580
2581     if (SvTHINKFIRST(sv)) {
2582         if (SvREADONLY(sv) && !SvOK(sv)) {
2583             if (ckWARN(WARN_UNINITIALIZED))
2584                 report_uninit(sv);
2585             return 0;
2586         }
2587     }
2588
2589     if (!SvIOKp(sv)) {
2590         if (S_sv_2iuv_common(aTHX_ sv))
2591             return 0;
2592     }
2593
2594     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2uv(%" UVuf ")\n",
2595                           PTR2UV(sv),SvUVX(sv)));
2596     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2597 }
2598
2599 /*
2600 =for apidoc sv_2nv_flags
2601
2602 Return the num value of an SV, doing any necessary string or integer
2603 conversion.  If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2604 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2605
2606 =cut
2607 */
2608
2609 NV
2610 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2611 {
2612     PERL_ARGS_ASSERT_SV_2NV_FLAGS;
2613
2614     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2615          && SvTYPE(sv) != SVt_PVFM);
2616     if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
2617         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2618            the same flag bit as SVf_IVisUV, so must not let them cache NVs.
2619            Regexps have no SvIVX and SvNVX fields.  */
2620         const char *ptr;
2621         if (flags & SV_GMAGIC)
2622             mg_get(sv);
2623         if (SvNOKp(sv))
2624             return SvNVX(sv);
2625         if (SvPOKp(sv) && !SvIOKp(sv)) {
2626             ptr = SvPVX_const(sv);
2627             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2628                 !grok_number(ptr, SvCUR(sv), NULL))
2629                 not_a_number(sv);
2630             return Atof(ptr);
2631         }
2632         if (SvIOKp(sv)) {
2633             if (SvIsUV(sv))
2634                 return (NV)SvUVX(sv);
2635             else
2636                 return (NV)SvIVX(sv);
2637         }
2638         if (SvROK(sv)) {
2639             goto return_rok;
2640         }
2641         assert(SvTYPE(sv) >= SVt_PVMG);
2642         /* This falls through to the report_uninit near the end of the
2643            function. */
2644     } else if (SvTHINKFIRST(sv)) {
2645         if (SvROK(sv)) {
2646         return_rok:
2647             if (SvAMAGIC(sv)) {
2648                 SV *tmpstr;
2649                 if (flags & SV_SKIP_OVERLOAD)
2650                     return 0;
2651                 tmpstr = AMG_CALLunary(sv, numer_amg);
2652                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2653                     return SvNV(tmpstr);
2654                 }
2655             }
2656             return PTR2NV(SvRV(sv));
2657         }
2658         if (SvREADONLY(sv) && !SvOK(sv)) {
2659             if (ckWARN(WARN_UNINITIALIZED))
2660                 report_uninit(sv);
2661             return 0.0;
2662         }
2663     }
2664     if (SvTYPE(sv) < SVt_NV) {
2665         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2666         sv_upgrade(sv, SVt_NV);
2667         CLANG_DIAG_IGNORE_STMT(-Wthread-safety);
2668         DEBUG_c({
2669             DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2670             STORE_LC_NUMERIC_SET_STANDARD();
2671             PerlIO_printf(Perl_debug_log,
2672                           "0x%" UVxf " num(%" NVgf ")\n",
2673                           PTR2UV(sv), SvNVX(sv));
2674             RESTORE_LC_NUMERIC();
2675         });
2676         CLANG_DIAG_RESTORE_STMT;
2677
2678     }
2679     else if (SvTYPE(sv) < SVt_PVNV)
2680         sv_upgrade(sv, SVt_PVNV);
2681     if (SvNOKp(sv)) {
2682         return SvNVX(sv);
2683     }
2684     if (SvIOKp(sv)) {
2685         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2686 #ifdef NV_PRESERVES_UV
2687         if (SvIOK(sv))
2688             SvNOK_on(sv);
2689         else
2690             SvNOKp_on(sv);
2691 #else
2692         /* Only set the public NV OK flag if this NV preserves the IV  */
2693         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2694         if (SvIOK(sv) &&
2695             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2696                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2697             SvNOK_on(sv);
2698         else
2699             SvNOKp_on(sv);
2700 #endif
2701     }
2702     else if (SvPOKp(sv)) {
2703         UV value;
2704         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2705         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2706             not_a_number(sv);
2707 #ifdef NV_PRESERVES_UV
2708         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2709             == IS_NUMBER_IN_UV) {
2710             /* It's definitely an integer */
2711             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2712         } else {
2713             S_sv_setnv(aTHX_ sv, numtype);
2714         }
2715         if (numtype)
2716             SvNOK_on(sv);
2717         else
2718             SvNOKp_on(sv);
2719 #else
2720         SvNV_set(sv, Atof(SvPVX_const(sv)));
2721         /* Only set the public NV OK flag if this NV preserves the value in
2722            the PV at least as well as an IV/UV would.
2723            Not sure how to do this 100% reliably. */
2724         /* if that shift count is out of range then Configure's test is
2725            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2726            UV_BITS */
2727         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2728             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2729             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2730         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2731             /* Can't use strtol etc to convert this string, so don't try.
2732                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2733             SvNOK_on(sv);
2734         } else {
2735             /* value has been set.  It may not be precise.  */
2736             if ((numtype & IS_NUMBER_NEG) && (value >= (UV)IV_MIN)) {
2737                 /* 2s complement assumption for (UV)IV_MIN  */
2738                 SvNOK_on(sv); /* Integer is too negative.  */
2739             } else {
2740                 SvNOKp_on(sv);
2741                 SvIOKp_on(sv);
2742
2743                 if (numtype & IS_NUMBER_NEG) {
2744                     /* -IV_MIN is undefined, but we should never reach
2745                      * this point with both IS_NUMBER_NEG and value ==
2746                      * (UV)IV_MIN */
2747                     assert(value != (UV)IV_MIN);
2748                     SvIV_set(sv, -(IV)value);
2749                 } else if (value <= (UV)IV_MAX) {
2750                     SvIV_set(sv, (IV)value);
2751                 } else {
2752                     SvUV_set(sv, value);
2753                     SvIsUV_on(sv);
2754                 }
2755
2756                 if (numtype & IS_NUMBER_NOT_INT) {
2757                     /* I believe that even if the original PV had decimals,
2758                        they are lost beyond the limit of the FP precision.
2759                        However, neither is canonical, so both only get p
2760                        flags.  NWC, 2000/11/25 */
2761                     /* Both already have p flags, so do nothing */
2762                 } else {
2763                     const NV nv = SvNVX(sv);
2764                     /* XXX should this spot have NAN_COMPARE_BROKEN, too? */
2765                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2766                         if (SvIVX(sv) == I_V(nv)) {
2767                             SvNOK_on(sv);
2768                         } else {
2769                             /* It had no "." so it must be integer.  */
2770                         }
2771                         SvIOK_on(sv);
2772                     } else {
2773                         /* between IV_MAX and NV(UV_MAX).
2774                            Could be slightly > UV_MAX */
2775
2776                         if (numtype & IS_NUMBER_NOT_INT) {
2777                             /* UV and NV both imprecise.  */
2778                         } else {
2779                             const UV nv_as_uv = U_V(nv);
2780
2781                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2782                                 SvNOK_on(sv);
2783                             }
2784                             SvIOK_on(sv);
2785                         }
2786                     }
2787                 }
2788             }
2789         }
2790         /* It might be more code efficient to go through the entire logic above
2791            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2792            gets complex and potentially buggy, so more programmer efficient
2793            to do it this way, by turning off the public flags:  */
2794         if (!numtype)
2795             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2796 #endif /* NV_PRESERVES_UV */
2797     }
2798     else  {
2799         if (isGV_with_GP(sv)) {
2800             glob_2number(MUTABLE_GV(sv));
2801             return 0.0;
2802         }
2803
2804         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2805             report_uninit(sv);
2806         assert (SvTYPE(sv) >= SVt_NV);
2807         /* Typically the caller expects that sv_any is not NULL now.  */
2808         /* XXX Ilya implies that this is a bug in callers that assume this
2809            and ideally should be fixed.  */
2810         return 0.0;
2811     }
2812     CLANG_DIAG_IGNORE_STMT(-Wthread-safety);
2813     DEBUG_c({
2814         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2815         STORE_LC_NUMERIC_SET_STANDARD();
2816         PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2nv(%" NVgf ")\n",
2817                       PTR2UV(sv), SvNVX(sv));
2818         RESTORE_LC_NUMERIC();
2819     });
2820     CLANG_DIAG_RESTORE_STMT;
2821     return SvNVX(sv);
2822 }
2823
2824 /*
2825 =for apidoc sv_2num
2826
2827 Return an SV with the numeric value of the source SV, doing any necessary
2828 reference or overload conversion.  The caller is expected to have handled
2829 get-magic already.
2830
2831 =cut
2832 */
2833
2834 SV *
2835 Perl_sv_2num(pTHX_ SV *const sv)
2836 {
2837     PERL_ARGS_ASSERT_SV_2NUM;
2838
2839     if (!SvROK(sv))
2840         return sv;
2841     if (SvAMAGIC(sv)) {
2842         SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2843         TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2844         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2845             return sv_2num(tmpsv);
2846     }
2847     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2848 }
2849
2850 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2851  * UV as a string towards the end of buf, and return pointers to start and
2852  * end of it.
2853  *
2854  * We assume that buf is at least TYPE_CHARS(UV) long.
2855  */
2856
2857 static char *
2858 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2859 {
2860     char *ptr = buf + TYPE_CHARS(UV);
2861     char * const ebuf = ptr;
2862     int sign;
2863
2864     PERL_ARGS_ASSERT_UIV_2BUF;
2865
2866     if (is_uv)
2867         sign = 0;
2868     else if (iv >= 0) {
2869         uv = iv;
2870         sign = 0;
2871     } else {
2872         uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv);
2873         sign = 1;
2874     }
2875     do {
2876         *--ptr = '0' + (char)(uv % 10);
2877     } while (uv /= 10);
2878     if (sign)
2879         *--ptr = '-';
2880     *peob = ebuf;
2881     return ptr;
2882 }
2883
2884 /* Helper for sv_2pv_flags and sv_vcatpvfn_flags.  If the NV is an
2885  * infinity or a not-a-number, writes the appropriate strings to the
2886  * buffer, including a zero byte.  On success returns the written length,
2887  * excluding the zero byte, on failure (not an infinity, not a nan)
2888  * returns zero, assert-fails on maxlen being too short.
2889  *
2890  * XXX for "Inf", "-Inf", and "NaN", we could have three read-only
2891  * shared string constants we point to, instead of generating a new
2892  * string for each instance. */
2893 STATIC size_t
2894 S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char plus) {
2895     char* s = buffer;
2896     assert(maxlen >= 4);
2897     if (Perl_isinf(nv)) {
2898         if (nv < 0) {
2899             if (maxlen < 5) /* "-Inf\0"  */
2900                 return 0;
2901             *s++ = '-';
2902         } else if (plus) {
2903             *s++ = '+';
2904         }
2905         *s++ = 'I';
2906         *s++ = 'n';
2907         *s++ = 'f';
2908     }
2909     else if (Perl_isnan(nv)) {
2910         *s++ = 'N';
2911         *s++ = 'a';
2912         *s++ = 'N';
2913         /* XXX optionally output the payload mantissa bits as
2914          * "(unsigned)" (to match the nan("...") C99 function,
2915          * or maybe as "(0xhhh...)"  would make more sense...
2916          * provide a format string so that the user can decide?
2917          * NOTE: would affect the maxlen and assert() logic.*/
2918     }
2919     else {
2920       return 0;
2921     }
2922     assert((s == buffer + 3) || (s == buffer + 4));
2923     *s = 0;
2924     return s - buffer;
2925 }
2926
2927 /*
2928 =for apidoc sv_2pv_flags
2929
2930 Returns a pointer to the string value of an SV, and sets C<*lp> to its length.
2931 If flags has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.  Coerces C<sv> to a
2932 string if necessary.  Normally invoked via the C<SvPV_flags> macro.
2933 C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
2934
2935 =cut
2936 */
2937
2938 char *
2939 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
2940 {
2941     char *s;
2942
2943     PERL_ARGS_ASSERT_SV_2PV_FLAGS;
2944
2945     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2946          && SvTYPE(sv) != SVt_PVFM);
2947     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2948         mg_get(sv);
2949     if (SvROK(sv)) {
2950         if (SvAMAGIC(sv)) {
2951             SV *tmpstr;
2952             if (flags & SV_SKIP_OVERLOAD)
2953                 return NULL;
2954             tmpstr = AMG_CALLunary(sv, string_amg);
2955             TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2956             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2957                 /* Unwrap this:  */
2958                 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2959                  */
2960
2961                 char *pv;
2962                 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2963                     if (flags & SV_CONST_RETURN) {
2964                         pv = (char *) SvPVX_const(tmpstr);
2965                     } else {
2966                         pv = (flags & SV_MUTABLE_RETURN)
2967                             ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2968                     }
2969                     if (lp)
2970                         *lp = SvCUR(tmpstr);
2971                 } else {
2972                     pv = sv_2pv_flags(tmpstr, lp, flags);
2973                 }
2974                 if (SvUTF8(tmpstr))
2975                     SvUTF8_on(sv);
2976                 else
2977                     SvUTF8_off(sv);
2978                 return pv;
2979             }
2980         }
2981         {
2982             STRLEN len;
2983             char *retval;
2984             char *buffer;
2985             SV *const referent = SvRV(sv);
2986
2987             if (!referent) {
2988                 len = 7;
2989                 retval = buffer = savepvn("NULLREF", len);
2990             } else if (SvTYPE(referent) == SVt_REGEXP &&
2991                        (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
2992                         amagic_is_enabled(string_amg))) {
2993                 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2994
2995                 assert(re);
2996                         
2997                 /* If the regex is UTF-8 we want the containing scalar to
2998                    have an UTF-8 flag too */
2999                 if (RX_UTF8(re))
3000                     SvUTF8_on(sv);
3001                 else
3002                     SvUTF8_off(sv);     
3003
3004                 if (lp)
3005                     *lp = RX_WRAPLEN(re);
3006  
3007                 return RX_WRAPPED(re);
3008             } else {
3009                 const char *const typestr = sv_reftype(referent, 0);
3010                 const STRLEN typelen = strlen(typestr);
3011                 UV addr = PTR2UV(referent);
3012                 const char *stashname = NULL;
3013                 STRLEN stashnamelen = 0; /* hush, gcc */
3014                 const char *buffer_end;
3015
3016                 if (SvOBJECT(referent)) {
3017                     const HEK *const name = HvNAME_HEK(SvSTASH(referent));
3018
3019                     if (name) {
3020                         stashname = HEK_KEY(name);
3021                         stashnamelen = HEK_LEN(name);
3022
3023                         if (HEK_UTF8(name)) {
3024                             SvUTF8_on(sv);
3025                         } else {
3026                             SvUTF8_off(sv);
3027                         }
3028                     } else {
3029                         stashname = "__ANON__";
3030                         stashnamelen = 8;
3031                     }
3032                     len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
3033                         + 2 * sizeof(UV) + 2 /* )\0 */;
3034                 } else {
3035                     len = typelen + 3 /* (0x */
3036                         + 2 * sizeof(UV) + 2 /* )\0 */;
3037                 }
3038
3039                 Newx(buffer, len, char);
3040                 buffer_end = retval = buffer + len;
3041
3042                 /* Working backwards  */
3043                 *--retval = '\0';
3044                 *--retval = ')';
3045                 do {
3046                     *--retval = PL_hexdigit[addr & 15];
3047                 } while (addr >>= 4);
3048                 *--retval = 'x';
3049                 *--retval = '0';
3050                 *--retval = '(';
3051
3052                 retval -= typelen;
3053                 memcpy(retval, typestr, typelen);
3054
3055                 if (stashname) {
3056                     *--retval = '=';
3057                     retval -= stashnamelen;
3058                     memcpy(retval, stashname, stashnamelen);
3059                 }
3060                 /* retval may not necessarily have reached the start of the
3061                    buffer here.  */
3062                 assert (retval >= buffer);
3063
3064                 len = buffer_end - retval - 1; /* -1 for that \0  */
3065             }
3066             if (lp)
3067                 *lp = len;
3068             SAVEFREEPV(buffer);
3069             return retval;
3070         }
3071     }
3072
3073     if (SvPOKp(sv)) {
3074         if (lp)
3075             *lp = SvCUR(sv);
3076         if (flags & SV_MUTABLE_RETURN)
3077             return SvPVX_mutable(sv);
3078         if (flags & SV_CONST_RETURN)
3079             return (char *)SvPVX_const(sv);
3080         return SvPVX(sv);
3081     }
3082
3083     if (SvIOK(sv)) {
3084         /* I'm assuming that if both IV and NV are equally valid then
3085            converting the IV is going to be more efficient */
3086         const U32 isUIOK = SvIsUV(sv);
3087         char buf[TYPE_CHARS(UV)];
3088         char *ebuf, *ptr;
3089         STRLEN len;
3090
3091         if (SvTYPE(sv) < SVt_PVIV)
3092             sv_upgrade(sv, SVt_PVIV);
3093         ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
3094         len = ebuf - ptr;
3095         /* inlined from sv_setpvn */
3096         s = SvGROW_mutable(sv, len + 1);
3097         Move(ptr, s, len, char);
3098         s += len;
3099         *s = '\0';
3100         SvPOK_on(sv);
3101     }
3102     else if (SvNOK(sv)) {
3103         if (SvTYPE(sv) < SVt_PVNV)
3104             sv_upgrade(sv, SVt_PVNV);
3105         if (SvNVX(sv) == 0.0
3106 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3107             && !Perl_isnan(SvNVX(sv))
3108 #endif
3109         ) {
3110             s = SvGROW_mutable(sv, 2);
3111             *s++ = '0';
3112             *s = '\0';
3113         } else {
3114             STRLEN len;
3115             STRLEN size = 5; /* "-Inf\0" */
3116
3117             s = SvGROW_mutable(sv, size);
3118             len = S_infnan_2pv(SvNVX(sv), s, size, 0);
3119             if (len > 0) {
3120                 s += len;
3121                 SvPOK_on(sv);
3122             }
3123             else {
3124                 /* some Xenix systems wipe out errno here */
3125                 dSAVE_ERRNO;
3126
3127                 size =
3128                     1 + /* sign */
3129                     1 + /* "." */
3130                     NV_DIG +
3131                     1 + /* "e" */
3132                     1 + /* sign */
3133                     5 + /* exponent digits */
3134                     1 + /* \0 */
3135                     2; /* paranoia */
3136
3137                 s = SvGROW_mutable(sv, size);
3138 #ifndef USE_LOCALE_NUMERIC
3139                 SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3140
3141                 SvPOK_on(sv);
3142 #else
3143                 {
3144                     bool local_radix;
3145                     DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3146                     STORE_LC_NUMERIC_SET_TO_NEEDED();
3147
3148                     local_radix = _NOT_IN_NUMERIC_STANDARD;
3149                     if (local_radix && SvCUR(PL_numeric_radix_sv) > 1) {
3150                         size += SvCUR(PL_numeric_radix_sv) - 1;
3151                         s = SvGROW_mutable(sv, size);
3152                     }
3153
3154                     SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3155
3156                     /* If the radix character is UTF-8, and actually is in the
3157                      * output, turn on the UTF-8 flag for the scalar */
3158                     if (   local_radix
3159                         && SvUTF8(PL_numeric_radix_sv)
3160                         && instr(s, SvPVX_const(PL_numeric_radix_sv)))
3161                     {
3162                         SvUTF8_on(sv);
3163                     }
3164
3165                     RESTORE_LC_NUMERIC();
3166                 }
3167
3168                 /* We don't call SvPOK_on(), because it may come to
3169                  * pass that the locale changes so that the
3170                  * stringification we just did is no longer correct.  We
3171                  * will have to re-stringify every time it is needed */
3172 #endif
3173                 RESTORE_ERRNO;
3174             }
3175             while (*s) s++;
3176         }
3177     }
3178     else if (isGV_with_GP(sv)) {
3179         GV *const gv = MUTABLE_GV(sv);
3180         SV *const buffer = sv_newmortal();
3181
3182         gv_efullname3(buffer, gv, "*");
3183
3184         assert(SvPOK(buffer));
3185         if (SvUTF8(buffer))
3186             SvUTF8_on(sv);
3187         else
3188             SvUTF8_off(sv);
3189         if (lp)
3190             *lp = SvCUR(buffer);
3191         return SvPVX(buffer);
3192     }
3193     else {
3194         if (lp)
3195             *lp = 0;
3196         if (flags & SV_UNDEF_RETURNS_NULL)
3197             return NULL;
3198         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3199             report_uninit(sv);
3200         /* Typically the caller expects that sv_any is not NULL now.  */
3201         if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
3202             sv_upgrade(sv, SVt_PV);
3203         return (char *)"";
3204     }
3205
3206     {
3207         const STRLEN len = s - SvPVX_const(sv);
3208         if (lp) 
3209             *lp = len;
3210         SvCUR_set(sv, len);
3211     }
3212     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2pv(%s)\n",
3213                           PTR2UV(sv),SvPVX_const(sv)));
3214     if (flags & SV_CONST_RETURN)
3215         return (char *)SvPVX_const(sv);
3216     if (flags & SV_MUTABLE_RETURN)
3217         return SvPVX_mutable(sv);
3218     return SvPVX(sv);
3219 }
3220
3221 /*
3222 =for apidoc sv_copypv
3223
3224 Copies a stringified representation of the source SV into the
3225 destination SV.  Automatically performs any necessary C<mg_get> and
3226 coercion of numeric values into strings.  Guaranteed to preserve
3227 C<UTF8> flag even from overloaded objects.  Similar in nature to
3228 C<sv_2pv[_flags]> but operates directly on an SV instead of just the
3229 string.  Mostly uses C<sv_2pv_flags> to do its work, except when that
3230 would lose the UTF-8'ness of the PV.
3231
3232 =for apidoc sv_copypv_nomg
3233
3234 Like C<sv_copypv>, but doesn't invoke get magic first.
3235
3236 =for apidoc sv_copypv_flags
3237
3238 Implementation of C<sv_copypv> and C<sv_copypv_nomg>.  Calls get magic iff flags
3239 has the C<SV_GMAGIC> bit set.
3240
3241 =cut
3242 */
3243
3244 void
3245 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3246 {
3247     STRLEN len;
3248     const char *s;
3249
3250     PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3251
3252     s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC));
3253     sv_setpvn(dsv,s,len);
3254     if (SvUTF8(ssv))
3255         SvUTF8_on(dsv);
3256     else
3257         SvUTF8_off(dsv);
3258 }
3259
3260 /*
3261 =for apidoc sv_2pvbyte
3262
3263 Return a pointer to the byte-encoded representation of the SV, and set C<*lp>
3264 to its length.  May cause the SV to be downgraded from UTF-8 as a
3265 side-effect.
3266
3267 Usually accessed via the C<SvPVbyte> macro.
3268
3269 =cut
3270 */
3271
3272 char *
3273 Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
3274 {
3275     PERL_ARGS_ASSERT_SV_2PVBYTE;
3276
3277     SvGETMAGIC(sv);
3278     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3279      || isGV_with_GP(sv) || SvROK(sv)) {
3280         SV *sv2 = sv_newmortal();
3281         sv_copypv_nomg(sv2,sv);
3282         sv = sv2;
3283     }
3284     sv_utf8_downgrade(sv,0);
3285     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3286 }
3287
3288 /*
3289 =for apidoc sv_2pvutf8
3290
3291 Return a pointer to the UTF-8-encoded representation of the SV, and set C<*lp>
3292 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3293
3294 Usually accessed via the C<SvPVutf8> macro.
3295
3296 =cut
3297 */
3298
3299 char *
3300 Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
3301 {
3302     PERL_ARGS_ASSERT_SV_2PVUTF8;
3303
3304     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3305      || isGV_with_GP(sv) || SvROK(sv))
3306         sv = sv_mortalcopy(sv);
3307     else
3308         SvGETMAGIC(sv);
3309     sv_utf8_upgrade_nomg(sv);
3310     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3311 }
3312
3313
3314 /*
3315 =for apidoc sv_2bool
3316
3317 This macro is only used by C<sv_true()> or its macro equivalent, and only if
3318 the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>.
3319 It calls C<sv_2bool_flags> with the C<SV_GMAGIC> flag.
3320
3321 =for apidoc sv_2bool_flags
3322
3323 This function is only used by C<sv_true()> and friends,  and only if
3324 the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>.  If the flags
3325 contain C<SV_GMAGIC>, then it does an C<mg_get()> first.
3326
3327
3328 =cut
3329 */
3330
3331 bool
3332 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
3333 {
3334     PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3335
3336     restart:
3337     if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3338
3339     if (!SvOK(sv))
3340         return 0;
3341     if (SvROK(sv)) {
3342         if (SvAMAGIC(sv)) {
3343             SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3344             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
3345                 bool svb;
3346                 sv = tmpsv;
3347                 if(SvGMAGICAL(sv)) {
3348                     flags = SV_GMAGIC;
3349                     goto restart; /* call sv_2bool */
3350                 }
3351                 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
3352                 else if(!SvOK(sv)) {
3353                     svb = 0;
3354                 }
3355                 else if(SvPOK(sv)) {
3356                     svb = SvPVXtrue(sv);
3357                 }
3358                 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
3359                     svb = (SvIOK(sv) && SvIVX(sv) != 0)
3360                         || (SvNOK(sv) && SvNVX(sv) != 0.0);
3361                 }
3362                 else {
3363                     flags = 0;
3364                     goto restart; /* call sv_2bool_nomg */
3365                 }
3366                 return cBOOL(svb);
3367             }
3368         }
3369         assert(SvRV(sv));
3370         return TRUE;
3371     }
3372     if (isREGEXP(sv))
3373         return
3374           RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
3375
3376     if (SvNOK(sv) && !SvPOK(sv))
3377         return SvNVX(sv) != 0.0;
3378
3379     return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
3380 }
3381
3382 /*
3383 =for apidoc sv_utf8_upgrade
3384
3385 Converts the PV of an SV to its UTF-8-encoded form.
3386 Forces the SV to string form if it is not already.
3387 Will C<mg_get> on C<sv> if appropriate.
3388 Always sets the C<SvUTF8> flag to avoid future validity checks even
3389 if the whole string is the same in UTF-8 as not.
3390 Returns the number of bytes in the converted string
3391
3392 This is not a general purpose byte encoding to Unicode interface:
3393 use the Encode extension for that.
3394
3395 =for apidoc sv_utf8_upgrade_nomg
3396
3397 Like C<sv_utf8_upgrade>, but doesn't do magic on C<sv>.
3398
3399 =for apidoc sv_utf8_upgrade_flags
3400
3401 Converts the PV of an SV to its UTF-8-encoded form.
3402 Forces the SV to string form if it is not already.
3403 Always sets the SvUTF8 flag to avoid future validity checks even
3404 if all the bytes are invariant in UTF-8.
3405 If C<flags> has C<SV_GMAGIC> bit set,
3406 will C<mg_get> on C<sv> if appropriate, else not.
3407
3408 The C<SV_FORCE_UTF8_UPGRADE> flag is now ignored.
3409
3410 Returns the number of bytes in the converted string.
3411
3412 This is not a general purpose byte encoding to Unicode interface:
3413 use the Encode extension for that.
3414
3415 =for apidoc sv_utf8_upgrade_flags_grow
3416
3417 Like C<sv_utf8_upgrade_flags>, but has an additional parameter C<extra>, which is
3418 the number of unused bytes the string of C<sv> is guaranteed to have free after
3419 it upon return.  This allows the caller to reserve extra space that it intends
3420 to fill, to avoid extra grows.
3421
3422 C<sv_utf8_upgrade>, C<sv_utf8_upgrade_nomg>, and C<sv_utf8_upgrade_flags>
3423 are implemented in terms of this function.
3424
3425 Returns the number of bytes in the converted string (not including the spares).
3426
3427 =cut
3428
3429 If the routine itself changes the string, it adds a trailing C<NUL>.  Such a
3430 C<NUL> isn't guaranteed due to having other routines do the work in some input
3431 cases, or if the input is already flagged as being in utf8.
3432
3433 */
3434
3435 STRLEN
3436 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3437 {
3438     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3439
3440     if (sv == &PL_sv_undef)
3441         return 0;
3442     if (!SvPOK_nog(sv)) {
3443         STRLEN len = 0;
3444         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3445             (void) sv_2pv_flags(sv,&len, flags);
3446             if (SvUTF8(sv)) {
3447                 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3448                 return len;
3449             }
3450         } else {
3451             (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3452         }
3453     }
3454
3455     /* SVt_REGEXP's shouldn't be upgraded to UTF8 - they're already
3456      * compiled and individual nodes will remain non-utf8 even if the
3457      * stringified version of the pattern gets upgraded. Whether the
3458      * PVX of a REGEXP should be grown or we should just croak, I don't
3459      * know - DAPM */
3460     if (SvUTF8(sv) || isREGEXP(sv)) {
3461         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3462         return SvCUR(sv);
3463     }
3464
3465     if (SvIsCOW(sv)) {
3466         S_sv_uncow(aTHX_ sv, 0);
3467     }
3468
3469     if (SvCUR(sv) == 0) {
3470         if (extra) SvGROW(sv, extra);
3471     } else { /* Assume Latin-1/EBCDIC */
3472         /* This function could be much more efficient if we
3473          * had a FLAG in SVs to signal if there are any variant
3474          * chars in the PV.  Given that there isn't such a flag
3475          * make the loop as fast as possible. */
3476         U8 * s = (U8 *) SvPVX_const(sv);
3477         U8 *t = s;
3478         
3479         if (is_utf8_invariant_string_loc(s, SvCUR(sv), (const U8 **) &t)) {
3480
3481             /* utf8 conversion not needed because all are invariants.  Mark
3482              * as UTF-8 even if no variant - saves scanning loop */
3483             SvUTF8_on(sv);
3484             if (extra) SvGROW(sv, SvCUR(sv) + extra);
3485             return SvCUR(sv);
3486         }
3487
3488         /* Here, there is at least one variant (t points to the first one), so
3489          * the string should be converted to utf8.  Everything from 's' to
3490          * 't - 1' will occupy only 1 byte each on output.
3491          *
3492          * Note that the incoming SV may not have a trailing '\0', as certain
3493          * code in pp_formline can send us partially built SVs.
3494          *
3495          * There are two main ways to convert.  One is to create a new string
3496          * and go through the input starting from the beginning, appending each
3497          * converted value onto the new string as we go along.  Going this
3498          * route, it's probably best to initially allocate enough space in the
3499          * string rather than possibly running out of space and having to
3500          * reallocate and then copy what we've done so far.  Since everything
3501          * from 's' to 't - 1' is invariant, the destination can be initialized
3502          * with these using a fast memory copy.  To be sure to allocate enough
3503          * space, one could use the worst case scenario, where every remaining
3504          * byte expands to two under UTF-8, or one could parse it and count
3505          * exactly how many do expand.
3506          *
3507          * The other way is to unconditionally parse the remainder of the
3508          * string to figure out exactly how big the expanded string will be,
3509          * growing if needed.  Then start at the end of the string and place
3510          * the character there at the end of the unfilled space in the expanded
3511          * one, working backwards until reaching 't'.
3512          *
3513          * The problem with assuming the worst case scenario is that for very
3514          * long strings, we could allocate much more memory than actually
3515          * needed, which can create performance problems.  If we have to parse
3516          * anyway, the second method is the winner as it may avoid an extra
3517          * copy.  The code used to use the first method under some
3518          * circumstances, but now that there is faster variant counting on
3519          * ASCII platforms, the second method is used exclusively, eliminating
3520          * some code that no longer has to be maintained. */
3521
3522         {
3523             /* Count the total number of variants there are.  We can start
3524              * just beyond the first one, which is known to be at 't' */
3525             const Size_t invariant_length = t - s;
3526             U8 * e = (U8 *) SvEND(sv);
3527
3528             /* The length of the left overs, plus 1. */
3529             const Size_t remaining_length_p1 = e - t;
3530
3531             /* We expand by 1 for the variant at 't' and one for each remaining
3532              * variant (we start looking at 't+1') */
3533             Size_t expansion = 1 + variant_under_utf8_count(t + 1, e);
3534
3535             /* +1 = trailing NUL */
3536             Size_t need = SvCUR(sv) + expansion + extra + 1;
3537             U8 * d;
3538
3539             /* Grow if needed */
3540             if (SvLEN(sv) < need) {
3541                 t = invariant_length + (U8*) SvGROW(sv, need);
3542                 e = t + remaining_length_p1;
3543             }
3544             SvCUR_set(sv, invariant_length + remaining_length_p1 + expansion);
3545
3546             /* Set the NUL at the end */
3547             d = (U8 *) SvEND(sv);
3548             *d-- = '\0';
3549
3550             /* Having decremented d, it points to the position to put the
3551              * very last byte of the expanded string.  Go backwards through
3552              * the string, copying and expanding as we go, stopping when we
3553              * get to the part that is invariant the rest of the way down */
3554
3555             e--;
3556             while (e >= t) {
3557                 if (NATIVE_BYTE_IS_INVARIANT(*e)) {
3558                     *d-- = *e;
3559                 } else {
3560                     *d-- = UTF8_EIGHT_BIT_LO(*e);
3561                     *d-- = UTF8_EIGHT_BIT_HI(*e);
3562                 }
3563                 e--;
3564             }
3565
3566             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3567                 /* Update pos. We do it at the end rather than during
3568                  * the upgrade, to avoid slowing down the common case
3569                  * (upgrade without pos).
3570                  * pos can be stored as either bytes or characters.  Since
3571                  * this was previously a byte string we can just turn off
3572                  * the bytes flag. */
3573                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3574                 if (mg) {
3575                     mg->mg_flags &= ~MGf_BYTES;
3576                 }
3577                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3578                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3579             }
3580         }
3581     }
3582
3583     SvUTF8_on(sv);
3584     return SvCUR(sv);
3585 }
3586
3587 /*
3588 =for apidoc sv_utf8_downgrade
3589
3590 Attempts to convert the PV of an SV from characters to bytes.
3591 If the PV contains a character that cannot fit
3592 in a byte, this conversion will fail;
3593 in this case, either returns false or, if C<fail_ok> is not
3594 true, croaks.
3595
3596 This is not a general purpose Unicode to byte encoding interface:
3597 use the C<Encode> extension for that.
3598
3599 =cut
3600 */
3601
3602 bool
3603 Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
3604 {
3605     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3606
3607     if (SvPOKp(sv) && SvUTF8(sv)) {
3608         if (SvCUR(sv)) {
3609             U8 *s;
3610             STRLEN len;
3611             int mg_flags = SV_GMAGIC;
3612
3613             if (SvIsCOW(sv)) {
3614                 S_sv_uncow(aTHX_ sv, 0);
3615             }
3616             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3617                 /* update pos */
3618                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3619                 if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
3620                         mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
3621                                                 SV_GMAGIC|SV_CONST_RETURN);
3622                         mg_flags = 0; /* sv_pos_b2u does get magic */
3623                 }
3624                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3625                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3626
3627             }
3628             s = (U8 *) SvPV_flags(sv, len, mg_flags);
3629
3630             if (!utf8_to_bytes(s, &len)) {
3631                 if (fail_ok)
3632                     return FALSE;
3633                 else {
3634                     if (PL_op)
3635                         Perl_croak(aTHX_ "Wide character in %s",
3636                                    OP_DESC(PL_op));
3637                     else
3638                         Perl_croak(aTHX_ "Wide character");
3639                 }
3640             }
3641             SvCUR_set(sv, len);
3642         }
3643     }
3644     SvUTF8_off(sv);
3645     return TRUE;
3646 }
3647
3648 /*
3649 =for apidoc sv_utf8_encode
3650
3651 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3652 flag off so that it looks like octets again.
3653
3654 =cut
3655 */
3656
3657 void
3658 Perl_sv_utf8_encode(pTHX_ SV *const sv)
3659 {
3660     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3661
3662     if (SvREADONLY(sv)) {
3663         sv_force_normal_flags(sv, 0);
3664     }
3665     (void) sv_utf8_upgrade(sv);
3666     SvUTF8_off(sv);
3667 }
3668
3669 /*
3670 =for apidoc sv_utf8_decode
3671
3672 If the PV of the SV is an octet sequence in Perl's extended UTF-8
3673 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3674 so that it looks like a character.  If the PV contains only single-byte
3675 characters, the C<SvUTF8> flag stays off.
3676 Scans PV for validity and returns FALSE if the PV is invalid UTF-8.
3677
3678 =cut
3679 */
3680
3681 bool
3682 Perl_sv_utf8_decode(pTHX_ SV *const sv)
3683 {
3684     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3685
3686     if (SvPOKp(sv)) {
3687         const U8 *start, *c, *first_variant;
3688
3689         /* The octets may have got themselves encoded - get them back as
3690          * bytes
3691          */
3692         if (!sv_utf8_downgrade(sv, TRUE))
3693             return FALSE;
3694
3695         /* it is actually just a matter of turning the utf8 flag on, but
3696          * we want to make sure everything inside is valid utf8 first.
3697          */
3698         c = start = (const U8 *) SvPVX_const(sv);
3699         if (! is_utf8_invariant_string_loc(c, SvCUR(sv), &first_variant)) {
3700             if (!is_utf8_string(first_variant, SvCUR(sv) - (first_variant -c)))
3701                 return FALSE;
3702             SvUTF8_on(sv);
3703         }
3704         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3705             /* XXX Is this dead code?  XS_utf8_decode calls SvSETMAGIC
3706                    after this, clearing pos.  Does anything on CPAN
3707                    need this? */
3708             /* adjust pos to the start of a UTF8 char sequence */
3709             MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3710             if (mg) {
3711                 I32 pos = mg->mg_len;
3712                 if (pos > 0) {
3713                     for (c = start + pos; c > start; c--) {
3714                         if (UTF8_IS_START(*c))
3715                             break;
3716                     }
3717                     mg->mg_len  = c - start;
3718                 }
3719             }
3720             if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3721                 magic_setutf8(sv,mg); /* clear UTF8 cache */
3722         }
3723     }
3724     return TRUE;
3725 }
3726
3727 /*
3728 =for apidoc sv_setsv
3729
3730 Copies the contents of the source SV C<ssv> into the destination SV
3731 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3732 function if the source SV needs to be reused.  Does not handle 'set' magic on
3733 destination SV.  Calls 'get' magic on source SV.  Loosely speaking, it
3734 performs a copy-by-value, obliterating any previous content of the
3735 destination.
3736
3737 You probably want to use one of the assortment of wrappers, such as
3738 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3739 C<SvSetMagicSV_nosteal>.
3740
3741 =for apidoc sv_setsv_flags
3742
3743 Copies the contents of the source SV C<ssv> into the destination SV
3744 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3745 function if the source SV needs to be reused.  Does not handle 'set' magic.
3746 Loosely speaking, it performs a copy-by-value, obliterating any previous
3747 content of the destination.
3748 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3749 C<ssv> if appropriate, else not.  If the C<flags>
3750 parameter has the C<SV_NOSTEAL> bit set then the
3751 buffers of temps will not be stolen.  C<sv_setsv>
3752 and C<sv_setsv_nomg> are implemented in terms of this function.
3753
3754 You probably want to use one of the assortment of wrappers, such as
3755 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3756 C<SvSetMagicSV_nosteal>.
3757
3758 This is the primary function for copying scalars, and most other
3759 copy-ish functions and macros use this underneath.
3760
3761 =cut
3762 */
3763
3764 static void
3765 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3766 {
3767     I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3768     HV *old_stash = NULL;
3769
3770     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3771
3772     if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3773         const char * const name = GvNAME(sstr);
3774         const STRLEN len = GvNAMELEN(sstr);
3775         {
3776             if (dtype >= SVt_PV) {
3777                 SvPV_free(dstr);
3778                 SvPV_set(dstr, 0);
3779                 SvLEN_set(dstr, 0);
3780                 SvCUR_set(dstr, 0);
3781             }
3782             SvUPGRADE(dstr, SVt_PVGV);
3783             (void)SvOK_off(dstr);
3784             isGV_with_GP_on(dstr);
3785         }
3786         GvSTASH(dstr) = GvSTASH(sstr);
3787         if (GvSTASH(dstr))
3788             Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3789         gv_name_set(MUTABLE_GV(dstr), name, len,
3790                         GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
3791         SvFAKE_on(dstr);        /* can coerce to non-glob */
3792     }
3793
3794     if(GvGP(MUTABLE_GV(sstr))) {
3795         /* If source has method cache entry, clear it */
3796         if(GvCVGEN(sstr)) {
3797             SvREFCNT_dec(GvCV(sstr));
3798             GvCV_set(sstr, NULL);
3799             GvCVGEN(sstr) = 0;
3800         }
3801         /* If source has a real method, then a method is
3802            going to change */
3803         else if(
3804          GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3805         ) {
3806             mro_changes = 1;
3807         }
3808     }
3809
3810     /* If dest already had a real method, that's a change as well */
3811     if(
3812         !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3813      && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3814     ) {
3815         mro_changes = 1;
3816     }
3817
3818     /* We don't need to check the name of the destination if it was not a
3819        glob to begin with. */
3820     if(dtype == SVt_PVGV) {
3821         const char * const name = GvNAME((const GV *)dstr);
3822         const STRLEN len = GvNAMELEN(dstr);
3823         if(memEQs(name, len, "ISA")
3824          /* The stash may have been detached from the symbol table, so
3825             check its name. */
3826          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3827         )
3828             mro_changes = 2;
3829         else {
3830             if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3831              || (len == 1 && name[0] == ':')) {
3832                 mro_changes = 3;
3833
3834                 /* Set aside the old stash, so we can reset isa caches on
3835                    its subclasses. */
3836                 if((old_stash = GvHV(dstr)))
3837                     /* Make sure we do not lose it early. */
3838                     SvREFCNT_inc_simple_void_NN(
3839                      sv_2mortal((SV *)old_stash)
3840                     );
3841             }
3842         }
3843
3844         SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
3845     }
3846
3847     /* freeing dstr's GP might free sstr (e.g. *x = $x),
3848      * so temporarily protect it */
3849     ENTER;
3850     SAVEFREESV(SvREFCNT_inc_simple_NN(sstr));
3851     gp_free(MUTABLE_GV(dstr));
3852     GvINTRO_off(dstr);          /* one-shot flag */
3853     GvGP_set(dstr, gp_ref(GvGP(sstr)));
3854     LEAVE;
3855
3856     if (SvTAINTED(sstr))
3857         SvTAINT(dstr);
3858     if (GvIMPORTED(dstr) != GVf_IMPORTED
3859         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3860         {
3861             GvIMPORTED_on(dstr);
3862         }
3863     GvMULTI_on(dstr);
3864     if(mro_changes == 2) {
3865       if (GvAV((const GV *)sstr)) {
3866         MAGIC *mg;
3867         SV * const sref = (SV *)GvAV((const GV *)dstr);
3868         if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3869             if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3870                 AV * const ary = newAV();
3871                 av_push(ary, mg->mg_obj); /* takes the refcount */
3872                 mg->mg_obj = (SV *)ary;
3873             }
3874             av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3875         }
3876         else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3877       }
3878       mro_isa_changed_in(GvSTASH(dstr));
3879     }
3880     else if(mro_changes == 3) {
3881         HV * const stash = GvHV(dstr);
3882         if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3883             mro_package_moved(
3884                 stash, old_stash,
3885                 (GV *)dstr, 0
3886             );
3887     }
3888     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3889     if (GvIO(dstr) && dtype == SVt_PVGV) {
3890         DEBUG_o(Perl_deb(aTHX_
3891                         "glob_assign_glob clearing PL_stashcache\n"));
3892         /* It's a cache. It will rebuild itself quite happily.
3893            It's a lot of effort to work out exactly which key (or keys)
3894            might be invalidated by the creation of the this file handle.
3895          */
3896         hv_clear(PL_stashcache);
3897     }
3898     return;
3899 }
3900
3901 void
3902 Perl_gv_setref(pTHX_ SV *const dstr, SV *const sstr)
3903 {
3904     SV * const sref = SvRV(sstr);
3905     SV *dref;
3906     const int intro = GvINTRO(dstr);
3907     SV **location;
3908     U8 import_flag = 0;
3909     const U32 stype = SvTYPE(sref);
3910
3911     PERL_ARGS_ASSERT_GV_SETREF;
3912
3913     if (intro) {
3914         GvINTRO_off(dstr);      /* one-shot flag */
3915         GvLINE(dstr) = CopLINE(PL_curcop);
3916         GvEGV(dstr) = MUTABLE_GV(dstr);
3917     }
3918     GvMULTI_on(dstr);
3919     switch (stype) {
3920     case SVt_PVCV:
3921         location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
3922         import_flag = GVf_IMPORTED_CV;
3923         goto common;
3924     case SVt_PVHV:
3925         location = (SV **) &GvHV(dstr);
3926         import_flag = GVf_IMPORTED_HV;
3927         goto common;
3928     case SVt_PVAV:
3929         location = (SV **) &GvAV(dstr);
3930         import_flag = GVf_IMPORTED_AV;
3931         goto common;
3932     case SVt_PVIO:
3933         location = (SV **) &GvIOp(dstr);
3934         goto common;
3935     case SVt_PVFM:
3936         location = (SV **) &GvFORM(dstr);
3937         goto common;
3938     default:
3939         location = &GvSV(dstr);
3940         import_flag = GVf_IMPORTED_SV;
3941     common:
3942         if (intro) {
3943             if (stype == SVt_PVCV) {
3944                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3945                 if (GvCVGEN(dstr)) {
3946                     SvREFCNT_dec(GvCV(dstr));
3947                     GvCV_set(dstr, NULL);
3948                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3949                 }
3950             }
3951             /* SAVEt_GVSLOT takes more room on the savestack and has more
3952                overhead in leave_scope than SAVEt_GENERIC_SV.  But for CVs
3953                leave_scope needs access to the GV so it can reset method
3954                caches.  We must use SAVEt_GVSLOT whenever the type is
3955                SVt_PVCV, even if the stash is anonymous, as the stash may
3956                gain a name somehow before leave_scope. */
3957             if (stype == SVt_PVCV) {
3958                 /* There is no save_pushptrptrptr.  Creating it for this
3959                    one call site would be overkill.  So inline the ss add
3960                    routines here. */
3961                 dSS_ADD;
3962                 SS_ADD_PTR(dstr);
3963                 SS_ADD_PTR(location);
3964                 SS_ADD_PTR(SvREFCNT_inc(*location));
3965                 SS_ADD_UV(SAVEt_GVSLOT);
3966                 SS_ADD_END(4);
3967             }
3968             else SAVEGENERICSV(*location);
3969         }
3970         dref = *location;
3971         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3972             CV* const cv = MUTABLE_CV(*location);
3973             if (cv) {
3974                 if (!GvCVGEN((const GV *)dstr) &&
3975                     (CvROOT(cv) || CvXSUB(cv)) &&
3976                     /* redundant check that avoids creating the extra SV
3977                        most of the time: */
3978                     (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
3979                     {
3980                         SV * const new_const_sv =
3981                             CvCONST((const CV *)sref)
3982                                  ? cv_const_sv((const CV *)sref)
3983                                  : NULL;
3984                         HV * const stash = GvSTASH((const GV *)dstr);
3985                         report_redefined_cv(
3986                            sv_2mortal(
3987                              stash
3988                                ? Perl_newSVpvf(aTHX_
3989                                     "%" HEKf "::%" HEKf,
3990                                     HEKfARG(HvNAME_HEK(stash)),
3991                                     HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr))))
3992                                : Perl_newSVpvf(aTHX_
3993                                     "%" HEKf,
3994                                     HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr))))
3995                            ),
3996                            cv,
3997                            CvCONST((const CV *)sref) ? &new_const_sv : NULL
3998                         );
3999                     }
4000                 if (!intro)
4001                     cv_ckproto_len_flags(cv, (const GV *)dstr,
4002                                    SvPOK(sref) ? CvPROTO(sref) : NULL,
4003                                    SvPOK(sref) ? CvPROTOLEN(sref) : 0,
4004                                    SvPOK(sref) ? SvUTF8(sref) : 0);
4005             }
4006             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4007             GvASSUMECV_on(dstr);
4008             if(GvSTASH(dstr)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
4009                 if (intro && GvREFCNT(dstr) > 1) {
4010                     /* temporary remove extra savestack's ref */
4011                     --GvREFCNT(dstr);
4012                     gv_method_changed(dstr);
4013                     ++GvREFCNT(dstr);
4014                 }
4015                 else gv_method_changed(dstr);
4016             }
4017         }
4018         *location = SvREFCNT_inc_simple_NN(sref);
4019         if (import_flag && !(GvFLAGS(dstr) & import_flag)
4020             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
4021             GvFLAGS(dstr) |= import_flag;
4022         }
4023
4024         if (stype == SVt_PVHV) {
4025             const char * const name = GvNAME((GV*)dstr);
4026             const STRLEN len = GvNAMELEN(dstr);
4027             if (
4028                 (
4029                    (len > 1 && name[len-2] == ':' && name[len-1] == ':')
4030                 || (len == 1 && name[0] == ':')
4031                 )
4032              && (!dref || HvENAME_get(dref))
4033             ) {
4034                 mro_package_moved(
4035                     (HV *)sref, (HV *)dref,
4036                     (GV *)dstr, 0
4037                 );
4038             }
4039         }
4040         else if (
4041             stype == SVt_PVAV && sref != dref
4042          && memEQs(GvNAME((GV*)dstr), GvNAMELEN((GV*)dstr), "ISA")
4043          /* The stash may have been detached from the symbol table, so
4044             check its name before doing anything. */
4045          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
4046         ) {
4047             MAGIC *mg;
4048             MAGIC * const omg = dref && SvSMAGICAL(dref)
4049                                  ? mg_find(dref, PERL_MAGIC_isa)
4050                                  : NULL;
4051             if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
4052                 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
4053                     AV * const ary = newAV();
4054                     av_push(ary, mg->mg_obj); /* takes the refcount */
4055                     mg->mg_obj = (SV *)ary;
4056                 }
4057                 if (omg) {
4058                     if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
4059                         SV **svp = AvARRAY((AV *)omg->mg_obj);
4060                         I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
4061                         while (items--)
4062                             av_push(
4063                              (AV *)mg->mg_obj,
4064                              SvREFCNT_inc_simple_NN(*svp++)
4065                             );
4066                     }
4067                     else
4068                         av_push(
4069                          (AV *)mg->mg_obj,
4070                          SvREFCNT_inc_simple_NN(omg->mg_obj)
4071                         );
4072                 }
4073                 else
4074                     av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
4075             }
4076             else
4077             {
4078                 SSize_t i;
4079                 sv_magic(
4080                  sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
4081                 );
4082                 for (i = 0; i <= AvFILL(sref); ++i) {
4083                     SV **elem = av_fetch ((AV*)sref, i, 0);
4084                     if (elem) {
4085                         sv_magic(
4086                           *elem, sref, PERL_MAGIC_isaelem, NULL, i
4087                         );
4088                     }
4089                 }
4090                 mg = mg_find(sref, PERL_MAGIC_isa);
4091             }
4092             /* Since the *ISA assignment could have affected more than
4093                one stash, don't call mro_isa_changed_in directly, but let
4094                magic_clearisa do it for us, as it already has the logic for
4095                dealing with globs vs arrays of globs. */
4096             assert(mg);
4097             Perl_magic_clearisa(aTHX_ NULL, mg);
4098         }
4099         else if (stype == SVt_PVIO) {
4100             DEBUG_o(Perl_deb(aTHX_ "gv_setref clearing PL_stashcache\n"));
4101             /* It's a cache. It will rebuild itself quite happily.
4102                It's a lot of effort to work out exactly which key (or keys)
4103                might be invalidated by the creation of the this file handle.
4104             */
4105             hv_clear(PL_stashcache);
4106         }
4107         break;
4108     }
4109     if (!intro) SvREFCNT_dec(dref);
4110     if (SvTAINTED(sstr))
4111         SvTAINT(dstr);
4112     return;
4113 }
4114
4115
4116
4117
4118 #ifdef PERL_DEBUG_READONLY_COW
4119 # include <sys/mman.h>
4120
4121 # ifndef PERL_MEMORY_DEBUG_HEADER_SIZE
4122 #  define PERL_MEMORY_DEBUG_HEADER_SIZE 0
4123 # endif
4124
4125 void
4126 Perl_sv_buf_to_ro(pTHX_ SV *sv)
4127 {
4128     struct perl_memory_debug_header * const header =
4129         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4130     const MEM_SIZE len = header->size;
4131     PERL_ARGS_ASSERT_SV_BUF_TO_RO;
4132 # ifdef PERL_TRACK_MEMPOOL
4133     if (!header->readonly) header->readonly = 1;
4134 # endif
4135     if (mprotect(header, len, PROT_READ))
4136         Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
4137                          header, len, errno);
4138 }
4139
4140 static void
4141 S_sv_buf_to_rw(pTHX_ SV *sv)
4142 {
4143     struct perl_memory_debug_header * const header =
4144         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4145     const MEM_SIZE len = header->size;
4146     PERL_ARGS_ASSERT_SV_BUF_TO_RW;
4147     if (mprotect(header, len, PROT_READ|PROT_WRITE))
4148         Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
4149                          header, len, errno);
4150 # ifdef PERL_TRACK_MEMPOOL
4151     header->readonly = 0;
4152 # endif
4153 }
4154
4155 #else
4156 # define sv_buf_to_ro(sv)       NOOP
4157 # define sv_buf_to_rw(sv)       NOOP
4158 #endif
4159
4160 void
4161 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
4162 {
4163     U32 sflags;
4164     int dtype;
4165     svtype stype;
4166     unsigned int both_type;
4167
4168     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
4169
4170     if (UNLIKELY( sstr == dstr ))
4171         return;
4172
4173     if (UNLIKELY( !sstr ))
4174         sstr = &PL_sv_undef;
4175
4176     stype = SvTYPE(sstr);
4177     dtype = SvTYPE(dstr);
4178     both_type = (stype | dtype);
4179
4180     /* with these values, we can check that both SVs are NULL/IV (and not
4181      * freed) just by testing the or'ed types */
4182     STATIC_ASSERT_STMT(SVt_NULL == 0);
4183     STATIC_ASSERT_STMT(SVt_IV   == 1);
4184     if (both_type <= 1) {
4185         /* both src and dst are UNDEF/IV/RV, so we can do a lot of
4186          * special-casing */
4187         U32 sflags;
4188         U32 new_dflags;
4189         SV *old_rv = NULL;
4190
4191         /* minimal subset of SV_CHECK_THINKFIRST_COW_DROP(dstr) */
4192         if (SvREADONLY(dstr))
4193             Perl_croak_no_modify();
4194         if (SvROK(dstr)) {
4195             if (SvWEAKREF(dstr))
4196                 sv_unref_flags(dstr, 0);
4197             else
4198                 old_rv = SvRV(dstr);
4199         }
4200
4201         assert(!SvGMAGICAL(sstr));
4202         assert(!SvGMAGICAL(dstr));
4203
4204         sflags = SvFLAGS(sstr);
4205         if (sflags & (SVf_IOK|SVf_ROK)) {
4206             SET_SVANY_FOR_BODYLESS_IV(dstr);
4207             new_dflags = SVt_IV;
4208
4209             if (sflags & SVf_ROK) {
4210                 dstr->sv_u.svu_rv = SvREFCNT_inc(SvRV(sstr));
4211                 new_dflags |= SVf_ROK;
4212             }
4213             else {
4214                 /* both src and dst are <= SVt_IV, so sv_any points to the
4215                  * head; so access the head directly
4216                  */
4217                 assert(    &(sstr->sv_u.svu_iv)
4218                         == &(((XPVIV*) SvANY(sstr))->xiv_iv));
4219                 assert(    &(dstr->sv_u.svu_iv)
4220                         == &(((XPVIV*) SvANY(dstr))->xiv_iv));
4221                 dstr->sv_u.svu_iv = sstr->sv_u.svu_iv;
4222                 new_dflags |= (SVf_IOK|SVp_IOK|(sflags & SVf_IVisUV));
4223             }
4224         }
4225         else {
4226             new_dflags = dtype; /* turn off everything except the type */
4227         }
4228         SvFLAGS(dstr) = new_dflags;
4229         SvREFCNT_dec(old_rv);
4230
4231         return;
4232     }
4233
4234     if (UNLIKELY(both_type == SVTYPEMASK)) {
4235         if (SvIS_FREED(dstr)) {
4236             Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
4237                        " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
4238         }
4239         if (SvIS_FREED(sstr)) {
4240             Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
4241                        (void*)sstr, (void*)dstr);
4242         }
4243     }
4244
4245
4246
4247     SV_CHECK_THINKFIRST_COW_DROP(dstr);
4248     dtype = SvTYPE(dstr); /* THINKFIRST may have changed type */
4249
4250     /* There's a lot of redundancy below but we're going for speed here */
4251
4252     switch (stype) {
4253     case SVt_NULL:
4254       undef_sstr:
4255         if (LIKELY( dtype != SVt_PVGV && dtype != SVt_PVLV )) {
4256             (void)SvOK_off(dstr);
4257             return;
4258         }
4259         break;
4260     case SVt_IV:
4261         if (SvIOK(sstr)) {
4262             switch (dtype) {
4263             case SVt_NULL:
4264                 /* For performance, we inline promoting to type SVt_IV. */
4265                 /* We're starting from SVt_NULL, so provided that define is
4266                  * actual 0, we don't have to unset any SV type flags
4267                  * to promote to SVt_IV. */
4268                 STATIC_ASSERT_STMT(SVt_NULL == 0);
4269                 SET_SVANY_FOR_BODYLESS_IV(dstr);
4270                 SvFLAGS(dstr) |= SVt_IV;
4271                 break;
4272             case SVt_NV:
4273             case SVt_PV:
4274                 sv_upgrade(dstr, SVt_PVIV);
4275                 break;
4276             case SVt_PVGV:
4277             case SVt_PVLV:
4278                 goto end_of_first_switch;
4279             }
4280             (void)SvIOK_only(dstr);
4281             SvIV_set(dstr,  SvIVX(sstr));
4282             if (SvIsUV(sstr))
4283                 SvIsUV_on(dstr);
4284             /* SvTAINTED can only be true if the SV has taint magic, which in
4285                turn means that the SV type is PVMG (or greater). This is the
4286                case statement for SVt_IV, so this cannot be true (whatever gcov
4287                may say).  */
4288             assert(!SvTAINTED(sstr));
4289             return;
4290         }
4291         if (!SvROK(sstr))
4292             goto undef_sstr;
4293         if (dtype < SVt_PV && dtype != SVt_IV)
4294             sv_upgrade(dstr, SVt_IV);
4295         break;
4296
4297     case SVt_NV:
4298         if (LIKELY( SvNOK(sstr) )) {
4299             switch (dtype) {
4300             case SVt_NULL:
4301             case SVt_IV:
4302                 sv_upgrade(dstr, SVt_NV);
4303                 break;
4304             case SVt_PV:
4305             case SVt_PVIV:
4306                 sv_upgrade(dstr, SVt_PVNV);
4307                 break;
4308             case SVt_PVGV:
4309             case SVt_PVLV:
4310                 goto end_of_first_switch;
4311             }
4312             SvNV_set(dstr, SvNVX(sstr));
4313             (void)SvNOK_only(dstr);
4314             /* SvTAINTED can only be true if the SV has taint magic, which in
4315                turn means that the SV type is PVMG (or greater). This is the
4316                case statement for SVt_NV, so this cannot be true (whatever gcov
4317                may say).  */
4318             assert(!SvTAINTED(sstr));
4319             return;
4320         }
4321         goto undef_sstr;
4322
4323     case SVt_PV:
4324         if (dtype < SVt_PV)
4325             sv_upgrade(dstr, SVt_PV);
4326         break;
4327     case SVt_PVIV:
4328         if (dtype < SVt_PVIV)
4329             sv_upgrade(dstr, SVt_PVIV);
4330         break;
4331     case SVt_PVNV:
4332         if (dtype < SVt_PVNV)
4333             sv_upgrade(dstr, SVt_PVNV);
4334         break;
4335     default:
4336         {
4337         const char * const type = sv_reftype(sstr,0);
4338         if (PL_op)
4339             /* diag_listed_as: Bizarre copy of %s */
4340             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4341         else
4342             Perl_croak(aTHX_ "Bizarre copy of %s", type);
4343         }
4344         NOT_REACHED; /* NOTREACHED */
4345
4346     case SVt_REGEXP:
4347       upgregexp:
4348         if (dtype < SVt_REGEXP)
4349             sv_upgrade(dstr, SVt_REGEXP);
4350         break;
4351
4352         case SVt_INVLIST:
4353     case SVt_PVLV:
4354     case SVt_PVGV:
4355     case SVt_PVMG:
4356         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4357             mg_get(sstr);
4358             if (SvTYPE(sstr) != stype)
4359                 stype = SvTYPE(sstr);
4360         }
4361         if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4362                     glob_assign_glob(dstr, sstr, dtype);
4363                     return;
4364         }
4365         if (stype == SVt_PVLV)
4366         {
4367             if (isREGEXP(sstr)) goto upgregexp;
4368             SvUPGRADE(dstr, SVt_PVNV);
4369         }
4370         else
4371             SvUPGRADE(dstr, (svtype)stype);
4372     }
4373  end_of_first_switch:
4374
4375     /* dstr may have been upgraded.  */
4376     dtype = SvTYPE(dstr);
4377     sflags = SvFLAGS(sstr);
4378
4379     if (UNLIKELY( dtype == SVt_PVCV )) {
4380         /* Assigning to a subroutine sets the prototype.  */
4381         if (SvOK(sstr)) {
4382             STRLEN len;
4383             const char *const ptr = SvPV_const(sstr, len);
4384
4385             SvGROW(dstr, len + 1);
4386             Copy(ptr, SvPVX(dstr), len + 1, char);
4387             SvCUR_set(dstr, len);
4388             SvPOK_only(dstr);
4389             SvFLAGS(dstr) |= sflags & SVf_UTF8;
4390             CvAUTOLOAD_off(dstr);
4391         } else {
4392             SvOK_off(dstr);
4393         }
4394     }
4395     else if (UNLIKELY(dtype == SVt_PVAV || dtype == SVt_PVHV
4396              || dtype == SVt_PVFM))
4397     {
4398         const char * const type = sv_reftype(dstr,0);
4399         if (PL_op)
4400             /* diag_listed_as: Cannot copy to %s */
4401             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4402         else
4403             Perl_croak(aTHX_ "Cannot copy to %s", type);
4404     } else if (sflags & SVf_ROK) {
4405         if (isGV_with_GP(dstr)
4406             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4407             sstr = SvRV(sstr);
4408             if (sstr == dstr) {
4409                 if (GvIMPORTED(dstr) != GVf_IMPORTED
4410                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4411                 {
4412                     GvIMPORTED_on(dstr);
4413                 }
4414                 GvMULTI_on(dstr);
4415                 return;
4416             }
4417             glob_assign_glob(dstr, sstr, dtype);
4418             return;
4419         }
4420
4421         if (dtype >= SVt_PV) {
4422             if (isGV_with_GP(dstr)) {
4423                 gv_setref(dstr, sstr);
4424                 return;
4425             }
4426             if (SvPVX_const(dstr)) {
4427                 SvPV_free(dstr);
4428                 SvLEN_set(dstr, 0);
4429                 SvCUR_set(dstr, 0);
4430             }
4431         }
4432         (void)SvOK_off(dstr);
4433         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4434         SvFLAGS(dstr) |= sflags & SVf_ROK;
4435         assert(!(sflags & SVp_NOK));
4436         assert(!(sflags & SVp_IOK));
4437         assert(!(sflags & SVf_NOK));
4438         assert(!(sflags & SVf_IOK));
4439     }
4440     else if (isGV_with_GP(dstr)) {
4441         if (!(sflags & SVf_OK)) {
4442             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4443                            "Undefined value assigned to typeglob");
4444         }
4445         else {
4446             GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
4447             if (dstr != (const SV *)gv) {
4448                 const char * const name = GvNAME((const GV *)dstr);
4449                 const STRLEN len = GvNAMELEN(dstr);
4450                 HV *old_stash = NULL;
4451                 bool reset_isa = FALSE;
4452                 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4453                  || (len == 1 && name[0] == ':')) {
4454                     /* Set aside the old stash, so we can reset isa caches
4455                        on its subclasses. */
4456                     if((old_stash = GvHV(dstr))) {
4457                         /* Make sure we do not lose it early. */
4458                         SvREFCNT_inc_simple_void_NN(
4459                          sv_2mortal((SV *)old_stash)
4460                         );
4461                     }
4462                     reset_isa = TRUE;
4463                 }
4464
4465                 if (GvGP(dstr)) {
4466                     SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
4467                     gp_free(MUTABLE_GV(dstr));
4468                 }
4469                 GvGP_set(dstr, gp_ref(GvGP(gv)));
4470
4471                 if (reset_isa) {
4472                     HV * const stash = GvHV(dstr);
4473                     if(
4474                         old_stash ? (HV *)HvENAME_get(old_stash) : stash
4475                     )
4476                         mro_package_moved(
4477                          stash, old_stash,
4478                          (GV *)dstr, 0
4479                         );
4480                 }
4481             }
4482         }
4483     }
4484     else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4485           && (stype == SVt_REGEXP || isREGEXP(sstr))) {
4486         reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4487     }
4488     else if (sflags & SVp_POK) {
4489         const STRLEN cur = SvCUR(sstr);
4490         const STRLEN len = SvLEN(sstr);
4491
4492         /*
4493          * We have three basic ways to copy the string:
4494          *
4495          *  1. Swipe
4496          *  2. Copy-on-write
4497          *  3. Actual copy
4498          * 
4499          * Which we choose is based on various factors.  The following
4500          * things are listed in order of speed, fastest to slowest:
4501          *  - Swipe
4502          *  - Copying a short string
4503          *  - Copy-on-write bookkeeping
4504          *  - malloc
4505          *  - Copying a long string
4506          * 
4507          * We swipe the string (steal the string buffer) if the SV on the
4508          * rhs is about to be freed anyway (TEMP and refcnt==1).  This is a
4509          * big win on long strings.  It should be a win on short strings if
4510          * SvPVX_const(dstr) has to be allocated.  If not, it should not 
4511          * slow things down, as SvPVX_const(sstr) would have been freed
4512          * soon anyway.
4513          * 
4514          * We also steal the buffer from a PADTMP (operator target) if it
4515          * is ‘long enough’.  For short strings, a swipe does not help
4516          * here, as it causes more malloc calls the next time the target
4517          * is used.  Benchmarks show that even if SvPVX_const(dstr) has to
4518          * be allocated it is still not worth swiping PADTMPs for short
4519          * strings, as the savings here are small.
4520          * 
4521          * If swiping is not an option, then we see whether it is
4522          * worth using copy-on-write.  If the lhs already has a buf-
4523          * fer big enough and the string is short, we skip it and fall back
4524          * to method 3, since memcpy is faster for short strings than the
4525          * later bookkeeping overhead that copy-on-write entails.
4526
4527          * If the rhs is not a copy-on-write string yet, then we also
4528          * consider whether the buffer is too large relative to the string
4529          * it holds.  Some operations such as readline allocate a large
4530          * buffer in the expectation of reusing it.  But turning such into
4531          * a COW buffer is counter-productive because it increases memory
4532          * usage by making readline allocate a new large buffer the sec-
4533          * ond time round.  So, if the buffer is too large, again, we use
4534          * method 3 (copy).
4535          * 
4536          * Finally, if there is no buffer on the left, or the buffer is too 
4537          * small, then we use copy-on-write and make both SVs share the
4538          * string buffer.
4539          *
4540          */
4541
4542         /* Whichever path we take through the next code, we want this true,
4543            and doing it now facilitates the COW check.  */
4544         (void)SvPOK_only(dstr);
4545
4546         if (
4547                  (              /* Either ... */
4548                                 /* slated for free anyway (and not COW)? */
4549                     (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
4550                                 /* or a swipable TARG */
4551                  || ((sflags &
4552                            (SVs_PADTMP|SVf_READONLY|SVf_PROTECT|SVf_IsCOW))
4553                        == SVs_PADTMP
4554                                 /* whose buffer is worth stealing */
4555                      && CHECK_COWBUF_THRESHOLD(cur,len)
4556                     )
4557                  ) &&
4558                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4559                  (!(flags & SV_NOSTEAL)) &&
4560                                         /* and we're allowed to steal temps */
4561                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4562                  len)             /* and really is a string */
4563         {       /* Passes the swipe test.  */
4564             if (SvPVX_const(dstr))      /* we know that dtype >= SVt_PV */
4565                 SvPV_free(dstr);
4566             SvPV_set(dstr, SvPVX_mutable(sstr));
4567             SvLEN_set(dstr, SvLEN(sstr));
4568             SvCUR_set(dstr, SvCUR(sstr));
4569
4570             SvTEMP_off(dstr);
4571             (void)SvOK_off(sstr);       /* NOTE: nukes most SvFLAGS on sstr */
4572             SvPV_set(sstr, NULL);
4573             SvLEN_set(sstr, 0);
4574             SvCUR_set(sstr, 0);
4575             SvTEMP_off(sstr);
4576         }
4577         else if (flags & SV_COW_SHARED_HASH_KEYS
4578               &&
4579 #ifdef PERL_COPY_ON_WRITE
4580                  (sflags & SVf_IsCOW
4581                    ? (!len ||
4582                        (  (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
4583                           /* If this is a regular (non-hek) COW, only so
4584                              many COW "copies" are possible. */
4585                        && CowREFCNT(sstr) != SV_COW_REFCNT_MAX  ))
4586                    : (  (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4587                      && !(SvFLAGS(dstr) & SVf_BREAK)
4588                      && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len
4589                      && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
4590                     ))
4591 #else
4592                  sflags & SVf_IsCOW
4593               && !(SvFLAGS(dstr) & SVf_BREAK)
4594 #endif
4595             ) {
4596             /* Either it's a shared hash key, or it's suitable for
4597                copy-on-write.  */
4598 #ifdef DEBUGGING
4599             if (DEBUG_C_TEST) {
4600                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4601                 sv_dump(sstr);
4602                 sv_dump(dstr);
4603             }
4604 #endif
4605 #ifdef PERL_ANY_COW
4606             if (!(sflags & SVf_IsCOW)) {
4607                     SvIsCOW_on(sstr);
4608                     CowREFCNT(sstr) = 0;
4609             }
4610 #endif
4611             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
4612                 SvPV_free(dstr);
4613             }
4614
4615 #ifdef PERL_ANY_COW
4616             if (len) {
4617                     if (sflags & SVf_IsCOW) {
4618                         sv_buf_to_rw(sstr);
4619                     }
4620                     CowREFCNT(sstr)++;
4621                     SvPV_set(dstr, SvPVX_mutable(sstr));
4622                     sv_buf_to_ro(sstr);
4623             } else
4624 #endif
4625             {
4626                     /* SvIsCOW_shared_hash */
4627                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4628                                           "Copy on write: Sharing hash\n"));
4629
4630                     assert (SvTYPE(dstr) >= SVt_PV);
4631                     SvPV_set(dstr,
4632                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4633             }
4634             SvLEN_set(dstr, len);
4635             SvCUR_set(dstr, cur);
4636             SvIsCOW_on(dstr);
4637         } else {
4638             /* Failed the swipe test, and we cannot do copy-on-write either.
4639                Have to copy the string.  */
4640             SvGROW(dstr, cur + 1);      /* inlined from sv_setpvn */
4641             Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
4642             SvCUR_set(dstr, cur);
4643             *SvEND(dstr) = '\0';
4644         }
4645         if (sflags & SVp_NOK) {
4646             SvNV_set(dstr, SvNVX(sstr));
4647         }
4648         if (sflags & SVp_IOK) {
4649             SvIV_set(dstr, SvIVX(sstr));
4650             if (sflags & SVf_IVisUV)
4651                 SvIsUV_on(dstr);
4652         }
4653         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4654         {
4655             const MAGIC * const smg = SvVSTRING_mg(sstr);
4656             if (smg) {
4657                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4658                          smg->mg_ptr, smg->mg_len);
4659                 SvRMAGICAL_on(dstr);
4660             }
4661         }
4662     }
4663     else if (sflags & (SVp_IOK|SVp_NOK)) {
4664         (void)SvOK_off(dstr);
4665         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4666         if (sflags & SVp_IOK) {
4667             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4668             SvIV_set(dstr, SvIVX(sstr));
4669         }
4670         if (sflags & SVp_NOK) {
4671             SvNV_set(dstr, SvNVX(sstr));
4672         }
4673     }
4674     else {
4675         if (isGV_with_GP(sstr)) {
4676             gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4677         }
4678         else
4679             (void)SvOK_off(dstr);
4680     }
4681     if (SvTAINTED(sstr))
4682         SvTAINT(dstr);
4683 }
4684
4685
4686 /*
4687 =for apidoc sv_set_undef
4688
4689 Equivalent to C<sv_setsv(sv, &PL_sv_undef)>, but more efficient.
4690 Doesn't handle set magic.
4691
4692 The perl equivalent is C<$sv = undef;>. Note that it doesn't free any string
4693 buffer, unlike C<undef $sv>.
4694
4695 Introduced in perl 5.25.12.
4696
4697 =cut
4698 */
4699
4700 void
4701 Perl_sv_set_undef(pTHX_ SV *sv)
4702 {
4703     U32 type = SvTYPE(sv);
4704
4705     PERL_ARGS_ASSERT_SV_SET_UNDEF;
4706
4707     /* shortcut, NULL, IV, RV */
4708
4709     if (type <= SVt_IV) {
4710         assert(!SvGMAGICAL(sv));
4711         if (SvREADONLY(sv)) {
4712             /* does undeffing PL_sv_undef count as modifying a read-only
4713              * variable? Some XS code does this */
4714             if (sv == &PL_sv_undef)
4715                 return;
4716             Perl_croak_no_modify();
4717         }
4718
4719         if (SvROK(sv)) {
4720             if (SvWEAKREF(sv))
4721                 sv_unref_flags(sv, 0);
4722             else {
4723                 SV *rv = SvRV(sv);
4724                 SvFLAGS(sv) = type; /* quickly turn off all flags */
4725                 SvREFCNT_dec_NN(rv);
4726                 return;
4727             }
4728         }
4729         SvFLAGS(sv) = type; /* quickly turn off all flags */
4730         return;
4731     }
4732
4733     if (SvIS_FREED(sv))
4734         Perl_croak(aTHX_ "panic: attempt to undefine a freed scalar %p",
4735             (void *)sv);
4736
4737     SV_CHECK_THINKFIRST_COW_DROP(sv);
4738
4739     if (isGV_with_GP(sv))
4740         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4741                        "Undefined value assigned to typeglob");
4742     else
4743         SvOK_off(sv);
4744 }
4745
4746
4747
4748 /*
4749 =for apidoc sv_setsv_mg
4750
4751 Like C<sv_setsv>, but also handles 'set' magic.
4752
4753 =cut
4754 */
4755
4756 void
4757 Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr)
4758 {
4759     PERL_ARGS_ASSERT_SV_SETSV_MG;
4760
4761     sv_setsv(dstr,sstr);
4762     SvSETMAGIC(dstr);
4763 }
4764
4765 #ifdef PERL_ANY_COW
4766 #  define SVt_COW SVt_PV
4767 SV *
4768 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4769 {
4770     STRLEN cur = SvCUR(sstr);
4771     STRLEN len = SvLEN(sstr);
4772     char *new_pv;
4773 #if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_COPY_ON_WRITE)
4774     const bool already = cBOOL(SvIsCOW(sstr));
4775 #endif
4776
4777     PERL_ARGS_ASSERT_SV_SETSV_COW;
4778 #ifdef DEBUGGING
4779     if (DEBUG_C_TEST) {
4780         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4781                       (void*)sstr, (void*)dstr);
4782         sv_dump(sstr);
4783         if (dstr)
4784                     sv_dump(dstr);
4785     }
4786 #endif
4787     if (dstr) {
4788         if (SvTHINKFIRST(dstr))
4789             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4790         else if (SvPVX_const(dstr))
4791             Safefree(SvPVX_mutable(dstr));
4792     }
4793     else
4794         new_SV(dstr);
4795     SvUPGRADE(dstr, SVt_COW);
4796
4797     assert (SvPOK(sstr));
4798     assert (SvPOKp(sstr));
4799
4800     if (SvIsCOW(sstr)) {
4801
4802         if (SvLEN(sstr) == 0) {
4803             /* source is a COW shared hash key.  */
4804             DEBUG_C(PerlIO_printf(Perl_debug_log,
4805                                   "Fast copy on write: Sharing hash\n"));
4806             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4807             goto common_exit;
4808         }
4809         assert(SvCUR(sstr)+1 < SvLEN(sstr));
4810         assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX);
4811     } else {
4812         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4813         SvUPGRADE(sstr, SVt_COW);
4814         SvIsCOW_on(sstr);
4815         DEBUG_C(PerlIO_printf(Perl_debug_log,
4816                               "Fast copy on write: Converting sstr to COW\n"));
4817         CowREFCNT(sstr) = 0;    
4818     }
4819 #  ifdef PERL_DEBUG_READONLY_COW
4820     if (already) sv_buf_to_rw(sstr);
4821 #  endif
4822     CowREFCNT(sstr)++;  
4823     new_pv = SvPVX_mutable(sstr);
4824     sv_buf_to_ro(sstr);
4825
4826   common_exit:
4827     SvPV_set(dstr, new_pv);
4828     SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
4829     if (SvUTF8(sstr))
4830         SvUTF8_on(dstr);
4831     SvLEN_set(dstr, len);
4832     SvCUR_set(dstr, cur);
4833 #ifdef DEBUGGING
4834     if (DEBUG_C_TEST)
4835                 sv_dump(dstr);
4836 #endif
4837     return dstr;
4838 }
4839 #endif
4840
4841 /*
4842 =for apidoc sv_setpv_bufsize
4843
4844 Sets the SV to be a string of cur bytes length, with at least
4845 len bytes available. Ensures that there is a null byte at SvEND.
4846 Returns a char * pointer to the SvPV buffer.
4847
4848 =cut
4849 */
4850
4851 char *
4852 Perl_sv_setpv_bufsize(pTHX_ SV *const sv, const STRLEN cur, const STRLEN len)
4853 {
4854     char *pv;
4855
4856     PERL_ARGS_ASSERT_SV_SETPV_BUFSIZE;
4857
4858     SV_CHECK_THINKFIRST_COW_DROP(sv);
4859     SvUPGRADE(sv, SVt_PV);
4860     pv = SvGROW(sv, len + 1);
4861     SvCUR_set(sv, cur);
4862     *(SvEND(sv))= '\0';
4863     (void)SvPOK_only_UTF8(sv);                /* validate pointer */
4864
4865     SvTAINT(sv);
4866     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4867     return pv;
4868 }
4869
4870 /*
4871 =for apidoc sv_setpvn
4872
4873 Copies a string (possibly containing embedded C<NUL> characters) into an SV.
4874 The C<len> parameter indicates the number of
4875 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4876 undefined.  Does not handle 'set' magic.  See C<L</sv_setpvn_mg>>.
4877
4878 =cut
4879 */
4880
4881 void
4882 Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4883 {
4884     char *dptr;
4885
4886     PERL_ARGS_ASSERT_SV_SETPVN;
4887
4888     SV_CHECK_THINKFIRST_COW_DROP(sv);
4889     if (isGV_with_GP(sv))
4890         Perl_croak_no_modify();
4891     if (!ptr) {
4892         (void)SvOK_off(sv);
4893         return;
4894     }
4895     else {
4896         /* len is STRLEN which is unsigned, need to copy to signed */
4897         const IV iv = len;
4898         if (iv < 0)
4899             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
4900                        IVdf, iv);
4901     }
4902     SvUPGRADE(sv, SVt_PV);
4903
4904     dptr = SvGROW(sv, len + 1);
4905     Move(ptr,dptr,len,char);
4906     dptr[len] = '\0';
4907     SvCUR_set(sv, len);
4908     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4909     SvTAINT(sv);
4910     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4911 }
4912
4913 /*
4914 =for apidoc sv_setpvn_mg
4915
4916 Like C<sv_setpvn>, but also handles 'set' magic.
4917
4918 =cut
4919 */
4920
4921 void
4922 Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4923 {
4924     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4925
4926     sv_setpvn(sv,ptr,len);
4927     SvSETMAGIC(sv);
4928 }
4929
4930 /*
4931 =for apidoc sv_setpv
4932
4933 Copies a string into an SV.  The string must be terminated with a C<NUL>
4934 character, and not contain embeded C<NUL>'s.
4935 Does not handle 'set' magic.  See C<L</sv_setpv_mg>>.
4936
4937 =cut
4938 */
4939
4940 void
4941 Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
4942 {
4943     STRLEN len;
4944
4945     PERL_ARGS_ASSERT_SV_SETPV;
4946
4947     SV_CHECK_THINKFIRST_COW_DROP(sv);
4948     if (!ptr) {
4949         (void)SvOK_off(sv);
4950         return;
4951     }
4952     len = strlen(ptr);
4953     SvUPGRADE(sv, SVt_PV);
4954
4955     SvGROW(sv, len + 1);
4956     Move(ptr,SvPVX(sv),len+1,char);
4957     SvCUR_set(sv, len);
4958     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4959     SvTAINT(sv);
4960     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4961 }
4962
4963 /*
4964 =for apidoc sv_setpv_mg
4965
4966 Like C<sv_setpv>, but also handles 'set' magic.
4967
4968 =cut
4969 */
4970
4971 void
4972 Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
4973 {
4974     PERL_ARGS_ASSERT_SV_SETPV_MG;
4975
4976     sv_setpv(sv,ptr);
4977     SvSETMAGIC(sv);
4978 }
4979
4980 void
4981 Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
4982 {
4983     PERL_ARGS_ASSERT_SV_SETHEK;
4984
4985     if (!hek) {
4986         return;
4987     }
4988
4989     if (HEK_LEN(hek) == HEf_SVKEY) {
4990         sv_setsv(sv, *(SV**)HEK_KEY(hek));
4991         return;
4992     } else {
4993         const int flags = HEK_FLAGS(hek);
4994         if (flags & HVhek_WASUTF8) {
4995             STRLEN utf8_len = HEK_LEN(hek);
4996             char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
4997             sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
4998             SvUTF8_on(sv);
4999             return;
5000         } else if (flags & HVhek_UNSHARED) {
5001             sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
5002             if (HEK_UTF8(hek))
5003                 SvUTF8_on(sv);
5004             else SvUTF8_off(sv);
5005             return;
5006         }
5007         {
5008             SV_CHECK_THINKFIRST_COW_DROP(sv);
5009             SvUPGRADE(sv, SVt_PV);
5010             SvPV_free(sv);
5011             SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
5012             SvCUR_set(sv, HEK_LEN(hek));
5013             SvLEN_set(sv, 0);
5014             SvIsCOW_on(sv);
5015             SvPOK_on(sv);
5016             if (HEK_UTF8(hek))
5017                 SvUTF8_on(sv);
5018             else SvUTF8_off(sv);
5019             return;
5020         }
5021     }
5022 }
5023
5024
5025 /*
5026 =for apidoc sv_usepvn_flags
5027
5028 Tells an SV to use C<ptr> to find its string value.  Normally the
5029 string is stored inside the SV, but sv_usepvn allows the SV to use an
5030 outside string.  C<ptr> should point to memory that was allocated
5031 by L<C<Newx>|perlclib/Memory Management and String Handling>.  It must be
5032 the start of a C<Newx>-ed block of memory, and not a pointer to the
5033 middle of it (beware of L<C<OOK>|perlguts/Offsets> and copy-on-write),
5034 and not be from a non-C<Newx> memory allocator like C<malloc>.  The
5035 string length, C<len>, must be supplied.  By default this function
5036 will C<Renew> (i.e. realloc, move) the memory pointed to by C<ptr>,
5037 so that pointer should not be freed or used by the programmer after
5038 giving it to C<sv_usepvn>, and neither should any pointers from "behind"
5039 that pointer (e.g. ptr + 1) be used.
5040
5041 If S<C<flags & SV_SMAGIC>> is true, will call C<SvSETMAGIC>.  If
5042 S<C<flags & SV_HAS_TRAILING_NUL>> is true, then C<ptr[len]> must be C<NUL>,
5043 and the realloc
5044 will be skipped (i.e. the buffer is actually at least 1 byte longer than
5045 C<len>, and already meets the requirements for storing in C<SvPVX>).
5046
5047 =cut
5048 */
5049
5050 void
5051 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
5052 {
5053     STRLEN allocate;
5054
5055     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
5056
5057     SV_CHECK_THINKFIRST_COW_DROP(sv);
5058     SvUPGRADE(sv, SVt_PV);
5059     if (!ptr) {
5060         (void)SvOK_off(sv);
5061         if (flags & SV_SMAGIC)
5062             SvSETMAGIC(sv);
5063         return;
5064     }
5065     if (SvPVX_const(sv))
5066         SvPV_free(sv);
5067
5068 #ifdef DEBUGGING
5069     if (flags & SV_HAS_TRAILING_NUL)
5070         assert(ptr[len] == '\0');
5071 #endif
5072
5073     allocate = (flags & SV_HAS_TRAILING_NUL)
5074         ? len + 1 :
5075 #ifdef Perl_safesysmalloc_size
5076         len + 1;
5077 #else 
5078         PERL_STRLEN_ROUNDUP(len + 1);
5079 #endif
5080     if (flags & SV_HAS_TRAILING_NUL) {
5081         /* It's long enough - do nothing.
5082            Specifically Perl_newCONSTSUB is relying on this.  */
5083     } else {
5084 #ifdef DEBUGGING
5085         /* Force a move to shake out bugs in callers.  */
5086         char *new_ptr = (char*)safemalloc(allocate);
5087         Copy(ptr, new_ptr, len, char);
5088         PoisonFree(ptr,len,char);
5089         Safefree(ptr);
5090         ptr = new_ptr;
5091 #else
5092         ptr = (char*) saferealloc (ptr, allocate);
5093 #endif
5094     }
5095 #ifdef Perl_safesysmalloc_size
5096     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
5097 #else
5098     SvLEN_set(sv, allocate);
5099 #endif
5100     SvCUR_set(sv, len);
5101     SvPV_set(sv, ptr);
5102     if (!(flags & SV_HAS_TRAILING_NUL)) {
5103         ptr[len] = '\0';
5104     }
5105     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5106     SvTAINT(sv);
5107     if (flags & SV_SMAGIC)
5108         SvSETMAGIC(sv);
5109 }
5110
5111
5112 static void
5113 S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
5114 {
5115     assert(SvIsCOW(sv));
5116     {
5117 #ifdef PERL_ANY_COW
5118         const char * const pvx = SvPVX_const(sv);
5119         const STRLEN len = SvLEN(sv);
5120         const STRLEN cur = SvCUR(sv);
5121
5122 #ifdef DEBUGGING
5123         if (DEBUG_C_TEST) {
5124                 PerlIO_printf(Perl_debug_log,
5125                               "Copy on write: Force normal %ld\n",
5126                               (long) flags);
5127                 sv_dump(sv);
5128         }
5129 #endif
5130         SvIsCOW_off(sv);
5131 # ifdef PERL_COPY_ON_WRITE
5132         if (len) {
5133             /* Must do this first, since the CowREFCNT uses SvPVX and
5134             we need to write to CowREFCNT, or de-RO the whole buffer if we are
5135             the only owner left of the buffer. */
5136             sv_buf_to_rw(sv); /* NOOP if RO-ing not supported */
5137             {
5138                 U8 cowrefcnt = CowREFCNT(sv);
5139                 if(cowrefcnt != 0) {
5140                     cowrefcnt--;
5141                     CowREFCNT(sv) = cowrefcnt;
5142                     sv_buf_to_ro(sv);
5143                     goto copy_over;
5144                 }
5145             }
5146             /* Else we are the only owner of the buffer. */
5147         }
5148         else
5149 # endif
5150         {
5151             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
5152             copy_over:
5153             SvPV_set(sv, NULL);
5154             SvCUR_set(sv, 0);
5155             SvLEN_set(sv, 0);
5156             if (flags & SV_COW_DROP_PV) {
5157                 /* OK, so we don't need to copy our buffer.  */
5158                 SvPOK_off(sv);
5159             } else {
5160                 SvGROW(sv, cur + 1);
5161                 Move(pvx,SvPVX(sv),cur,char);
5162                 SvCUR_set(sv, cur);
5163                 *SvEND(sv) = '\0';
5164             }
5165             if (len) {
5166             } else {
5167                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5168             }
5169 #ifdef DEBUGGING
5170             if (DEBUG_C_TEST)
5171                 sv_dump(sv);
5172 #endif
5173         }
5174 #else
5175             const char * const pvx = SvPVX_const(sv);
5176             const STRLEN len = SvCUR(sv);
5177             SvIsCOW_off(sv);
5178             SvPV_set(sv, NULL);
5179             SvLEN_set(sv, 0);
5180             if (flags & SV_COW_DROP_PV) {
5181                 /* OK, so we don't need to copy our buffer.  */
5182                 SvPOK_off(sv);
5183             } else {
5184                 SvGROW(sv, len + 1);
5185                 Move(pvx,SvPVX(sv),len,char);
5186                 *SvEND(sv) = '\0';
5187             }
5188             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5189 #endif
5190     }
5191 }
5192
5193
5194 /*
5195 =for apidoc sv_force_normal_flags
5196
5197 Undo various types of fakery on an SV, where fakery means
5198 "more than" a string: if the PV is a shared string, make
5199 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5200 an C<xpvmg>; if we're a copy-on-write scalar, this is the on-write time when
5201 we do the copy, and is also used locally; if this is a
5202 vstring, drop the vstring magic.  If C<SV_COW_DROP_PV> is set
5203 then a copy-on-write scalar drops its PV buffer (if any) and becomes
5204 C<SvPOK_off> rather than making a copy.  (Used where this
5205 scalar is about to be set to some other value.)  In addition,
5206 the C<flags> parameter gets passed to C<sv_unref_flags()>
5207 when unreffing.  C<sv_force_normal> calls this function
5208 with flags set to 0.
5209
5210 This function is expected to be used to signal to perl that this SV is
5211 about to be written to, and any extra book-keeping needs to be taken care
5212 of.  Hence, it croaks on read-only values.
5213
5214 =cut
5215 */
5216
5217 void
5218 Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
5219 {
5220     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
5221
5222     if (SvREADONLY(sv))
5223         Perl_croak_no_modify();
5224     else if (SvIsCOW(sv) && LIKELY(SvTYPE(sv) != SVt_PVHV))
5225         S_sv_uncow(aTHX_ sv, flags);
5226     if (SvROK(sv))
5227         sv_unref_flags(sv, flags);
5228     else if (SvFAKE(sv) && isGV_with_GP(sv))
5229         sv_unglob(sv, flags);
5230     else if (SvFAKE(sv) && isREGEXP(sv)) {
5231         /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
5232            to sv_unglob. We only need it here, so inline it.  */
5233         const bool islv = SvTYPE(sv) == SVt_PVLV;
5234         const svtype new_type =
5235           islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
5236         SV *const temp = newSV_type(new_type);
5237         regexp *old_rx_body;
5238
5239         if (new_type == SVt_PVMG) {
5240             SvMAGIC_set(temp, SvMAGIC(sv));
5241             SvMAGIC_set(sv, NULL);
5242             SvSTASH_set(temp, SvSTASH(sv));
5243             SvSTASH_set(sv, NULL);
5244         }
5245         if (!islv)
5246             SvCUR_set(temp, SvCUR(sv));
5247         /* Remember that SvPVX is in the head, not the body. */
5248         assert(ReANY((REGEXP *)sv)->mother_re);
5249
5250         if (islv) {
5251             /* LV-as-regex has sv->sv_any pointing to an XPVLV body,
5252              * whose xpvlenu_rx field points to the regex body */
5253             XPV *xpv = (XPV*)(SvANY(sv));
5254             old_rx_body = xpv->xpv_len_u.xpvlenu_rx;
5255             xpv->xpv_len_u.xpvlenu_rx = NULL;
5256         }
5257         else
5258             old_rx_body = ReANY((REGEXP *)sv);
5259
5260         /* Their buffer is already owned by someone else. */
5261         if (flags & SV_COW_DROP_PV) {
5262             /* SvLEN is already 0.  For SVt_REGEXP, we have a brand new
5263                zeroed body.  For SVt_PVLV, we zeroed it above (len field
5264                a union with xpvlenu_rx) */
5265             assert(!SvLEN(islv ? sv : temp));
5266             sv->sv_u.svu_pv = 0;
5267         }
5268         else {
5269             sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
5270             SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
5271             SvPOK_on(sv);
5272         }
5273
5274         /* Now swap the rest of the bodies. */
5275
5276         SvFAKE_off(sv);
5277         if (!islv) {
5278             SvFLAGS(sv) &= ~SVTYPEMASK;
5279             SvFLAGS(sv) |= new_type;
5280             SvANY(sv) = SvANY(temp);
5281         }
5282
5283         SvFLAGS(temp) &= ~(SVTYPEMASK);
5284         SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
5285         SvANY(temp) = old_rx_body;
5286
5287         SvREFCNT_dec_NN(temp);
5288     }
5289     else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
5290 }
5291
5292 /*
5293 =for apidoc sv_chop
5294
5295 Efficient removal of characters from the beginning of the string buffer.
5296 C<SvPOK(sv)>, or at least C<SvPOKp(sv)>, must be true and C<ptr> must be a
5297 pointer to somewhere inside the string buffer.  C<ptr> becomes the first
5298 character of the adjusted string.  Uses the C<OOK> hack.  On return, only
5299 C<SvPOK(sv)> and C<SvPOKp(sv)> among the C<OK> flags will be true.
5300
5301 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
5302 refer to the same chunk of data.
5303
5304 The unfortunate similarity of this function's name to that of Perl's C<chop>
5305 operator is strictly coincidental.  This function works from the left;
5306 C<chop> works from the right.
5307
5308 =cut
5309 */
5310
5311 void
5312 Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
5313 {
5314     STRLEN delta;
5315     STRLEN old_delta;
5316     U8 *p;
5317 #ifdef DEBUGGING
5318     const U8 *evacp;
5319     STRLEN evacn;
5320 #endif
5321     STRLEN max_delta;
5322
5323     PERL_ARGS_ASSERT_SV_CHOP;
5324
5325     if (!ptr || !SvPOKp(sv))
5326         return;
5327     delta = ptr - SvPVX_const(sv);
5328     if (!delta) {
5329         /* Nothing to do.  */
5330         return;
5331     }
5332     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
5333     if (delta > max_delta)
5334         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
5335                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
5336     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
5337     SV_CHECK_THINKFIRST(sv);
5338     SvPOK_only_UTF8(sv);
5339
5340     if (!SvOOK(sv)) {
5341         if (!SvLEN(sv)) { /* make copy of shared string */
5342             const char *pvx = SvPVX_const(sv);
5343             const STRLEN len = SvCUR(sv);
5344             SvGROW(sv, len + 1);
5345             Move(pvx,SvPVX(sv),len,char);
5346             *SvEND(sv) = '\0';
5347         }
5348         SvOOK_on(sv);
5349         old_delta = 0;
5350     } else {
5351         SvOOK_offset(sv, old_delta);
5352     }
5353     SvLEN_set(sv, SvLEN(sv) - delta);
5354     SvCUR_set(sv, SvCUR(sv) - delta);
5355     SvPV_set(sv, SvPVX(sv) + delta);
5356
5357     p = (U8 *)SvPVX_const(sv);
5358
5359 #ifdef DEBUGGING
5360     /* how many bytes were evacuated?  we will fill them with sentinel
5361        bytes, except for the part holding the new offset of course. */
5362     evacn = delta;
5363     if (old_delta)
5364         evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
5365     assert(evacn);
5366     assert(evacn <= delta + old_delta);
5367     evacp = p - evacn;
5368 #endif
5369
5370     /* This sets 'delta' to the accumulated value of all deltas so far */
5371     delta += old_delta;
5372     assert(delta);
5373
5374     /* If 'delta' fits in a byte, store it just prior to the new beginning of
5375      * the string; otherwise store a 0 byte there and store 'delta' just prior
5376      * to that, using as many bytes as a STRLEN occupies.  Thus it overwrites a
5377      * portion of the chopped part of the string */
5378     if (delta < 0x100) {
5379         *--p = (U8) delta;
5380     } else {
5381         *--p = 0;
5382         p -= sizeof(STRLEN);
5383         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
5384     }
5385
5386 #ifdef DEBUGGING
5387     /* Fill the preceding buffer with sentinals to verify that no-one is
5388        using it.  */
5389     while (p > evacp) {
5390         --p;
5391         *p = (U8)PTR2UV(p);
5392     }
5393 #endif
5394 }
5395
5396 /*
5397 =for apidoc sv_catpvn
5398
5399 Concatenates the string onto the end of the string which is in the SV.
5400 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
5401 status set, then the bytes appended should be valid UTF-8.
5402 Handles 'get' magic, but not 'set' magic.  See C<L</sv_catpvn_mg>>.
5403
5404 =for apidoc sv_catpvn_flags
5405
5406 Concatenates the string onto the end of the string which is in the SV.  The
5407 C<len> indicates number of bytes to copy.
5408
5409 By default, the string appended is assumed to be valid UTF-8 if the SV has
5410 the UTF-8 status set, and a string of bytes otherwise.  One can force the
5411 appended string to be interpreted as UTF-8 by supplying the C<SV_CATUTF8>
5412 flag, and as bytes by supplying the C<SV_CATBYTES> flag; the SV or the
5413 string appended will be upgraded to UTF-8 if necessary.
5414
5415 If C<flags> has the C<SV_SMAGIC> bit set, will
5416 C<mg_set> on C<dsv> afterwards if appropriate.
5417 C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5418 in terms of this function.
5419
5420 =cut
5421 */
5422
5423 void
5424 Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
5425 {
5426     STRLEN dlen;
5427     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5428
5429     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5430     assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5431
5432     if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
5433       if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
5434          sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5435          dlen = SvCUR(dsv);
5436       }
5437       else SvGROW(dsv, dlen + slen + 3);
5438       if (sstr == dstr)
5439         sstr = SvPVX_const(dsv);
5440       Move(sstr, SvPVX(dsv) + dlen, slen, char);
5441       SvCUR_set(dsv, SvCUR(dsv) + slen);
5442     }
5443     else {
5444         /* We inline bytes_to_utf8, to avoid an extra malloc. */
5445         const char * const send = sstr + slen;
5446         U8 *d;
5447
5448         /* Something this code does not account for, which I think is
5449            impossible; it would require the same pv to be treated as
5450            bytes *and* utf8, which would indicate a bug elsewhere. */
5451         assert(sstr != dstr);
5452
5453         SvGROW(dsv, dlen + slen * 2 + 3);
5454         d = (U8 *)SvPVX(dsv) + dlen;
5455
5456         while (sstr < send) {
5457             append_utf8_from_native_byte(*sstr, &d);
5458             sstr++;
5459         }
5460         SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5461     }
5462     *SvEND(dsv) = '\0';
5463     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
5464     SvTAINT(dsv);
5465     if (flags & SV_SMAGIC)
5466         SvSETMAGIC(dsv);
5467 }
5468
5469 /*
5470 =for apidoc sv_catsv
5471
5472 Concatenates the string from SV C<ssv> onto the end of the string in SV
5473 C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5474 Handles 'get' magic on both SVs, but no 'set' magic.  See C<L</sv_catsv_mg>>
5475 and C<L</sv_catsv_nomg>>.
5476
5477 =for apidoc sv_catsv_flags
5478
5479 Concatenates the string from SV C<ssv> onto the end of the string in SV
5480 C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5481 If C<flags> has the C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if
5482 appropriate.  If C<flags> has the C<SV_SMAGIC> bit set, C<mg_set> will be called on
5483 the modified SV afterward, if appropriate.  C<sv_catsv>, C<sv_catsv_nomg>,
5484 and C<sv_catsv_mg> are implemented in terms of this function.
5485
5486 =cut */
5487
5488 void
5489 Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
5490 {
5491     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5492
5493     if (ssv) {
5494         STRLEN slen;
5495         const char *spv = SvPV_flags_const(ssv, slen, flags);
5496         if (flags & SV_GMAGIC)
5497                 SvGETMAGIC(dsv);
5498         sv_catpvn_flags(dsv, spv, slen,
5499                             DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
5500         if (flags & SV_SMAGIC)
5501                 SvSETMAGIC(dsv);
5502     }
5503 }
5504
5505 /*
5506 =for apidoc sv_catpv
5507
5508 Concatenates the C<NUL>-terminated string onto the end of the string which is
5509 in the SV.
5510 If the SV has the UTF-8 status set, then the bytes appended should be
5511 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See
5512 C<L</sv_catpv_mg>>.
5513
5514 =cut */
5515
5516 void
5517 Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
5518 {
5519     STRLEN len;
5520     STRLEN tlen;
5521     char *junk;
5522
5523     PERL_ARGS_ASSERT_SV_CATPV;
5524
5525     if (!ptr)
5526         return;
5527     junk = SvPV_force(sv, tlen);
5528     len = strlen(ptr);
5529     SvGROW(sv, tlen + len + 1);
5530     if (ptr == junk)
5531         ptr = SvPVX_const(sv);
5532     Move(ptr,SvPVX(sv)+tlen,len+1,char);
5533     SvCUR_set(sv, SvCUR(sv) + len);
5534     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5535     SvTAINT(sv);
5536 }
5537
5538 /*
5539 =for apidoc sv_catpv_flags
5540
5541 Concatenates the C<NUL>-terminated string onto the end of the string which is
5542 in the SV.
5543 If the SV has the UTF-8 status set, then the bytes appended should
5544 be valid UTF-8.  If C<flags> has the C<SV_SMAGIC> bit set, will C<mg_set>
5545 on the modified SV if appropriate.
5546
5547 =cut
5548 */
5549
5550 void
5551 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
5552 {
5553     PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5554     sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
5555 }
5556
5557 /*
5558 =for apidoc sv_catpv_mg
5559
5560 Like C<sv_catpv>, but also handles 'set' magic.
5561
5562 =cut
5563 */
5564
5565 void
5566 Perl_sv_catpv_mg(pTHX_ SV *const sv, const char *const ptr)
5567 {
5568     PERL_ARGS_ASSERT_SV_CATPV_MG;
5569
5570     sv_catpv(sv,ptr);
5571     SvSETMAGIC(sv);
5572 }
5573
5574 /*
5575 =for apidoc newSV
5576
5577 Creates a new SV.  A non-zero C<len> parameter indicates the number of
5578 bytes of preallocated string space the SV should have.  An extra byte for a
5579 trailing C<NUL> is also reserved.  (C<SvPOK> is not set for the SV even if string
5580 space is allocated.)  The reference count for the new SV is set to 1.
5581
5582 In 5.9.3, C<newSV()> replaces the older C<NEWSV()> API, and drops the first
5583 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5584 This aid has been superseded by a new build option, C<PERL_MEM_LOG> (see
5585 L<perlhacktips/PERL_MEM_LOG>).  The older API is still there for use in XS
5586 modules supporting older perls.
5587
5588 =cut
5589 */
5590
5591 SV *
5592 Perl_newSV(pTHX_ const STRLEN len)
5593 {
5594     SV *sv;
5595
5596     new_SV(sv);
5597     if (len) {
5598         sv_grow(sv, len + 1);
5599     }
5600     return sv;
5601 }
5602 /*
5603 =for apidoc sv_magicext
5604
5605 Adds magic to an SV, upgrading it if necessary.  Applies the
5606 supplied C<vtable> and returns a pointer to the magic added.
5607
5608 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5609 In particular, you can add magic to C<SvREADONLY> SVs, and add more than
5610 one instance of the same C<how>.
5611
5612 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5613 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5614 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5615 to contain an SV* and is stored as-is with its C<REFCNT> incremented.
5616
5617 (This is now used as a subroutine by C<sv_magic>.)
5618
5619 =cut
5620 */
5621 MAGIC * 
5622 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, 
5623                 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5624 {
5625     MAGIC* mg;
5626
5627     PERL_ARGS_ASSERT_SV_MAGICEXT;
5628
5629     SvUPGRADE(sv, SVt_PVMG);
5630     Newxz(mg, 1, MAGIC);
5631     mg->mg_moremagic = SvMAGIC(sv);
5632     SvMAGIC_set(sv, mg);
5633
5634     /* Sometimes a magic contains a reference loop, where the sv and
5635        object refer to each other.  To prevent a reference loop that
5636        would prevent such objects being freed, we look for such loops
5637        and if we find one we avoid incrementing the object refcount.
5638
5639        Note we cannot do this to avoid self-tie loops as intervening RV must
5640        have its REFCNT incremented to keep it in existence.
5641
5642     */
5643     if (!obj || obj == sv ||
5644         how == PERL_MAGIC_arylen ||
5645         how == PERL_MAGIC_regdata ||
5646         how == PERL_MAGIC_regdatum ||
5647         how == PERL_MAGIC_symtab ||
5648         (SvTYPE(obj) == SVt_PVGV &&
5649             (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5650              || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5651              || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5652     {
5653         mg->mg_obj = obj;
5654     }
5655     else {
5656         mg->mg_obj = SvREFCNT_inc_simple(obj);
5657         mg->mg_flags |= MGf_REFCOUNTED;
5658     }
5659
5660     /* Normal self-ties simply pass a null object, and instead of
5661        using mg_obj directly, use the SvTIED_obj macro to produce a
5662        new RV as needed.  For glob "self-ties", we are tieing the PVIO
5663        with an RV obj pointing to the glob containing the PVIO.  In
5664        this case, to avoid a reference loop, we need to weaken the
5665        reference.
5666     */
5667
5668     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5669         obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5670     {
5671       sv_rvweaken(obj);
5672     }
5673