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