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