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