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