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