This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
SvSetSV() is not returnable, but that's okay since
[perl5.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_ 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_ WARN_UNINITIALIZED, PL_warn_uninit,
550                     " in ", OP_DESC(PL_op));
551     else
552         Perl_warner(aTHX_ 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;
1230     U32         cur;
1231     U32         len;
1232     IV          iv;
1233     NV          nv;
1234     MAGIC*      magic;
1235     HV*         stash;
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 #ifdef HAS_64K_LIMIT
1544     if (newlen >= 0x10000) {
1545         PerlIO_printf(Perl_debug_log,
1546                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1547         my_exit(1);
1548     }
1549 #endif /* HAS_64K_LIMIT */
1550     if (SvROK(sv))
1551         sv_unref(sv);
1552     if (SvTYPE(sv) < SVt_PV) {
1553         sv_upgrade(sv, SVt_PV);
1554         s = SvPVX(sv);
1555     }
1556     else if (SvOOK(sv)) {       /* pv is offset? */
1557         sv_backoff(sv);
1558         s = SvPVX(sv);
1559         if (newlen > SvLEN(sv))
1560             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1561 #ifdef HAS_64K_LIMIT
1562         if (newlen >= 0x10000)
1563             newlen = 0xFFFF;
1564 #endif
1565     }
1566     else
1567         s = SvPVX(sv);
1568     if (newlen > SvLEN(sv)) {           /* need more room? */
1569         if (SvLEN(sv) && s) {
1570 #if defined(MYMALLOC) && !defined(LEAKTEST)
1571             STRLEN l = malloced_size((void*)SvPVX(sv));
1572             if (newlen <= l) {
1573                 SvLEN_set(sv, l);
1574                 return s;
1575             } else
1576 #endif
1577             Renew(s,newlen,char);
1578         }
1579         else {
1580             /* sv_force_normal_flags() must not try to unshare the new
1581                PVX we allocate below. AMS 20010713 */
1582             if (SvREADONLY(sv) && SvFAKE(sv)) {
1583                 SvFAKE_off(sv);
1584                 SvREADONLY_off(sv);
1585             }
1586             New(703, s, newlen, char);
1587             if (SvPVX(sv) && SvCUR(sv)) {
1588                 Move(SvPVX(sv), s, SvCUR(sv), char);
1589             }
1590         }
1591         SvPV_set(sv, s);
1592         SvLEN_set(sv, newlen);
1593     }
1594     return s;
1595 }
1596
1597 /*
1598 =for apidoc sv_setiv
1599
1600 Copies an integer into the given SV, upgrading first if necessary.
1601 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1602
1603 =cut
1604 */
1605
1606 void
1607 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1608 {
1609     SV_CHECK_THINKFIRST(sv);
1610     switch (SvTYPE(sv)) {
1611     case SVt_NULL:
1612         sv_upgrade(sv, SVt_IV);
1613         break;
1614     case SVt_NV:
1615         sv_upgrade(sv, SVt_PVNV);
1616         break;
1617     case SVt_RV:
1618     case SVt_PV:
1619         sv_upgrade(sv, SVt_PVIV);
1620         break;
1621
1622     case SVt_PVGV:
1623     case SVt_PVAV:
1624     case SVt_PVHV:
1625     case SVt_PVCV:
1626     case SVt_PVFM:
1627     case SVt_PVIO:
1628         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1629                    OP_DESC(PL_op));
1630     }
1631     (void)SvIOK_only(sv);                       /* validate number */
1632     SvIVX(sv) = i;
1633     SvTAINT(sv);
1634 }
1635
1636 /*
1637 =for apidoc sv_setiv_mg
1638
1639 Like C<sv_setiv>, but also handles 'set' magic.
1640
1641 =cut
1642 */
1643
1644 void
1645 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1646 {
1647     sv_setiv(sv,i);
1648     SvSETMAGIC(sv);
1649 }
1650
1651 /*
1652 =for apidoc sv_setuv
1653
1654 Copies an unsigned integer into the given SV, upgrading first if necessary.
1655 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1656
1657 =cut
1658 */
1659
1660 void
1661 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1662 {
1663     /* With these two if statements:
1664        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1665
1666        without
1667        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1668
1669        If you wish to remove them, please benchmark to see what the effect is
1670     */
1671     if (u <= (UV)IV_MAX) {
1672        sv_setiv(sv, (IV)u);
1673        return;
1674     }
1675     sv_setiv(sv, 0);
1676     SvIsUV_on(sv);
1677     SvUVX(sv) = u;
1678 }
1679
1680 /*
1681 =for apidoc sv_setuv_mg
1682
1683 Like C<sv_setuv>, but also handles 'set' magic.
1684
1685 =cut
1686 */
1687
1688 void
1689 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1690 {
1691     /* With these two if statements:
1692        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1693
1694        without
1695        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1696
1697        If you wish to remove them, please benchmark to see what the effect is
1698     */
1699     if (u <= (UV)IV_MAX) {
1700        sv_setiv(sv, (IV)u);
1701     } else {
1702        sv_setiv(sv, 0);
1703        SvIsUV_on(sv);
1704        sv_setuv(sv,u);
1705     }
1706     SvSETMAGIC(sv);
1707 }
1708
1709 /*
1710 =for apidoc sv_setnv
1711
1712 Copies a double into the given SV, upgrading first if necessary.
1713 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1714
1715 =cut
1716 */
1717
1718 void
1719 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1720 {
1721     SV_CHECK_THINKFIRST(sv);
1722     switch (SvTYPE(sv)) {
1723     case SVt_NULL:
1724     case SVt_IV:
1725         sv_upgrade(sv, SVt_NV);
1726         break;
1727     case SVt_RV:
1728     case SVt_PV:
1729     case SVt_PVIV:
1730         sv_upgrade(sv, SVt_PVNV);
1731         break;
1732
1733     case SVt_PVGV:
1734     case SVt_PVAV:
1735     case SVt_PVHV:
1736     case SVt_PVCV:
1737     case SVt_PVFM:
1738     case SVt_PVIO:
1739         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1740                    OP_NAME(PL_op));
1741     }
1742     SvNVX(sv) = num;
1743     (void)SvNOK_only(sv);                       /* validate number */
1744     SvTAINT(sv);
1745 }
1746
1747 /*
1748 =for apidoc sv_setnv_mg
1749
1750 Like C<sv_setnv>, but also handles 'set' magic.
1751
1752 =cut
1753 */
1754
1755 void
1756 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1757 {
1758     sv_setnv(sv,num);
1759     SvSETMAGIC(sv);
1760 }
1761
1762 /* Print an "isn't numeric" warning, using a cleaned-up,
1763  * printable version of the offending string
1764  */
1765
1766 STATIC void
1767 S_not_a_number(pTHX_ SV *sv)
1768 {
1769      SV *dsv;
1770      char tmpbuf[64];
1771      char *pv;
1772
1773      if (DO_UTF8(sv)) {
1774           dsv = sv_2mortal(newSVpv("", 0));
1775           pv = sv_uni_display(dsv, sv, 10, 0);
1776      } else {
1777           char *d = tmpbuf;
1778           char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1779           /* each *s can expand to 4 chars + "...\0",
1780              i.e. need room for 8 chars */
1781         
1782           char *s, *end;
1783           for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
1784                int ch = *s & 0xFF;
1785                if (ch & 128 && !isPRINT_LC(ch)) {
1786                     *d++ = 'M';
1787                     *d++ = '-';
1788                     ch &= 127;
1789                }
1790                if (ch == '\n') {
1791                     *d++ = '\\';
1792                     *d++ = 'n';
1793                }
1794                else if (ch == '\r') {
1795                     *d++ = '\\';
1796                     *d++ = 'r';
1797                }
1798                else if (ch == '\f') {
1799                     *d++ = '\\';
1800                     *d++ = 'f';
1801                }
1802                else if (ch == '\\') {
1803                     *d++ = '\\';
1804                     *d++ = '\\';
1805                }
1806                else if (ch == '\0') {
1807                     *d++ = '\\';
1808                     *d++ = '0';
1809                }
1810                else if (isPRINT_LC(ch))
1811                     *d++ = ch;
1812                else {
1813                     *d++ = '^';
1814                     *d++ = toCTRL(ch);
1815                }
1816           }
1817           if (s < end) {
1818                *d++ = '.';
1819                *d++ = '.';
1820                *d++ = '.';
1821           }
1822           *d = '\0';
1823           pv = tmpbuf;
1824     }
1825
1826     if (PL_op)
1827         Perl_warner(aTHX_ WARN_NUMERIC,
1828                     "Argument \"%s\" isn't numeric in %s", pv,
1829                     OP_DESC(PL_op));
1830     else
1831         Perl_warner(aTHX_ WARN_NUMERIC,
1832                     "Argument \"%s\" isn't numeric", pv);
1833 }
1834
1835 /*
1836 =for apidoc looks_like_number
1837
1838 Test if the content of an SV looks like a number (or is a number).
1839 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1840 non-numeric warning), even if your atof() doesn't grok them.
1841
1842 =cut
1843 */
1844
1845 I32
1846 Perl_looks_like_number(pTHX_ SV *sv)
1847 {
1848     register char *sbegin;
1849     STRLEN len;
1850
1851     if (SvPOK(sv)) {
1852         sbegin = SvPVX(sv);
1853         len = SvCUR(sv);
1854     }
1855     else if (SvPOKp(sv))
1856         sbegin = SvPV(sv, len);
1857     else
1858         return 1; /* Historic.  Wrong?  */
1859     return grok_number(sbegin, len, NULL);
1860 }
1861
1862 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1863    until proven guilty, assume that things are not that bad... */
1864
1865 /*
1866    NV_PRESERVES_UV:
1867
1868    As 64 bit platforms often have an NV that doesn't preserve all bits of
1869    an IV (an assumption perl has been based on to date) it becomes necessary
1870    to remove the assumption that the NV always carries enough precision to
1871    recreate the IV whenever needed, and that the NV is the canonical form.
1872    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1873    precision as a side effect of conversion (which would lead to insanity
1874    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1875    1) to distinguish between IV/UV/NV slots that have cached a valid
1876       conversion where precision was lost and IV/UV/NV slots that have a
1877       valid conversion which has lost no precision
1878    2) to ensure that if a numeric conversion to one form is requested that
1879       would lose precision, the precise conversion (or differently
1880       imprecise conversion) is also performed and cached, to prevent
1881       requests for different numeric formats on the same SV causing
1882       lossy conversion chains. (lossless conversion chains are perfectly
1883       acceptable (still))
1884
1885
1886    flags are used:
1887    SvIOKp is true if the IV slot contains a valid value
1888    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1889    SvNOKp is true if the NV slot contains a valid value
1890    SvNOK  is true only if the NV value is accurate
1891
1892    so
1893    while converting from PV to NV, check to see if converting that NV to an
1894    IV(or UV) would lose accuracy over a direct conversion from PV to
1895    IV(or UV). If it would, cache both conversions, return NV, but mark
1896    SV as IOK NOKp (ie not NOK).
1897
1898    While converting from PV to IV, check to see if converting that IV to an
1899    NV would lose accuracy over a direct conversion from PV to NV. If it
1900    would, cache both conversions, flag similarly.
1901
1902    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1903    correctly because if IV & NV were set NV *always* overruled.
1904    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1905    changes - now IV and NV together means that the two are interchangeable:
1906    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1907
1908    The benefit of this is that operations such as pp_add know that if
1909    SvIOK is true for both left and right operands, then integer addition
1910    can be used instead of floating point (for cases where the result won't
1911    overflow). Before, floating point was always used, which could lead to
1912    loss of precision compared with integer addition.
1913
1914    * making IV and NV equal status should make maths accurate on 64 bit
1915      platforms
1916    * may speed up maths somewhat if pp_add and friends start to use
1917      integers when possible instead of fp. (Hopefully the overhead in
1918      looking for SvIOK and checking for overflow will not outweigh the
1919      fp to integer speedup)
1920    * will slow down integer operations (callers of SvIV) on "inaccurate"
1921      values, as the change from SvIOK to SvIOKp will cause a call into
1922      sv_2iv each time rather than a macro access direct to the IV slot
1923    * should speed up number->string conversion on integers as IV is
1924      favoured when IV and NV are equally accurate
1925
1926    ####################################################################
1927    You had better be using SvIOK_notUV if you want an IV for arithmetic:
1928    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1929    On the other hand, SvUOK is true iff UV.
1930    ####################################################################
1931
1932    Your mileage will vary depending your CPU's relative fp to integer
1933    performance ratio.
1934 */
1935
1936 #ifndef NV_PRESERVES_UV
1937 #  define IS_NUMBER_UNDERFLOW_IV 1
1938 #  define IS_NUMBER_UNDERFLOW_UV 2
1939 #  define IS_NUMBER_IV_AND_UV    2
1940 #  define IS_NUMBER_OVERFLOW_IV  4
1941 #  define IS_NUMBER_OVERFLOW_UV  5
1942
1943 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1944
1945 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1946 STATIC int
1947 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
1948 {
1949     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));
1950     if (SvNVX(sv) < (NV)IV_MIN) {
1951         (void)SvIOKp_on(sv);
1952         (void)SvNOK_on(sv);
1953         SvIVX(sv) = IV_MIN;
1954         return IS_NUMBER_UNDERFLOW_IV;
1955     }
1956     if (SvNVX(sv) > (NV)UV_MAX) {
1957         (void)SvIOKp_on(sv);
1958         (void)SvNOK_on(sv);
1959         SvIsUV_on(sv);
1960         SvUVX(sv) = UV_MAX;
1961         return IS_NUMBER_OVERFLOW_UV;
1962     }
1963     (void)SvIOKp_on(sv);
1964     (void)SvNOK_on(sv);
1965     /* Can't use strtol etc to convert this string.  (See truth table in
1966        sv_2iv  */
1967     if (SvNVX(sv) <= (UV)IV_MAX) {
1968         SvIVX(sv) = I_V(SvNVX(sv));
1969         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1970             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1971         } else {
1972             /* Integer is imprecise. NOK, IOKp */
1973         }
1974         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1975     }
1976     SvIsUV_on(sv);
1977     SvUVX(sv) = U_V(SvNVX(sv));
1978     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1979         if (SvUVX(sv) == UV_MAX) {
1980             /* As we know that NVs don't preserve UVs, UV_MAX cannot
1981                possibly be preserved by NV. Hence, it must be overflow.
1982                NOK, IOKp */
1983             return IS_NUMBER_OVERFLOW_UV;
1984         }
1985         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1986     } else {
1987         /* Integer is imprecise. NOK, IOKp */
1988     }
1989     return IS_NUMBER_OVERFLOW_IV;
1990 }
1991 #endif /* !NV_PRESERVES_UV*/
1992
1993 /*
1994 =for apidoc sv_2iv
1995
1996 Return the integer value of an SV, doing any necessary string conversion,
1997 magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
1998
1999 =cut
2000 */
2001
2002 IV
2003 Perl_sv_2iv(pTHX_ register SV *sv)
2004 {
2005     if (!sv)
2006         return 0;
2007     if (SvGMAGICAL(sv)) {
2008         mg_get(sv);
2009         if (SvIOKp(sv))
2010             return SvIVX(sv);
2011         if (SvNOKp(sv)) {
2012             return I_V(SvNVX(sv));
2013         }
2014         if (SvPOKp(sv) && SvLEN(sv))
2015             return asIV(sv);
2016         if (!SvROK(sv)) {
2017             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2018                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2019                     report_uninit();
2020             }
2021             return 0;
2022         }
2023     }
2024     if (SvTHINKFIRST(sv)) {
2025         if (SvROK(sv)) {
2026           SV* tmpstr;
2027           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2028                 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2029               return SvIV(tmpstr);
2030           return PTR2IV(SvRV(sv));
2031         }
2032         if (SvREADONLY(sv) && SvFAKE(sv)) {
2033             sv_force_normal(sv);
2034         }
2035         if (SvREADONLY(sv) && !SvOK(sv)) {
2036             if (ckWARN(WARN_UNINITIALIZED))
2037                 report_uninit();
2038             return 0;
2039         }
2040     }
2041     if (SvIOKp(sv)) {
2042         if (SvIsUV(sv)) {
2043             return (IV)(SvUVX(sv));
2044         }
2045         else {
2046             return SvIVX(sv);
2047         }
2048     }
2049     if (SvNOKp(sv)) {
2050         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2051          * without also getting a cached IV/UV from it at the same time
2052          * (ie PV->NV conversion should detect loss of accuracy and cache
2053          * IV or UV at same time to avoid this.  NWC */
2054
2055         if (SvTYPE(sv) == SVt_NV)
2056             sv_upgrade(sv, SVt_PVNV);
2057
2058         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2059         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2060            certainly cast into the IV range at IV_MAX, whereas the correct
2061            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2062            cases go to UV */
2063         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2064             SvIVX(sv) = I_V(SvNVX(sv));
2065             if (SvNVX(sv) == (NV) SvIVX(sv)
2066 #ifndef NV_PRESERVES_UV
2067                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2068                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2069                 /* Don't flag it as "accurately an integer" if the number
2070                    came from a (by definition imprecise) NV operation, and
2071                    we're outside the range of NV integer precision */
2072 #endif
2073                 ) {
2074                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2075                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2076                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2077                                       PTR2UV(sv),
2078                                       SvNVX(sv),
2079                                       SvIVX(sv)));
2080
2081             } else {
2082                 /* IV not precise.  No need to convert from PV, as NV
2083                    conversion would already have cached IV if it detected
2084                    that PV->IV would be better than PV->NV->IV
2085                    flags already correct - don't set public IOK.  */
2086                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2087                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2088                                       PTR2UV(sv),
2089                                       SvNVX(sv),
2090                                       SvIVX(sv)));
2091             }
2092             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2093                but the cast (NV)IV_MIN rounds to a the value less (more
2094                negative) than IV_MIN which happens to be equal to SvNVX ??
2095                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2096                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2097                (NV)UVX == NVX are both true, but the values differ. :-(
2098                Hopefully for 2s complement IV_MIN is something like
2099                0x8000000000000000 which will be exact. NWC */
2100         }
2101         else {
2102             SvUVX(sv) = U_V(SvNVX(sv));
2103             if (
2104                 (SvNVX(sv) == (NV) SvUVX(sv))
2105 #ifndef  NV_PRESERVES_UV
2106                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2107                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2108                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2109                 /* Don't flag it as "accurately an integer" if the number
2110                    came from a (by definition imprecise) NV operation, and
2111                    we're outside the range of NV integer precision */
2112 #endif
2113                 )
2114                 SvIOK_on(sv);
2115             SvIsUV_on(sv);
2116           ret_iv_max:
2117             DEBUG_c(PerlIO_printf(Perl_debug_log,
2118                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2119                                   PTR2UV(sv),
2120                                   SvUVX(sv),
2121                                   SvUVX(sv)));
2122             return (IV)SvUVX(sv);
2123         }
2124     }
2125     else if (SvPOKp(sv) && SvLEN(sv)) {
2126         UV value;
2127         int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2128         /* We want to avoid a possible problem when we cache an IV which
2129            may be later translated to an NV, and the resulting NV is not
2130            the same as the direct translation of the initial string
2131            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2132            be careful to ensure that the value with the .456 is around if the
2133            NV value is requested in the future).
2134         
2135            This means that if we cache such an IV, we need to cache the
2136            NV as well.  Moreover, we trade speed for space, and do not
2137            cache the NV if we are sure it's not needed.
2138          */
2139
2140         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2141         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2142              == IS_NUMBER_IN_UV) {
2143             /* It's definitely an integer, only upgrade to PVIV */
2144             if (SvTYPE(sv) < SVt_PVIV)
2145                 sv_upgrade(sv, SVt_PVIV);
2146             (void)SvIOK_on(sv);
2147         } else if (SvTYPE(sv) < SVt_PVNV)
2148             sv_upgrade(sv, SVt_PVNV);
2149
2150         /* If NV preserves UV then we only use the UV value if we know that
2151            we aren't going to call atof() below. If NVs don't preserve UVs
2152            then the value returned may have more precision than atof() will
2153            return, even though value isn't perfectly accurate.  */
2154         if ((numtype & (IS_NUMBER_IN_UV
2155 #ifdef NV_PRESERVES_UV
2156                         | IS_NUMBER_NOT_INT
2157 #endif
2158             )) == IS_NUMBER_IN_UV) {
2159             /* This won't turn off the public IOK flag if it was set above  */
2160             (void)SvIOKp_on(sv);
2161
2162             if (!(numtype & IS_NUMBER_NEG)) {
2163                 /* positive */;
2164                 if (value <= (UV)IV_MAX) {
2165                     SvIVX(sv) = (IV)value;
2166                 } else {
2167                     SvUVX(sv) = value;
2168                     SvIsUV_on(sv);
2169                 }
2170             } else {
2171                 /* 2s complement assumption  */
2172                 if (value <= (UV)IV_MIN) {
2173                     SvIVX(sv) = -(IV)value;
2174                 } else {
2175                     /* Too negative for an IV.  This is a double upgrade, but
2176                        I'm assuming it will be rare.  */
2177                     if (SvTYPE(sv) < SVt_PVNV)
2178                         sv_upgrade(sv, SVt_PVNV);
2179                     SvNOK_on(sv);
2180                     SvIOK_off(sv);
2181                     SvIOKp_on(sv);
2182                     SvNVX(sv) = -(NV)value;
2183                     SvIVX(sv) = IV_MIN;
2184                 }
2185             }
2186         }
2187         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2188            will be in the previous block to set the IV slot, and the next
2189            block to set the NV slot.  So no else here.  */
2190         
2191         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2192             != IS_NUMBER_IN_UV) {
2193             /* It wasn't an (integer that doesn't overflow the UV). */
2194             SvNVX(sv) = Atof(SvPVX(sv));
2195
2196             if (! numtype && ckWARN(WARN_NUMERIC))
2197                 not_a_number(sv);
2198
2199 #if defined(USE_LONG_DOUBLE)
2200             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2201                                   PTR2UV(sv), SvNVX(sv)));
2202 #else
2203             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2204                                   PTR2UV(sv), SvNVX(sv)));
2205 #endif
2206
2207
2208 #ifdef NV_PRESERVES_UV
2209             (void)SvIOKp_on(sv);
2210             (void)SvNOK_on(sv);
2211             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2212                 SvIVX(sv) = I_V(SvNVX(sv));
2213                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2214                     SvIOK_on(sv);
2215                 } else {
2216                     /* Integer is imprecise. NOK, IOKp */
2217                 }
2218                 /* UV will not work better than IV */
2219             } else {
2220                 if (SvNVX(sv) > (NV)UV_MAX) {
2221                     SvIsUV_on(sv);
2222                     /* Integer is inaccurate. NOK, IOKp, is UV */
2223                     SvUVX(sv) = UV_MAX;
2224                     SvIsUV_on(sv);
2225                 } else {
2226                     SvUVX(sv) = U_V(SvNVX(sv));
2227                     /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2228                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2229                         SvIOK_on(sv);
2230                         SvIsUV_on(sv);
2231                     } else {
2232                         /* Integer is imprecise. NOK, IOKp, is UV */
2233                         SvIsUV_on(sv);
2234                     }
2235                 }
2236                 goto ret_iv_max;
2237             }
2238 #else /* NV_PRESERVES_UV */
2239             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2240                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2241                 /* The IV slot will have been set from value returned by
2242                    grok_number above.  The NV slot has just been set using
2243                    Atof.  */
2244                 SvNOK_on(sv);
2245                 assert (SvIOKp(sv));
2246             } else {
2247                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2248                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2249                     /* Small enough to preserve all bits. */
2250                     (void)SvIOKp_on(sv);
2251                     SvNOK_on(sv);
2252                     SvIVX(sv) = I_V(SvNVX(sv));
2253                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2254                         SvIOK_on(sv);
2255                     /* Assumption: first non-preserved integer is < IV_MAX,
2256                        this NV is in the preserved range, therefore: */
2257                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2258                           < (UV)IV_MAX)) {
2259                         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);
2260                     }
2261                 } else {
2262                     /* IN_UV NOT_INT
2263                          0      0       already failed to read UV.
2264                          0      1       already failed to read UV.
2265                          1      0       you won't get here in this case. IV/UV
2266                                         slot set, public IOK, Atof() unneeded.
2267                          1      1       already read UV.
2268                        so there's no point in sv_2iuv_non_preserve() attempting
2269                        to use atol, strtol, strtoul etc.  */
2270                     if (sv_2iuv_non_preserve (sv, numtype)
2271                         >= IS_NUMBER_OVERFLOW_IV)
2272                     goto ret_iv_max;
2273                 }
2274             }
2275 #endif /* NV_PRESERVES_UV */
2276         }
2277     } else  {
2278         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2279             report_uninit();
2280         if (SvTYPE(sv) < SVt_IV)
2281             /* Typically the caller expects that sv_any is not NULL now.  */
2282             sv_upgrade(sv, SVt_IV);
2283         return 0;
2284     }
2285     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2286         PTR2UV(sv),SvIVX(sv)));
2287     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2288 }
2289
2290 /*
2291 =for apidoc sv_2uv
2292
2293 Return the unsigned integer value of an SV, doing any necessary string
2294 conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
2295 macros.
2296
2297 =cut
2298 */
2299
2300 UV
2301 Perl_sv_2uv(pTHX_ register SV *sv)
2302 {
2303     if (!sv)
2304         return 0;
2305     if (SvGMAGICAL(sv)) {
2306         mg_get(sv);
2307         if (SvIOKp(sv))
2308             return SvUVX(sv);
2309         if (SvNOKp(sv))
2310             return U_V(SvNVX(sv));
2311         if (SvPOKp(sv) && SvLEN(sv))
2312             return asUV(sv);
2313         if (!SvROK(sv)) {
2314             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2315                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2316                     report_uninit();
2317             }
2318             return 0;
2319         }
2320     }
2321     if (SvTHINKFIRST(sv)) {
2322         if (SvROK(sv)) {
2323           SV* tmpstr;
2324           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2325                 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2326               return SvUV(tmpstr);
2327           return PTR2UV(SvRV(sv));
2328         }
2329         if (SvREADONLY(sv) && SvFAKE(sv)) {
2330             sv_force_normal(sv);
2331         }
2332         if (SvREADONLY(sv) && !SvOK(sv)) {
2333             if (ckWARN(WARN_UNINITIALIZED))
2334                 report_uninit();
2335             return 0;
2336         }
2337     }
2338     if (SvIOKp(sv)) {
2339         if (SvIsUV(sv)) {
2340             return SvUVX(sv);
2341         }
2342         else {
2343             return (UV)SvIVX(sv);
2344         }
2345     }
2346     if (SvNOKp(sv)) {
2347         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2348          * without also getting a cached IV/UV from it at the same time
2349          * (ie PV->NV conversion should detect loss of accuracy and cache
2350          * IV or UV at same time to avoid this. */
2351         /* IV-over-UV optimisation - choose to cache IV if possible */
2352
2353         if (SvTYPE(sv) == SVt_NV)
2354             sv_upgrade(sv, SVt_PVNV);
2355
2356         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2357         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2358             SvIVX(sv) = I_V(SvNVX(sv));
2359             if (SvNVX(sv) == (NV) SvIVX(sv)
2360 #ifndef NV_PRESERVES_UV
2361                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2362                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2363                 /* Don't flag it as "accurately an integer" if the number
2364                    came from a (by definition imprecise) NV operation, and
2365                    we're outside the range of NV integer precision */
2366 #endif
2367                 ) {
2368                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2369                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2370                                       "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2371                                       PTR2UV(sv),
2372                                       SvNVX(sv),
2373                                       SvIVX(sv)));
2374
2375             } else {
2376                 /* IV not precise.  No need to convert from PV, as NV
2377                    conversion would already have cached IV if it detected
2378                    that PV->IV would be better than PV->NV->IV
2379                    flags already correct - don't set public IOK.  */
2380                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2381                                       "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2382                                       PTR2UV(sv),
2383                                       SvNVX(sv),
2384                                       SvIVX(sv)));
2385             }
2386             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2387                but the cast (NV)IV_MIN rounds to a the value less (more
2388                negative) than IV_MIN which happens to be equal to SvNVX ??
2389                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2390                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2391                (NV)UVX == NVX are both true, but the values differ. :-(
2392                Hopefully for 2s complement IV_MIN is something like
2393                0x8000000000000000 which will be exact. NWC */
2394         }
2395         else {
2396             SvUVX(sv) = U_V(SvNVX(sv));
2397             if (
2398                 (SvNVX(sv) == (NV) SvUVX(sv))
2399 #ifndef  NV_PRESERVES_UV
2400                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2401                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2402                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2403                 /* Don't flag it as "accurately an integer" if the number
2404                    came from a (by definition imprecise) NV operation, and
2405                    we're outside the range of NV integer precision */
2406 #endif
2407                 )
2408                 SvIOK_on(sv);
2409             SvIsUV_on(sv);
2410             DEBUG_c(PerlIO_printf(Perl_debug_log,
2411                                   "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2412                                   PTR2UV(sv),
2413                                   SvUVX(sv),
2414                                   SvUVX(sv)));
2415         }
2416     }
2417     else if (SvPOKp(sv) && SvLEN(sv)) {
2418         UV value;
2419         int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2420
2421         /* We want to avoid a possible problem when we cache a UV which
2422            may be later translated to an NV, and the resulting NV is not
2423            the translation of the initial data.
2424         
2425            This means that if we cache such a UV, we need to cache the
2426            NV as well.  Moreover, we trade speed for space, and do not
2427            cache the NV if not needed.
2428          */
2429
2430         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2431         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2432              == IS_NUMBER_IN_UV) {
2433             /* It's definitely an integer, only upgrade to PVIV */
2434             if (SvTYPE(sv) < SVt_PVIV)
2435                 sv_upgrade(sv, SVt_PVIV);
2436             (void)SvIOK_on(sv);
2437         } else if (SvTYPE(sv) < SVt_PVNV)
2438             sv_upgrade(sv, SVt_PVNV);
2439
2440         /* If NV preserves UV then we only use the UV value if we know that
2441            we aren't going to call atof() below. If NVs don't preserve UVs
2442            then the value returned may have more precision than atof() will
2443            return, even though it isn't accurate.  */
2444         if ((numtype & (IS_NUMBER_IN_UV
2445 #ifdef NV_PRESERVES_UV
2446                         | IS_NUMBER_NOT_INT
2447 #endif
2448             )) == IS_NUMBER_IN_UV) {
2449             /* This won't turn off the public IOK flag if it was set above  */
2450             (void)SvIOKp_on(sv);
2451
2452             if (!(numtype & IS_NUMBER_NEG)) {
2453                 /* positive */;
2454                 if (value <= (UV)IV_MAX) {
2455                     SvIVX(sv) = (IV)value;
2456                 } else {
2457                     /* it didn't overflow, and it was positive. */
2458                     SvUVX(sv) = value;
2459                     SvIsUV_on(sv);
2460                 }
2461             } else {
2462                 /* 2s complement assumption  */
2463                 if (value <= (UV)IV_MIN) {
2464                     SvIVX(sv) = -(IV)value;
2465                 } else {
2466                     /* Too negative for an IV.  This is a double upgrade, but
2467                        I'm assuming it will be rare.  */
2468                     if (SvTYPE(sv) < SVt_PVNV)
2469                         sv_upgrade(sv, SVt_PVNV);
2470                     SvNOK_on(sv);
2471                     SvIOK_off(sv);
2472                     SvIOKp_on(sv);
2473                     SvNVX(sv) = -(NV)value;
2474                     SvIVX(sv) = IV_MIN;
2475                 }
2476             }
2477         }
2478         
2479         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2480             != IS_NUMBER_IN_UV) {
2481             /* It wasn't an integer, or it overflowed the UV. */
2482             SvNVX(sv) = Atof(SvPVX(sv));
2483
2484             if (! numtype && ckWARN(WARN_NUMERIC))
2485                     not_a_number(sv);
2486
2487 #if defined(USE_LONG_DOUBLE)
2488             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2489                                   PTR2UV(sv), SvNVX(sv)));
2490 #else
2491             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2492                                   PTR2UV(sv), SvNVX(sv)));
2493 #endif
2494
2495 #ifdef NV_PRESERVES_UV
2496             (void)SvIOKp_on(sv);
2497             (void)SvNOK_on(sv);
2498             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2499                 SvIVX(sv) = I_V(SvNVX(sv));
2500                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2501                     SvIOK_on(sv);
2502                 } else {
2503                     /* Integer is imprecise. NOK, IOKp */
2504                 }
2505                 /* UV will not work better than IV */
2506             } else {
2507                 if (SvNVX(sv) > (NV)UV_MAX) {
2508                     SvIsUV_on(sv);
2509                     /* Integer is inaccurate. NOK, IOKp, is UV */
2510                     SvUVX(sv) = UV_MAX;
2511                     SvIsUV_on(sv);
2512                 } else {
2513                     SvUVX(sv) = U_V(SvNVX(sv));
2514                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2515                        NV preservse UV so can do correct comparison.  */
2516                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2517                         SvIOK_on(sv);
2518                         SvIsUV_on(sv);
2519                     } else {
2520                         /* Integer is imprecise. NOK, IOKp, is UV */
2521                         SvIsUV_on(sv);
2522                     }
2523                 }
2524             }
2525 #else /* NV_PRESERVES_UV */
2526             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2527                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2528                 /* The UV slot will have been set from value returned by
2529                    grok_number above.  The NV slot has just been set using
2530                    Atof.  */
2531                 SvNOK_on(sv);
2532                 assert (SvIOKp(sv));
2533             } else {
2534                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2535                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2536                     /* Small enough to preserve all bits. */
2537                     (void)SvIOKp_on(sv);
2538                     SvNOK_on(sv);
2539                     SvIVX(sv) = I_V(SvNVX(sv));
2540                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2541                         SvIOK_on(sv);
2542                     /* Assumption: first non-preserved integer is < IV_MAX,
2543                        this NV is in the preserved range, therefore: */
2544                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2545                           < (UV)IV_MAX)) {
2546                         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);
2547                     }
2548                 } else
2549                     sv_2iuv_non_preserve (sv, numtype);
2550             }
2551 #endif /* NV_PRESERVES_UV */
2552         }
2553     }
2554     else  {
2555         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2556             if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2557                 report_uninit();
2558         }
2559         if (SvTYPE(sv) < SVt_IV)
2560             /* Typically the caller expects that sv_any is not NULL now.  */
2561             sv_upgrade(sv, SVt_IV);
2562         return 0;
2563     }
2564
2565     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2566                           PTR2UV(sv),SvUVX(sv)));
2567     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2568 }
2569
2570 /*
2571 =for apidoc sv_2nv
2572
2573 Return the num value of an SV, doing any necessary string or integer
2574 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2575 macros.
2576
2577 =cut
2578 */
2579
2580 NV
2581 Perl_sv_2nv(pTHX_ register SV *sv)
2582 {
2583     if (!sv)
2584         return 0.0;
2585     if (SvGMAGICAL(sv)) {
2586         mg_get(sv);
2587         if (SvNOKp(sv))
2588             return SvNVX(sv);
2589         if (SvPOKp(sv) && SvLEN(sv)) {
2590             if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2591                 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
2592                 not_a_number(sv);
2593             return Atof(SvPVX(sv));
2594         }
2595         if (SvIOKp(sv)) {
2596             if (SvIsUV(sv))
2597                 return (NV)SvUVX(sv);
2598             else
2599                 return (NV)SvIVX(sv);
2600         }       
2601         if (!SvROK(sv)) {
2602             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2603                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2604                     report_uninit();
2605             }
2606             return 0;
2607         }
2608     }
2609     if (SvTHINKFIRST(sv)) {
2610         if (SvROK(sv)) {
2611           SV* tmpstr;
2612           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2613                 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2614               return SvNV(tmpstr);
2615           return PTR2NV(SvRV(sv));
2616         }
2617         if (SvREADONLY(sv) && SvFAKE(sv)) {
2618             sv_force_normal(sv);
2619         }
2620         if (SvREADONLY(sv) && !SvOK(sv)) {
2621             if (ckWARN(WARN_UNINITIALIZED))
2622                 report_uninit();
2623             return 0.0;
2624         }
2625     }
2626     if (SvTYPE(sv) < SVt_NV) {
2627         if (SvTYPE(sv) == SVt_IV)
2628             sv_upgrade(sv, SVt_PVNV);
2629         else
2630             sv_upgrade(sv, SVt_NV);
2631 #ifdef USE_LONG_DOUBLE
2632         DEBUG_c({
2633             STORE_NUMERIC_LOCAL_SET_STANDARD();
2634             PerlIO_printf(Perl_debug_log,
2635                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2636                           PTR2UV(sv), SvNVX(sv));
2637             RESTORE_NUMERIC_LOCAL();
2638         });
2639 #else
2640         DEBUG_c({
2641             STORE_NUMERIC_LOCAL_SET_STANDARD();
2642             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2643                           PTR2UV(sv), SvNVX(sv));
2644             RESTORE_NUMERIC_LOCAL();
2645         });
2646 #endif
2647     }
2648     else if (SvTYPE(sv) < SVt_PVNV)
2649         sv_upgrade(sv, SVt_PVNV);
2650     if (SvNOKp(sv)) {
2651         return SvNVX(sv);
2652     }
2653     if (SvIOKp(sv)) {
2654         SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2655 #ifdef NV_PRESERVES_UV
2656         SvNOK_on(sv);
2657 #else
2658         /* Only set the public NV OK flag if this NV preserves the IV  */
2659         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2660         if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2661                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2662             SvNOK_on(sv);
2663         else
2664             SvNOKp_on(sv);
2665 #endif
2666     }
2667     else if (SvPOKp(sv) && SvLEN(sv)) {
2668         UV value;
2669         int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2670         if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2671             not_a_number(sv);
2672 #ifdef NV_PRESERVES_UV
2673         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2674             == IS_NUMBER_IN_UV) {
2675             /* It's definitely an integer */
2676             SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
2677         } else
2678             SvNVX(sv) = Atof(SvPVX(sv));
2679         SvNOK_on(sv);
2680 #else
2681         SvNVX(sv) = Atof(SvPVX(sv));
2682         /* Only set the public NV OK flag if this NV preserves the value in
2683            the PV at least as well as an IV/UV would.
2684            Not sure how to do this 100% reliably. */
2685         /* if that shift count is out of range then Configure's test is
2686            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2687            UV_BITS */
2688         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2689             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2690             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2691         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2692             /* Can't use strtol etc to convert this string, so don't try.
2693                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2694             SvNOK_on(sv);
2695         } else {
2696             /* value has been set.  It may not be precise.  */
2697             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2698                 /* 2s complement assumption for (UV)IV_MIN  */
2699                 SvNOK_on(sv); /* Integer is too negative.  */
2700             } else {
2701                 SvNOKp_on(sv);
2702                 SvIOKp_on(sv);
2703
2704                 if (numtype & IS_NUMBER_NEG) {
2705                     SvIVX(sv) = -(IV)value;
2706                 } else if (value <= (UV)IV_MAX) {
2707                     SvIVX(sv) = (IV)value;
2708                 } else {
2709                     SvUVX(sv) = value;
2710                     SvIsUV_on(sv);
2711                 }
2712
2713                 if (numtype & IS_NUMBER_NOT_INT) {
2714                     /* I believe that even if the original PV had decimals,
2715                        they are lost beyond the limit of the FP precision.
2716                        However, neither is canonical, so both only get p
2717                        flags.  NWC, 2000/11/25 */
2718                     /* Both already have p flags, so do nothing */
2719                 } else {
2720                     NV nv = SvNVX(sv);
2721                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2722                         if (SvIVX(sv) == I_V(nv)) {
2723                             SvNOK_on(sv);
2724                             SvIOK_on(sv);
2725                         } else {
2726                             SvIOK_on(sv);
2727                             /* It had no "." so it must be integer.  */
2728                         }
2729                     } else {
2730                         /* between IV_MAX and NV(UV_MAX).
2731                            Could be slightly > UV_MAX */
2732
2733                         if (numtype & IS_NUMBER_NOT_INT) {
2734                             /* UV and NV both imprecise.  */
2735                         } else {
2736                             UV nv_as_uv = U_V(nv);
2737
2738                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2739                                 SvNOK_on(sv);
2740                                 SvIOK_on(sv);
2741                             } else {
2742                                 SvIOK_on(sv);
2743                             }
2744                         }
2745                     }
2746                 }
2747             }
2748         }
2749 #endif /* NV_PRESERVES_UV */
2750     }
2751     else  {
2752         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2753             report_uninit();
2754         if (SvTYPE(sv) < SVt_NV)
2755             /* Typically the caller expects that sv_any is not NULL now.  */
2756             /* XXX Ilya implies that this is a bug in callers that assume this
2757                and ideally should be fixed.  */
2758             sv_upgrade(sv, SVt_NV);
2759         return 0.0;
2760     }
2761 #if defined(USE_LONG_DOUBLE)
2762     DEBUG_c({
2763         STORE_NUMERIC_LOCAL_SET_STANDARD();
2764         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2765                       PTR2UV(sv), SvNVX(sv));
2766         RESTORE_NUMERIC_LOCAL();
2767     });
2768 #else
2769     DEBUG_c({
2770         STORE_NUMERIC_LOCAL_SET_STANDARD();
2771         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2772                       PTR2UV(sv), SvNVX(sv));
2773         RESTORE_NUMERIC_LOCAL();
2774     });
2775 #endif
2776     return SvNVX(sv);
2777 }
2778
2779 /* asIV(): extract an integer from the string value of an SV.
2780  * Caller must validate PVX  */
2781
2782 STATIC IV
2783 S_asIV(pTHX_ SV *sv)
2784 {
2785     UV value;
2786     int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2787
2788     if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2789         == IS_NUMBER_IN_UV) {
2790         /* It's definitely an integer */
2791         if (numtype & IS_NUMBER_NEG) {
2792             if (value < (UV)IV_MIN)
2793                 return -(IV)value;
2794         } else {
2795             if (value < (UV)IV_MAX)
2796                 return (IV)value;
2797         }
2798     }
2799     if (!numtype) {
2800         if (ckWARN(WARN_NUMERIC))
2801             not_a_number(sv);
2802     }
2803     return I_V(Atof(SvPVX(sv)));
2804 }
2805
2806 /* asUV(): extract an unsigned integer from the string value of an SV
2807  * Caller must validate PVX  */
2808
2809 STATIC UV
2810 S_asUV(pTHX_ SV *sv)
2811 {
2812     UV value;
2813     int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2814
2815     if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2816         == IS_NUMBER_IN_UV) {
2817         /* It's definitely an integer */
2818         if (!(numtype & IS_NUMBER_NEG))
2819             return value;
2820     }
2821     if (!numtype) {
2822         if (ckWARN(WARN_NUMERIC))
2823             not_a_number(sv);
2824     }
2825     return U_V(Atof(SvPVX(sv)));
2826 }
2827
2828 /*
2829 =for apidoc sv_2pv_nolen
2830
2831 Like C<sv_2pv()>, but doesn't return the length too. You should usually
2832 use the macro wrapper C<SvPV_nolen(sv)> instead.
2833 =cut
2834 */
2835
2836 char *
2837 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2838 {
2839     STRLEN n_a;
2840     return sv_2pv(sv, &n_a);
2841 }
2842
2843 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2844  * UV as a string towards the end of buf, and return pointers to start and
2845  * end of it.
2846  *
2847  * We assume that buf is at least TYPE_CHARS(UV) long.
2848  */
2849
2850 static char *
2851 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2852 {
2853     char *ptr = buf + TYPE_CHARS(UV);
2854     char *ebuf = ptr;
2855     int sign;
2856
2857     if (is_uv)
2858         sign = 0;
2859     else if (iv >= 0) {
2860         uv = iv;
2861         sign = 0;
2862     } else {
2863         uv = -iv;
2864         sign = 1;
2865     }
2866     do {
2867         *--ptr = '0' + (uv % 10);
2868     } while (uv /= 10);
2869     if (sign)
2870         *--ptr = '-';
2871     *peob = ebuf;
2872     return ptr;
2873 }
2874
2875 /* For backwards-compatibility only. sv_2pv() is normally #def'ed to
2876  * C<sv_2pv_macro()>. See also C<sv_2pv_flags()>.
2877  */
2878
2879 char *
2880 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2881 {
2882     return sv_2pv_flags(sv, lp, SV_GMAGIC);
2883 }
2884
2885 /*
2886 =for apidoc sv_2pv_flags
2887
2888 Returns a pointer to the string value of an SV, and sets *lp to its length.
2889 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2890 if necessary.
2891 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2892 usually end up here too.
2893
2894 =cut
2895 */
2896
2897 char *
2898 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2899 {
2900     register char *s;
2901     int olderrno;
2902     SV *tsv;
2903     char tbuf[64];      /* Must fit sprintf/Gconvert of longest IV/NV */
2904     char *tmpbuf = tbuf;
2905
2906     if (!sv) {
2907         *lp = 0;
2908         return "";
2909     }
2910     if (SvGMAGICAL(sv)) {
2911         if (flags & SV_GMAGIC)
2912             mg_get(sv);
2913         if (SvPOKp(sv)) {
2914             *lp = SvCUR(sv);
2915             return SvPVX(sv);
2916         }
2917         if (SvIOKp(sv)) {
2918             if (SvIsUV(sv))
2919                 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2920             else
2921                 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2922             tsv = Nullsv;
2923             goto tokensave;
2924         }
2925         if (SvNOKp(sv)) {
2926             Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2927             tsv = Nullsv;
2928             goto tokensave;
2929         }
2930         if (!SvROK(sv)) {
2931             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2932                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2933                     report_uninit();
2934             }
2935             *lp = 0;
2936             return "";
2937         }
2938     }
2939     if (SvTHINKFIRST(sv)) {
2940         if (SvROK(sv)) {
2941             SV* tmpstr;
2942             if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2943                 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2944                 return SvPV(tmpstr,*lp);
2945             sv = (SV*)SvRV(sv);
2946             if (!sv)
2947                 s = "NULLREF";
2948             else {
2949                 MAGIC *mg;
2950                 
2951                 switch (SvTYPE(sv)) {
2952                 case SVt_PVMG:
2953                     if ( ((SvFLAGS(sv) &
2954                            (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2955                           == (SVs_OBJECT|SVs_RMG))
2956                          && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2957                          && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2958                         regexp *re = (regexp *)mg->mg_obj;
2959
2960                         if (!mg->mg_ptr) {
2961                             char *fptr = "msix";
2962                             char reflags[6];
2963                             char ch;
2964                             int left = 0;
2965                             int right = 4;
2966                             U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2967
2968                             while((ch = *fptr++)) {
2969                                 if(reganch & 1) {
2970                                     reflags[left++] = ch;
2971                                 }
2972                                 else {
2973                                     reflags[right--] = ch;
2974                                 }
2975                                 reganch >>= 1;
2976                             }
2977                             if(left != 4) {
2978                                 reflags[left] = '-';
2979                                 left = 5;
2980                             }
2981
2982                             mg->mg_len = re->prelen + 4 + left;
2983                             New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2984                             Copy("(?", mg->mg_ptr, 2, char);
2985                             Copy(reflags, mg->mg_ptr+2, left, char);
2986                             Copy(":", mg->mg_ptr+left+2, 1, char);
2987                             Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2988                             mg->mg_ptr[mg->mg_len - 1] = ')';
2989                             mg->mg_ptr[mg->mg_len] = 0;
2990                         }
2991                         PL_reginterp_cnt += re->program[0].next_off;
2992                         *lp = mg->mg_len;
2993                         return mg->mg_ptr;
2994                     }
2995                                         /* Fall through */
2996                 case SVt_NULL:
2997                 case SVt_IV:
2998                 case SVt_NV:
2999                 case SVt_RV:
3000                 case SVt_PV:
3001                 case SVt_PVIV:
3002                 case SVt_PVNV:
3003                 case SVt_PVBM:  if (SvROK(sv))
3004                                     s = "REF";
3005                                 else
3006                                     s = "SCALAR";               break;
3007                 case SVt_PVLV:  s = "LVALUE";                   break;
3008                 case SVt_PVAV:  s = "ARRAY";                    break;
3009                 case SVt_PVHV:  s = "HASH";                     break;
3010                 case SVt_PVCV:  s = "CODE";                     break;
3011                 case SVt_PVGV:  s = "GLOB";                     break;
3012                 case SVt_PVFM:  s = "FORMAT";                   break;
3013                 case SVt_PVIO:  s = "IO";                       break;
3014                 default:        s = "UNKNOWN";                  break;
3015                 }
3016                 tsv = NEWSV(0,0);
3017                 if (SvOBJECT(sv)) {
3018                     HV *svs = SvSTASH(sv);
3019                     Perl_sv_setpvf(
3020                         aTHX_ tsv, "%s=%s",
3021                         /* [20011101.072] This bandaid for C<package;>
3022                            should eventually be removed. AMS 20011103 */
3023                         (svs ? HvNAME(svs) : "<none>"), s
3024                     );
3025                 }
3026                 else
3027                     sv_setpv(tsv, s);
3028                 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
3029                 goto tokensaveref;
3030             }
3031             *lp = strlen(s);
3032             return s;
3033         }
3034         if (SvREADONLY(sv) && !SvOK(sv)) {
3035             if (ckWARN(WARN_UNINITIALIZED))
3036                 report_uninit();
3037             *lp = 0;
3038             return "";
3039         }
3040     }
3041     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3042         /* I'm assuming that if both IV and NV are equally valid then
3043            converting the IV is going to be more efficient */
3044         U32 isIOK = SvIOK(sv);
3045         U32 isUIOK = SvIsUV(sv);
3046         char buf[TYPE_CHARS(UV)];
3047         char *ebuf, *ptr;
3048
3049         if (SvTYPE(sv) < SVt_PVIV)
3050             sv_upgrade(sv, SVt_PVIV);
3051         if (isUIOK)
3052             ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3053         else
3054             ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3055         SvGROW(sv, ebuf - ptr + 1);     /* inlined from sv_setpvn */
3056         Move(ptr,SvPVX(sv),ebuf - ptr,char);
3057         SvCUR_set(sv, ebuf - ptr);
3058         s = SvEND(sv);
3059         *s = '\0';
3060         if (isIOK)
3061             SvIOK_on(sv);
3062         else
3063             SvIOKp_on(sv);
3064         if (isUIOK)
3065             SvIsUV_on(sv);
3066     }
3067     else if (SvNOKp(sv)) {
3068         if (SvTYPE(sv) < SVt_PVNV)
3069             sv_upgrade(sv, SVt_PVNV);
3070         /* The +20 is pure guesswork.  Configure test needed. --jhi */
3071         SvGROW(sv, NV_DIG + 20);
3072         s = SvPVX(sv);
3073         olderrno = errno;       /* some Xenix systems wipe out errno here */
3074 #ifdef apollo
3075         if (SvNVX(sv) == 0.0)
3076             (void)strcpy(s,"0");
3077         else
3078 #endif /*apollo*/
3079         {
3080             Gconvert(SvNVX(sv), NV_DIG, 0, s);
3081         }
3082         errno = olderrno;
3083 #ifdef FIXNEGATIVEZERO
3084         if (*s == '-' && s[1] == '0' && !s[2])
3085             strcpy(s,"0");
3086 #endif
3087         while (*s) s++;
3088 #ifdef hcx
3089         if (s[-1] == '.')
3090             *--s = '\0';
3091 #endif
3092     }
3093     else {
3094         if (ckWARN(WARN_UNINITIALIZED)
3095             && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3096             report_uninit();
3097         *lp = 0;
3098         if (SvTYPE(sv) < SVt_PV)
3099             /* Typically the caller expects that sv_any is not NULL now.  */
3100             sv_upgrade(sv, SVt_PV);
3101         return "";
3102     }
3103     *lp = s - SvPVX(sv);
3104     SvCUR_set(sv, *lp);
3105     SvPOK_on(sv);
3106     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3107                           PTR2UV(sv),SvPVX(sv)));
3108     return SvPVX(sv);
3109
3110   tokensave:
3111     if (SvROK(sv)) {    /* XXX Skip this when sv_pvn_force calls */
3112         /* Sneaky stuff here */
3113
3114       tokensaveref:
3115         if (!tsv)
3116             tsv = newSVpv(tmpbuf, 0);
3117         sv_2mortal(tsv);
3118         *lp = SvCUR(tsv);
3119         return SvPVX(tsv);
3120     }
3121     else {
3122         STRLEN len;
3123         char *t;
3124
3125         if (tsv) {
3126             sv_2mortal(tsv);
3127             t = SvPVX(tsv);
3128             len = SvCUR(tsv);
3129         }
3130         else {
3131             t = tmpbuf;
3132             len = strlen(tmpbuf);
3133         }
3134 #ifdef FIXNEGATIVEZERO
3135         if (len == 2 && t[0] == '-' && t[1] == '0') {
3136             t = "0";
3137             len = 1;
3138         }
3139 #endif
3140         (void)SvUPGRADE(sv, SVt_PV);
3141         *lp = len;
3142         s = SvGROW(sv, len + 1);
3143         SvCUR_set(sv, len);
3144         (void)strcpy(s, t);
3145         SvPOKp_on(sv);
3146         return s;
3147     }
3148 }
3149
3150 /*
3151 =for apidoc sv_copypv
3152
3153 Copies a stringified representation of the source SV into the
3154 destination SV.  Automatically performs any necessary mg_get and
3155 coercion of numeric values into strings.  Guaranteed to preserve 
3156 UTF-8 flag even from overloaded objects.  Similar in nature to
3157 sv_2pv[_flags] but operates directly on an SV instead of just the 
3158 string.  Mostly uses sv_2pv_flags to do its work, except when that 
3159 would lose the UTF-8'ness of the PV.
3160
3161 =cut
3162 */
3163
3164 void
3165 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3166 {
3167     SV *tmpsv = sv_newmortal();
3168
3169     if ( SvTHINKFIRST(ssv) && SvROK(ssv) && SvAMAGIC(ssv) ) {
3170         tmpsv = AMG_CALLun(ssv,string);
3171         if (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(ssv)))
3172             SvSetSV(dsv,tmpsv);
3173     }
3174     {
3175         STRLEN len;
3176         char *s;
3177         s = SvPV(ssv,len);
3178         sv_setpvn(tmpsv,s,len);
3179         if (SvUTF8(ssv))
3180             SvUTF8_on(tmpsv);
3181         else
3182             SvUTF8_off(tmpsv);
3183         SvSetSV(dsv,tmpsv);
3184     }
3185 }
3186
3187 /*
3188 =for apidoc sv_2pvbyte_nolen
3189
3190 Return a pointer to the byte-encoded representation of the SV.
3191 May cause the SV to be downgraded from UTF8 as a side-effect.
3192
3193 Usually accessed via the C<SvPVbyte_nolen> macro.
3194
3195 =cut
3196 */
3197
3198 char *
3199 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3200 {
3201     STRLEN n_a;
3202     return sv_2pvbyte(sv, &n_a);
3203 }
3204
3205 /*
3206 =for apidoc sv_2pvbyte
3207
3208 Return a pointer to the byte-encoded representation of the SV, and set *lp
3209 to its length.  May cause the SV to be downgraded from UTF8 as a
3210 side-effect.
3211
3212 Usually accessed via the C<SvPVbyte> macro.
3213
3214 =cut
3215 */
3216
3217 char *
3218 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3219 {
3220     sv_utf8_downgrade(sv,0);
3221     return SvPV(sv,*lp);
3222 }
3223
3224 /*
3225 =for apidoc sv_2pvutf8_nolen
3226
3227 Return a pointer to the UTF8-encoded representation of the SV.
3228 May cause the SV to be upgraded to UTF8 as a side-effect.
3229
3230 Usually accessed via the C<SvPVutf8_nolen> macro.
3231
3232 =cut
3233 */
3234
3235 char *
3236 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3237 {
3238     STRLEN n_a;
3239     return sv_2pvutf8(sv, &n_a);
3240 }
3241
3242 /*
3243 =for apidoc sv_2pvutf8
3244
3245 Return a pointer to the UTF8-encoded representation of the SV, and set *lp
3246 to its length.  May cause the SV to be upgraded to UTF8 as a side-effect.
3247
3248 Usually accessed via the C<SvPVutf8> macro.
3249
3250 =cut
3251 */
3252
3253 char *
3254 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3255 {
3256     sv_utf8_upgrade(sv);
3257     return SvPV(sv,*lp);
3258 }
3259
3260 /*
3261 =for apidoc sv_2bool
3262
3263 This function is only called on magical items, and is only used by
3264 sv_true() or its macro equivalent.
3265
3266 =cut
3267 */
3268
3269 bool
3270 Perl_sv_2bool(pTHX_ register SV *sv)
3271 {
3272     if (SvGMAGICAL(sv))
3273         mg_get(sv);
3274
3275     if (!SvOK(sv))
3276         return 0;
3277     if (SvROK(sv)) {
3278         SV* tmpsv;
3279         if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3280                 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3281             return SvTRUE(tmpsv);
3282       return SvRV(sv) != 0;
3283     }
3284     if (SvPOKp(sv)) {
3285         register XPV* Xpvtmp;
3286         if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3287                 (*Xpvtmp->xpv_pv > '0' ||
3288                 Xpvtmp->xpv_cur > 1 ||
3289                 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3290             return 1;
3291         else
3292             return 0;
3293     }
3294     else {
3295         if (SvIOKp(sv))
3296             return SvIVX(sv) != 0;
3297         else {
3298             if (SvNOKp(sv))
3299                 return SvNVX(sv) != 0.0;
3300             else
3301                 return FALSE;
3302         }
3303     }
3304 }
3305
3306 /*
3307 =for apidoc sv_utf8_upgrade
3308
3309 Convert the PV of an SV to its UTF8-encoded form.
3310 Forces the SV to string form if it is not already.
3311 Always sets the SvUTF8 flag to avoid future validity checks even
3312 if all the bytes have hibit clear.
3313
3314 =cut
3315 */
3316
3317 STRLEN
3318 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3319 {
3320     return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3321 }
3322
3323 /*
3324 =for apidoc sv_utf8_upgrade_flags
3325
3326 Convert the PV of an SV to its UTF8-encoded form.
3327 Forces the SV to string form if it is not already.
3328 Always sets the SvUTF8 flag to avoid future validity checks even
3329 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3330 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3331 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3332
3333 =cut
3334 */
3335
3336 STRLEN
3337 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3338 {
3339     U8 *s, *t, *e;
3340     int  hibit = 0;
3341
3342     if (!sv)
3343         return 0;
3344
3345     if (!SvPOK(sv)) {
3346         STRLEN len = 0;
3347         (void) sv_2pv_flags(sv,&len, flags);
3348         if (!SvPOK(sv))
3349              return len;
3350     }
3351
3352     if (SvUTF8(sv))
3353         return SvCUR(sv);
3354
3355     if (SvREADONLY(sv) && SvFAKE(sv)) {
3356         sv_force_normal(sv);
3357     }
3358
3359     if (PL_encoding)
3360         Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding);
3361     else { /* Assume Latin-1/EBCDIC */
3362          /* This function could be much more efficient if we
3363           * had a FLAG in SVs to signal if there are any hibit
3364           * chars in the PV.  Given that there isn't such a flag
3365           * make the loop as fast as possible. */
3366          s = (U8 *) SvPVX(sv);
3367          e = (U8 *) SvEND(sv);
3368          t = s;
3369          while (t < e) {
3370               U8 ch = *t++;
3371               if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3372                    break;
3373          }
3374          if (hibit) {
3375               STRLEN len;
3376         
3377               len = SvCUR(sv) + 1; /* Plus the \0 */
3378               SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3379               SvCUR(sv) = len - 1;
3380               if (SvLEN(sv) != 0)
3381                    Safefree(s); /* No longer using what was there before. */
3382               SvLEN(sv) = len; /* No longer know the real size. */
3383          }
3384          /* Mark as UTF-8 even if no hibit - saves scanning loop */
3385          SvUTF8_on(sv);
3386     }
3387     return SvCUR(sv);
3388 }
3389
3390 /*
3391 =for apidoc sv_utf8_downgrade
3392
3393 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3394 This may not be possible if the PV contains non-byte encoding characters;
3395 if this is the case, either returns false or, if C<fail_ok> is not
3396 true, croaks.
3397
3398 =cut
3399 */
3400
3401 bool
3402 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3403 {
3404     if (SvPOK(sv) && SvUTF8(sv)) {
3405         if (SvCUR(sv)) {
3406             U8 *s;
3407             STRLEN len;
3408
3409             if (SvREADONLY(sv) && SvFAKE(sv))
3410                 sv_force_normal(sv);
3411             s = (U8 *) SvPV(sv, len);
3412             if (!utf8_to_bytes(s, &len)) {
3413                 if (fail_ok)
3414                     return FALSE;
3415                 else {
3416                     if (PL_op)
3417                         Perl_croak(aTHX_ "Wide character in %s",
3418                                    OP_DESC(PL_op));
3419                     else
3420                         Perl_croak(aTHX_ "Wide character");
3421                 }
3422             }
3423             SvCUR(sv) = len;
3424         }
3425     }
3426     SvUTF8_off(sv);
3427     return TRUE;
3428 }
3429
3430 /*
3431 =for apidoc sv_utf8_encode
3432
3433 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3434 flag so that it looks like octets again. Used as a building block
3435 for encode_utf8 in Encode.xs
3436
3437 =cut
3438 */
3439
3440 void
3441 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3442 {
3443     (void) sv_utf8_upgrade(sv);
3444     SvUTF8_off(sv);
3445 }
3446
3447 /*
3448 =for apidoc sv_utf8_decode
3449
3450 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3451 turn off SvUTF8 if needed so that we see characters. Used as a building block
3452 for decode_utf8 in Encode.xs
3453
3454 =cut
3455 */
3456
3457 bool
3458 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3459 {
3460     if (SvPOK(sv)) {
3461         U8 *c;
3462         U8 *e;
3463
3464         /* The octets may have got themselves encoded - get them back as
3465          * bytes
3466          */
3467         if (!sv_utf8_downgrade(sv, TRUE))
3468             return FALSE;
3469
3470         /* it is actually just a matter of turning the utf8 flag on, but
3471          * we want to make sure everything inside is valid utf8 first.
3472          */
3473         c = (U8 *) SvPVX(sv);
3474         if (!is_utf8_string(c, SvCUR(sv)+1))
3475             return FALSE;
3476         e = (U8 *) SvEND(sv);
3477         while (c < e) {
3478             U8 ch = *c++;
3479             if (!UTF8_IS_INVARIANT(ch)) {
3480                 SvUTF8_on(sv);
3481                 break;
3482             }
3483         }
3484     }
3485     return TRUE;
3486 }
3487
3488 /*
3489 =for apidoc sv_setsv
3490
3491 Copies the contents of the source SV C<ssv> into the destination SV
3492 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3493 function if the source SV needs to be reused. Does not handle 'set' magic.
3494 Loosely speaking, it performs a copy-by-value, obliterating any previous
3495 content of the destination.
3496
3497 You probably want to use one of the assortment of wrappers, such as
3498 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3499 C<SvSetMagicSV_nosteal>.
3500
3501
3502 =cut
3503 */
3504
3505 /* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
3506    for binary compatibility only
3507 */
3508 void
3509 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3510 {
3511     sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3512 }
3513
3514 /*
3515 =for apidoc sv_setsv_flags
3516
3517 Copies the contents of the source SV C<ssv> into the destination SV
3518 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3519 function if the source SV needs to be reused. Does not handle 'set' magic.
3520 Loosely speaking, it performs a copy-by-value, obliterating any previous
3521 content of the destination.
3522 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3523 C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
3524 implemented in terms of this function.
3525
3526 You probably want to use one of the assortment of wrappers, such as
3527 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3528 C<SvSetMagicSV_nosteal>.
3529
3530 This is the primary function for copying scalars, and most other
3531 copy-ish functions and macros use this underneath.
3532
3533 =cut
3534 */
3535
3536 void
3537 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3538 {
3539     register U32 sflags;
3540     register int dtype;
3541     register int stype;
3542
3543     if (sstr == dstr)
3544         return;
3545     SV_CHECK_THINKFIRST(dstr);
3546     if (!sstr)
3547         sstr = &PL_sv_undef;
3548     stype = SvTYPE(sstr);
3549     dtype = SvTYPE(dstr);
3550
3551     SvAMAGIC_off(dstr);
3552
3553     /* There's a lot of redundancy below but we're going for speed here */
3554
3555     switch (stype) {
3556     case SVt_NULL:
3557       undef_sstr:
3558         if (dtype != SVt_PVGV) {
3559             (void)SvOK_off(dstr);
3560             return;
3561         }
3562         break;
3563     case SVt_IV:
3564         if (SvIOK(sstr)) {
3565             switch (dtype) {
3566             case SVt_NULL:
3567                 sv_upgrade(dstr, SVt_IV);
3568                 break;
3569             case SVt_NV:
3570                 sv_upgrade(dstr, SVt_PVNV);
3571                 break;
3572             case SVt_RV:
3573             case SVt_PV:
3574                 sv_upgrade(dstr, SVt_PVIV);
3575                 break;
3576             }
3577             (void)SvIOK_only(dstr);
3578             SvIVX(dstr) = SvIVX(sstr);
3579             if (SvIsUV(sstr))
3580                 SvIsUV_on(dstr);
3581             if (SvTAINTED(sstr))
3582                 SvTAINT(dstr);
3583             return;
3584         }
3585         goto undef_sstr;
3586
3587     case SVt_NV:
3588         if (SvNOK(sstr)) {
3589             switch (dtype) {
3590             case SVt_NULL:
3591             case SVt_IV:
3592                 sv_upgrade(dstr, SVt_NV);
3593                 break;
3594             case SVt_RV:
3595             case SVt_PV:
3596             case SVt_PVIV:
3597                 sv_upgrade(dstr, SVt_PVNV);
3598                 break;
3599             }
3600             SvNVX(dstr) = SvNVX(sstr);
3601             (void)SvNOK_only(dstr);
3602             if (SvTAINTED(sstr))
3603                 SvTAINT(dstr);
3604             return;
3605         }
3606         goto undef_sstr;
3607
3608     case SVt_RV:
3609         if (dtype < SVt_RV)
3610             sv_upgrade(dstr, SVt_RV);
3611         else if (dtype == SVt_PVGV &&
3612                  SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3613             sstr = SvRV(sstr);
3614             if (sstr == dstr) {
3615                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3616                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3617                 {
3618                     GvIMPORTED_on(dstr);
3619                 }
3620                 GvMULTI_on(dstr);
3621                 return;
3622             }
3623             goto glob_assign;
3624         }
3625         break;
3626     case SVt_PV:
3627     case SVt_PVFM:
3628         if (dtype < SVt_PV)
3629             sv_upgrade(dstr, SVt_PV);
3630         break;
3631     case SVt_PVIV:
3632         if (dtype < SVt_PVIV)
3633             sv_upgrade(dstr, SVt_PVIV);
3634         break;
3635     case SVt_PVNV:
3636         if (dtype < SVt_PVNV)
3637             sv_upgrade(dstr, SVt_PVNV);
3638         break;
3639     case SVt_PVAV:
3640     case SVt_PVHV:
3641     case SVt_PVCV:
3642     case SVt_PVIO:
3643         if (PL_op)
3644             Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3645                 OP_NAME(PL_op));
3646         else
3647             Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3648         break;
3649
3650     case SVt_PVGV:
3651         if (dtype <= SVt_PVGV) {
3652   glob_assign:
3653             if (dtype != SVt_PVGV) {
3654                 char *name = GvNAME(sstr);
3655                 STRLEN len = GvNAMELEN(sstr);
3656                 sv_upgrade(dstr, SVt_PVGV);
3657                 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3658                 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3659                 GvNAME(dstr) = savepvn(name, len);
3660                 GvNAMELEN(dstr) = len;
3661                 SvFAKE_on(dstr);        /* can coerce to non-glob */
3662             }
3663             /* ahem, death to those who redefine active sort subs */
3664             else if (PL_curstackinfo->si_type == PERLSI_SORT
3665                      && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3666                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3667                       GvNAME(dstr));
3668
3669 #ifdef GV_UNIQUE_CHECK
3670                 if (GvUNIQUE((GV*)dstr)) {
3671                     Perl_croak(aTHX_ PL_no_modify);
3672                 }
3673 #endif
3674
3675             (void)SvOK_off(dstr);
3676             GvINTRO_off(dstr);          /* one-shot flag */
3677             gp_free((GV*)dstr);
3678             GvGP(dstr) = gp_ref(GvGP(sstr));
3679             if (SvTAINTED(sstr))
3680                 SvTAINT(dstr);
3681             if (GvIMPORTED(dstr) != GVf_IMPORTED
3682                 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3683             {
3684                 GvIMPORTED_on(dstr);
3685             }
3686             GvMULTI_on(dstr);
3687             return;
3688         }
3689         /* FALL THROUGH */
3690
3691     default:
3692         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3693             mg_get(sstr);
3694             if (SvTYPE(sstr) != stype) {
3695                 stype = SvTYPE(sstr);
3696                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3697                     goto glob_assign;
3698             }
3699         }
3700         if (stype == SVt_PVLV)
3701             (void)SvUPGRADE(dstr, SVt_PVNV);
3702         else
3703             (void)SvUPGRADE(dstr, stype);
3704     }
3705
3706     sflags = SvFLAGS(sstr);
3707
3708     if (sflags & SVf_ROK) {
3709         if (dtype >= SVt_PV) {
3710             if (dtype == SVt_PVGV) {
3711                 SV *sref = SvREFCNT_inc(SvRV(sstr));
3712                 SV *dref = 0;
3713                 int intro = GvINTRO(dstr);
3714
3715 #ifdef GV_UNIQUE_CHECK
3716                 if (GvUNIQUE((GV*)dstr)) {
3717                     Perl_croak(aTHX_ PL_no_modify);
3718                 }
3719 #endif
3720
3721                 if (intro) {
3722                     GvINTRO_off(dstr);  /* one-shot flag */
3723                     GvLINE(dstr) = CopLINE(PL_curcop);
3724                     GvEGV(dstr) = (GV*)dstr;
3725                 }
3726                 GvMULTI_on(dstr);
3727                 switch (SvTYPE(sref)) {
3728                 case SVt_PVAV:
3729                     if (intro)
3730                         SAVESPTR(GvAV(dstr));
3731                     else
3732                         dref = (SV*)GvAV(dstr);
3733                     GvAV(dstr) = (AV*)sref;
3734                     if (!GvIMPORTED_AV(dstr)
3735                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3736                     {
3737                         GvIMPORTED_AV_on(dstr);
3738                     }
3739                     break;
3740                 case SVt_PVHV:
3741                     if (intro)
3742                         SAVESPTR(GvHV(dstr));
3743                     else
3744                         dref = (SV*)GvHV(dstr);
3745                     GvHV(dstr) = (HV*)sref;
3746                     if (!GvIMPORTED_HV(dstr)
3747                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3748                     {
3749                         GvIMPORTED_HV_on(dstr);
3750                     }
3751                     break;
3752                 case SVt_PVCV:
3753                     if (intro) {
3754                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3755                             SvREFCNT_dec(GvCV(dstr));
3756                             GvCV(dstr) = Nullcv;
3757                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3758                             PL_sub_generation++;
3759                         }
3760                         SAVESPTR(GvCV(dstr));
3761                     }
3762                     else
3763                         dref = (SV*)GvCV(dstr);
3764                     if (GvCV(dstr) != (CV*)sref) {
3765                         CV* cv = GvCV(dstr);
3766                         if (cv) {
3767                             if (!GvCVGEN((GV*)dstr) &&
3768                                 (CvROOT(cv) || CvXSUB(cv)))
3769                             {
3770                                 /* ahem, death to those who redefine
3771                                  * active sort subs */
3772                                 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3773                                       PL_sortcop == CvSTART(cv))
3774                                     Perl_croak(aTHX_
3775                                     "Can't redefine active sort subroutine %s",
3776                                           GvENAME((GV*)dstr));
3777                                 /* Redefining a sub - warning is mandatory if
3778                                    it was a const and its value changed. */
3779                                 if (ckWARN(WARN_REDEFINE)
3780                                     || (CvCONST(cv)
3781                                         && (!CvCONST((CV*)sref)
3782                                             || sv_cmp(cv_const_sv(cv),
3783                                                       cv_const_sv((CV*)sref)))))
3784                                 {
3785                                     Perl_warner(aTHX_ WARN_REDEFINE,
3786                                         CvCONST(cv)
3787                                         ? "Constant subroutine %s redefined"
3788                                         : "Subroutine %s redefined",
3789                                         GvENAME((GV*)dstr));
3790                                 }
3791                             }
3792                             if (!intro)
3793                                 cv_ckproto(cv, (GV*)dstr,
3794                                         SvPOK(sref) ? SvPVX(sref) : Nullch);
3795                         }
3796                         GvCV(dstr) = (CV*)sref;
3797                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3798                         GvASSUMECV_on(dstr);
3799                         PL_sub_generation++;
3800                     }
3801                     if (!GvIMPORTED_CV(dstr)
3802                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3803                     {
3804                         GvIMPORTED_CV_on(dstr);
3805                     }
3806                     break;
3807                 case SVt_PVIO:
3808                     if (intro)
3809                         SAVESPTR(GvIOp(dstr));
3810                     else
3811                         dref = (SV*)GvIOp(dstr);
3812                     GvIOp(dstr) = (IO*)sref;
3813                     break;
3814                 case SVt_PVFM:
3815                     if (intro)
3816                         SAVESPTR(GvFORM(dstr));
3817                     else
3818                         dref = (SV*)GvFORM(dstr);
3819                     GvFORM(dstr) = (CV*)sref;
3820                     break;
3821                 default:
3822                     if (intro)
3823                         SAVESPTR(GvSV(dstr));
3824                     else
3825                         dref = (SV*)GvSV(dstr);
3826                     GvSV(dstr) = sref;
3827                     if (!GvIMPORTED_SV(dstr)
3828                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3829                     {
3830                         GvIMPORTED_SV_on(dstr);
3831                     }
3832                     break;
3833                 }
3834                 if (dref)
3835                     SvREFCNT_dec(dref);
3836                 if (intro)
3837                     SAVEFREESV(sref);
3838                 if (SvTAINTED(sstr))
3839                     SvTAINT(dstr);
3840                 return;
3841             }
3842             if (SvPVX(dstr)) {
3843                 (void)SvOOK_off(dstr);          /* backoff */
3844                 if (SvLEN(dstr))
3845                     Safefree(SvPVX(dstr));
3846                 SvLEN(dstr)=SvCUR(dstr)=0;
3847             }
3848         }
3849         (void)SvOK_off(dstr);
3850         SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3851         SvROK_on(dstr);
3852         if (sflags & SVp_NOK) {
3853             SvNOKp_on(dstr);
3854             /* Only set the public OK flag if the source has public OK.  */
3855             if (sflags & SVf_NOK)
3856                 SvFLAGS(dstr) |= SVf_NOK;
3857             SvNVX(dstr) = SvNVX(sstr);
3858         }
3859         if (sflags & SVp_IOK) {
3860             (void)SvIOKp_on(dstr);
3861             if (sflags & SVf_IOK)
3862                 SvFLAGS(dstr) |= SVf_IOK;
3863             if (sflags & SVf_IVisUV)
3864                 SvIsUV_on(dstr);
3865             SvIVX(dstr) = SvIVX(sstr);
3866         }
3867         if (SvAMAGIC(sstr)) {
3868             SvAMAGIC_on(dstr);
3869         }
3870     }
3871     else if (sflags & SVp_POK) {
3872
3873         /*
3874          * Check to see if we can just swipe the string.  If so, it's a
3875          * possible small lose on short strings, but a big win on long ones.
3876          * It might even be a win on short strings if SvPVX(dstr)
3877          * has to be allocated and SvPVX(sstr) has to be freed.
3878          */
3879
3880         if (SvTEMP(sstr) &&             /* slated for free anyway? */
3881             SvREFCNT(sstr) == 1 &&      /* and no other references to it? */
3882             !(sflags & SVf_OOK) &&      /* and not involved in OOK hack? */
3883             SvLEN(sstr)         &&      /* and really is a string */
3884                                 /* and won't be needed again, potentially */
3885             !(PL_op && PL_op->op_type == OP_AASSIGN))
3886         {
3887             if (SvPVX(dstr)) {          /* we know that dtype >= SVt_PV */
3888                 if (SvOOK(dstr)) {
3889                     SvFLAGS(dstr) &= ~SVf_OOK;
3890                     Safefree(SvPVX(dstr) - SvIVX(dstr));
3891                 }
3892                 else if (SvLEN(dstr))
3893                     Safefree(SvPVX(dstr));
3894             }
3895             (void)SvPOK_only(dstr);
3896             SvPV_set(dstr, SvPVX(sstr));
3897             SvLEN_set(dstr, SvLEN(sstr));
3898             SvCUR_set(dstr, SvCUR(sstr));
3899
3900             SvTEMP_off(dstr);
3901             (void)SvOK_off(sstr);       /* NOTE: nukes most SvFLAGS on sstr */
3902             SvPV_set(sstr, Nullch);
3903             SvLEN_set(sstr, 0);
3904             SvCUR_set(sstr, 0);
3905             SvTEMP_off(sstr);
3906         }
3907         else {                          /* have to copy actual string */
3908             STRLEN len = SvCUR(sstr);
3909
3910             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
3911             Move(SvPVX(sstr),SvPVX(dstr),len,char);
3912             SvCUR_set(dstr, len);
3913             *SvEND(dstr) = '\0';
3914             (void)SvPOK_only(dstr);
3915         }
3916         if (sflags & SVf_UTF8)
3917             SvUTF8_on(dstr);
3918         /*SUPPRESS 560*/
3919         if (sflags & SVp_NOK) {
3920             SvNOKp_on(dstr);
3921             if (sflags & SVf_NOK)
3922                 SvFLAGS(dstr) |= SVf_NOK;
3923             SvNVX(dstr) = SvNVX(sstr);
3924         }
3925         if (sflags & SVp_IOK) {
3926             (void)SvIOKp_on(dstr);
3927             if (sflags & SVf_IOK)
3928                 SvFLAGS(dstr) |= SVf_IOK;
3929             if (sflags & SVf_IVisUV)
3930                 SvIsUV_on(dstr);
3931             SvIVX(dstr) = SvIVX(sstr);
3932         }
3933     }
3934     else if (sflags & SVp_IOK) {
3935         if (sflags & SVf_IOK)
3936             (void)SvIOK_only(dstr);
3937         else {
3938             (void)SvOK_off(dstr);
3939             (void)SvIOKp_on(dstr);
3940         }
3941         /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
3942         if (sflags & SVf_IVisUV)
3943             SvIsUV_on(dstr);
3944         SvIVX(dstr) = SvIVX(sstr);
3945         if (sflags & SVp_NOK) {
3946             if (sflags & SVf_NOK)
3947                 (void)SvNOK_on(dstr);
3948             else
3949                 (void)SvNOKp_on(dstr);
3950             SvNVX(dstr) = SvNVX(sstr);
3951         }
3952     }
3953     else if (sflags & SVp_NOK) {
3954         if (sflags & SVf_NOK)
3955             (void)SvNOK_only(dstr);
3956         else {
3957             (void)SvOK_off(dstr);
3958             SvNOKp_on(dstr);
3959         }
3960         SvNVX(dstr) = SvNVX(sstr);
3961     }
3962     else {
3963         if (dtype == SVt_PVGV) {
3964             if (ckWARN(WARN_MISC))
3965                 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3966         }
3967         else
3968             (void)SvOK_off(dstr);
3969     }
3970     if (SvTAINTED(sstr))
3971         SvTAINT(dstr);
3972 }
3973
3974 /*
3975 =for apidoc sv_setsv_mg
3976
3977 Like C<sv_setsv>, but also handles 'set' magic.
3978
3979 =cut
3980 */
3981
3982 void
3983 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3984 {
3985     sv_setsv(dstr,sstr);
3986     SvSETMAGIC(dstr);
3987 }
3988
3989 /*
3990 =for apidoc sv_setpvn
3991
3992 Copies a string into an SV.  The C<len> parameter indicates the number of
3993 bytes to be copied.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
3994
3995 =cut
3996 */
3997
3998 void
3999 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4000 {
4001     register char *dptr;
4002
4003     SV_CHECK_THINKFIRST(sv);
4004     if (!ptr) {
4005         (void)SvOK_off(sv);
4006         return;
4007     }
4008     else {
4009         /* len is STRLEN which is unsigned, need to copy to signed */
4010         IV iv = len;
4011         if (iv < 0)
4012             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4013     }
4014     (void)SvUPGRADE(sv, SVt_PV);
4015
4016     SvGROW(sv, len + 1);
4017     dptr = SvPVX(sv);
4018     Move(ptr,dptr,len,char);
4019     dptr[len] = '\0';
4020     SvCUR_set(sv, len);
4021     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4022     SvTAINT(sv);
4023 }
4024
4025 /*
4026 =for apidoc sv_setpvn_mg
4027
4028 Like C<sv_setpvn>, but also handles 'set' magic.
4029
4030 =cut
4031 */
4032
4033 void
4034 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4035 {
4036     sv_setpvn(sv,ptr,len);
4037     SvSETMAGIC(sv);
4038 }
4039
4040 /*
4041 =for apidoc sv_setpv
4042
4043 Copies a string into an SV.  The string must be null-terminated.  Does not
4044 handle 'set' magic.  See C<sv_setpv_mg>.
4045
4046 =cut
4047 */
4048
4049 void
4050 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4051 {
4052     register STRLEN len;
4053
4054     SV_CHECK_THINKFIRST(sv);
4055     if (!ptr) {
4056         (void)SvOK_off(sv);
4057         return;
4058     }
4059     len = strlen(ptr);
4060     (void)SvUPGRADE(sv, SVt_PV);
4061
4062     SvGROW(sv, len + 1);
4063     Move(ptr,SvPVX(sv),len+1,char);
4064     SvCUR_set(sv, len);
4065     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4066     SvTAINT(sv);
4067 }
4068
4069 /*
4070 =for apidoc sv_setpv_mg
4071
4072 Like C<sv_setpv>, but also handles 'set' magic.
4073
4074 =cut
4075 */
4076
4077 void
4078 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4079 {
4080     sv_setpv(sv,ptr);
4081     SvSETMAGIC(sv);
4082 }
4083
4084 /*
4085 =for apidoc sv_usepvn
4086
4087 Tells an SV to use C<ptr> to find its string value.  Normally the string is
4088 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4089 The C<ptr> should point to memory that was allocated by C<malloc>.  The
4090 string length, C<len>, must be supplied.  This function will realloc the
4091 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4092 the programmer after giving it to sv_usepvn.  Does not handle 'set' magic.
4093 See C<sv_usepvn_mg>.
4094
4095 =cut
4096 */
4097
4098 void
4099 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4100 {
4101     SV_CHECK_THINKFIRST(sv);
4102     (void)SvUPGRADE(sv, SVt_PV);
4103     if (!ptr) {
4104         (void)SvOK_off(sv);
4105         return;
4106     }
4107     (void)SvOOK_off(sv);
4108     if (SvPVX(sv) && SvLEN(sv))
4109         Safefree(SvPVX(sv));
4110     Renew(ptr, len+1, char);
4111     SvPVX(sv) = ptr;
4112     SvCUR_set(sv, len);
4113     SvLEN_set(sv, len+1);
4114     *SvEND(sv) = '\0';
4115     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4116     SvTAINT(sv);
4117 }
4118
4119 /*
4120 =for apidoc sv_usepvn_mg
4121
4122 Like C<sv_usepvn>, but also handles 'set' magic.
4123
4124 =cut
4125 */
4126
4127 void
4128 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4129 {
4130     sv_usepvn(sv,ptr,len);
4131     SvSETMAGIC(sv);
4132 }
4133
4134 /*
4135 =for apidoc sv_force_normal_flags
4136
4137 Undo various types of fakery on an SV: if the PV is a shared string, make
4138 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4139 an xpvmg. The C<flags> parameter gets passed to  C<sv_unref_flags()>
4140 when unrefing. C<sv_force_normal> calls this function with flags set to 0.
4141
4142 =cut
4143 */
4144
4145 void
4146 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4147 {
4148     if (SvREADONLY(sv)) {
4149         if (SvFAKE(sv)) {
4150             char *pvx = SvPVX(sv);
4151             STRLEN len = SvCUR(sv);
4152             U32 hash   = SvUVX(sv);
4153             SvGROW(sv, len + 1);
4154             Move(pvx,SvPVX(sv),len,char);
4155             *SvEND(sv) = '\0';
4156             SvFAKE_off(sv);
4157             SvREADONLY_off(sv);
4158             unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
4159         }
4160         else if (PL_curcop != &PL_compiling)
4161             Perl_croak(aTHX_ PL_no_modify);
4162     }
4163     if (SvROK(sv))
4164         sv_unref_flags(sv, flags);
4165     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4166         sv_unglob(sv);
4167 }
4168
4169 /*
4170 =for apidoc sv_force_normal
4171
4172 Undo various types of fakery on an SV: if the PV is a shared string, make
4173 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4174 an xpvmg. See also C<sv_force_normal_flags>.
4175
4176 =cut
4177 */
4178
4179 void
4180 Perl_sv_force_normal(pTHX_ register SV *sv)
4181 {
4182     sv_force_normal_flags(sv, 0);
4183 }
4184
4185 /*
4186 =for apidoc sv_chop
4187
4188 Efficient removal of characters from the beginning of the string buffer.
4189 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4190 the string buffer.  The C<ptr> becomes the first character of the adjusted
4191 string. Uses the "OOK hack".
4192
4193 =cut
4194 */
4195
4196 void
4197 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
4198 {
4199     register STRLEN delta;
4200
4201     if (!ptr || !SvPOKp(sv))
4202         return;
4203     SV_CHECK_THINKFIRST(sv);
4204     if (SvTYPE(sv) < SVt_PVIV)
4205         sv_upgrade(sv,SVt_PVIV);
4206
4207     if (!SvOOK(sv)) {
4208         if (!SvLEN(sv)) { /* make copy of shared string */
4209             char *pvx = SvPVX(sv);
4210             STRLEN len = SvCUR(sv);
4211             SvGROW(sv, len + 1);
4212             Move(pvx,SvPVX(sv),len,char);
4213             *SvEND(sv) = '\0';
4214         }
4215         SvIVX(sv) = 0;
4216         SvFLAGS(sv) |= SVf_OOK;
4217     }
4218     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
4219     delta = ptr - SvPVX(sv);
4220     SvLEN(sv) -= delta;
4221     SvCUR(sv) -= delta;
4222     SvPVX(sv) += delta;
4223     SvIVX(sv) += delta;
4224 }
4225
4226 /*
4227 =for apidoc sv_catpvn
4228
4229 Concatenates the string onto the end of the string which is in the SV.  The
4230 C<len> indicates number of bytes to copy.  If the SV has the UTF8
4231 status set, then the bytes appended should be valid UTF8.
4232 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
4233
4234 =cut
4235 */
4236
4237 /* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
4238    for binary compatibility only
4239 */
4240 void
4241 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
4242 {
4243     sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
4244 }
4245
4246 /*
4247 =for apidoc sv_catpvn_flags
4248
4249 Concatenates the string onto the end of the string which is in the SV.  The
4250 C<len> indicates number of bytes to copy.  If the SV has the UTF8
4251 status set, then the bytes appended should be valid UTF8.
4252 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4253 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4254 in terms of this function.
4255
4256 =cut
4257 */
4258
4259 void
4260 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4261 {
4262     STRLEN dlen;
4263     char *dstr;
4264
4265     dstr = SvPV_force_flags(dsv, dlen, flags);
4266     SvGROW(dsv, dlen + slen + 1);
4267     if (sstr == dstr)
4268         sstr = SvPVX(dsv);
4269     Move(sstr, SvPVX(dsv) + dlen, slen, char);
4270     SvCUR(dsv) += slen;
4271     *SvEND(dsv) = '\0';
4272     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
4273     SvTAINT(dsv);
4274 }
4275
4276 /*
4277 =for apidoc sv_catpvn_mg
4278
4279 Like C<sv_catpvn>, but also handles 'set' magic.
4280
4281 =cut
4282 */
4283
4284 void
4285 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4286 {
4287     sv_catpvn(sv,ptr,len);
4288     SvSETMAGIC(sv);
4289 }
4290
4291 /*
4292 =for apidoc sv_catsv
4293
4294 Concatenates the string from SV C<ssv> onto the end of the string in
4295 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
4296 not 'set' magic.  See C<sv_catsv_mg>.
4297
4298 =cut */
4299
4300 /* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
4301    for binary compatibility only
4302 */
4303 void
4304 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
4305 {
4306     sv_catsv_flags(dstr, sstr, SV_GMAGIC);
4307 }
4308
4309 /*
4310 =for apidoc sv_catsv_flags
4311
4312 Concatenates the string from SV C<ssv> onto the end of the string in
4313 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
4314 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4315 and C<sv_catsv_nomg> are implemented in terms of this function.
4316
4317 =cut */
4318
4319 void
4320 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4321 {
4322     char *spv;
4323     STRLEN slen;
4324     if (!ssv)
4325         return;
4326     if ((spv = SvPV(ssv, slen))) {
4327         /*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4328             gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4329             Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4330             get dutf8 = 0x20000000, (i.e.  SVf_UTF8) even though
4331             dsv->sv_flags doesn't have that bit set.
4332                 Andy Dougherty  12 Oct 2001
4333         */
4334         I32 sutf8 = DO_UTF8(ssv);
4335         I32 dutf8;
4336
4337         if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4338             mg_get(dsv);
4339         dutf8 = DO_UTF8(dsv);
4340
4341         if (dutf8 != sutf8) {
4342             if (dutf8) {
4343                 /* Not modifying source SV, so taking a temporary copy. */
4344                 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4345
4346                 sv_utf8_upgrade(csv);
4347                 spv = SvPV(csv, slen);
4348             }
4349             else
4350                 sv_utf8_upgrade_nomg(dsv);
4351         }
4352         sv_catpvn_nomg(dsv, spv, slen);
4353     }
4354 }
4355
4356 /*
4357 =for apidoc sv_catsv_mg
4358
4359 Like C<sv_catsv>, but also handles 'set' magic.
4360
4361 =cut
4362 */
4363
4364 void
4365 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4366 {
4367     sv_catsv(dsv,ssv);
4368     SvSETMAGIC(dsv);
4369 }
4370
4371 /*
4372 =for apidoc sv_catpv
4373
4374 Concatenates the string onto the end of the string which is in the SV.
4375 If the SV has the UTF8 status set, then the bytes appended should be
4376 valid UTF8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
4377
4378 =cut */
4379
4380 void
4381 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4382 {
4383     register STRLEN len;
4384     STRLEN tlen;
4385     char *junk;
4386
4387     if (!ptr)
4388         return;
4389     junk = SvPV_force(sv, tlen);
4390     len = strlen(ptr);
4391     SvGROW(sv, tlen + len + 1);
4392     if (ptr == junk)
4393         ptr = SvPVX(sv);
4394     Move(ptr,SvPVX(sv)+tlen,len+1,char);
4395     SvCUR(sv) += len;
4396     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4397     SvTAINT(sv);
4398 }
4399
4400 /*
4401 =for apidoc sv_catpv_mg
4402
4403 Like C<sv_catpv>, but also handles 'set' magic.
4404
4405 =cut
4406 */
4407
4408 void
4409 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4410 {
4411     sv_catpv(sv,ptr);
4412     SvSETMAGIC(sv);
4413 }
4414
4415 /*
4416 =for apidoc newSV
4417
4418 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4419 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4420 macro.
4421
4422 =cut
4423 */
4424
4425 SV *
4426 Perl_newSV(pTHX_ STRLEN len)
4427 {
4428     register SV *sv;
4429
4430     new_SV(sv);
4431     if (len) {
4432         sv_upgrade(sv, SVt_PV);
4433         SvGROW(sv, len + 1);
4434     }
4435     return sv;
4436 }
4437 /*
4438 =for apidoc sv_magicext
4439
4440 Adds magic to an SV, upgrading it if necessary. Applies the
4441 supplied vtable and returns pointer to the magic added.
4442
4443 Note that sv_magicext will allow things that sv_magic will not.
4444 In particular you can add magic to SvREADONLY SVs and and more than
4445 one instance of the same 'how'
4446
4447 I C<namelen> is greater then zero then a savepvn() I<copy> of C<name> is stored,
4448 if C<namelen> is zero then C<name> is stored as-is and - as another special
4449 case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain
4450 an C<SV*> and has its REFCNT incremented
4451
4452 (This is now used as a subroutine by sv_magic.)
4453
4454 =cut
4455 */
4456 MAGIC * 
4457 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
4458                  const char* name, I32 namlen)
4459 {
4460     MAGIC* mg;
4461
4462     if (SvTYPE(sv) < SVt_PVMG) {
4463         (void)SvUPGRADE(sv, SVt_PVMG);
4464     }
4465     Newz(702,mg, 1, MAGIC);
4466     mg->mg_moremagic = SvMAGIC(sv);
4467     SvMAGIC(sv) = mg;
4468
4469     /* Some magic sontains a reference loop, where the sv and object refer to
4470        each other.  To prevent a reference loop that would prevent such
4471        objects being freed, we look for such loops and if we find one we
4472        avoid incrementing the object refcount. */
4473     if (!obj || obj == sv ||
4474         how == PERL_MAGIC_arylen ||
4475         how == PERL_MAGIC_qr ||
4476         (SvTYPE(obj) == SVt_PVGV &&
4477             (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4478             GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4479             GvFORM(obj) == (CV*)sv)))
4480     {
4481         mg->mg_obj = obj;
4482     }
4483     else {
4484         mg->mg_obj = SvREFCNT_inc(obj);
4485         mg->mg_flags |= MGf_REFCOUNTED;
4486     }
4487     mg->mg_type = how;
4488     mg->mg_len = namlen;
4489     if (name) {
4490         if (namlen > 0)
4491             mg->mg_ptr = savepvn(name, namlen);
4492         else if (namlen == HEf_SVKEY)
4493             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4494         else
4495             mg->mg_ptr = (char *) name;
4496     }
4497     mg->mg_virtual = vtable;
4498
4499     mg_magical(sv);
4500     if (SvGMAGICAL(sv))
4501         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4502     return mg;
4503 }
4504
4505 /*
4506 =for apidoc sv_magic
4507
4508 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4509 then adds a new magic item of type C<how> to the head of the magic list.
4510
4511 =cut
4512 */
4513
4514 void
4515 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4516 {
4517     MAGIC* mg;
4518     MGVTBL *vtable = 0;
4519
4520     if (SvREADONLY(sv)) {
4521         if (PL_curcop != &PL_compiling
4522             && how != PERL_MAGIC_regex_global
4523             && how != PERL_MAGIC_bm
4524             && how != PERL_MAGIC_fm
4525             && how != PERL_MAGIC_sv
4526            )
4527         {
4528             Perl_croak(aTHX_ PL_no_modify);
4529         }
4530     }
4531     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4532         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4533             /* sv_magic() refuses to add a magic of the same 'how' as an
4534                existing one
4535              */
4536             if (how == PERL_MAGIC_taint)
4537                 mg->mg_len |= 1;
4538             return;
4539         }
4540     }
4541
4542     switch (how) {
4543     case PERL_MAGIC_sv:
4544         vtable = &PL_vtbl_sv;
4545         break;
4546     case PERL_MAGIC_overload:
4547         vtable = &PL_vtbl_amagic;
4548         break;
4549     case PERL_MAGIC_overload_elem:
4550         vtable = &PL_vtbl_amagicelem;
4551         break;
4552     case PERL_MAGIC_overload_table:
4553         vtable = &PL_vtbl_ovrld;
4554         break;
4555     case PERL_MAGIC_bm:
4556         vtable = &PL_vtbl_bm;
4557         break;
4558     case PERL_MAGIC_regdata:
4559         vtable = &PL_vtbl_regdata;
4560         break;
4561     case PERL_MAGIC_regdatum:
4562         vtable = &PL_vtbl_regdatum;
4563         break;
4564     case PERL_MAGIC_env:
4565         vtable = &PL_vtbl_env;
4566         break;
4567     case PERL_MAGIC_fm:
4568         vtable = &PL_vtbl_fm;
4569         break;
4570     case PERL_MAGIC_envelem:
4571         vtable = &PL_vtbl_envelem;
4572         break;
4573     case PERL_MAGIC_regex_global:
4574         vtable = &PL_vtbl_mglob;
4575         break;
4576     case PERL_MAGIC_isa:
4577         vtable = &PL_vtbl_isa;
4578         break;
4579     case PERL_MAGIC_isaelem:
4580         vtable = &PL_vtbl_isaelem;
4581         break;
4582     case PERL_MAGIC_nkeys:
4583         vtable = &PL_vtbl_nkeys;
4584         break;
4585     case PERL_MAGIC_dbfile:
4586         vtable = 0;
4587         break;
4588     case PERL_MAGIC_dbline:
4589         vtable = &PL_vtbl_dbline;
4590         break;
4591 #ifdef USE_5005THREADS
4592     case PERL_MAGIC_mutex:
4593         vtable = &PL_vtbl_mutex;
4594         break;
4595 #endif /* USE_5005THREADS */
4596 #ifdef USE_LOCALE_COLLATE
4597     case PERL_MAGIC_collxfrm:
4598         vtable = &PL_vtbl_collxfrm;
4599         break;
4600 #endif /* USE_LOCALE_COLLATE */
4601     case PERL_MAGIC_tied:
4602         vtable = &PL_vtbl_pack;
4603         break;
4604     case PERL_MAGIC_tiedelem:
4605     case PERL_MAGIC_tiedscalar:
4606         vtable = &PL_vtbl_packelem;
4607         break;
4608     case PERL_MAGIC_qr:
4609         vtable = &PL_vtbl_regexp;
4610         break;
4611     case PERL_MAGIC_sig:
4612         vtable = &PL_vtbl_sig;
4613         break;
4614     case PERL_MAGIC_sigelem:
4615         vtable = &PL_vtbl_sigelem;
4616         break;
4617     case PERL_MAGIC_taint:
4618         vtable = &PL_vtbl_taint;
4619         break;
4620     case PERL_MAGIC_uvar:
4621         vtable = &PL_vtbl_uvar;
4622         break;
4623     case PERL_MAGIC_vec:
4624         vtable = &PL_vtbl_vec;
4625         break;
4626     case PERL_MAGIC_substr:
4627         vtable = &PL_vtbl_substr;
4628         break;
4629     case PERL_MAGIC_defelem:
4630         vtable = &PL_vtbl_defelem;
4631         break;
4632     case PERL_MAGIC_glob:
4633         vtable = &PL_vtbl_glob;
4634         break;
4635     case PERL_MAGIC_arylen:
4636         vtable = &PL_vtbl_arylen;
4637         break;
4638     case PERL_MAGIC_pos:
4639         vtable = &PL_vtbl_pos;
4640         break;
4641     case PERL_MAGIC_backref:
4642         vtable = &PL_vtbl_backref;
4643         break;
4644     case PERL_MAGIC_ext:
4645         /* Reserved for use by extensions not perl internals.           */
4646         /* Useful for attaching extension internal data to perl vars.   */
4647         /* Note that multiple extensions may clash if magical scalars   */
4648         /* etc holding private data from one are passed to another.     */
4649         break;
4650     default:
4651         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4652     }
4653
4654     /* Rest of work is done else where */
4655     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4656
4657     switch (how) {
4658     case PERL_MAGIC_taint:
4659         mg->mg_len = 1;
4660         break;
4661     case PERL_MAGIC_ext:
4662     case PERL_MAGIC_dbfile:
4663         SvRMAGICAL_on(sv);
4664         break;
4665     }
4666 }
4667
4668 /*
4669 =for apidoc sv_unmagic
4670
4671 Removes all magic of type C<type> from an SV.
4672
4673 =cut
4674 */
4675
4676 int
4677 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4678 {
4679     MAGIC* mg;
4680     MAGIC** mgp;
4681     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4682         return 0;
4683     mgp = &SvMAGIC(sv);
4684     for (mg = *mgp; mg; mg = *mgp) {
4685         if (mg->mg_type == type) {
4686             MGVTBL* vtbl = mg->mg_virtual;
4687             *mgp = mg->mg_moremagic;
4688             if (vtbl && vtbl->svt_free)
4689                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4690             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4691                 if (mg->mg_len > 0)
4692                     Safefree(mg->mg_ptr);
4693                 else if (mg->mg_len == HEf_SVKEY)
4694                     SvREFCNT_dec((SV*)mg->mg_ptr);
4695             }
4696             if (mg->mg_flags & MGf_REFCOUNTED)
4697                 SvREFCNT_dec(mg->mg_obj);
4698             Safefree(mg);
4699         }
4700         else
4701             mgp = &mg->mg_moremagic;
4702     }
4703     if (!SvMAGIC(sv)) {
4704         SvMAGICAL_off(sv);
4705        SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4706     }
4707
4708     return 0;
4709 }
4710
4711 /*
4712 =for apidoc sv_rvweaken
4713
4714 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4715 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4716 push a back-reference to this RV onto the array of backreferences
4717 associated with that magic.
4718
4719 =cut
4720 */
4721
4722 SV *
4723 Perl_sv_rvweaken(pTHX_ SV *sv)
4724 {
4725     SV *tsv;
4726     if (!SvOK(sv))  /* let undefs pass */
4727         return sv;
4728     if (!SvROK(sv))
4729         Perl_croak(aTHX_ "Can't weaken a nonreference");
4730     else if (SvWEAKREF(sv)) {
4731         if (ckWARN(WARN_MISC))
4732             Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4733         return sv;
4734     }
4735     tsv = SvRV(sv);
4736     sv_add_backref(tsv, sv);
4737     SvWEAKREF_on(sv);
4738     SvREFCNT_dec(tsv);
4739     return sv;
4740 }
4741
4742 /* Give tsv backref magic if it hasn't already got it, then push a
4743  * back-reference to sv onto the array associated with the backref magic.
4744  */
4745
4746 STATIC void
4747 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4748 {
4749     AV *av;
4750     MAGIC *mg;
4751     if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4752         av = (AV*)mg->mg_obj;
4753     else {
4754         av = newAV();
4755         sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4756         SvREFCNT_dec(av);           /* for sv_magic */
4757     }
4758     av_push(av,sv);
4759 }
4760
4761 /* delete a back-reference to ourselves from the backref magic associated
4762  * with the SV we point to.
4763  */
4764
4765 STATIC void
4766 S_sv_del_backref(pTHX_ SV *sv)
4767 {
4768     AV *av;
4769     SV **svp;
4770     I32 i;
4771     SV *tsv = SvRV(sv);
4772     MAGIC *mg;
4773     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4774         Perl_croak(aTHX_ "panic: del_backref");
4775     av = (AV *)mg->mg_obj;
4776     svp = AvARRAY(av);
4777     i = AvFILLp(av);
4778     while (i >= 0) {
4779         if (svp[i] == sv) {
4780             svp[i] = &PL_sv_undef; /* XXX */
4781         }
4782         i--;
4783     }
4784 }
4785
4786 /*
4787 =for apidoc sv_insert
4788
4789 Inserts a string at the specified offset/length within the SV. Similar to
4790 the Perl substr() function.
4791
4792 =cut
4793 */
4794
4795 void
4796 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4797 {
4798     register char *big;
4799     register char *mid;
4800     register char *midend;
4801     register char *bigend;
4802     register I32 i;
4803     STRLEN curlen;
4804
4805
4806     if (!bigstr)
4807         Perl_croak(aTHX_ "Can't modify non-existent substring");
4808     SvPV_force(bigstr, curlen);
4809     (void)SvPOK_only_UTF8(bigstr);
4810     if (offset + len > curlen) {
4811         SvGROW(bigstr, offset+len+1);
4812         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4813         SvCUR_set(bigstr, offset+len);
4814     }
4815
4816     SvTAINT(bigstr);
4817     i = littlelen - len;
4818     if (i > 0) {                        /* string might grow */
4819         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4820         mid = big + offset + len;
4821         midend = bigend = big + SvCUR(bigstr);
4822         bigend += i;
4823         *bigend = '\0';
4824         while (midend > mid)            /* shove everything down */
4825             *--bigend = *--midend;
4826         Move(little,big+offset,littlelen,char);
4827         SvCUR(bigstr) += i;
4828         SvSETMAGIC(bigstr);
4829         return;
4830     }
4831     else if (i == 0) {
4832         Move(little,SvPVX(bigstr)+offset,len,char);
4833         SvSETMAGIC(bigstr);
4834         return;
4835     }
4836
4837     big = SvPVX(bigstr);
4838     mid = big + offset;
4839     midend = mid + len;
4840     bigend = big + SvCUR(bigstr);
4841
4842     if (midend > bigend)
4843         Perl_croak(aTHX_ "panic: sv_insert");
4844
4845     if (mid - big > bigend - midend) {  /* faster to shorten from end */
4846         if (littlelen) {
4847             Move(little, mid, littlelen,char);
4848             mid += littlelen;
4849         }
4850         i = bigend - midend;
4851         if (i > 0) {
4852             Move(midend, mid, i,char);
4853             mid += i;
4854         }
4855         *mid = '\0';
4856         SvCUR_set(bigstr, mid - big);
4857     }
4858     /*SUPPRESS 560*/
4859     else if ((i = mid - big)) { /* faster from front */
4860         midend -= littlelen;
4861         mid = midend;
4862         sv_chop(bigstr,midend-i);
4863         big += i;
4864         while (i--)
4865             *--midend = *--big;
4866         if (littlelen)
4867             Move(little, mid, littlelen,char);
4868     }
4869     else if (littlelen) {
4870         midend -= littlelen;
4871         sv_chop(bigstr,midend);
4872         Move(little,midend,littlelen,char);
4873     }
4874     else {
4875         sv_chop(bigstr,midend);
4876     }
4877     SvSETMAGIC(bigstr);
4878 }
4879
4880 /*
4881 =for apidoc sv_replace
4882
4883 Make the first argument a copy of the second, then delete the original.
4884 The target SV physically takes over ownership of the body of the source SV
4885 and inherits its flags; however, the target keeps any magic it owns,
4886 and any magic in the source is discarded.
4887 Note that this is a rather specialist SV copying operation; most of the
4888 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
4889
4890 =cut
4891 */
4892
4893 void
4894 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4895 {
4896     U32 refcnt = SvREFCNT(sv);
4897     SV_CHECK_THINKFIRST(sv);
4898     if (SvREFCNT(nsv) != 1 &&&nbs