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