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