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