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