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