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