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