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