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