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