This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In sv.c, _all_ {new,del}_X* macros can be *_body_allocated.
[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_allocated(sv_type)             \
993     (void *)((char *)S_new_body(aTHX_ sv_type)  \
994              - bodies_by_type[sv_type].offset)
995
996 #define del_body_allocated(p, sv_type)          \
997     del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
998
999
1000 #define my_safemalloc(s)        (void*)safemalloc(s)
1001 #define my_safecalloc(s)        (void*)safecalloc(s, 1)
1002 #define my_safefree(p)  safefree((char*)p)
1003
1004 #ifdef PURIFY
1005
1006 #define new_XNV()       my_safemalloc(sizeof(XPVNV))
1007 #define del_XNV(p)      my_safefree(p)
1008
1009 #define new_XPVNV()     my_safemalloc(sizeof(XPVNV))
1010 #define del_XPVNV(p)    my_safefree(p)
1011
1012 #define new_XPVAV()     my_safemalloc(sizeof(XPVAV))
1013 #define del_XPVAV(p)    my_safefree(p)
1014
1015 #define new_XPVHV()     my_safemalloc(sizeof(XPVHV))
1016 #define del_XPVHV(p)    my_safefree(p)
1017
1018 #define new_XPVMG()     my_safemalloc(sizeof(XPVMG))
1019 #define del_XPVMG(p)    my_safefree(p)
1020
1021 #define new_XPVGV()     my_safemalloc(sizeof(XPVGV))
1022 #define del_XPVGV(p)    my_safefree(p)
1023
1024 #else /* !PURIFY */
1025
1026 #define new_XNV()       new_body_allocated(SVt_NV)
1027 #define del_XNV(p)      del_body_allocated(p, SVt_NV)
1028
1029 #define new_XPVNV()     new_body_allocated(SVt_PVNV)
1030 #define del_XPVNV(p)    del_body_allocated(p, SVt_PVNV)
1031
1032 #define new_XPVAV()     new_body_allocated(SVt_PVAV)
1033 #define del_XPVAV(p)    del_body_allocated(p, SVt_PVAV)
1034
1035 #define new_XPVHV()     new_body_allocated(SVt_PVHV)
1036 #define del_XPVHV(p)    del_body_allocated(p, SVt_PVHV)
1037
1038 #define new_XPVMG()     new_body_allocated(SVt_PVMG)
1039 #define del_XPVMG(p)    del_body_allocated(p, SVt_PVMG)
1040
1041 #define new_XPVGV()     new_body_allocated(SVt_PVGV)
1042 #define del_XPVGV(p)    del_body_allocated(p, SVt_PVGV)
1043
1044 #endif /* PURIFY */
1045
1046 /* no arena for you! */
1047
1048 #define new_NOARENA(details) \
1049         my_safemalloc((details)->body_size + (details)->offset)
1050 #define new_NOARENAZ(details) \
1051         my_safecalloc((details)->body_size + (details)->offset)
1052
1053 STATIC void *
1054 S_more_bodies (pTHX_ const svtype sv_type)
1055 {
1056     dVAR;
1057     void ** const root = &PL_body_roots[sv_type];
1058     const struct body_details * const bdp = &bodies_by_type[sv_type];
1059     const size_t body_size = bdp->body_size;
1060     char *start;
1061     const char *end;
1062     const size_t arena_size = Perl_malloc_good_size(bdp->arena_size);
1063 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1064     static bool done_sanity_check;
1065
1066     /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1067      * variables like done_sanity_check. */
1068     if (!done_sanity_check) {
1069         unsigned int i = SVt_LAST;
1070
1071         done_sanity_check = TRUE;
1072
1073         while (i--)
1074             assert (bodies_by_type[i].type == i);
1075     }
1076 #endif
1077
1078     assert(bdp->arena_size);
1079
1080     start = (char*) Perl_get_arena(aTHX_ arena_size, sv_type);
1081
1082     end = start + arena_size - 2 * body_size;
1083
1084     /* computed count doesnt reflect the 1st slot reservation */
1085 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1086     DEBUG_m(PerlIO_printf(Perl_debug_log,
1087                           "arena %p end %p arena-size %d (from %d) type %d "
1088                           "size %d ct %d\n",
1089                           (void*)start, (void*)end, (int)arena_size,
1090                           (int)bdp->arena_size, sv_type, (int)body_size,
1091                           (int)arena_size / (int)body_size));
1092 #else
1093     DEBUG_m(PerlIO_printf(Perl_debug_log,
1094                           "arena %p end %p arena-size %d type %d size %d ct %d\n",
1095                           (void*)start, (void*)end,
1096                           (int)bdp->arena_size, sv_type, (int)body_size,
1097                           (int)bdp->arena_size / (int)body_size));
1098 #endif
1099     *root = (void *)start;
1100
1101     while (start <= end) {
1102         char * const next = start + body_size;
1103         *(void**) start = (void *)next;
1104         start = next;
1105     }
1106     *(void **)start = 0;
1107
1108     return *root;
1109 }
1110
1111 /* grab a new thing from the free list, allocating more if necessary.
1112    The inline version is used for speed in hot routines, and the
1113    function using it serves the rest (unless PURIFY).
1114 */
1115 #define new_body_inline(xpv, sv_type) \
1116     STMT_START { \
1117         void ** const r3wt = &PL_body_roots[sv_type]; \
1118         xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \
1119           ? *((void **)(r3wt)) : more_bodies(sv_type)); \
1120         *(r3wt) = *(void**)(xpv); \
1121     } STMT_END
1122
1123 #ifndef PURIFY
1124
1125 STATIC void *
1126 S_new_body(pTHX_ const svtype sv_type)
1127 {
1128     dVAR;
1129     void *xpv;
1130     new_body_inline(xpv, sv_type);
1131     return xpv;
1132 }
1133
1134 #endif
1135
1136 static const struct body_details fake_rv =
1137     { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1138
1139 /*
1140 =for apidoc sv_upgrade
1141
1142 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1143 SV, then copies across as much information as possible from the old body.
1144 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1145
1146 =cut
1147 */
1148
1149 void
1150 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1151 {
1152     dVAR;
1153     void*       old_body;
1154     void*       new_body;
1155     const svtype old_type = SvTYPE(sv);
1156     const struct body_details *new_type_details;
1157     const struct body_details *old_type_details
1158         = bodies_by_type + old_type;
1159     SV *referant = NULL;
1160
1161     PERL_ARGS_ASSERT_SV_UPGRADE;
1162
1163     if (old_type == new_type)
1164         return;
1165
1166     /* This clause was purposefully added ahead of the early return above to
1167        the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1168        inference by Nick I-S that it would fix other troublesome cases. See
1169        changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1170
1171        Given that shared hash key scalars are no longer PVIV, but PV, there is
1172        no longer need to unshare so as to free up the IVX slot for its proper
1173        purpose. So it's safe to move the early return earlier.  */
1174
1175     if (new_type != SVt_PV && SvIsCOW(sv)) {
1176         sv_force_normal_flags(sv, 0);
1177     }
1178
1179     old_body = SvANY(sv);
1180
1181     /* Copying structures onto other structures that have been neatly zeroed
1182        has a subtle gotcha. Consider XPVMG
1183
1184        +------+------+------+------+------+-------+-------+
1185        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
1186        +------+------+------+------+------+-------+-------+
1187        0      4      8     12     16     20      24      28
1188
1189        where NVs are aligned to 8 bytes, so that sizeof that structure is
1190        actually 32 bytes long, with 4 bytes of padding at the end:
1191
1192        +------+------+------+------+------+-------+-------+------+
1193        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
1194        +------+------+------+------+------+-------+-------+------+
1195        0      4      8     12     16     20      24      28     32
1196
1197        so what happens if you allocate memory for this structure:
1198
1199        +------+------+------+------+------+-------+-------+------+------+...
1200        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
1201        +------+------+------+------+------+-------+-------+------+------+...
1202        0      4      8     12     16     20      24      28     32     36
1203
1204        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1205        expect, because you copy the area marked ??? onto GP. Now, ??? may have
1206        started out as zero once, but it's quite possible that it isn't. So now,
1207        rather than a nicely zeroed GP, you have it pointing somewhere random.
1208        Bugs ensue.
1209
1210        (In fact, GP ends up pointing at a previous GP structure, because the
1211        principle cause of the padding in XPVMG getting garbage is a copy of
1212        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1213        this happens to be moot because XPVGV has been re-ordered, with GP
1214        no longer after STASH)
1215
1216        So we are careful and work out the size of used parts of all the
1217        structures.  */
1218
1219     switch (old_type) {
1220     case SVt_NULL:
1221         break;
1222     case SVt_IV:
1223         if (SvROK(sv)) {
1224             referant = SvRV(sv);
1225             old_type_details = &fake_rv;
1226             if (new_type == SVt_NV)
1227                 new_type = SVt_PVNV;
1228         } else {
1229             if (new_type < SVt_PVIV) {
1230                 new_type = (new_type == SVt_NV)
1231                     ? SVt_PVNV : SVt_PVIV;
1232             }
1233         }
1234         break;
1235     case SVt_NV:
1236         if (new_type < SVt_PVNV) {
1237             new_type = SVt_PVNV;
1238         }
1239         break;
1240     case SVt_PV:
1241         assert(new_type > SVt_PV);
1242         assert(SVt_IV < SVt_PV);
1243         assert(SVt_NV < SVt_PV);
1244         break;
1245     case SVt_PVIV:
1246         break;
1247     case SVt_PVNV:
1248         break;
1249     case SVt_PVMG:
1250         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1251            there's no way that it can be safely upgraded, because perl.c
1252            expects to Safefree(SvANY(PL_mess_sv))  */
1253         assert(sv != PL_mess_sv);
1254         /* This flag bit is used to mean other things in other scalar types.
1255            Given that it only has meaning inside the pad, it shouldn't be set
1256            on anything that can get upgraded.  */
1257         assert(!SvPAD_TYPED(sv));
1258         break;
1259     default:
1260         if (old_type_details->cant_upgrade)
1261             Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1262                        sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1263     }
1264
1265     if (old_type > new_type)
1266         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1267                 (int)old_type, (int)new_type);
1268
1269     new_type_details = bodies_by_type + new_type;
1270
1271     SvFLAGS(sv) &= ~SVTYPEMASK;
1272     SvFLAGS(sv) |= new_type;
1273
1274     /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1275        the return statements above will have triggered.  */
1276     assert (new_type != SVt_NULL);
1277     switch (new_type) {
1278     case SVt_IV:
1279         assert(old_type == SVt_NULL);
1280         SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1281         SvIV_set(sv, 0);
1282         return;
1283     case SVt_NV:
1284         assert(old_type == SVt_NULL);
1285         SvANY(sv) = new_XNV();
1286         SvNV_set(sv, 0);
1287         return;
1288     case SVt_PVHV:
1289     case SVt_PVAV:
1290         assert(new_type_details->body_size);
1291
1292 #ifndef PURIFY  
1293         assert(new_type_details->arena);
1294         assert(new_type_details->arena_size);
1295         /* This points to the start of the allocated area.  */
1296         new_body_inline(new_body, new_type);
1297         Zero(new_body, new_type_details->body_size, char);
1298         new_body = ((char *)new_body) - new_type_details->offset;
1299 #else
1300         /* We always allocated the full length item with PURIFY. To do this
1301            we fake things so that arena is false for all 16 types..  */
1302         new_body = new_NOARENAZ(new_type_details);
1303 #endif
1304         SvANY(sv) = new_body;
1305         if (new_type == SVt_PVAV) {
1306             AvMAX(sv)   = -1;
1307             AvFILLp(sv) = -1;
1308             AvREAL_only(sv);
1309             if (old_type_details->body_size) {
1310                 AvALLOC(sv) = 0;
1311             } else {
1312                 /* It will have been zeroed when the new body was allocated.
1313                    Lets not write to it, in case it confuses a write-back
1314                    cache.  */
1315             }
1316         } else {
1317             assert(!SvOK(sv));
1318             SvOK_off(sv);
1319 #ifndef NODEFAULT_SHAREKEYS
1320             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
1321 #endif
1322             HvMAX(sv) = 7; /* (start with 8 buckets) */
1323             if (old_type_details->body_size) {
1324                 HvFILL(sv) = 0;
1325             } else {
1326                 /* It will have been zeroed when the new body was allocated.
1327                    Lets not write to it, in case it confuses a write-back
1328                    cache.  */
1329             }
1330         }
1331
1332         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1333            The target created by newSVrv also is, and it can have magic.
1334            However, it never has SvPVX set.
1335         */
1336         if (old_type == SVt_IV) {
1337             assert(!SvROK(sv));
1338         } else if (old_type >= SVt_PV) {
1339             assert(SvPVX_const(sv) == 0);
1340         }
1341
1342         if (old_type >= SVt_PVMG) {
1343             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1344             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1345         } else {
1346             sv->sv_u.svu_array = NULL; /* or svu_hash  */
1347         }
1348         break;
1349
1350
1351     case SVt_REGEXP:
1352         /* This ensures that SvTHINKFIRST(sv) is true, and hence that
1353            sv_force_normal_flags(sv) is called.  */
1354         SvFAKE_on(sv);
1355     case SVt_PVIV:
1356         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1357            no route from NV to PVIV, NOK can never be true  */
1358         assert(!SvNOKp(sv));
1359         assert(!SvNOK(sv));
1360     case SVt_PVIO:
1361     case SVt_PVFM:
1362     case SVt_PVGV:
1363     case SVt_PVCV:
1364     case SVt_PVLV:
1365     case SVt_PVMG:
1366     case SVt_PVNV:
1367     case SVt_PV:
1368
1369         assert(new_type_details->body_size);
1370         /* We always allocated the full length item with PURIFY. To do this
1371            we fake things so that arena is false for all 16 types..  */
1372         if(new_type_details->arena) {
1373             /* This points to the start of the allocated area.  */
1374             new_body_inline(new_body, new_type);
1375             Zero(new_body, new_type_details->body_size, char);
1376             new_body = ((char *)new_body) - new_type_details->offset;
1377         } else {
1378             new_body = new_NOARENAZ(new_type_details);
1379         }
1380         SvANY(sv) = new_body;
1381
1382         if (old_type_details->copy) {
1383             /* There is now the potential for an upgrade from something without
1384                an offset (PVNV or PVMG) to something with one (PVCV, PVFM)  */
1385             int offset = old_type_details->offset;
1386             int length = old_type_details->copy;
1387
1388             if (new_type_details->offset > old_type_details->offset) {
1389                 const int difference
1390                     = new_type_details->offset - old_type_details->offset;
1391                 offset += difference;
1392                 length -= difference;
1393             }
1394             assert (length >= 0);
1395                 
1396             Copy((char *)old_body + offset, (char *)new_body + offset, length,
1397                  char);
1398         }
1399
1400 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1401         /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1402          * correct 0.0 for us.  Otherwise, if the old body didn't have an
1403          * NV slot, but the new one does, then we need to initialise the
1404          * freshly created NV slot with whatever the correct bit pattern is
1405          * for 0.0  */
1406         if (old_type_details->zero_nv && !new_type_details->zero_nv
1407             && !isGV_with_GP(sv))
1408             SvNV_set(sv, 0);
1409 #endif
1410
1411         if (new_type == SVt_PVIO) {
1412             IO * const io = MUTABLE_IO(sv);
1413             GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1414
1415             SvOBJECT_on(io);
1416             /* Clear the stashcache because a new IO could overrule a package
1417                name */
1418             hv_clear(PL_stashcache);
1419
1420             SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1421             IoPAGE_LEN(sv) = 60;
1422         }
1423         if (old_type < SVt_PV) {
1424             /* referant will be NULL unless the old type was SVt_IV emulating
1425                SVt_RV */
1426             sv->sv_u.svu_rv = referant;
1427         }
1428         break;
1429     default:
1430         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1431                    (unsigned long)new_type);
1432     }
1433
1434     if (old_type > SVt_IV) {
1435 #ifdef PURIFY
1436         my_safefree(old_body);
1437 #else
1438         /* Note that there is an assumption that all bodies of types that
1439            can be upgraded came from arenas. Only the more complex non-
1440            upgradable types are allowed to be directly malloc()ed.  */
1441         assert(old_type_details->arena);
1442         del_body((void*)((char*)old_body + old_type_details->offset),
1443                  &PL_body_roots[old_type]);
1444 #endif
1445     }
1446 }
1447
1448 /*
1449 =for apidoc sv_backoff
1450
1451 Remove any string offset. You should normally use the C<SvOOK_off> macro
1452 wrapper instead.
1453
1454 =cut
1455 */
1456
1457 int
1458 Perl_sv_backoff(pTHX_ register SV *const sv)
1459 {
1460     STRLEN delta;
1461     const char * const s = SvPVX_const(sv);
1462
1463     PERL_ARGS_ASSERT_SV_BACKOFF;
1464     PERL_UNUSED_CONTEXT;
1465
1466     assert(SvOOK(sv));
1467     assert(SvTYPE(sv) != SVt_PVHV);
1468     assert(SvTYPE(sv) != SVt_PVAV);
1469
1470     SvOOK_offset(sv, delta);
1471     
1472     SvLEN_set(sv, SvLEN(sv) + delta);
1473     SvPV_set(sv, SvPVX(sv) - delta);
1474     Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1475     SvFLAGS(sv) &= ~SVf_OOK;
1476     return 0;
1477 }
1478
1479 /*
1480 =for apidoc sv_grow
1481
1482 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1483 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1484 Use the C<SvGROW> wrapper instead.
1485
1486 =cut
1487 */
1488
1489 char *
1490 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1491 {
1492     register char *s;
1493
1494     PERL_ARGS_ASSERT_SV_GROW;
1495
1496     if (PL_madskills && newlen >= 0x100000) {
1497         PerlIO_printf(Perl_debug_log,
1498                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1499     }
1500 #ifdef HAS_64K_LIMIT
1501     if (newlen >= 0x10000) {
1502         PerlIO_printf(Perl_debug_log,
1503                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1504         my_exit(1);
1505     }
1506 #endif /* HAS_64K_LIMIT */
1507     if (SvROK(sv))
1508         sv_unref(sv);
1509     if (SvTYPE(sv) < SVt_PV) {
1510         sv_upgrade(sv, SVt_PV);
1511         s = SvPVX_mutable(sv);
1512     }
1513     else if (SvOOK(sv)) {       /* pv is offset? */
1514         sv_backoff(sv);
1515         s = SvPVX_mutable(sv);
1516         if (newlen > SvLEN(sv))
1517             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1518 #ifdef HAS_64K_LIMIT
1519         if (newlen >= 0x10000)
1520             newlen = 0xFFFF;
1521 #endif
1522     }
1523     else
1524         s = SvPVX_mutable(sv);
1525
1526     if (newlen > SvLEN(sv)) {           /* need more room? */
1527 #ifndef Perl_safesysmalloc_size
1528         newlen = PERL_STRLEN_ROUNDUP(newlen);
1529 #endif
1530         if (SvLEN(sv) && s) {
1531             s = (char*)saferealloc(s, newlen);
1532         }
1533         else {
1534             s = (char*)safemalloc(newlen);
1535             if (SvPVX_const(sv) && SvCUR(sv)) {
1536                 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1537             }
1538         }
1539         SvPV_set(sv, s);
1540 #ifdef Perl_safesysmalloc_size
1541         /* Do this here, do it once, do it right, and then we will never get
1542            called back into sv_grow() unless there really is some growing
1543            needed.  */
1544         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1545 #else
1546         SvLEN_set(sv, newlen);
1547 #endif
1548     }
1549     return s;
1550 }
1551
1552 /*
1553 =for apidoc sv_setiv
1554
1555 Copies an integer into the given SV, upgrading first if necessary.
1556 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1557
1558 =cut
1559 */
1560
1561 void
1562 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1563 {
1564     dVAR;
1565
1566     PERL_ARGS_ASSERT_SV_SETIV;
1567
1568     SV_CHECK_THINKFIRST_COW_DROP(sv);
1569     switch (SvTYPE(sv)) {
1570     case SVt_NULL:
1571     case SVt_NV:
1572         sv_upgrade(sv, SVt_IV);
1573         break;
1574     case SVt_PV:
1575         sv_upgrade(sv, SVt_PVIV);
1576         break;
1577
1578     case SVt_PVGV:
1579         if (!isGV_with_GP(sv))
1580             break;
1581     case SVt_PVAV:
1582     case SVt_PVHV:
1583     case SVt_PVCV:
1584     case SVt_PVFM:
1585     case SVt_PVIO:
1586         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1587                    OP_DESC(PL_op));
1588     default: NOOP;
1589     }
1590     (void)SvIOK_only(sv);                       /* validate number */
1591     SvIV_set(sv, i);
1592     SvTAINT(sv);
1593 }
1594
1595 /*
1596 =for apidoc sv_setiv_mg
1597
1598 Like C<sv_setiv>, but also handles 'set' magic.
1599
1600 =cut
1601 */
1602
1603 void
1604 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1605 {
1606     PERL_ARGS_ASSERT_SV_SETIV_MG;
1607
1608     sv_setiv(sv,i);
1609     SvSETMAGIC(sv);
1610 }
1611
1612 /*
1613 =for apidoc sv_setuv
1614
1615 Copies an unsigned integer into the given SV, upgrading first if necessary.
1616 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1617
1618 =cut
1619 */
1620
1621 void
1622 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1623 {
1624     PERL_ARGS_ASSERT_SV_SETUV;
1625
1626     /* With these two if statements:
1627        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1628
1629        without
1630        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1631
1632        If you wish to remove them, please benchmark to see what the effect is
1633     */
1634     if (u <= (UV)IV_MAX) {
1635        sv_setiv(sv, (IV)u);
1636        return;
1637     }
1638     sv_setiv(sv, 0);
1639     SvIsUV_on(sv);
1640     SvUV_set(sv, u);
1641 }
1642
1643 /*
1644 =for apidoc sv_setuv_mg
1645
1646 Like C<sv_setuv>, but also handles 'set' magic.
1647
1648 =cut
1649 */
1650
1651 void
1652 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1653 {
1654     PERL_ARGS_ASSERT_SV_SETUV_MG;
1655
1656     sv_setuv(sv,u);
1657     SvSETMAGIC(sv);
1658 }
1659
1660 /*
1661 =for apidoc sv_setnv
1662
1663 Copies a double into the given SV, upgrading first if necessary.
1664 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1665
1666 =cut
1667 */
1668
1669 void
1670 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1671 {
1672     dVAR;
1673
1674     PERL_ARGS_ASSERT_SV_SETNV;
1675
1676     SV_CHECK_THINKFIRST_COW_DROP(sv);
1677     switch (SvTYPE(sv)) {
1678     case SVt_NULL:
1679     case SVt_IV:
1680         sv_upgrade(sv, SVt_NV);
1681         break;
1682     case SVt_PV:
1683     case SVt_PVIV:
1684         sv_upgrade(sv, SVt_PVNV);
1685         break;
1686
1687     case SVt_PVGV:
1688         if (!isGV_with_GP(sv))
1689             break;
1690     case SVt_PVAV:
1691     case SVt_PVHV:
1692     case SVt_PVCV:
1693     case SVt_PVFM:
1694     case SVt_PVIO:
1695         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1696                    OP_DESC(PL_op));
1697     default: NOOP;
1698     }
1699     SvNV_set(sv, num);
1700     (void)SvNOK_only(sv);                       /* validate number */
1701     SvTAINT(sv);
1702 }
1703
1704 /*
1705 =for apidoc sv_setnv_mg
1706
1707 Like C<sv_setnv>, but also handles 'set' magic.
1708
1709 =cut
1710 */
1711
1712 void
1713 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1714 {
1715     PERL_ARGS_ASSERT_SV_SETNV_MG;
1716
1717     sv_setnv(sv,num);
1718     SvSETMAGIC(sv);
1719 }
1720
1721 /* Print an "isn't numeric" warning, using a cleaned-up,
1722  * printable version of the offending string
1723  */
1724
1725 STATIC void
1726 S_not_a_number(pTHX_ SV *const sv)
1727 {
1728      dVAR;
1729      SV *dsv;
1730      char tmpbuf[64];
1731      const char *pv;
1732
1733      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1734
1735      if (DO_UTF8(sv)) {
1736           dsv = newSVpvs_flags("", SVs_TEMP);
1737           pv = sv_uni_display(dsv, sv, 10, 0);
1738      } else {
1739           char *d = tmpbuf;
1740           const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1741           /* each *s can expand to 4 chars + "...\0",
1742              i.e. need room for 8 chars */
1743         
1744           const char *s = SvPVX_const(sv);
1745           const char * const end = s + SvCUR(sv);
1746           for ( ; s < end && d < limit; s++ ) {
1747                int ch = *s & 0xFF;
1748                if (ch & 128 && !isPRINT_LC(ch)) {
1749                     *d++ = 'M';
1750                     *d++ = '-';
1751                     ch &= 127;
1752                }
1753                if (ch == '\n') {
1754                     *d++ = '\\';
1755                     *d++ = 'n';
1756                }
1757                else if (ch == '\r') {
1758                     *d++ = '\\';
1759                     *d++ = 'r';
1760                }
1761                else if (ch == '\f') {
1762                     *d++ = '\\';
1763                     *d++ = 'f';
1764                }
1765                else if (ch == '\\') {
1766                     *d++ = '\\';
1767                     *d++ = '\\';
1768                }
1769                else if (ch == '\0') {
1770                     *d++ = '\\';
1771                     *d++ = '0';
1772                }
1773                else if (isPRINT_LC(ch))
1774                     *d++ = ch;
1775                else {
1776                     *d++ = '^';
1777                     *d++ = toCTRL(ch);
1778                }
1779           }
1780           if (s < end) {
1781                *d++ = '.';
1782                *d++ = '.';
1783                *d++ = '.';
1784           }
1785           *d = '\0';
1786           pv = tmpbuf;
1787     }
1788
1789     if (PL_op)
1790         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1791                     "Argument \"%s\" isn't numeric in %s", pv,
1792                     OP_DESC(PL_op));
1793     else
1794         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1795                     "Argument \"%s\" isn't numeric", pv);
1796 }
1797
1798 /*
1799 =for apidoc looks_like_number
1800
1801 Test if the content of an SV looks like a number (or is a number).
1802 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1803 non-numeric warning), even if your atof() doesn't grok them.
1804
1805 =cut
1806 */
1807
1808 I32
1809 Perl_looks_like_number(pTHX_ SV *const sv)
1810 {
1811     register const char *sbegin;
1812     STRLEN len;
1813
1814     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1815
1816     if (SvPOK(sv)) {
1817         sbegin = SvPVX_const(sv);
1818         len = SvCUR(sv);
1819     }
1820     else if (SvPOKp(sv))
1821         sbegin = SvPV_const(sv, len);
1822     else
1823         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1824     return grok_number(sbegin, len, NULL);
1825 }
1826
1827 STATIC bool
1828 S_glob_2number(pTHX_ GV * const gv)
1829 {
1830     const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1831     SV *const buffer = sv_newmortal();
1832
1833     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1834
1835     /* FAKE globs can get coerced, so need to turn this off temporarily if it
1836        is on.  */
1837     SvFAKE_off(gv);
1838     gv_efullname3(buffer, gv, "*");
1839     SvFLAGS(gv) |= wasfake;
1840
1841     /* We know that all GVs stringify to something that is not-a-number,
1842         so no need to test that.  */
1843     if (ckWARN(WARN_NUMERIC))
1844         not_a_number(buffer);
1845     /* We just want something true to return, so that S_sv_2iuv_common
1846         can tail call us and return true.  */
1847     return TRUE;
1848 }
1849
1850 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1851    until proven guilty, assume that things are not that bad... */
1852
1853 /*
1854    NV_PRESERVES_UV:
1855
1856    As 64 bit platforms often have an NV that doesn't preserve all bits of
1857    an IV (an assumption perl has been based on to date) it becomes necessary
1858    to remove the assumption that the NV always carries enough precision to
1859    recreate the IV whenever needed, and that the NV is the canonical form.
1860    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1861    precision as a side effect of conversion (which would lead to insanity
1862    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1863    1) to distinguish between IV/UV/NV slots that have cached a valid
1864       conversion where precision was lost and IV/UV/NV slots that have a
1865       valid conversion which has lost no precision
1866    2) to ensure that if a numeric conversion to one form is requested that
1867       would lose precision, the precise conversion (or differently
1868       imprecise conversion) is also performed and cached, to prevent
1869       requests for different numeric formats on the same SV causing
1870       lossy conversion chains. (lossless conversion chains are perfectly
1871       acceptable (still))
1872
1873
1874    flags are used:
1875    SvIOKp is true if the IV slot contains a valid value
1876    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1877    SvNOKp is true if the NV slot contains a valid value
1878    SvNOK  is true only if the NV value is accurate
1879
1880    so
1881    while converting from PV to NV, check to see if converting that NV to an
1882    IV(or UV) would lose accuracy over a direct conversion from PV to
1883    IV(or UV). If it would, cache both conversions, return NV, but mark
1884    SV as IOK NOKp (ie not NOK).
1885
1886    While converting from PV to IV, check to see if converting that IV to an
1887    NV would lose accuracy over a direct conversion from PV to NV. If it
1888    would, cache both conversions, flag similarly.
1889
1890    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1891    correctly because if IV & NV were set NV *always* overruled.
1892    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1893    changes - now IV and NV together means that the two are interchangeable:
1894    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1895
1896    The benefit of this is that operations such as pp_add know that if
1897    SvIOK is true for both left and right operands, then integer addition
1898    can be used instead of floating point (for cases where the result won't
1899    overflow). Before, floating point was always used, which could lead to
1900    loss of precision compared with integer addition.
1901
1902    * making IV and NV equal status should make maths accurate on 64 bit
1903      platforms
1904    * may speed up maths somewhat if pp_add and friends start to use
1905      integers when possible instead of fp. (Hopefully the overhead in
1906      looking for SvIOK and checking for overflow will not outweigh the
1907      fp to integer speedup)
1908    * will slow down integer operations (callers of SvIV) on "inaccurate"
1909      values, as the change from SvIOK to SvIOKp will cause a call into
1910      sv_2iv each time rather than a macro access direct to the IV slot
1911    * should speed up number->string conversion on integers as IV is
1912      favoured when IV and NV are equally accurate
1913
1914    ####################################################################
1915    You had better be using SvIOK_notUV if you want an IV for arithmetic:
1916    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1917    On the other hand, SvUOK is true iff UV.
1918    ####################################################################
1919
1920    Your mileage will vary depending your CPU's relative fp to integer
1921    performance ratio.
1922 */
1923
1924 #ifndef NV_PRESERVES_UV
1925 #  define IS_NUMBER_UNDERFLOW_IV 1
1926 #  define IS_NUMBER_UNDERFLOW_UV 2
1927 #  define IS_NUMBER_IV_AND_UV    2
1928 #  define IS_NUMBER_OVERFLOW_IV  4
1929 #  define IS_NUMBER_OVERFLOW_UV  5
1930
1931 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1932
1933 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1934 STATIC int
1935 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1936 #  ifdef DEBUGGING
1937                        , I32 numtype
1938 #  endif
1939                        )
1940 {
1941     dVAR;
1942
1943     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1944
1945     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));
1946     if (SvNVX(sv) < (NV)IV_MIN) {
1947         (void)SvIOKp_on(sv);
1948         (void)SvNOK_on(sv);
1949         SvIV_set(sv, IV_MIN);
1950         return IS_NUMBER_UNDERFLOW_IV;
1951     }
1952     if (SvNVX(sv) > (NV)UV_MAX) {
1953         (void)SvIOKp_on(sv);
1954         (void)SvNOK_on(sv);
1955         SvIsUV_on(sv);
1956         SvUV_set(sv, UV_MAX);
1957         return IS_NUMBER_OVERFLOW_UV;
1958     }
1959     (void)SvIOKp_on(sv);
1960     (void)SvNOK_on(sv);
1961     /* Can't use strtol etc to convert this string.  (See truth table in
1962        sv_2iv  */
1963     if (SvNVX(sv) <= (UV)IV_MAX) {
1964         SvIV_set(sv, I_V(SvNVX(sv)));
1965         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1966             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1967         } else {
1968             /* Integer is imprecise. NOK, IOKp */
1969         }
1970         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1971     }
1972     SvIsUV_on(sv);
1973     SvUV_set(sv, U_V(SvNVX(sv)));
1974     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1975         if (SvUVX(sv) == UV_MAX) {
1976             /* As we know that NVs don't preserve UVs, UV_MAX cannot
1977                possibly be preserved by NV. Hence, it must be overflow.
1978                NOK, IOKp */
1979             return IS_NUMBER_OVERFLOW_UV;
1980         }
1981         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1982     } else {
1983         /* Integer is imprecise. NOK, IOKp */
1984     }
1985     return IS_NUMBER_OVERFLOW_IV;
1986 }
1987 #endif /* !NV_PRESERVES_UV*/
1988
1989 STATIC bool
1990 S_sv_2iuv_common(pTHX_ SV *const sv)
1991 {
1992     dVAR;
1993
1994     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
1995
1996     if (SvNOKp(sv)) {
1997         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1998          * without also getting a cached IV/UV from it at the same time
1999          * (ie PV->NV conversion should detect loss of accuracy and cache
2000          * IV or UV at same time to avoid this. */
2001         /* IV-over-UV optimisation - choose to cache IV if possible */
2002
2003         if (SvTYPE(sv) == SVt_NV)
2004             sv_upgrade(sv, SVt_PVNV);
2005
2006         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2007         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2008            certainly cast into the IV range at IV_MAX, whereas the correct
2009            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2010            cases go to UV */
2011 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2012         if (Perl_isnan(SvNVX(sv))) {
2013             SvUV_set(sv, 0);
2014             SvIsUV_on(sv);
2015             return FALSE;
2016         }
2017 #endif
2018         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2019             SvIV_set(sv, I_V(SvNVX(sv)));
2020             if (SvNVX(sv) == (NV) SvIVX(sv)
2021 #ifndef NV_PRESERVES_UV
2022                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2023                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2024                 /* Don't flag it as "accurately an integer" if the number
2025                    came from a (by definition imprecise) NV operation, and
2026                    we're outside the range of NV integer precision */
2027 #endif
2028                 ) {
2029                 if (SvNOK(sv))
2030                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2031                 else {
2032                     /* scalar has trailing garbage, eg "42a" */
2033                 }
2034                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2035                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2036                                       PTR2UV(sv),
2037                                       SvNVX(sv),
2038                                       SvIVX(sv)));
2039
2040             } else {
2041                 /* IV not precise.  No need to convert from PV, as NV
2042                    conversion would already have cached IV if it detected
2043                    that PV->IV would be better than PV->NV->IV
2044                    flags already correct - don't set public IOK.  */
2045                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2046                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2047                                       PTR2UV(sv),
2048                                       SvNVX(sv),
2049                                       SvIVX(sv)));
2050             }
2051             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2052                but the cast (NV)IV_MIN rounds to a the value less (more
2053                negative) than IV_MIN which happens to be equal to SvNVX ??
2054                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2055                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2056                (NV)UVX == NVX are both true, but the values differ. :-(
2057                Hopefully for 2s complement IV_MIN is something like
2058                0x8000000000000000 which will be exact. NWC */
2059         }
2060         else {
2061             SvUV_set(sv, U_V(SvNVX(sv)));
2062             if (
2063                 (SvNVX(sv) == (NV) SvUVX(sv))
2064 #ifndef  NV_PRESERVES_UV
2065                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2066                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2067                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2068                 /* Don't flag it as "accurately an integer" if the number
2069                    came from a (by definition imprecise) NV operation, and
2070                    we're outside the range of NV integer precision */
2071 #endif
2072                 && SvNOK(sv)
2073                 )
2074                 SvIOK_on(sv);
2075             SvIsUV_on(sv);
2076             DEBUG_c(PerlIO_printf(Perl_debug_log,
2077                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2078                                   PTR2UV(sv),
2079                                   SvUVX(sv),
2080                                   SvUVX(sv)));
2081         }
2082     }
2083     else if (SvPOKp(sv) && SvLEN(sv)) {
2084         UV value;
2085         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2086         /* We want to avoid a possible problem when we cache an IV/ a UV which
2087            may be later translated to an NV, and the resulting NV is not
2088            the same as the direct translation of the initial string
2089            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2090            be careful to ensure that the value with the .456 is around if the
2091            NV value is requested in the future).
2092         
2093            This means that if we cache such an IV/a UV, we need to cache the
2094            NV as well.  Moreover, we trade speed for space, and do not
2095            cache the NV if we are sure it's not needed.
2096          */
2097
2098         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2099         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2100              == IS_NUMBER_IN_UV) {
2101             /* It's definitely an integer, only upgrade to PVIV */
2102             if (SvTYPE(sv) < SVt_PVIV)
2103                 sv_upgrade(sv, SVt_PVIV);
2104             (void)SvIOK_on(sv);
2105         } else if (SvTYPE(sv) < SVt_PVNV)
2106             sv_upgrade(sv, SVt_PVNV);
2107
2108         /* If NVs preserve UVs then we only use the UV value if we know that
2109            we aren't going to call atof() below. If NVs don't preserve UVs
2110            then the value returned may have more precision than atof() will
2111            return, even though value isn't perfectly accurate.  */
2112         if ((numtype & (IS_NUMBER_IN_UV
2113 #ifdef NV_PRESERVES_UV
2114                         | IS_NUMBER_NOT_INT
2115 #endif
2116             )) == IS_NUMBER_IN_UV) {
2117             /* This won't turn off the public IOK flag if it was set above  */
2118             (void)SvIOKp_on(sv);
2119
2120             if (!(numtype & IS_NUMBER_NEG)) {
2121                 /* positive */;
2122                 if (value <= (UV)IV_MAX) {
2123                     SvIV_set(sv, (IV)value);
2124                 } else {
2125                     /* it didn't overflow, and it was positive. */
2126                     SvUV_set(sv, value);
2127                     SvIsUV_on(sv);
2128                 }
2129             } else {
2130                 /* 2s complement assumption  */
2131                 if (value <= (UV)IV_MIN) {
2132                     SvIV_set(sv, -(IV)value);
2133                 } else {
2134                     /* Too negative for an IV.  This is a double upgrade, but
2135                        I'm assuming it will be rare.  */
2136                     if (SvTYPE(sv) < SVt_PVNV)
2137                         sv_upgrade(sv, SVt_PVNV);
2138                     SvNOK_on(sv);
2139                     SvIOK_off(sv);
2140                     SvIOKp_on(sv);
2141                     SvNV_set(sv, -(NV)value);
2142                     SvIV_set(sv, IV_MIN);
2143                 }
2144             }
2145         }
2146         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2147            will be in the previous block to set the IV slot, and the next
2148            block to set the NV slot.  So no else here.  */
2149         
2150         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2151             != IS_NUMBER_IN_UV) {
2152             /* It wasn't an (integer that doesn't overflow the UV). */
2153             SvNV_set(sv, Atof(SvPVX_const(sv)));
2154
2155             if (! numtype && ckWARN(WARN_NUMERIC))
2156                 not_a_number(sv);
2157
2158 #if defined(USE_LONG_DOUBLE)
2159             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2160                                   PTR2UV(sv), SvNVX(sv)));
2161 #else
2162             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2163                                   PTR2UV(sv), SvNVX(sv)));
2164 #endif
2165
2166 #ifdef NV_PRESERVES_UV
2167             (void)SvIOKp_on(sv);
2168             (void)SvNOK_on(sv);
2169             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2170                 SvIV_set(sv, I_V(SvNVX(sv)));
2171                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2172                     SvIOK_on(sv);
2173                 } else {
2174                     NOOP;  /* Integer is imprecise. NOK, IOKp */
2175                 }
2176                 /* UV will not work better than IV */
2177             } else {
2178                 if (SvNVX(sv) > (NV)UV_MAX) {
2179                     SvIsUV_on(sv);
2180                     /* Integer is inaccurate. NOK, IOKp, is UV */
2181                     SvUV_set(sv, UV_MAX);
2182                 } else {
2183                     SvUV_set(sv, U_V(SvNVX(sv)));
2184                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2185                        NV preservse UV so can do correct comparison.  */
2186                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2187                         SvIOK_on(sv);
2188                     } else {
2189                         NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
2190                     }
2191                 }
2192                 SvIsUV_on(sv);
2193             }
2194 #else /* NV_PRESERVES_UV */
2195             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2196                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2197                 /* The IV/UV slot will have been set from value returned by
2198                    grok_number above.  The NV slot has just been set using
2199                    Atof.  */
2200                 SvNOK_on(sv);
2201                 assert (SvIOKp(sv));
2202             } else {
2203                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2204                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2205                     /* Small enough to preserve all bits. */
2206                     (void)SvIOKp_on(sv);
2207                     SvNOK_on(sv);
2208                     SvIV_set(sv, I_V(SvNVX(sv)));
2209                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2210                         SvIOK_on(sv);
2211                     /* Assumption: first non-preserved integer is < IV_MAX,
2212                        this NV is in the preserved range, therefore: */
2213                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2214                           < (UV)IV_MAX)) {
2215                         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);
2216                     }
2217                 } else {
2218                     /* IN_UV NOT_INT
2219                          0      0       already failed to read UV.
2220                          0      1       already failed to read UV.
2221                          1      0       you won't get here in this case. IV/UV
2222                                         slot set, public IOK, Atof() unneeded.
2223                          1      1       already read UV.
2224                        so there's no point in sv_2iuv_non_preserve() attempting
2225                        to use atol, strtol, strtoul etc.  */
2226 #  ifdef DEBUGGING
2227                     sv_2iuv_non_preserve (sv, numtype);
2228 #  else
2229                     sv_2iuv_non_preserve (sv);
2230 #  endif
2231                 }
2232             }
2233 #endif /* NV_PRESERVES_UV */
2234         /* It might be more code efficient to go through the entire logic above
2235            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2236            gets complex and potentially buggy, so more programmer efficient
2237            to do it this way, by turning off the public flags:  */
2238         if (!numtype)
2239             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2240         }
2241     }
2242     else  {
2243         if (isGV_with_GP(sv))
2244             return glob_2number(MUTABLE_GV(sv));
2245
2246         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2247             if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2248                 report_uninit(sv);
2249         }
2250         if (SvTYPE(sv) < SVt_IV)
2251             /* Typically the caller expects that sv_any is not NULL now.  */
2252             sv_upgrade(sv, SVt_IV);
2253         /* Return 0 from the caller.  */
2254         return TRUE;
2255     }
2256     return FALSE;
2257 }
2258
2259 /*
2260 =for apidoc sv_2iv_flags
2261
2262 Return the integer value of an SV, doing any necessary string
2263 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2264 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2265
2266 =cut
2267 */
2268
2269 IV
2270 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2271 {
2272     dVAR;
2273     if (!sv)
2274         return 0;
2275     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2276         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2277            cache IVs just in case. In practice it seems that they never
2278            actually anywhere accessible by user Perl code, let alone get used
2279            in anything other than a string context.  */
2280         if (flags & SV_GMAGIC)
2281             mg_get(sv);
2282         if (SvIOKp(sv))
2283             return SvIVX(sv);
2284         if (SvNOKp(sv)) {
2285             return I_V(SvNVX(sv));
2286         }
2287         if (SvPOKp(sv) && SvLEN(sv)) {
2288             UV value;
2289             const int numtype
2290                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2291
2292             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2293                 == IS_NUMBER_IN_UV) {
2294                 /* It's definitely an integer */
2295                 if (numtype & IS_NUMBER_NEG) {
2296                     if (value < (UV)IV_MIN)
2297                         return -(IV)value;
2298                 } else {
2299                     if (value < (UV)IV_MAX)
2300                         return (IV)value;
2301                 }
2302             }
2303             if (!numtype) {
2304                 if (ckWARN(WARN_NUMERIC))
2305                     not_a_number(sv);
2306             }
2307             return I_V(Atof(SvPVX_const(sv)));
2308         }
2309         if (SvROK(sv)) {
2310             goto return_rok;
2311         }
2312         assert(SvTYPE(sv) >= SVt_PVMG);
2313         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2314     } else if (SvTHINKFIRST(sv)) {
2315         if (SvROK(sv)) {
2316         return_rok:
2317             if (SvAMAGIC(sv)) {
2318                 SV * tmpstr;
2319                 if (flags & SV_SKIP_OVERLOAD)
2320                     return 0;
2321                 tmpstr=AMG_CALLun(sv,numer);
2322                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2323                     return SvIV(tmpstr);
2324                 }
2325             }
2326             return PTR2IV(SvRV(sv));
2327         }
2328         if (SvIsCOW(sv)) {
2329             sv_force_normal_flags(sv, 0);
2330         }
2331         if (SvREADONLY(sv) && !SvOK(sv)) {
2332             if (ckWARN(WARN_UNINITIALIZED))
2333                 report_uninit(sv);
2334             return 0;
2335         }
2336     }
2337     if (!SvIOKp(sv)) {
2338         if (S_sv_2iuv_common(aTHX_ sv))
2339             return 0;
2340     }
2341     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2342         PTR2UV(sv),SvIVX(sv)));
2343     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2344 }
2345
2346 /*
2347 =for apidoc sv_2uv_flags
2348
2349 Return the unsigned integer value of an SV, doing any necessary string
2350 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2351 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2352
2353 =cut
2354 */
2355
2356 UV
2357 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2358 {
2359     dVAR;
2360     if (!sv)
2361         return 0;
2362     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2363         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2364            cache IVs just in case.  */
2365         if (flags & SV_GMAGIC)
2366             mg_get(sv);
2367         if (SvIOKp(sv))
2368             return SvUVX(sv);
2369         if (SvNOKp(sv))
2370             return U_V(SvNVX(sv));
2371         if (SvPOKp(sv) && SvLEN(sv)) {
2372             UV value;
2373             const int numtype
2374                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2375
2376             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2377                 == IS_NUMBER_IN_UV) {
2378                 /* It's definitely an integer */
2379                 if (!(numtype & IS_NUMBER_NEG))
2380                     return value;
2381             }
2382             if (!numtype) {
2383                 if (ckWARN(WARN_NUMERIC))
2384                     not_a_number(sv);
2385             }
2386             return U_V(Atof(SvPVX_const(sv)));
2387         }
2388         if (SvROK(sv)) {
2389             goto return_rok;
2390         }
2391         assert(SvTYPE(sv) >= SVt_PVMG);
2392         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2393     } else if (SvTHINKFIRST(sv)) {
2394         if (SvROK(sv)) {
2395         return_rok:
2396             if (SvAMAGIC(sv)) {
2397                 SV *tmpstr;
2398                 if (flags & SV_SKIP_OVERLOAD)
2399                     return 0;
2400                 tmpstr = AMG_CALLun(sv,numer);
2401                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2402                     return SvUV(tmpstr);
2403                 }
2404             }
2405             return PTR2UV(SvRV(sv));
2406         }
2407         if (SvIsCOW(sv)) {
2408             sv_force_normal_flags(sv, 0);
2409         }
2410         if (SvREADONLY(sv) && !SvOK(sv)) {
2411             if (ckWARN(WARN_UNINITIALIZED))
2412                 report_uninit(sv);
2413             return 0;
2414         }
2415     }
2416     if (!SvIOKp(sv)) {
2417         if (S_sv_2iuv_common(aTHX_ sv))
2418             return 0;
2419     }
2420
2421     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2422                           PTR2UV(sv),SvUVX(sv)));
2423     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2424 }
2425
2426 /*
2427 =for apidoc sv_2nv
2428
2429 Return the num value of an SV, doing any necessary string or integer
2430 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2431 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2432
2433 =cut
2434 */
2435
2436 NV
2437 Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
2438 {
2439     dVAR;
2440     if (!sv)
2441         return 0.0;
2442     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2443         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2444            cache IVs just in case.  */
2445         if (flags & SV_GMAGIC)
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 *tmpstr;
2472                 if (flags & SV_SKIP_OVERLOAD)
2473                     return 0;
2474                 tmpstr = AMG_CALLun(sv,numer);
2475                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2476                     return SvNV(tmpstr);
2477                 }
2478             }
2479             return PTR2NV(SvRV(sv));
2480         }
2481         if (SvIsCOW(sv)) {
2482             sv_force_normal_flags(sv, 0);
2483         }
2484         if (SvREADONLY(sv) && !SvOK(sv)) {
2485             if (ckWARN(WARN_UNINITIALIZED))
2486                 report_uninit(sv);
2487             return 0.0;
2488         }
2489     }
2490     if (SvTYPE(sv) < SVt_NV) {
2491         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2492         sv_upgrade(sv, SVt_NV);
2493 #ifdef USE_LONG_DOUBLE
2494         DEBUG_c({
2495             STORE_NUMERIC_LOCAL_SET_STANDARD();
2496             PerlIO_printf(Perl_debug_log,
2497                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2498                           PTR2UV(sv), SvNVX(sv));
2499             RESTORE_NUMERIC_LOCAL();
2500         });
2501 #else
2502         DEBUG_c({
2503             STORE_NUMERIC_LOCAL_SET_STANDARD();
2504             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2505                           PTR2UV(sv), SvNVX(sv));
2506             RESTORE_NUMERIC_LOCAL();
2507         });
2508 #endif
2509     }
2510     else if (SvTYPE(sv) < SVt_PVNV)
2511         sv_upgrade(sv, SVt_PVNV);
2512     if (SvNOKp(sv)) {
2513         return SvNVX(sv);
2514     }
2515     if (SvIOKp(sv)) {
2516         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2517 #ifdef NV_PRESERVES_UV
2518         if (SvIOK(sv))
2519             SvNOK_on(sv);
2520         else
2521             SvNOKp_on(sv);
2522 #else
2523         /* Only set the public NV OK flag if this NV preserves the IV  */
2524         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2525         if (SvIOK(sv) &&
2526             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2527                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2528             SvNOK_on(sv);
2529         else
2530             SvNOKp_on(sv);
2531 #endif
2532     }
2533     else if (SvPOKp(sv) && SvLEN(sv)) {
2534         UV value;
2535         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2536         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2537             not_a_number(sv);
2538 #ifdef NV_PRESERVES_UV
2539         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2540             == IS_NUMBER_IN_UV) {
2541             /* It's definitely an integer */
2542             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2543         } else
2544             SvNV_set(sv, Atof(SvPVX_const(sv)));
2545         if (numtype)
2546             SvNOK_on(sv);
2547         else
2548             SvNOKp_on(sv);
2549 #else
2550         SvNV_set(sv, Atof(SvPVX_const(sv)));
2551         /* Only set the public NV OK flag if this NV preserves the value in
2552            the PV at least as well as an IV/UV would.
2553            Not sure how to do this 100% reliably. */
2554         /* if that shift count is out of range then Configure's test is
2555            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2556            UV_BITS */
2557         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2558             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2559             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2560         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2561             /* Can't use strtol etc to convert this string, so don't try.
2562                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2563             SvNOK_on(sv);
2564         } else {
2565             /* value has been set.  It may not be precise.  */
2566             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2567                 /* 2s complement assumption for (UV)IV_MIN  */
2568                 SvNOK_on(sv); /* Integer is too negative.  */
2569             } else {
2570                 SvNOKp_on(sv);
2571                 SvIOKp_on(sv);
2572
2573                 if (numtype & IS_NUMBER_NEG) {
2574                     SvIV_set(sv, -(IV)value);
2575                 } else if (value <= (UV)IV_MAX) {
2576                     SvIV_set(sv, (IV)value);
2577                 } else {
2578                     SvUV_set(sv, value);
2579                     SvIsUV_on(sv);
2580                 }
2581
2582                 if (numtype & IS_NUMBER_NOT_INT) {
2583                     /* I believe that even if the original PV had decimals,
2584                        they are lost beyond the limit of the FP precision.
2585                        However, neither is canonical, so both only get p
2586                        flags.  NWC, 2000/11/25 */
2587                     /* Both already have p flags, so do nothing */
2588                 } else {
2589                     const NV nv = SvNVX(sv);
2590                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2591                         if (SvIVX(sv) == I_V(nv)) {
2592                             SvNOK_on(sv);
2593                         } else {
2594                             /* It had no "." so it must be integer.  */
2595                         }
2596                         SvIOK_on(sv);
2597                     } else {
2598                         /* between IV_MAX and NV(UV_MAX).
2599                            Could be slightly > UV_MAX */
2600
2601                         if (numtype & IS_NUMBER_NOT_INT) {
2602                             /* UV and NV both imprecise.  */
2603                         } else {
2604                             const UV nv_as_uv = U_V(nv);
2605
2606                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2607                                 SvNOK_on(sv);
2608                             }
2609                             SvIOK_on(sv);
2610                         }
2611                     }
2612                 }
2613             }
2614         }
2615         /* It might be more code efficient to go through the entire logic above
2616            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2617            gets complex and potentially buggy, so more programmer efficient
2618            to do it this way, by turning off the public flags:  */
2619         if (!numtype)
2620             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2621 #endif /* NV_PRESERVES_UV */
2622     }
2623     else  {
2624         if (isGV_with_GP(sv)) {
2625             glob_2number(MUTABLE_GV(sv));
2626             return 0.0;
2627         }
2628
2629         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2630             report_uninit(sv);
2631         assert (SvTYPE(sv) >= SVt_NV);
2632         /* Typically the caller expects that sv_any is not NULL now.  */
2633         /* XXX Ilya implies that this is a bug in callers that assume this
2634            and ideally should be fixed.  */
2635         return 0.0;
2636     }
2637 #if defined(USE_LONG_DOUBLE)
2638     DEBUG_c({
2639         STORE_NUMERIC_LOCAL_SET_STANDARD();
2640         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2641                       PTR2UV(sv), SvNVX(sv));
2642         RESTORE_NUMERIC_LOCAL();
2643     });
2644 #else
2645     DEBUG_c({
2646         STORE_NUMERIC_LOCAL_SET_STANDARD();
2647         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2648                       PTR2UV(sv), SvNVX(sv));
2649         RESTORE_NUMERIC_LOCAL();
2650     });
2651 #endif
2652     return SvNVX(sv);
2653 }
2654
2655 /*
2656 =for apidoc sv_2num
2657
2658 Return an SV with the numeric value of the source SV, doing any necessary
2659 reference or overload conversion.  You must use the C<SvNUM(sv)> macro to
2660 access this function.
2661
2662 =cut
2663 */
2664
2665 SV *
2666 Perl_sv_2num(pTHX_ register SV *const sv)
2667 {
2668     PERL_ARGS_ASSERT_SV_2NUM;
2669
2670     if (!SvROK(sv))
2671         return sv;
2672     if (SvAMAGIC(sv)) {
2673         SV * const tmpsv = AMG_CALLun(sv,numer);
2674         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2675             return sv_2num(tmpsv);
2676     }
2677     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2678 }
2679
2680 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2681  * UV as a string towards the end of buf, and return pointers to start and
2682  * end of it.
2683  *
2684  * We assume that buf is at least TYPE_CHARS(UV) long.
2685  */
2686
2687 static char *
2688 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2689 {
2690     char *ptr = buf + TYPE_CHARS(UV);
2691     char * const ebuf = ptr;
2692     int sign;
2693
2694     PERL_ARGS_ASSERT_UIV_2BUF;
2695
2696     if (is_uv)
2697         sign = 0;
2698     else if (iv >= 0) {
2699         uv = iv;
2700         sign = 0;
2701     } else {
2702         uv = -iv;
2703         sign = 1;
2704     }
2705     do {
2706         *--ptr = '0' + (char)(uv % 10);
2707     } while (uv /= 10);
2708     if (sign)
2709         *--ptr = '-';
2710     *peob = ebuf;
2711     return ptr;
2712 }
2713
2714 /*
2715 =for apidoc sv_2pv_flags
2716
2717 Returns a pointer to the string value of an SV, and sets *lp to its length.
2718 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2719 if necessary.
2720 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2721 usually end up here too.
2722
2723 =cut
2724 */
2725
2726 char *
2727 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2728 {
2729     dVAR;
2730     register char *s;
2731
2732     if (!sv) {
2733         if (lp)
2734             *lp = 0;
2735         return (char *)"";
2736     }
2737     if (SvGMAGICAL(sv)) {
2738         if (flags & SV_GMAGIC)
2739             mg_get(sv);
2740         if (SvPOKp(sv)) {
2741             if (lp)
2742                 *lp = SvCUR(sv);
2743             if (flags & SV_MUTABLE_RETURN)
2744                 return SvPVX_mutable(sv);
2745             if (flags & SV_CONST_RETURN)
2746                 return (char *)SvPVX_const(sv);
2747             return SvPVX(sv);
2748         }
2749         if (SvIOKp(sv) || SvNOKp(sv)) {
2750             char tbuf[64];  /* Must fit sprintf/Gconvert of longest IV/NV */
2751             STRLEN len;
2752
2753             if (SvIOKp(sv)) {
2754                 len = SvIsUV(sv)
2755                     ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2756                     : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2757             } else {
2758                 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2759                 len = strlen(tbuf);
2760             }
2761             assert(!SvROK(sv));
2762             {
2763                 dVAR;
2764
2765 #ifdef FIXNEGATIVEZERO
2766                 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2767                     tbuf[0] = '0';
2768                     tbuf[1] = 0;
2769                     len = 1;
2770                 }
2771 #endif
2772                 SvUPGRADE(sv, SVt_PV);
2773                 if (lp)
2774                     *lp = len;
2775                 s = SvGROW_mutable(sv, len + 1);
2776                 SvCUR_set(sv, len);
2777                 SvPOKp_on(sv);
2778                 return (char*)memcpy(s, tbuf, len + 1);
2779             }
2780         }
2781         if (SvROK(sv)) {
2782             goto return_rok;
2783         }
2784         assert(SvTYPE(sv) >= SVt_PVMG);
2785         /* This falls through to the report_uninit near the end of the
2786            function. */
2787     } else if (SvTHINKFIRST(sv)) {
2788         if (SvROK(sv)) {
2789         return_rok:
2790             if (SvAMAGIC(sv)) {
2791                 SV *tmpstr;
2792                 if (flags & SV_SKIP_OVERLOAD)
2793                     return NULL;
2794                 tmpstr = AMG_CALLun(sv,string);
2795                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2796                     /* Unwrap this:  */
2797                     /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2798                      */
2799
2800                     char *pv;
2801                     if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2802                         if (flags & SV_CONST_RETURN) {
2803                             pv = (char *) SvPVX_const(tmpstr);
2804                         } else {
2805                             pv = (flags & SV_MUTABLE_RETURN)
2806                                 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2807                         }
2808                         if (lp)
2809                             *lp = SvCUR(tmpstr);
2810                     } else {
2811                         pv = sv_2pv_flags(tmpstr, lp, flags);
2812                     }
2813                     if (SvUTF8(tmpstr))
2814                         SvUTF8_on(sv);
2815                     else
2816                         SvUTF8_off(sv);
2817                     return pv;
2818                 }
2819             }
2820             {
2821                 STRLEN len;
2822                 char *retval;
2823                 char *buffer;
2824                 SV *const referent = SvRV(sv);
2825
2826                 if (!referent) {
2827                     len = 7;
2828                     retval = buffer = savepvn("NULLREF", len);
2829                 } else if (SvTYPE(referent) == SVt_REGEXP) {
2830                     REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2831                     I32 seen_evals = 0;
2832
2833                     assert(re);
2834                         
2835                     /* If the regex is UTF-8 we want the containing scalar to
2836                        have an UTF-8 flag too */
2837                     if (RX_UTF8(re))
2838                         SvUTF8_on(sv);
2839                     else
2840                         SvUTF8_off(sv); 
2841
2842                     if ((seen_evals = RX_SEEN_EVALS(re)))
2843                         PL_reginterp_cnt += seen_evals;
2844
2845                     if (lp)
2846                         *lp = RX_WRAPLEN(re);
2847  
2848                     return RX_WRAPPED(re);
2849                 } else {
2850                     const char *const typestr = sv_reftype(referent, 0);
2851                     const STRLEN typelen = strlen(typestr);
2852                     UV addr = PTR2UV(referent);
2853                     const char *stashname = NULL;
2854                     STRLEN stashnamelen = 0; /* hush, gcc */
2855                     const char *buffer_end;
2856
2857                     if (SvOBJECT(referent)) {
2858                         const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2859
2860                         if (name) {
2861                             stashname = HEK_KEY(name);
2862                             stashnamelen = HEK_LEN(name);
2863
2864                             if (HEK_UTF8(name)) {
2865                                 SvUTF8_on(sv);
2866                             } else {
2867                                 SvUTF8_off(sv);
2868                             }
2869                         } else {
2870                             stashname = "__ANON__";
2871                             stashnamelen = 8;
2872                         }
2873                         len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2874                             + 2 * sizeof(UV) + 2 /* )\0 */;
2875                     } else {
2876                         len = typelen + 3 /* (0x */
2877                             + 2 * sizeof(UV) + 2 /* )\0 */;
2878                     }
2879
2880                     Newx(buffer, len, char);
2881                     buffer_end = retval = buffer + len;
2882
2883                     /* Working backwards  */
2884                     *--retval = '\0';
2885                     *--retval = ')';
2886                     do {
2887                         *--retval = PL_hexdigit[addr & 15];
2888                     } while (addr >>= 4);
2889                     *--retval = 'x';
2890                     *--retval = '0';
2891                     *--retval = '(';
2892
2893                     retval -= typelen;
2894                     memcpy(retval, typestr, typelen);
2895
2896                     if (stashname) {
2897                         *--retval = '=';
2898                         retval -= stashnamelen;
2899                         memcpy(retval, stashname, stashnamelen);
2900                     }
2901                     /* retval may not neccesarily have reached the start of the
2902                        buffer here.  */
2903                     assert (retval >= buffer);
2904
2905                     len = buffer_end - retval - 1; /* -1 for that \0  */
2906                 }
2907                 if (lp)
2908                     *lp = len;
2909                 SAVEFREEPV(buffer);
2910                 return retval;
2911             }
2912         }
2913         if (SvREADONLY(sv) && !SvOK(sv)) {
2914             if (lp)
2915                 *lp = 0;
2916             if (flags & SV_UNDEF_RETURNS_NULL)
2917                 return NULL;
2918             if (ckWARN(WARN_UNINITIALIZED))
2919                 report_uninit(sv);
2920             return (char *)"";
2921         }
2922     }
2923     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2924         /* I'm assuming that if both IV and NV are equally valid then
2925            converting the IV is going to be more efficient */
2926         const U32 isUIOK = SvIsUV(sv);
2927         char buf[TYPE_CHARS(UV)];
2928         char *ebuf, *ptr;
2929         STRLEN len;
2930
2931         if (SvTYPE(sv) < SVt_PVIV)
2932             sv_upgrade(sv, SVt_PVIV);
2933         ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2934         len = ebuf - ptr;
2935         /* inlined from sv_setpvn */
2936         s = SvGROW_mutable(sv, len + 1);
2937         Move(ptr, s, len, char);
2938         s += len;
2939         *s = '\0';
2940     }
2941     else if (SvNOKp(sv)) {
2942         dSAVE_ERRNO;
2943         if (SvTYPE(sv) < SVt_PVNV)
2944             sv_upgrade(sv, SVt_PVNV);
2945         /* The +20 is pure guesswork.  Configure test needed. --jhi */
2946         s = SvGROW_mutable(sv, NV_DIG + 20);
2947         /* some Xenix systems wipe out errno here */
2948 #ifdef apollo
2949         if (SvNVX(sv) == 0.0)
2950             my_strlcpy(s, "0", SvLEN(sv));
2951         else
2952 #endif /*apollo*/
2953         {
2954             Gconvert(SvNVX(sv), NV_DIG, 0, s);
2955         }
2956         RESTORE_ERRNO;
2957 #ifdef FIXNEGATIVEZERO
2958         if (*s == '-' && s[1] == '0' && !s[2]) {
2959             s[0] = '0';
2960             s[1] = 0;
2961         }
2962 #endif
2963         while (*s) s++;
2964 #ifdef hcx
2965         if (s[-1] == '.')
2966             *--s = '\0';
2967 #endif
2968     }
2969     else {
2970         if (isGV_with_GP(sv)) {
2971             GV *const gv = MUTABLE_GV(sv);
2972             const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
2973             SV *const buffer = sv_newmortal();
2974
2975             /* FAKE globs can get coerced, so need to turn this off temporarily
2976                if it is on.  */
2977             SvFAKE_off(gv);
2978             gv_efullname3(buffer, gv, "*");
2979             SvFLAGS(gv) |= wasfake;
2980
2981             if (SvPOK(buffer)) {
2982                 if (lp) {
2983                     *lp = SvCUR(buffer);
2984                 }
2985                 return SvPVX(buffer);
2986             }
2987             else {
2988                 if (lp)
2989                     *lp = 0;
2990                 return (char *)"";
2991             }
2992         }
2993
2994         if (lp)
2995             *lp = 0;
2996         if (flags & SV_UNDEF_RETURNS_NULL)
2997             return NULL;
2998         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2999             report_uninit(sv);
3000         if (SvTYPE(sv) < SVt_PV)
3001             /* Typically the caller expects that sv_any is not NULL now.  */
3002             sv_upgrade(sv, SVt_PV);
3003         return (char *)"";
3004     }
3005     {
3006         const STRLEN len = s - SvPVX_const(sv);
3007         if (lp) 
3008             *lp = len;
3009         SvCUR_set(sv, len);
3010     }
3011     SvPOK_on(sv);
3012     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3013                           PTR2UV(sv),SvPVX_const(sv)));
3014     if (flags & SV_CONST_RETURN)
3015         return (char *)SvPVX_const(sv);
3016     if (flags & SV_MUTABLE_RETURN)
3017         return SvPVX_mutable(sv);
3018     return SvPVX(sv);
3019 }
3020
3021 /*
3022 =for apidoc sv_copypv
3023
3024 Copies a stringified representation of the source SV into the
3025 destination SV.  Automatically performs any necessary mg_get and
3026 coercion of numeric values into strings.  Guaranteed to preserve
3027 UTF8 flag even from overloaded objects.  Similar in nature to
3028 sv_2pv[_flags] but operates directly on an SV instead of just the
3029 string.  Mostly uses sv_2pv_flags to do its work, except when that
3030 would lose the UTF-8'ness of the PV.
3031
3032 =cut
3033 */
3034
3035 void
3036 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
3037 {
3038     STRLEN len;
3039     const char * const s = SvPV_const(ssv,len);
3040
3041     PERL_ARGS_ASSERT_SV_COPYPV;
3042
3043     sv_setpvn(dsv,s,len);
3044     if (SvUTF8(ssv))
3045         SvUTF8_on(dsv);
3046     else
3047         SvUTF8_off(dsv);
3048 }
3049
3050 /*
3051 =for apidoc sv_2pvbyte
3052
3053 Return a pointer to the byte-encoded representation of the SV, and set *lp
3054 to its length.  May cause the SV to be downgraded from UTF-8 as a
3055 side-effect.
3056
3057 Usually accessed via the C<SvPVbyte> macro.
3058
3059 =cut
3060 */
3061
3062 char *
3063 Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
3064 {
3065     PERL_ARGS_ASSERT_SV_2PVBYTE;
3066
3067     sv_utf8_downgrade(sv,0);
3068     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3069 }
3070
3071 /*
3072 =for apidoc sv_2pvutf8
3073
3074 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3075 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3076
3077 Usually accessed via the C<SvPVutf8> macro.
3078
3079 =cut
3080 */
3081
3082 char *
3083 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
3084 {
3085     PERL_ARGS_ASSERT_SV_2PVUTF8;
3086
3087     sv_utf8_upgrade(sv);
3088     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3089 }
3090
3091
3092 /*
3093 =for apidoc sv_2bool
3094
3095 This function is only called on magical items, and is only used by
3096 sv_true() or its macro equivalent.
3097
3098 =cut
3099 */
3100
3101 bool
3102 Perl_sv_2bool(pTHX_ register SV *const sv)
3103 {
3104     dVAR;
3105
3106     PERL_ARGS_ASSERT_SV_2BOOL;
3107
3108     SvGETMAGIC(sv);
3109
3110     if (!SvOK(sv))
3111         return 0;
3112     if (SvROK(sv)) {
3113         if (SvAMAGIC(sv)) {
3114             SV * const tmpsv = AMG_CALLun(sv,bool_);
3115             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3116                 return cBOOL(SvTRUE(tmpsv));
3117         }
3118         return SvRV(sv) != 0;
3119     }
3120     if (SvPOKp(sv)) {
3121         register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3122         if (Xpvtmp &&
3123                 (*sv->sv_u.svu_pv > '0' ||
3124                 Xpvtmp->xpv_cur > 1 ||
3125                 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3126             return 1;
3127         else
3128             return 0;
3129     }
3130     else {
3131         if (SvIOKp(sv))
3132             return SvIVX(sv) != 0;
3133         else {
3134             if (SvNOKp(sv))
3135                 return SvNVX(sv) != 0.0;
3136             else {
3137                 if (isGV_with_GP(sv))
3138                     return TRUE;
3139                 else
3140                     return FALSE;
3141             }
3142         }
3143     }
3144 }
3145
3146 /*
3147 =for apidoc sv_utf8_upgrade
3148
3149 Converts the PV of an SV to its UTF-8-encoded form.
3150 Forces the SV to string form if it is not already.
3151 Will C<mg_get> on C<sv> if appropriate.
3152 Always sets the SvUTF8 flag to avoid future validity checks even
3153 if the whole string is the same in UTF-8 as not.
3154 Returns the number of bytes in the converted string
3155
3156 This is not as a general purpose byte encoding to Unicode interface:
3157 use the Encode extension for that.
3158
3159 =for apidoc sv_utf8_upgrade_nomg
3160
3161 Like sv_utf8_upgrade, but doesn't do magic on C<sv>
3162
3163 =for apidoc sv_utf8_upgrade_flags
3164
3165 Converts the PV of an SV to its UTF-8-encoded form.
3166 Forces the SV to string form if it is not already.
3167 Always sets the SvUTF8 flag to avoid future validity checks even
3168 if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set,
3169 will C<mg_get> on C<sv> if appropriate, else not.
3170 Returns the number of bytes in the converted string
3171 C<sv_utf8_upgrade> and
3172 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3173
3174 This is not as a general purpose byte encoding to Unicode interface:
3175 use the Encode extension for that.
3176
3177 =cut
3178
3179 The grow version is currently not externally documented.  It adds a parameter,
3180 extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3181 have free after it upon return.  This allows the caller to reserve extra space
3182 that it intends to fill, to avoid extra grows.
3183
3184 Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3185 which can be used to tell this function to not first check to see if there are
3186 any characters that are different in UTF-8 (variant characters) which would
3187 force it to allocate a new string to sv, but to assume there are.  Typically
3188 this flag is used by a routine that has already parsed the string to find that
3189 there are such characters, and passes this information on so that the work
3190 doesn't have to be repeated.
3191
3192 (One might think that the calling routine could pass in the position of the
3193 first such variant, so it wouldn't have to be found again.  But that is not the
3194 case, because typically when the caller is likely to use this flag, it won't be
3195 calling this routine unless it finds something that won't fit into a byte.
3196 Otherwise it tries to not upgrade and just use bytes.  But some things that
3197 do fit into a byte are variants in utf8, and the caller may not have been
3198 keeping track of these.)
3199
3200 If the routine itself changes the string, it adds a trailing NUL.  Such a NUL
3201 isn't guaranteed due to having other routines do the work in some input cases,
3202 or if the input is already flagged as being in utf8.
3203
3204 The speed of this could perhaps be improved for many cases if someone wanted to
3205 write a fast function that counts the number of variant characters in a string,
3206 especially if it could return the position of the first one.
3207
3208 */
3209
3210 STRLEN
3211 Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
3212 {
3213     dVAR;
3214
3215     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3216
3217     if (sv == &PL_sv_undef)
3218         return 0;
3219     if (!SvPOK(sv)) {
3220         STRLEN len = 0;
3221         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3222             (void) sv_2pv_flags(sv,&len, flags);
3223             if (SvUTF8(sv)) {
3224                 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3225                 return len;
3226             }
3227         } else {
3228             (void) SvPV_force(sv,len);
3229         }
3230     }
3231
3232     if (SvUTF8(sv)) {
3233         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3234         return SvCUR(sv);
3235     }
3236
3237     if (SvIsCOW(sv)) {
3238         sv_force_normal_flags(sv, 0);
3239     }
3240
3241     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3242         sv_recode_to_utf8(sv, PL_encoding);
3243         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3244         return SvCUR(sv);
3245     }
3246
3247     if (SvCUR(sv) == 0) {
3248         if (extra) SvGROW(sv, extra);
3249     } else { /* Assume Latin-1/EBCDIC */
3250         /* This function could be much more efficient if we
3251          * had a FLAG in SVs to signal if there are any variant
3252          * chars in the PV.  Given that there isn't such a flag
3253          * make the loop as fast as possible (although there are certainly ways
3254          * to speed this up, eg. through vectorization) */
3255         U8 * s = (U8 *) SvPVX_const(sv);
3256         U8 * e = (U8 *) SvEND(sv);
3257         U8 *t = s;
3258         STRLEN two_byte_count = 0;
3259         
3260         if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3261
3262         /* See if really will need to convert to utf8.  We mustn't rely on our
3263          * incoming SV being well formed and having a trailing '\0', as certain
3264          * code in pp_formline can send us partially built SVs. */
3265
3266         while (t < e) {
3267             const U8 ch = *t++;
3268             if (NATIVE_IS_INVARIANT(ch)) continue;
3269
3270             t--;    /* t already incremented; re-point to first variant */
3271             two_byte_count = 1;
3272             goto must_be_utf8;
3273         }
3274
3275         /* utf8 conversion not needed because all are invariants.  Mark as
3276          * UTF-8 even if no variant - saves scanning loop */
3277         SvUTF8_on(sv);
3278         return SvCUR(sv);
3279
3280 must_be_utf8:
3281
3282         /* Here, the string should be converted to utf8, either because of an
3283          * input flag (two_byte_count = 0), or because a character that
3284          * requires 2 bytes was found (two_byte_count = 1).  t points either to
3285          * the beginning of the string (if we didn't examine anything), or to
3286          * the first variant.  In either case, everything from s to t - 1 will
3287          * occupy only 1 byte each on output.
3288          *
3289          * There are two main ways to convert.  One is to create a new string
3290          * and go through the input starting from the beginning, appending each
3291          * converted value onto the new string as we go along.  It's probably
3292          * best to allocate enough space in the string for the worst possible
3293          * case rather than possibly running out of space and having to
3294          * reallocate and then copy what we've done so far.  Since everything
3295          * from s to t - 1 is invariant, the destination can be initialized
3296          * with these using a fast memory copy
3297          *
3298          * The other way is to figure out exactly how big the string should be
3299          * by parsing the entire input.  Then you don't have to make it big
3300          * enough to handle the worst possible case, and more importantly, if
3301          * the string you already have is large enough, you don't have to
3302          * allocate a new string, you can copy the last character in the input
3303          * string to the final position(s) that will be occupied by the
3304          * converted string and go backwards, stopping at t, since everything
3305          * before that is invariant.
3306          *
3307          * There are advantages and disadvantages to each method.
3308          *
3309          * In the first method, we can allocate a new string, do the memory
3310          * copy from the s to t - 1, and then proceed through the rest of the
3311          * string byte-by-byte.
3312          *
3313          * In the second method, we proceed through the rest of the input
3314          * string just calculating how big the converted string will be.  Then
3315          * there are two cases:
3316          *  1)  if the string has enough extra space to handle the converted
3317          *      value.  We go backwards through the string, converting until we
3318          *      get to the position we are at now, and then stop.  If this
3319          *      position is far enough along in the string, this method is
3320          *      faster than the other method.  If the memory copy were the same
3321          *      speed as the byte-by-byte loop, that position would be about
3322          *      half-way, as at the half-way mark, parsing to the end and back
3323          *      is one complete string's parse, the same amount as starting
3324          *      over and going all the way through.  Actually, it would be
3325          *      somewhat less than half-way, as it's faster to just count bytes
3326          *      than to also copy, and we don't have the overhead of allocating
3327          *      a new string, changing the scalar to use it, and freeing the
3328          *      existing one.  But if the memory copy is fast, the break-even
3329          *      point is somewhere after half way.  The counting loop could be
3330          *      sped up by vectorization, etc, to move the break-even point
3331          *      further towards the beginning.
3332          *  2)  if the string doesn't have enough space to handle the converted
3333          *      value.  A new string will have to be allocated, and one might
3334          *      as well, given that, start from the beginning doing the first
3335          *      method.  We've spent extra time parsing the string and in
3336          *      exchange all we've gotten is that we know precisely how big to
3337          *      make the new one.  Perl is more optimized for time than space,
3338          *      so this case is a loser.
3339          * So what I've decided to do is not use the 2nd method unless it is
3340          * guaranteed that a new string won't have to be allocated, assuming
3341          * the worst case.  I also decided not to put any more conditions on it
3342          * than this, for now.  It seems likely that, since the worst case is
3343          * twice as big as the unknown portion of the string (plus 1), we won't
3344          * be guaranteed enough space, causing us to go to the first method,
3345          * unless the string is short, or the first variant character is near
3346          * the end of it.  In either of these cases, it seems best to use the
3347          * 2nd method.  The only circumstance I can think of where this would
3348          * be really slower is if the string had once had much more data in it
3349          * than it does now, but there is still a substantial amount in it  */
3350
3351         {
3352             STRLEN invariant_head = t - s;
3353             STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3354             if (SvLEN(sv) < size) {
3355
3356                 /* Here, have decided to allocate a new string */
3357
3358                 U8 *dst;
3359                 U8 *d;
3360
3361                 Newx(dst, size, U8);
3362
3363                 /* If no known invariants at the beginning of the input string,
3364                  * set so starts from there.  Otherwise, can use memory copy to
3365                  * get up to where we are now, and then start from here */
3366
3367                 if (invariant_head <= 0) {
3368                     d = dst;
3369                 } else {
3370                     Copy(s, dst, invariant_head, char);
3371                     d = dst + invariant_head;
3372                 }
3373
3374                 while (t < e) {
3375                     const UV uv = NATIVE8_TO_UNI(*t++);
3376                     if (UNI_IS_INVARIANT(uv))
3377                         *d++ = (U8)UNI_TO_NATIVE(uv);
3378                     else {
3379                         *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
3380                         *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
3381                     }
3382                 }
3383                 *d = '\0';
3384                 SvPV_free(sv); /* No longer using pre-existing string */
3385                 SvPV_set(sv, (char*)dst);
3386                 SvCUR_set(sv, d - dst);
3387                 SvLEN_set(sv, size);
3388             } else {
3389
3390                 /* Here, have decided to get the exact size of the string.
3391                  * Currently this happens only when we know that there is
3392                  * guaranteed enough space to fit the converted string, so
3393                  * don't have to worry about growing.  If two_byte_count is 0,
3394                  * then t points to the first byte of the string which hasn't
3395                  * been examined yet.  Otherwise two_byte_count is 1, and t
3396                  * points to the first byte in the string that will expand to
3397                  * two.  Depending on this, start examining at t or 1 after t.
3398                  * */
3399
3400                 U8 *d = t + two_byte_count;
3401
3402
3403                 /* Count up the remaining bytes that expand to two */
3404
3405                 while (d < e) {
3406                     const U8 chr = *d++;
3407                     if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
3408                 }
3409
3410                 /* The string will expand by just the number of bytes that
3411                  * occupy two positions.  But we are one afterwards because of
3412                  * the increment just above.  This is the place to put the
3413                  * trailing NUL, and to set the length before we decrement */
3414
3415                 d += two_byte_count;
3416                 SvCUR_set(sv, d - s);
3417                 *d-- = '\0';
3418
3419
3420                 /* Having decremented d, it points to the position to put the
3421                  * very last byte of the expanded string.  Go backwards through
3422                  * the string, copying and expanding as we go, stopping when we
3423                  * get to the part that is invariant the rest of the way down */
3424
3425                 e--;
3426                 while (e >= t) {
3427                     const U8 ch = NATIVE8_TO_UNI(*e--);
3428                     if (UNI_IS_INVARIANT(ch)) {
3429                         *d-- = UNI_TO_NATIVE(ch);
3430                     } else {
3431                         *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
3432                         *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
3433                     }
3434                 }
3435             }
3436         }
3437     }
3438
3439     /* Mark as UTF-8 even if no variant - saves scanning loop */
3440     SvUTF8_on(sv);
3441     return SvCUR(sv);
3442 }
3443
3444 /*
3445 =for apidoc sv_utf8_downgrade
3446
3447 Attempts to convert the PV of an SV from characters to bytes.
3448 If the PV contains a character that cannot fit
3449 in a byte, this conversion will fail;
3450 in this case, either returns false or, if C<fail_ok> is not
3451 true, croaks.
3452
3453 This is not as a general purpose Unicode to byte encoding interface:
3454 use the Encode extension for that.
3455
3456 =cut
3457 */
3458
3459 bool
3460 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3461 {
3462     dVAR;
3463
3464     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3465
3466     if (SvPOKp(sv) && SvUTF8(sv)) {
3467         if (SvCUR(sv)) {
3468             U8 *s;
3469             STRLEN len;
3470
3471             if (SvIsCOW(sv)) {
3472                 sv_force_normal_flags(sv, 0);
3473             }
3474             s = (U8 *) SvPV(sv, len);
3475             if (!utf8_to_bytes(s, &len)) {
3476                 if (fail_ok)
3477                     return FALSE;
3478                 else {
3479                     if (PL_op)
3480                         Perl_croak(aTHX_ "Wide character in %s",
3481                                    OP_DESC(PL_op));
3482                     else
3483                         Perl_croak(aTHX_ "Wide character");
3484                 }
3485             }
3486             SvCUR_set(sv, len);
3487         }
3488     }
3489     SvUTF8_off(sv);
3490     return TRUE;
3491 }
3492
3493 /*
3494 =for apidoc sv_utf8_encode
3495
3496 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3497 flag off so that it looks like octets again.
3498
3499 =cut
3500 */
3501
3502 void
3503 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3504 {
3505     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3506
3507     if (SvIsCOW(sv)) {
3508         sv_force_normal_flags(sv, 0);
3509     }
3510     if (SvREADONLY(sv)) {
3511         Perl_croak(aTHX_ "%s", PL_no_modify);
3512     }
3513     (void) sv_utf8_upgrade(sv);
3514     SvUTF8_off(sv);
3515 }
3516
3517 /*
3518 =for apidoc sv_utf8_decode
3519
3520 If the PV of the SV is an octet sequence in UTF-8
3521 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3522 so that it looks like a character. If the PV contains only single-byte
3523 characters, the C<SvUTF8> flag stays being off.
3524 Scans PV for validity and returns false if the PV is invalid UTF-8.
3525
3526 =cut
3527 */
3528
3529 bool
3530 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3531 {
3532     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3533
3534     if (SvPOKp(sv)) {
3535         const U8 *c;
3536         const U8 *e;
3537
3538         /* The octets may have got themselves encoded - get them back as
3539          * bytes
3540          */
3541         if (!sv_utf8_downgrade(sv, TRUE))
3542             return FALSE;
3543
3544         /* it is actually just a matter of turning the utf8 flag on, but
3545          * we want to make sure everything inside is valid utf8 first.
3546          */
3547         c = (const U8 *) SvPVX_const(sv);
3548         if (!is_utf8_string(c, SvCUR(sv)+1))
3549             return FALSE;
3550         e = (const U8 *) SvEND(sv);
3551         while (c < e) {
3552             const U8 ch = *c++;
3553             if (!UTF8_IS_INVARIANT(ch)) {
3554                 SvUTF8_on(sv);
3555                 break;
3556             }
3557         }
3558     }
3559     return TRUE;
3560 }
3561
3562 /*
3563 =for apidoc sv_setsv
3564
3565 Copies the contents of the source SV C<ssv> into the destination SV
3566 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3567 function if the source SV needs to be reused. Does not handle 'set' magic.
3568 Loosely speaking, it performs a copy-by-value, obliterating any previous
3569 content of the destination.
3570
3571 You probably want to use one of the assortment of wrappers, such as
3572 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3573 C<SvSetMagicSV_nosteal>.
3574
3575 =for apidoc sv_setsv_flags
3576
3577 Copies the contents of the source SV C<ssv> into the destination SV
3578 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3579 function if the source SV needs to be reused. Does not handle 'set' magic.
3580 Loosely speaking, it performs a copy-by-value, obliterating any previous
3581 content of the destination.
3582 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3583 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3584 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3585 and C<sv_setsv_nomg> are implemented in terms of this function.
3586
3587 You probably want to use one of the assortment of wrappers, such as
3588 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3589 C<SvSetMagicSV_nosteal>.
3590
3591 This is the primary function for copying scalars, and most other
3592 copy-ish functions and macros use this underneath.
3593
3594 =cut
3595 */
3596
3597 static void
3598 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3599 {
3600     I32 mro_changes = 0; /* 1 = method, 2 = isa */
3601
3602     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3603
3604     if (dtype != SVt_PVGV) {
3605         const char * const name = GvNAME(sstr);
3606         const STRLEN len = GvNAMELEN(sstr);
3607         {
3608             if (dtype >= SVt_PV) {
3609                 SvPV_free(dstr);
3610                 SvPV_set(dstr, 0);
3611                 SvLEN_set(dstr, 0);
3612                 SvCUR_set(dstr, 0);
3613             }
3614             SvUPGRADE(dstr, SVt_PVGV);
3615             (void)SvOK_off(dstr);
3616             /* FIXME - why are we doing this, then turning it off and on again
3617                below?  */
3618             isGV_with_GP_on(dstr);
3619         }
3620         GvSTASH(dstr) = GvSTASH(sstr);
3621         if (GvSTASH(dstr))
3622             Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3623         gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD);
3624         SvFAKE_on(dstr);        /* can coerce to non-glob */
3625     }
3626
3627     if(GvGP(MUTABLE_GV(sstr))) {
3628         /* If source has method cache entry, clear it */
3629         if(GvCVGEN(sstr)) {
3630             SvREFCNT_dec(GvCV(sstr));
3631             GvCV(sstr) = NULL;
3632             GvCVGEN(sstr) = 0;
3633         }
3634         /* If source has a real method, then a method is
3635            going to change */
3636         else if(GvCV((const GV *)sstr)) {
3637             mro_changes = 1;
3638         }
3639     }
3640
3641     /* If dest already had a real method, that's a change as well */
3642     if(!mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)) {
3643         mro_changes = 1;
3644     }
3645
3646     if(strEQ(GvNAME((const GV *)dstr),"ISA"))
3647         mro_changes = 2;
3648
3649     gp_free(MUTABLE_GV(dstr));
3650     isGV_with_GP_off(dstr);
3651     (void)SvOK_off(dstr);
3652     isGV_with_GP_on(dstr);
3653     GvINTRO_off(dstr);          /* one-shot flag */
3654     GvGP(dstr) = gp_ref(GvGP(sstr));
3655     if (SvTAINTED(sstr))
3656         SvTAINT(dstr);
3657     if (GvIMPORTED(dstr) != GVf_IMPORTED
3658         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3659         {
3660             GvIMPORTED_on(dstr);
3661         }
3662     GvMULTI_on(dstr);
3663     if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
3664     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3665     return;
3666 }
3667
3668 static void
3669 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3670 {
3671     SV * const sref = SvREFCNT_inc(SvRV(sstr));
3672     SV *dref = NULL;
3673     const int intro = GvINTRO(dstr);
3674     SV **location;
3675     U8 import_flag = 0;
3676     const U32 stype = SvTYPE(sref);
3677
3678     PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3679
3680     if (intro) {
3681         GvINTRO_off(dstr);      /* one-shot flag */
3682         GvLINE(dstr) = CopLINE(PL_curcop);
3683         GvEGV(dstr) = MUTABLE_GV(dstr);
3684     }
3685     GvMULTI_on(dstr);
3686     switch (stype) {
3687     case SVt_PVCV:
3688         location = (SV **) &GvCV(dstr);
3689         import_flag = GVf_IMPORTED_CV;
3690         goto common;
3691     case SVt_PVHV:
3692         location = (SV **) &GvHV(dstr);
3693         import_flag = GVf_IMPORTED_HV;
3694         goto common;
3695     case SVt_PVAV:
3696         location = (SV **) &GvAV(dstr);
3697         import_flag = GVf_IMPORTED_AV;
3698         goto common;
3699     case SVt_PVIO:
3700         location = (SV **) &GvIOp(dstr);
3701         goto common;
3702     case SVt_PVFM:
3703         location = (SV **) &GvFORM(dstr);
3704         goto common;
3705     default:
3706         location = &GvSV(dstr);
3707         import_flag = GVf_IMPORTED_SV;
3708     common:
3709         if (intro) {
3710             if (stype == SVt_PVCV) {
3711                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3712                 if (GvCVGEN(dstr)) {
3713                     SvREFCNT_dec(GvCV(dstr));
3714                     GvCV(dstr) = NULL;
3715                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3716                 }
3717             }
3718             SAVEGENERICSV(*location);
3719         }
3720         else
3721             dref = *location;
3722         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3723             CV* const cv = MUTABLE_CV(*location);
3724             if (cv) {
3725                 if (!GvCVGEN((const GV *)dstr) &&
3726                     (CvROOT(cv) || CvXSUB(cv)))
3727                     {
3728                         /* Redefining a sub - warning is mandatory if
3729                            it was a const and its value changed. */
3730                         if (CvCONST(cv) && CvCONST((const CV *)sref)
3731                             && cv_const_sv(cv)
3732                             == cv_const_sv((const CV *)sref)) {
3733                             NOOP;
3734                             /* They are 2 constant subroutines generated from
3735                                the same constant. This probably means that
3736                                they are really the "same" proxy subroutine
3737                                instantiated in 2 places. Most likely this is
3738                                when a constant is exported twice.  Don't warn.
3739                             */
3740                         }
3741                         else if (ckWARN(WARN_REDEFINE)
3742                                  || (CvCONST(cv)
3743                                      && (!CvCONST((const CV *)sref)
3744                                          || sv_cmp(cv_const_sv(cv),
3745                                                    cv_const_sv((const CV *)
3746                                                                sref))))) {
3747                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3748                                         (const char *)
3749                                         (CvCONST(cv)
3750                                          ? "Constant subroutine %s::%s redefined"
3751                                          : "Subroutine %s::%s redefined"),
3752                                         HvNAME_get(GvSTASH((const GV *)dstr)),
3753                                         GvENAME(MUTABLE_GV(dstr)));
3754                         }
3755                     }
3756                 if (!intro)
3757                     cv_ckproto_len(cv, (const GV *)dstr,
3758                                    SvPOK(sref) ? SvPVX_const(sref) : NULL,
3759                                    SvPOK(sref) ? SvCUR(sref) : 0);
3760             }
3761             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3762             GvASSUMECV_on(dstr);
3763             if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3764         }
3765         *location = sref;
3766         if (import_flag && !(GvFLAGS(dstr) & import_flag)
3767             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3768             GvFLAGS(dstr) |= import_flag;
3769         }
3770         if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) {
3771             sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3772             mro_isa_changed_in(GvSTASH(dstr));
3773         }
3774         break;
3775     }
3776     SvREFCNT_dec(dref);
3777     if (SvTAINTED(sstr))
3778         SvTAINT(dstr);
3779     return;
3780 }
3781
3782 void
3783 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3784 {
3785     dVAR;
3786     register U32 sflags;
3787     register int dtype;
3788     register svtype stype;
3789
3790     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3791
3792     if (sstr == dstr)
3793         return;
3794
3795     if (SvIS_FREED(dstr)) {
3796         Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3797                    " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3798     }
3799     SV_CHECK_THINKFIRST_COW_DROP(dstr);
3800     if (!sstr)
3801         sstr = &PL_sv_undef;
3802     if (SvIS_FREED(sstr)) {
3803         Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3804                    (void*)sstr, (void*)dstr);
3805     }
3806     stype = SvTYPE(sstr);
3807     dtype = SvTYPE(dstr);
3808
3809     (void)SvAMAGIC_off(dstr);
3810     if ( SvVOK(dstr) )
3811     {
3812         /* need to nuke the magic */
3813         mg_free(dstr);
3814     }
3815
3816     /* There's a lot of redundancy below but we're going for speed here */
3817
3818     switch (stype) {
3819     case SVt_NULL:
3820       undef_sstr:
3821         if (dtype != SVt_PVGV) {
3822             (void)SvOK_off(dstr);
3823             return;
3824         }
3825         break;
3826     case SVt_IV:
3827         if (SvIOK(sstr)) {
3828             switch (dtype) {
3829             case SVt_NULL:
3830                 sv_upgrade(dstr, SVt_IV);
3831                 break;
3832             case SVt_NV:
3833             case SVt_PV:
3834                 sv_upgrade(dstr, SVt_PVIV);
3835                 break;
3836             case SVt_PVGV:
3837                 goto end_of_first_switch;
3838             }
3839             (void)SvIOK_only(dstr);
3840             SvIV_set(dstr,  SvIVX(sstr));
3841             if (SvIsUV(sstr))
3842                 SvIsUV_on(dstr);
3843             /* SvTAINTED can only be true if the SV has taint magic, which in
3844                turn means that the SV type is PVMG (or greater). This is the
3845                case statement for SVt_IV, so this cannot be true (whatever gcov
3846                may say).  */
3847             assert(!SvTAINTED(sstr));
3848             return;
3849         }
3850         if (!SvROK(sstr))
3851             goto undef_sstr;
3852         if (dtype < SVt_PV && dtype != SVt_IV)
3853             sv_upgrade(dstr, SVt_IV);
3854         break;
3855
3856     case SVt_NV:
3857         if (SvNOK(sstr)) {
3858             switch (dtype) {
3859             case SVt_NULL:
3860             case SVt_IV:
3861                 sv_upgrade(dstr, SVt_NV);
3862                 break;
3863             case SVt_PV:
3864             case SVt_PVIV:
3865                 sv_upgrade(dstr, SVt_PVNV);
3866                 break;
3867             case SVt_PVGV:
3868                 goto end_of_first_switch;
3869             }
3870             SvNV_set(dstr, SvNVX(sstr));
3871             (void)SvNOK_only(dstr);
3872             /* SvTAINTED can only be true if the SV has taint magic, which in
3873                turn means that the SV type is PVMG (or greater). This is the
3874                case statement for SVt_NV, so this cannot be true (whatever gcov
3875                may say).  */
3876             assert(!SvTAINTED(sstr));
3877             return;
3878         }
3879         goto undef_sstr;
3880
3881     case SVt_PVFM:
3882 #ifdef PERL_OLD_COPY_ON_WRITE
3883         if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3884             if (dtype < SVt_PVIV)
3885                 sv_upgrade(dstr, SVt_PVIV);
3886             break;
3887         }
3888         /* Fall through */
3889 #endif
3890     case SVt_PV:
3891         if (dtype < SVt_PV)
3892             sv_upgrade(dstr, SVt_PV);
3893         break;
3894     case SVt_PVIV:
3895         if (dtype < SVt_PVIV)
3896             sv_upgrade(dstr, SVt_PVIV);
3897         break;
3898     case SVt_PVNV:
3899         if (dtype < SVt_PVNV)
3900             sv_upgrade(dstr, SVt_PVNV);
3901         break;
3902     default:
3903         {
3904         const char * const type = sv_reftype(sstr,0);
3905         if (PL_op)
3906             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
3907         else
3908             Perl_croak(aTHX_ "Bizarre copy of %s", type);
3909         }
3910         break;
3911
3912     case SVt_REGEXP:
3913         if (dtype < SVt_REGEXP)
3914             sv_upgrade(dstr, SVt_REGEXP);
3915         break;
3916
3917         /* case SVt_BIND: */
3918     case SVt_PVLV:
3919     case SVt_PVGV:
3920         if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
3921             glob_assign_glob(dstr, sstr, dtype);
3922             return;
3923         }
3924         /* SvVALID means that this PVGV is playing at being an FBM.  */
3925         /*FALLTHROUGH*/
3926
3927     case SVt_PVMG:
3928         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3929             mg_get(sstr);
3930             if (SvTYPE(sstr) != stype) {
3931                 stype = SvTYPE(sstr);
3932                 if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
3933                     glob_assign_glob(dstr, sstr, dtype);
3934                     return;
3935                 }
3936             }
3937         }
3938         if (stype == SVt_PVLV)
3939             SvUPGRADE(dstr, SVt_PVNV);
3940         else
3941             SvUPGRADE(dstr, (svtype)stype);
3942     }
3943  end_of_first_switch:
3944
3945     /* dstr may have been upgraded.  */
3946     dtype = SvTYPE(dstr);
3947     sflags = SvFLAGS(sstr);
3948
3949     if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
3950         /* Assigning to a subroutine sets the prototype.  */
3951         if (SvOK(sstr)) {
3952             STRLEN len;
3953             const char *const ptr = SvPV_const(sstr, len);
3954
3955             SvGROW(dstr, len + 1);
3956             Copy(ptr, SvPVX(dstr), len + 1, char);
3957             SvCUR_set(dstr, len);
3958             SvPOK_only(dstr);
3959             SvFLAGS(dstr) |= sflags & SVf_UTF8;
3960         } else {
3961             SvOK_off(dstr);
3962         }
3963     } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
3964         const char * const type = sv_reftype(dstr,0);
3965         if (PL_op)
3966             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
3967         else
3968             Perl_croak(aTHX_ "Cannot copy to %s", type);
3969     } else if (sflags & SVf_ROK) {
3970         if (isGV_with_GP(dstr) && dtype == SVt_PVGV
3971             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
3972             sstr = SvRV(sstr);
3973             if (sstr == dstr) {
3974                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3975                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3976                 {
3977                     GvIMPORTED_on(dstr);
3978                 }
3979                 GvMULTI_on(dstr);
3980                 return;
3981             }
3982             glob_assign_glob(dstr, sstr, dtype);
3983             return;
3984         }
3985
3986         if (dtype >= SVt_PV) {
3987             if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3988                 glob_assign_ref(dstr, sstr);
3989                 return;
3990             }
3991             if (SvPVX_const(dstr)) {
3992                 SvPV_free(dstr);
3993                 SvLEN_set(dstr, 0);
3994                 SvCUR_set(dstr, 0);
3995             }
3996         }
3997         (void)SvOK_off(dstr);
3998         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3999         SvFLAGS(dstr) |= sflags & SVf_ROK;
4000         assert(!(sflags & SVp_NOK));
4001         assert(!(sflags & SVp_IOK));
4002         assert(!(sflags & SVf_NOK));
4003         assert(!(sflags & SVf_IOK));
4004     }
4005     else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
4006         if (!(sflags & SVf_OK)) {
4007             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4008                            "Undefined value assigned to typeglob");
4009         }
4010         else {
4011             GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
4012             if (dstr != (const SV *)gv) {
4013                 if (GvGP(dstr))
4014                     gp_free(MUTABLE_GV(dstr));
4015                 GvGP(dstr) = gp_ref(GvGP(gv));
4016             }
4017         }
4018     }
4019     else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
4020         reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4021     }
4022     else if (sflags & SVp_POK) {
4023         bool isSwipe = 0;
4024
4025         /*
4026          * Check to see if we can just swipe the string.  If so, it's a
4027          * possible small lose on short strings, but a big win on long ones.
4028          * It might even be a win on short strings if SvPVX_const(dstr)
4029          * has to be allocated and SvPVX_const(sstr) has to be freed.
4030          * Likewise if we can set up COW rather than doing an actual copy, we
4031          * drop to the else clause, as the swipe code and the COW setup code
4032          * have much in common.
4033          */
4034
4035         /* Whichever path we take through the next code, we want this true,
4036            and doing it now facilitates the COW check.  */
4037         (void)SvPOK_only(dstr);
4038
4039         if (
4040             /* If we're already COW then this clause is not true, and if COW
4041                is allowed then we drop down to the else and make dest COW 
4042                with us.  If caller hasn't said that we're allowed to COW
4043                shared hash keys then we don't do the COW setup, even if the
4044                source scalar is a shared hash key scalar.  */
4045             (((flags & SV_COW_SHARED_HASH_KEYS)
4046                ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
4047                : 1 /* If making a COW copy is forbidden then the behaviour we
4048                        desire is as if the source SV isn't actually already
4049                        COW, even if it is.  So we act as if the source flags
4050                        are not COW, rather than actually testing them.  */
4051               )
4052 #ifndef PERL_OLD_COPY_ON_WRITE
4053              /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4054                 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4055                 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4056                 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4057                 but in turn, it's somewhat dead code, never expected to go
4058                 live, but more kept as a placeholder on how to do it better
4059                 in a newer implementation.  */
4060              /* If we are COW and dstr is a suitable target then we drop down
4061                 into the else and make dest a COW of us.  */
4062              || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4063 #endif
4064              )
4065             &&
4066             !(isSwipe =
4067                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
4068                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4069                  (!(flags & SV_NOSTEAL)) &&
4070                                         /* and we're allowed to steal temps */
4071                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4072                  SvLEN(sstr))             /* and really is a string */
4073 #ifdef PERL_OLD_COPY_ON_WRITE
4074             && ((flags & SV_COW_SHARED_HASH_KEYS)
4075                 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4076                      && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4077                      && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
4078                 : 1)
4079 #endif
4080             ) {
4081             /* Failed the swipe test, and it's not a shared hash key either.
4082                Have to copy the string.  */
4083             STRLEN len = SvCUR(sstr);
4084             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
4085             Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4086             SvCUR_set(dstr, len);
4087             *SvEND(dstr) = '\0';
4088         } else {
4089             /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4090                be true in here.  */
4091             /* Either it's a shared hash key, or it's suitable for
4092                copy-on-write or we can swipe the string.  */
4093             if (DEBUG_C_TEST) {
4094                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4095                 sv_dump(sstr);
4096                 sv_dump(dstr);
4097             }
4098 #ifdef PERL_OLD_COPY_ON_WRITE
4099             if (!isSwipe) {
4100                 if ((sflags & (SVf_FAKE | SVf_READONLY))
4101                     != (SVf_FAKE | SVf_READONLY)) {
4102                     SvREADONLY_on(sstr);
4103                     SvFAKE_on(sstr);
4104                     /* Make the source SV into a loop of 1.
4105                        (about to become 2) */
4106                     SV_COW_NEXT_SV_SET(sstr, sstr);
4107                 }
4108             }
4109 #endif
4110             /* Initial code is common.  */
4111             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
4112                 SvPV_free(dstr);
4113             }
4114
4115             if (!isSwipe) {
4116                 /* making another shared SV.  */
4117                 STRLEN cur = SvCUR(sstr);
4118                 STRLEN len = SvLEN(sstr);
4119 #ifdef PERL_OLD_COPY_ON_WRITE
4120                 if (len) {
4121                     assert (SvTYPE(dstr) >= SVt_PVIV);
4122                     /* SvIsCOW_normal */
4123                     /* splice us in between source and next-after-source.  */
4124                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4125                     SV_COW_NEXT_SV_SET(sstr, dstr);
4126                     SvPV_set(dstr, SvPVX_mutable(sstr));
4127                 } else
4128 #endif
4129                 {
4130                     /* SvIsCOW_shared_hash */
4131                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4132                                           "Copy on write: Sharing hash\n"));
4133
4134                     assert (SvTYPE(dstr) >= SVt_PV);
4135                     SvPV_set(dstr,
4136                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4137                 }
4138                 SvLEN_set(dstr, len);
4139                 SvCUR_set(dstr, cur);
4140                 SvREADONLY_on(dstr);
4141                 SvFAKE_on(dstr);
4142             }
4143             else
4144                 {       /* Passes the swipe test.  */
4145                 SvPV_set(dstr, SvPVX_mutable(sstr));
4146                 SvLEN_set(dstr, SvLEN(sstr));
4147                 SvCUR_set(dstr, SvCUR(sstr));
4148
4149                 SvTEMP_off(dstr);
4150                 (void)SvOK_off(sstr);   /* NOTE: nukes most SvFLAGS on sstr */
4151                 SvPV_set(sstr, NULL);
4152                 SvLEN_set(sstr, 0);
4153                 SvCUR_set(sstr, 0);
4154                 SvTEMP_off(sstr);
4155             }
4156         }
4157         if (sflags & SVp_NOK) {
4158             SvNV_set(dstr, SvNVX(sstr));
4159         }
4160         if (sflags & SVp_IOK) {
4161             SvIV_set(dstr, SvIVX(sstr));
4162             /* Must do this otherwise some other overloaded use of 0x80000000
4163                gets confused. I guess SVpbm_VALID */
4164             if (sflags & SVf_IVisUV)
4165                 SvIsUV_on(dstr);
4166         }
4167         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4168         {
4169             const MAGIC * const smg = SvVSTRING_mg(sstr);
4170             if (smg) {
4171                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4172                          smg->mg_ptr, smg->mg_len);
4173                 SvRMAGICAL_on(dstr);
4174             }
4175         }
4176     }
4177     else if (sflags & (SVp_IOK|SVp_NOK)) {
4178         (void)SvOK_off(dstr);
4179         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4180         if (sflags & SVp_IOK) {
4181             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4182             SvIV_set(dstr, SvIVX(sstr));
4183         }
4184         if (sflags & SVp_NOK) {
4185             SvNV_set(dstr, SvNVX(sstr));
4186         }
4187     }
4188     else {
4189         if (isGV_with_GP(sstr)) {
4190             /* This stringification rule for globs is spread in 3 places.
4191                This feels bad. FIXME.  */
4192             const U32 wasfake = sflags & SVf_FAKE;
4193
4194             /* FAKE globs can get coerced, so need to turn this off
4195                temporarily if it is on.  */
4196             SvFAKE_off(sstr);
4197             gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4198             SvFLAGS(sstr) |= wasfake;
4199         }
4200         else
4201             (void)SvOK_off(dstr);
4202     }
4203     if (SvTAINTED(sstr))
4204         SvTAINT(dstr);
4205 }
4206
4207 /*
4208 =for apidoc sv_setsv_mg
4209
4210 Like C<sv_setsv>, but also handles 'set' magic.
4211
4212 =cut
4213 */
4214
4215 void
4216 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4217 {
4218     PERL_ARGS_ASSERT_SV_SETSV_MG;
4219
4220     sv_setsv(dstr,sstr);
4221     SvSETMAGIC(dstr);
4222 }
4223
4224 #ifdef PERL_OLD_COPY_ON_WRITE
4225 SV *
4226 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4227 {
4228     STRLEN cur = SvCUR(sstr);
4229     STRLEN len = SvLEN(sstr);
4230     register char *new_pv;
4231
4232     PERL_ARGS_ASSERT_SV_SETSV_COW;
4233
4234     if (DEBUG_C_TEST) {
4235         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4236                       (void*)sstr, (void*)dstr);
4237         sv_dump(sstr);
4238         if (dstr)
4239                     sv_dump(dstr);
4240     }
4241
4242     if (dstr) {
4243         if (SvTHINKFIRST(dstr))
4244             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4245         else if (SvPVX_const(dstr))
4246             Safefree(SvPVX_const(dstr));
4247     }
4248     else
4249         new_SV(dstr);
4250     SvUPGRADE(dstr, SVt_PVIV);
4251
4252     assert (SvPOK(sstr));
4253     assert (SvPOKp(sstr));
4254     assert (!SvIOK(sstr));
4255     assert (!SvIOKp(sstr));
4256     assert (!SvNOK(sstr));
4257     assert (!SvNOKp(sstr));
4258
4259     if (SvIsCOW(sstr)) {
4260
4261         if (SvLEN(sstr) == 0) {
4262             /* source is a COW shared hash key.  */
4263             DEBUG_C(PerlIO_printf(Perl_debug_log,
4264                                   "Fast copy on write: Sharing hash\n"));
4265             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4266             goto common_exit;
4267         }
4268         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4269     } else {
4270         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4271         SvUPGRADE(sstr, SVt_PVIV);
4272         SvREADONLY_on(sstr);
4273         SvFAKE_on(sstr);
4274         DEBUG_C(PerlIO_printf(Perl_debug_log,
4275                               "Fast copy on write: Converting sstr to COW\n"));
4276         SV_COW_NEXT_SV_SET(dstr, sstr);
4277     }
4278     SV_COW_NEXT_SV_SET(sstr, dstr);
4279     new_pv = SvPVX_mutable(sstr);
4280
4281   common_exit:
4282     SvPV_set(dstr, new_pv);
4283     SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4284     if (SvUTF8(sstr))
4285         SvUTF8_on(dstr);
4286     SvLEN_set(dstr, len);
4287     SvCUR_set(dstr, cur);
4288     if (DEBUG_C_TEST) {
4289         sv_dump(dstr);
4290     }
4291     return dstr;
4292 }
4293 #endif
4294
4295 /*
4296 =for apidoc sv_setpvn
4297
4298 Copies a string into an SV.  The C<len> parameter indicates the number of
4299 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4300 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4301
4302 =cut
4303 */
4304
4305 void
4306 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4307 {
4308     dVAR;
4309     register char *dptr;
4310
4311     PERL_ARGS_ASSERT_SV_SETPVN;
4312
4313     SV_CHECK_THINKFIRST_COW_DROP(sv);
4314     if (!ptr) {
4315         (void)SvOK_off(sv);
4316         return;
4317     }
4318     else {
4319         /* len is STRLEN which is unsigned, need to copy to signed */
4320         const IV iv = len;
4321         if (iv < 0)
4322             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4323     }
4324     SvUPGRADE(sv, SVt_PV);
4325
4326     dptr = SvGROW(sv, len + 1);
4327     Move(ptr,dptr,len,char);
4328     dptr[len] = '\0';
4329     SvCUR_set(sv, len);
4330     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4331     SvTAINT(sv);
4332 }
4333
4334 /*
4335 =for apidoc sv_setpvn_mg
4336
4337 Like C<sv_setpvn>, but also handles 'set' magic.
4338
4339 =cut
4340 */
4341
4342 void
4343 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4344 {
4345     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4346
4347     sv_setpvn(sv,ptr,len);
4348     SvSETMAGIC(sv);
4349 }
4350
4351 /*
4352 =for apidoc sv_setpv
4353
4354 Copies a string into an SV.  The string must be null-terminated.  Does not
4355 handle 'set' magic.  See C<sv_setpv_mg>.
4356
4357 =cut
4358 */
4359
4360 void
4361 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4362 {
4363     dVAR;
4364     register STRLEN len;
4365
4366     PERL_ARGS_ASSERT_SV_SETPV;
4367
4368     SV_CHECK_THINKFIRST_COW_DROP(sv);
4369     if (!ptr) {
4370         (void)SvOK_off(sv);
4371         return;
4372     }
4373     len = strlen(ptr);
4374     SvUPGRADE(sv, SVt_PV);
4375
4376     SvGROW(sv, len + 1);
4377     Move(ptr,SvPVX(sv),len+1,char);
4378     SvCUR_set(sv, len);
4379     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4380     SvTAINT(sv);
4381 }
4382
4383 /*
4384 =for apidoc sv_setpv_mg
4385
4386 Like C<sv_setpv>, but also handles 'set' magic.
4387
4388 =cut
4389 */
4390
4391 void
4392 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4393 {
4394     PERL_ARGS_ASSERT_SV_SETPV_MG;
4395
4396     sv_setpv(sv,ptr);
4397     SvSETMAGIC(sv);
4398 }
4399
4400 /*
4401 =for apidoc sv_usepvn_flags
4402
4403 Tells an SV to use C<ptr> to find its string value.  Normally the
4404 string is stored inside the SV but sv_usepvn allows the SV to use an
4405 outside string.  The C<ptr> should point to memory that was allocated
4406 by C<malloc>.  The string length, C<len>, must be supplied.  By default
4407 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4408 so that pointer should not be freed or used by the programmer after
4409 giving it to sv_usepvn, and neither should any pointers from "behind"
4410 that pointer (e.g. ptr + 1) be used.
4411
4412 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4413 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4414 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4415 C<len>, and already meets the requirements for storing in C<SvPVX>)
4416
4417 =cut
4418 */
4419
4420 void
4421 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4422 {
4423     dVAR;
4424     STRLEN allocate;
4425
4426     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4427
4428     SV_CHECK_THINKFIRST_COW_DROP(sv);
4429     SvUPGRADE(sv, SVt_PV);
4430     if (!ptr) {
4431         (void)SvOK_off(sv);
4432         if (flags & SV_SMAGIC)
4433             SvSETMAGIC(sv);
4434         return;
4435     }
4436     if (SvPVX_const(sv))
4437         SvPV_free(sv);
4438
4439 #ifdef DEBUGGING
4440     if (flags & SV_HAS_TRAILING_NUL)
4441         assert(ptr[len] == '\0');
4442 #endif
4443
4444     allocate = (flags & SV_HAS_TRAILING_NUL)
4445         ? len + 1 :
4446 #ifdef Perl_safesysmalloc_size
4447         len + 1;
4448 #else 
4449         PERL_STRLEN_ROUNDUP(len + 1);
4450 #endif
4451     if (flags & SV_HAS_TRAILING_NUL) {
4452         /* It's long enough - do nothing.
4453            Specfically Perl_newCONSTSUB is relying on this.  */
4454     } else {
4455 #ifdef DEBUGGING
4456         /* Force a move to shake out bugs in callers.  */
4457         char *new_ptr = (char*)safemalloc(allocate);
4458         Copy(ptr, new_ptr, len, char);
4459         PoisonFree(ptr,len,char);
4460         Safefree(ptr);
4461         ptr = new_ptr;
4462 #else
4463         ptr = (char*) saferealloc (ptr, allocate);
4464 #endif
4465     }
4466 #ifdef Perl_safesysmalloc_size
4467     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4468 #else
4469     SvLEN_set(sv, allocate);
4470 #endif
4471     SvCUR_set(sv, len);
4472     SvPV_set(sv, ptr);
4473     if (!(flags & SV_HAS_TRAILING_NUL)) {
4474         ptr[len] = '\0';
4475     }
4476     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4477     SvTAINT(sv);
4478     if (flags & SV_SMAGIC)
4479         SvSETMAGIC(sv);
4480 }
4481
4482 #ifdef PERL_OLD_COPY_ON_WRITE
4483 /* Need to do this *after* making the SV normal, as we need the buffer
4484    pointer to remain valid until after we've copied it.  If we let go too early,
4485    another thread could invalidate it by unsharing last of the same hash key
4486    (which it can do by means other than releasing copy-on-write Svs)
4487    or by changing the other copy-on-write SVs in the loop.  */
4488 STATIC void
4489 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4490 {
4491     PERL_ARGS_ASSERT_SV_RELEASE_COW;
4492
4493     { /* this SV was SvIsCOW_normal(sv) */
4494          /* we need to find the SV pointing to us.  */
4495         SV *current = SV_COW_NEXT_SV(after);
4496
4497         if (current == sv) {
4498             /* The SV we point to points back to us (there were only two of us
4499                in the loop.)
4500                Hence other SV is no longer copy on write either.  */
4501             SvFAKE_off(after);
4502             SvREADONLY_off(after);
4503         } else {
4504             /* We need to follow the pointers around the loop.  */
4505             SV *next;
4506             while ((next = SV_COW_NEXT_SV(current)) != sv) {
4507                 assert (next);
4508                 current = next;
4509                  /* don't loop forever if the structure is bust, and we have
4510                     a pointer into a closed loop.  */
4511                 assert (current != after);
4512                 assert (SvPVX_const(current) == pvx);
4513             }
4514             /* Make the SV before us point to the SV after us.  */
4515             SV_COW_NEXT_SV_SET(current, after);
4516         }
4517     }
4518 }
4519 #endif
4520 /*
4521 =for apidoc sv_force_normal_flags
4522
4523 Undo various types of fakery on an SV: if the PV is a shared string, make
4524 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4525 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4526 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4527 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4528 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4529 set to some other value.) In addition, the C<flags> parameter gets passed to
4530 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4531 with flags set to 0.
4532
4533 =cut
4534 */
4535
4536 void
4537 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4538 {
4539     dVAR;
4540
4541     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4542
4543 #ifdef PERL_OLD_COPY_ON_WRITE
4544     if (SvREADONLY(sv)) {
4545         if (SvFAKE(sv)) {
4546             const char * const pvx = SvPVX_const(sv);
4547             const STRLEN len = SvLEN(sv);
4548             const STRLEN cur = SvCUR(sv);
4549             /* next COW sv in the loop.  If len is 0 then this is a shared-hash
4550                key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4551                we'll fail an assertion.  */
4552             SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4553
4554             if (DEBUG_C_TEST) {
4555                 PerlIO_printf(Perl_debug_log,
4556                               "Copy on write: Force normal %ld\n",
4557                               (long) flags);
4558                 sv_dump(sv);
4559             }
4560             SvFAKE_off(sv);
4561             SvREADONLY_off(sv);
4562             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
4563             SvPV_set(sv, NULL);
4564             SvLEN_set(sv, 0);
4565             if (flags & SV_COW_DROP_PV) {
4566                 /* OK, so we don't need to copy our buffer.  */
4567                 SvPOK_off(sv);
4568             } else {
4569                 SvGROW(sv, cur + 1);
4570                 Move(pvx,SvPVX(sv),cur,char);
4571                 SvCUR_set(sv, cur);
4572                 *SvEND(sv) = '\0';
4573             }
4574             if (len) {
4575                 sv_release_COW(sv, pvx, next);
4576             } else {
4577                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4578             }
4579             if (DEBUG_C_TEST) {
4580                 sv_dump(sv);
4581             }
4582         }
4583         else if (IN_PERL_RUNTIME)
4584             Perl_croak(aTHX_ "%s", PL_no_modify);
4585     }
4586 #else
4587     if (SvREADONLY(sv)) {
4588         if (SvFAKE(sv)) {
4589             const char * const pvx = SvPVX_const(sv);
4590             const STRLEN len = SvCUR(sv);
4591             SvFAKE_off(sv);
4592             SvREADONLY_off(sv);
4593             SvPV_set(sv, NULL);
4594             SvLEN_set(sv, 0);
4595             SvGROW(sv, len + 1);
4596             Move(pvx,SvPVX(sv),len,char);
4597             *SvEND(sv) = '\0';
4598             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4599         }
4600         else if (IN_PERL_RUNTIME)
4601             Perl_croak(aTHX_ "%s", PL_no_modify);
4602     }
4603 #endif
4604     if (SvROK(sv))
4605         sv_unref_flags(sv, flags);
4606     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4607         sv_unglob(sv);
4608     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
4609         /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous
4610            to sv_unglob. We only need it here, so inline it.  */
4611         const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
4612         SV *const temp = newSV_type(new_type);
4613         void *const temp_p = SvANY(sv);
4614
4615         if (new_type == SVt_PVMG) {
4616             SvMAGIC_set(temp, SvMAGIC(sv));
4617             SvMAGIC_set(sv, NULL);
4618             SvSTASH_set(temp, SvSTASH(sv));
4619             SvSTASH_set(sv, NULL);
4620         }
4621         SvCUR_set(temp, SvCUR(sv));
4622         /* Remember that SvPVX is in the head, not the body. */
4623         if (SvLEN(temp)) {
4624             SvLEN_set(temp, SvLEN(sv));
4625             /* This signals "buffer is owned by someone else" in sv_clear,
4626                which is the least effort way to stop it freeing the buffer.
4627             */
4628             SvLEN_set(sv, SvLEN(sv)+1);
4629         } else {
4630             /* Their buffer is already owned by someone else. */
4631             SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
4632             SvLEN_set(temp, SvCUR(sv)+1);
4633         }
4634
4635         /* Now swap the rest of the bodies. */
4636
4637         SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
4638         SvFLAGS(sv) |= new_type;
4639         SvANY(sv) = SvANY(temp);
4640
4641         SvFLAGS(temp) &= ~(SVTYPEMASK);
4642         SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
4643         SvANY(temp) = temp_p;
4644
4645         SvREFCNT_dec(temp);
4646     }
4647 }
4648
4649 /*
4650 =for apidoc sv_chop
4651
4652 Efficient removal of characters from the beginning of the string buffer.
4653 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4654 the string buffer.  The C<ptr> becomes the first character of the adjusted
4655 string. Uses the "OOK hack".
4656 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4657 refer to the same chunk of data.
4658
4659 =cut
4660 */
4661
4662 void
4663 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4664 {
4665     STRLEN delta;
4666     STRLEN old_delta;
4667     U8 *p;
4668 #ifdef DEBUGGING
4669     const U8 *real_start;
4670 #endif
4671     STRLEN max_delta;
4672
4673     PERL_ARGS_ASSERT_SV_CHOP;
4674
4675     if (!ptr || !SvPOKp(sv))
4676         return;
4677     delta = ptr - SvPVX_const(sv);
4678     if (!delta) {
4679         /* Nothing to do.  */
4680         return;
4681     }