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