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