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