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