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