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