This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[PATCH] Re: perl@16433
[perl5.git] / sv.c
1 /*    sv.c
2  *
3  *    Copyright (c) 1991-2002, Larry Wall
4  *
5  *    You may distribute under the terms of either the GNU General Public
6  *    License or the Artistic License, as specified in the README file.
7  *
8  * "I wonder what the Entish is for 'yes' and 'no'," he thought.
9  *
10  *
11  * This file contains the code that creates, manipulates and destroys
12  * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
13  * structure of an SV, so their creation and destruction is handled
14  * here; higher-level functions are in av.c, hv.c, and so on. Opcode
15  * level functions (eg. substr, split, join) for each of the types are
16  * in the pp*.c files.
17  */
18
19 #include "EXTERN.h"
20 #define PERL_IN_SV_C
21 #include "perl.h"
22 #include "regcomp.h"
23
24 #define FCALL *f
25 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
26
27
28 /* ============================================================================
29
30 =head1 Allocation and deallocation of SVs.
31
32 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
33 av, hv...) contains type and reference count information, as well as a
34 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
35 specific to each type.
36
37 Normally, this allocation is done using arenas, which are approximately
38 1K chunks of memory parcelled up into N heads or bodies. The first slot
39 in each arena is reserved, and is used to hold a link to the next arena.
40 In the case of heads, the unused first slot also contains some flags and
41 a note of the number of slots.  Snaked through each arena chain is a
42 linked list of free items; when this becomes empty, an extra arena is
43 allocated and divided up into N items which are threaded into the free
44 list.
45
46 The following global variables are associated with arenas:
47
48     PL_sv_arenaroot     pointer to list of SV arenas
49     PL_sv_root          pointer to list of free SV structures
50
51     PL_foo_arenaroot    pointer to list of foo arenas,
52     PL_foo_root         pointer to list of free foo bodies
53                             ... for foo in xiv, xnv, xrv, xpv etc.
54
55 Note that some of the larger and more rarely used body types (eg xpvio)
56 are not allocated using arenas, but are instead just malloc()/free()ed as
57 required. Also, if PURIFY is defined, arenas are abandoned altogether,
58 with all items individually malloc()ed. In addition, a few SV heads are
59 not allocated from an arena, but are instead directly created as static
60 or auto variables, eg PL_sv_undef.
61
62 The SV arena serves the secondary purpose of allowing still-live SVs
63 to be located and destroyed during final cleanup.
64
65 At the lowest level, the macros new_SV() and del_SV() grab and free
66 an SV head.  (If debugging with -DD, del_SV() calls the function S_del_sv()
67 to return the SV to the free list with error checking.) new_SV() calls
68 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
69 SVs in the free list have their SvTYPE field set to all ones.
70
71 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
72 that allocate and return individual body types. Normally these are mapped
73 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
74 instead mapped directly to malloc()/free() if PURIFY is defined. The
75 new/del functions remove from, or add to, the appropriate PL_foo_root
76 list, and call more_xiv() etc to add a new arena if the list is empty.
77
78 At the time of very final cleanup, sv_free_arenas() is called from
79 perl_destruct() to physically free all the arenas allocated since the
80 start of the interpreter.  Note that this also clears PL_he_arenaroot,
81 which is otherwise dealt with in hv.c.
82
83 Manipulation of any of the PL_*root pointers is protected by enclosing
84 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
85 if threads are enabled.
86
87 The function visit() scans the SV arenas list, and calls a specified
88 function for each SV it finds which is still live - ie which has an SvTYPE
89 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
90 following functions (specified as [function that calls visit()] / [function
91 called by visit() for each SV]):
92
93     sv_report_used() / do_report_used()
94                         dump all remaining SVs (debugging aid)
95
96     sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
97                         Attempt to free all objects pointed to by RVs,
98                         and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
99                         try to do the same for all objects indirectly
100                         referenced by typeglobs too.  Called once from
101                         perl_destruct(), prior to calling sv_clean_all()
102                         below.
103
104     sv_clean_all() / do_clean_all()
105                         SvREFCNT_dec(sv) each remaining SV, possibly
106                         triggering an sv_free(). It also sets the
107                         SVf_BREAK flag on the SV to indicate that the
108                         refcnt has been artificially lowered, and thus
109                         stopping sv_free() from giving spurious warnings
110                         about SVs which unexpectedly have a refcnt
111                         of zero.  called repeatedly from perl_destruct()
112                         until there are no SVs left.
113
114 =head2 Summary
115
116 Private API to rest of sv.c
117
118     new_SV(),  del_SV(),
119
120     new_XIV(), del_XIV(),
121     new_XNV(), del_XNV(),
122     etc
123
124 Public API:
125
126     sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
127
128
129 =cut
130
131 ============================================================================ */
132
133
134
135 /*
136  * "A time to plant, and a time to uproot what was planted..."
137  */
138
139 #define plant_SV(p) \
140     STMT_START {                                        \
141         SvANY(p) = (void *)PL_sv_root;                  \
142         SvFLAGS(p) = SVTYPEMASK;                        \
143         PL_sv_root = (p);                               \
144         --PL_sv_count;                                  \
145     } STMT_END
146
147 /* sv_mutex must be held while calling uproot_SV() */
148 #define uproot_SV(p) \
149     STMT_START {                                        \
150         (p) = PL_sv_root;                               \
151         PL_sv_root = (SV*)SvANY(p);                     \
152         ++PL_sv_count;                                  \
153     } STMT_END
154
155
156 /* new_SV(): return a new, empty SV head */
157
158 #define new_SV(p) \
159     STMT_START {                                        \
160         LOCK_SV_MUTEX;                                  \
161         if (PL_sv_root)                                 \
162             uproot_SV(p);                               \
163         else                                            \
164             (p) = more_sv();                            \
165         UNLOCK_SV_MUTEX;                                \
166         SvANY(p) = 0;                                   \
167         SvREFCNT(p) = 1;                                \
168         SvFLAGS(p) = 0;                                 \
169     } STMT_END
170
171
172 /* del_SV(): return an empty SV head to the free list */
173
174 #ifdef DEBUGGING
175
176 #define del_SV(p) \
177     STMT_START {                                        \
178         LOCK_SV_MUTEX;                                  \
179         if (DEBUG_D_TEST)                               \
180             del_sv(p);                                  \
181         else                                            \
182             plant_SV(p);                                \
183         UNLOCK_SV_MUTEX;                                \
184     } STMT_END
185
186 STATIC void
187 S_del_sv(pTHX_ SV *p)
188 {
189     if (DEBUG_D_TEST) {
190         SV* sva;
191         SV* sv;
192         SV* svend;
193         int ok = 0;
194         for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
195             sv = sva + 1;
196             svend = &sva[SvREFCNT(sva)];
197             if (p >= sv && p < svend)
198                 ok = 1;
199         }
200         if (!ok) {
201             if (ckWARN_d(WARN_INTERNAL))        
202                 Perl_warner(aTHX_ 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' + (char)(uv % 10);
2871     } while (uv /= 10);
2872     if (sign)
2873         *--ptr = '-';
2874     *peob = ebuf;
2875     return ptr;
2876 }
2877
2878 /*
2879 =for apidoc sv_2pv_flags
2880
2881 Returns a pointer to the string value of an SV, and sets *lp to its length.
2882 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2883 if necessary.
2884 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2885 usually end up here too.
2886
2887 =cut
2888 */
2889
2890 char *
2891 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2892 {
2893     register char *s;
2894     int olderrno;
2895     SV *tsv;
2896     char tbuf[64];      /* Must fit sprintf/Gconvert of longest IV/NV */
2897     char *tmpbuf = tbuf;
2898
2899     if (!sv) {
2900         *lp = 0;
2901         return "";
2902     }
2903     if (SvGMAGICAL(sv)) {
2904         if (flags & SV_GMAGIC)
2905             mg_get(sv);
2906         if (SvPOKp(sv)) {
2907             *lp = SvCUR(sv);
2908             return SvPVX(sv);
2909         }
2910         if (SvIOKp(sv)) {
2911             if (SvIsUV(sv))
2912                 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2913             else
2914                 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2915             tsv = Nullsv;
2916             goto tokensave;
2917         }
2918         if (SvNOKp(sv)) {
2919             Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2920             tsv = Nullsv;
2921             goto tokensave;
2922         }
2923         if (!SvROK(sv)) {
2924             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2925                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2926                     report_uninit();
2927             }
2928             *lp = 0;
2929             return "";
2930         }
2931     }
2932     if (SvTHINKFIRST(sv)) {
2933         if (SvROK(sv)) {
2934             SV* tmpstr;
2935             if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2936                 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2937                 return SvPV(tmpstr,*lp);
2938             sv = (SV*)SvRV(sv);
2939             if (!sv)
2940                 s = "NULLREF";
2941             else {
2942                 MAGIC *mg;
2943                 
2944                 switch (SvTYPE(sv)) {
2945                 case SVt_PVMG:
2946                     if ( ((SvFLAGS(sv) &
2947                            (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2948                           == (SVs_OBJECT|SVs_RMG))
2949                          && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2950                          && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2951                         regexp *re = (regexp *)mg->mg_obj;
2952
2953                         if (!mg->mg_ptr) {
2954                             char *fptr = "msix";
2955                             char reflags[6];
2956                             char ch;
2957                             int left = 0;
2958                             int right = 4;
2959                             char need_newline = 0;
2960                             U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
2961
2962                             while((ch = *fptr++)) {
2963                                 if(reganch & 1) {
2964                                     reflags[left++] = ch;
2965                                 }
2966                                 else {
2967                                     reflags[right--] = ch;
2968                                 }
2969                                 reganch >>= 1;
2970                             }
2971                             if(left != 4) {
2972                                 reflags[left] = '-';
2973                                 left = 5;
2974                             }
2975
2976                             mg->mg_len = re->prelen + 4 + left;
2977                             /*
2978                              * If /x was used, we have to worry about a regex
2979                              * ending with a comment later being embedded
2980                              * within another regex. If so, we don't want this
2981                              * regex's "commentization" to leak out to the
2982                              * right part of the enclosing regex, we must cap
2983                              * it with a newline.
2984                              *
2985                              * So, if /x was used, we scan backwards from the
2986                              * end of the regex. If we find a '#' before we
2987                              * find a newline, we need to add a newline
2988                              * ourself. If we find a '\n' first (or if we
2989                              * don't find '#' or '\n'), we don't need to add
2990                              * anything.  -jfriedl
2991                              */
2992                             if (PMf_EXTENDED & re->reganch)
2993                             {
2994                                 char *endptr = re->precomp + re->prelen;
2995                                 while (endptr >= re->precomp)
2996                                 {
2997                                     char c = *(endptr--);
2998                                     if (c == '\n')
2999                                         break; /* don't need another */
3000                                     if (c == '#') {
3001                                         /* we end while in a comment, so we
3002                                            need a newline */
3003                                         mg->mg_len++; /* save space for it */
3004                                         need_newline = 1; /* note to add it */
3005                                     }
3006                                 }
3007                             }
3008
3009                             New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3010                             Copy("(?", mg->mg_ptr, 2, char);
3011                             Copy(reflags, mg->mg_ptr+2, left, char);
3012                             Copy(":", mg->mg_ptr+left+2, 1, char);
3013                             Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3014                             if (need_newline)
3015                                 mg->mg_ptr[mg->mg_len - 2] = '\n';
3016                             mg->mg_ptr[mg->mg_len - 1] = ')';
3017                             mg->mg_ptr[mg->mg_len] = 0;
3018                         }
3019                         PL_reginterp_cnt += re->program[0].next_off;
3020                         *lp = mg->mg_len;
3021                         return mg->mg_ptr;
3022                     }
3023                                         /* Fall through */
3024                 case SVt_NULL:
3025                 case SVt_IV:
3026                 case SVt_NV:
3027                 case SVt_RV:
3028                 case SVt_PV:
3029                 case SVt_PVIV:
3030                 case SVt_PVNV:
3031                 case SVt_PVBM:  if (SvROK(sv))
3032                                     s = "REF";
3033                                 else
3034                                     s = "SCALAR";               break;
3035                 case SVt_PVLV:  s = "LVALUE";                   break;
3036                 case SVt_PVAV:  s = "ARRAY";                    break;
3037                 case SVt_PVHV:  s = "HASH";                     break;
3038                 case SVt_PVCV:  s = "CODE";                     break;
3039                 case SVt_PVGV:  s = "GLOB";                     break;
3040                 case SVt_PVFM:  s = "FORMAT";                   break;
3041                 case SVt_PVIO:  s = "IO";                       break;
3042                 default:        s = "UNKNOWN";                  break;
3043                 }
3044                 tsv = NEWSV(0,0);
3045                 if (SvOBJECT(sv)) {
3046                     HV *svs = SvSTASH(sv);
3047                     Perl_sv_setpvf(
3048                         aTHX_ tsv, "%s=%s",
3049                         /* [20011101.072] This bandaid for C<package;>
3050                            should eventually be removed. AMS 20011103 */
3051                         (svs ? HvNAME(svs) : "<none>"), s
3052                     );
3053                 }
3054                 else
3055                     sv_setpv(tsv, s);
3056                 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
3057                 goto tokensaveref;
3058             }
3059             *lp = strlen(s);
3060             return s;
3061         }
3062         if (SvREADONLY(sv) && !SvOK(sv)) {
3063             if (ckWARN(WARN_UNINITIALIZED))
3064                 report_uninit();
3065             *lp = 0;
3066             return "";
3067         }
3068     }
3069     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3070         /* I'm assuming that if both IV and NV are equally valid then
3071            converting the IV is going to be more efficient */
3072         U32 isIOK = SvIOK(sv);
3073         U32 isUIOK = SvIsUV(sv);
3074         char buf[TYPE_CHARS(UV)];
3075         char *ebuf, *ptr;
3076
3077         if (SvTYPE(sv) < SVt_PVIV)
3078             sv_upgrade(sv, SVt_PVIV);
3079         if (isUIOK)
3080             ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3081         else
3082             ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3083         SvGROW(sv, (STRLEN)(ebuf - ptr + 1));   /* inlined from sv_setpvn */
3084         Move(ptr,SvPVX(sv),ebuf - ptr,char);
3085         SvCUR_set(sv, ebuf - ptr);
3086         s = SvEND(sv);
3087         *s = '\0';
3088         if (isIOK)
3089             SvIOK_on(sv);
3090         else
3091             SvIOKp_on(sv);
3092         if (isUIOK)
3093             SvIsUV_on(sv);
3094     }
3095     else if (SvNOKp(sv)) {
3096         if (SvTYPE(sv) < SVt_PVNV)
3097             sv_upgrade(sv, SVt_PVNV);
3098         /* The +20 is pure guesswork.  Configure test needed. --jhi */
3099         SvGROW(sv, NV_DIG + 20);
3100         s = SvPVX(sv);
3101         olderrno = errno;       /* some Xenix systems wipe out errno here */
3102 #ifdef apollo
3103         if (SvNVX(sv) == 0.0)
3104             (void)strcpy(s,"0");
3105         else
3106 #endif /*apollo*/
3107         {
3108             Gconvert(SvNVX(sv), NV_DIG, 0, s);
3109         }
3110         errno = olderrno;
3111 #ifdef FIXNEGATIVEZERO
3112         if (*s == '-' && s[1] == '0' && !s[2])
3113             strcpy(s,"0");
3114 #endif
3115         while (*s) s++;
3116 #ifdef hcx
3117         if (s[-1] == '.')
3118             *--s = '\0';
3119 #endif
3120     }
3121     else {
3122         if (ckWARN(WARN_UNINITIALIZED)
3123             && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3124             report_uninit();
3125         *lp = 0;
3126         if (SvTYPE(sv) < SVt_PV)
3127             /* Typically the caller expects that sv_any is not NULL now.  */
3128             sv_upgrade(sv, SVt_PV);
3129         return "";
3130     }
3131     *lp = s - SvPVX(sv);
3132     SvCUR_set(sv, *lp);
3133     SvPOK_on(sv);
3134     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3135                           PTR2UV(sv),SvPVX(sv)));
3136     return SvPVX(sv);
3137
3138   tokensave:
3139     if (SvROK(sv)) {    /* XXX Skip this when sv_pvn_force calls */
3140         /* Sneaky stuff here */
3141
3142       tokensaveref:
3143         if (!tsv)
3144             tsv = newSVpv(tmpbuf, 0);
3145         sv_2mortal(tsv);
3146         *lp = SvCUR(tsv);
3147         return SvPVX(tsv);
3148     }
3149     else {
3150         STRLEN len;
3151         char *t;
3152
3153         if (tsv) {
3154             sv_2mortal(tsv);
3155             t = SvPVX(tsv);
3156             len = SvCUR(tsv);
3157         }
3158         else {
3159             t = tmpbuf;
3160             len = strlen(tmpbuf);
3161         }
3162 #ifdef FIXNEGATIVEZERO
3163         if (len == 2 && t[0] == '-' && t[1] == '0') {
3164             t = "0";
3165             len = 1;
3166         }
3167 #endif
3168         (void)SvUPGRADE(sv, SVt_PV);
3169         *lp = len;
3170         s = SvGROW(sv, len + 1);
3171         SvCUR_set(sv, len);
3172         (void)strcpy(s, t);
3173         SvPOKp_on(sv);
3174         return s;
3175     }
3176 }
3177
3178 /*
3179 =for apidoc sv_copypv
3180
3181 Copies a stringified representation of the source SV into the
3182 destination SV.  Automatically performs any necessary mg_get and
3183 coercion of numeric values into strings.  Guaranteed to preserve
3184 UTF-8 flag even from overloaded objects.  Similar in nature to
3185 sv_2pv[_flags] but operates directly on an SV instead of just the
3186 string.  Mostly uses sv_2pv_flags to do its work, except when that
3187 would lose the UTF-8'ness of the PV.
3188
3189 =cut
3190 */
3191
3192 void
3193 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3194 {
3195     SV *tmpsv = sv_newmortal();
3196
3197     if ( SvTHINKFIRST(ssv) && SvROK(ssv) && SvAMAGIC(ssv) ) {
3198         tmpsv = AMG_CALLun(ssv,string);
3199         if (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(ssv))) {
3200             SvSetSV(dsv,tmpsv);
3201             return;
3202         }
3203     }
3204     {
3205         STRLEN len;
3206         char *s;
3207         s = SvPV(ssv,len);
3208         sv_setpvn(tmpsv,s,len);
3209         if (SvUTF8(ssv))
3210             SvUTF8_on(tmpsv);
3211         else
3212             SvUTF8_off(tmpsv);
3213         SvSetSV(dsv,tmpsv);
3214     }
3215 }
3216
3217 /*
3218 =for apidoc sv_2pvbyte_nolen
3219
3220 Return a pointer to the byte-encoded representation of the SV.
3221 May cause the SV to be downgraded from UTF8 as a side-effect.
3222
3223 Usually accessed via the C<SvPVbyte_nolen> macro.
3224
3225 =cut
3226 */
3227
3228 char *
3229 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3230 {
3231     STRLEN n_a;
3232     return sv_2pvbyte(sv, &n_a);
3233 }
3234
3235 /*
3236 =for apidoc sv_2pvbyte
3237
3238 Return a pointer to the byte-encoded representation of the SV, and set *lp
3239 to its length.  May cause the SV to be downgraded from UTF8 as a
3240 side-effect.
3241
3242 Usually accessed via the C<SvPVbyte> macro.
3243
3244 =cut
3245 */
3246
3247 char *
3248 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3249 {
3250     sv_utf8_downgrade(sv,0);
3251     return SvPV(sv,*lp);
3252 }
3253
3254 /*
3255 =for apidoc sv_2pvutf8_nolen
3256
3257 Return a pointer to the UTF8-encoded representation of the SV.
3258 May cause the SV to be upgraded to UTF8 as a side-effect.
3259
3260 Usually accessed via the C<SvPVutf8_nolen> macro.
3261
3262 =cut
3263 */
3264
3265 char *
3266 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3267 {
3268     STRLEN n_a;
3269     return sv_2pvutf8(sv, &n_a);
3270 }
3271
3272 /*
3273 =for apidoc sv_2pvutf8
3274
3275 Return a pointer to the UTF8-encoded representation of the SV, and set *lp
3276 to its length.  May cause the SV to be upgraded to UTF8 as a side-effect.
3277
3278 Usually accessed via the C<SvPVutf8> macro.
3279
3280 =cut
3281 */
3282
3283 char *
3284 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3285 {
3286     sv_utf8_upgrade(sv);
3287     return SvPV(sv,*lp);
3288 }
3289
3290 /*
3291 =for apidoc sv_2bool
3292
3293 This function is only called on magical items, and is only used by
3294 sv_true() or its macro equivalent.
3295
3296 =cut
3297 */
3298
3299 bool
3300 Perl_sv_2bool(pTHX_ register SV *sv)
3301 {
3302     if (SvGMAGICAL(sv))
3303         mg_get(sv);
3304
3305     if (!SvOK(sv))
3306         return 0;
3307     if (SvROK(sv)) {
3308         SV* tmpsv;
3309         if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3310                 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3311             return (bool)SvTRUE(tmpsv);
3312       return SvRV(sv) != 0;
3313     }
3314     if (SvPOKp(sv)) {
3315         register XPV* Xpvtmp;
3316         if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3317                 (*Xpvtmp->xpv_pv > '0' ||
3318                 Xpvtmp->xpv_cur > 1 ||
3319                 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3320             return 1;
3321         else
3322             return 0;
3323     }
3324     else {
3325         if (SvIOKp(sv))
3326             return SvIVX(sv) != 0;
3327         else {
3328             if (SvNOKp(sv))
3329                 return SvNVX(sv) != 0.0;
3330             else
3331                 return FALSE;
3332         }
3333     }
3334 }
3335
3336 /*
3337 =for apidoc sv_utf8_upgrade
3338
3339 Convert the PV of an SV to its UTF8-encoded form.
3340 Forces the SV to string form if it is not already.
3341 Always sets the SvUTF8 flag to avoid future validity checks even
3342 if all the bytes have hibit clear.
3343
3344 This is not as a general purpose byte encoding to Unicode interface:
3345 use the Encode extension for that.
3346
3347 =for apidoc sv_utf8_upgrade_flags
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. If C<flags> has C<SV_GMAGIC> bit set,
3353 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3354 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3355
3356 This is not as a general purpose byte encoding to Unicode interface:
3357 use the Encode extension for that.
3358
3359 =cut
3360 */
3361
3362 STRLEN
3363 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3364 {
3365     U8 *s, *t, *e;
3366     int  hibit = 0;
3367
3368     if (!sv)
3369         return 0;
3370
3371     if (!SvPOK(sv)) {
3372         STRLEN len = 0;
3373         (void) sv_2pv_flags(sv,&len, flags);
3374         if (!SvPOK(sv))
3375              return len;
3376     }
3377
3378     if (SvUTF8(sv))
3379         return SvCUR(sv);
3380
3381     if (SvREADONLY(sv) && SvFAKE(sv)) {
3382         sv_force_normal(sv);
3383     }
3384
3385     if (PL_encoding)
3386         sv_recode_to_utf8(sv, PL_encoding);
3387     else { /* Assume Latin-1/EBCDIC */
3388          /* This function could be much more efficient if we
3389           * had a FLAG in SVs to signal if there are any hibit
3390           * chars in the PV.  Given that there isn't such a flag
3391           * make the loop as fast as possible. */
3392          s = (U8 *) SvPVX(sv);
3393          e = (U8 *) SvEND(sv);
3394          t = s;
3395          while (t < e) {
3396               U8 ch = *t++;
3397               if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3398                    break;
3399          }
3400          if (hibit) {
3401               STRLEN len;
3402         
3403               len = SvCUR(sv) + 1; /* Plus the \0 */
3404               SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3405               SvCUR(sv) = len - 1;
3406               if (SvLEN(sv) != 0)
3407                    Safefree(s); /* No longer using what was there before. */
3408               SvLEN(sv) = len; /* No longer know the real size. */
3409          }
3410          /* Mark as UTF-8 even if no hibit - saves scanning loop */
3411          SvUTF8_on(sv);
3412     }
3413     return SvCUR(sv);
3414 }
3415
3416 /*
3417 =for apidoc sv_utf8_downgrade
3418
3419 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3420 This may not be possible if the PV contains non-byte encoding characters;
3421 if this is the case, either returns false or, if C<fail_ok> is not
3422 true, croaks.
3423
3424 This is not as a general purpose Unicode to byte encoding interface:
3425 use the Encode extension for that.
3426
3427 =cut
3428 */
3429
3430 bool
3431 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3432 {
3433     if (SvPOK(sv) && SvUTF8(sv)) {
3434         if (SvCUR(sv)) {
3435             U8 *s;
3436             STRLEN len;
3437
3438             if (SvREADONLY(sv) && SvFAKE(sv))
3439                 sv_force_normal(sv);
3440             s = (U8 *) SvPV(sv, len);
3441             if (!utf8_to_bytes(s, &len)) {
3442                 if (fail_ok)
3443                     return FALSE;
3444                 else {
3445                     if (PL_op)
3446                         Perl_croak(aTHX_ "Wide character in %s",
3447                                    OP_DESC(PL_op));
3448                     else
3449                         Perl_croak(aTHX_ "Wide character");
3450                 }
3451             }
3452             SvCUR(sv) = len;
3453         }
3454     }
3455     SvUTF8_off(sv);
3456     return TRUE;
3457 }
3458
3459 /*
3460 =for apidoc sv_utf8_encode
3461
3462 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3463 flag so that it looks like octets again. Used as a building block
3464 for encode_utf8 in Encode.xs
3465
3466 =cut
3467 */
3468
3469 void
3470 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3471 {
3472     (void) sv_utf8_upgrade(sv);
3473     SvUTF8_off(sv);
3474 }
3475
3476 /*
3477 =for apidoc sv_utf8_decode
3478
3479 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3480 turn off SvUTF8 if needed so that we see characters. Used as a building block
3481 for decode_utf8 in Encode.xs
3482
3483 =cut
3484 */
3485
3486 bool
3487 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3488 {
3489     if (SvPOK(sv)) {
3490         U8 *c;
3491         U8 *e;
3492
3493         /* The octets may have got themselves encoded - get them back as
3494          * bytes
3495          */
3496         if (!sv_utf8_downgrade(sv, TRUE))
3497             return FALSE;
3498
3499         /* it is actually just a matter of turning the utf8 flag on, but
3500          * we want to make sure everything inside is valid utf8 first.
3501          */
3502         c = (U8 *) SvPVX(sv);
3503         if (!is_utf8_string(c, SvCUR(sv)+1))
3504             return FALSE;
3505         e = (U8 *) SvEND(sv);
3506         while (c < e) {
3507             U8 ch = *c++;
3508             if (!UTF8_IS_INVARIANT(ch)) {
3509                 SvUTF8_on(sv);
3510                 break;
3511             }
3512         }
3513     }
3514     return TRUE;
3515 }
3516
3517 /*
3518 =for apidoc sv_setsv
3519
3520 Copies the contents of the source SV C<ssv> into the destination SV
3521 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3522 function if the source SV needs to be reused. Does not handle 'set' magic.
3523 Loosely speaking, it performs a copy-by-value, obliterating any previous
3524 content of the destination.
3525
3526 You probably want to use one of the assortment of wrappers, such as
3527 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3528 C<SvSetMagicSV_nosteal>.
3529
3530 =for apidoc sv_setsv_flags
3531
3532 Copies the contents of the source SV C<ssv> into the destination SV
3533 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3534 function if the source SV needs to be reused. Does not handle 'set' magic.
3535 Loosely speaking, it performs a copy-by-value, obliterating any previous
3536 content of the destination.
3537 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3538 C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
3539 implemented in terms of this function.
3540
3541 You probably want to use one of the assortment of wrappers, such as
3542 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3543 C<SvSetMagicSV_nosteal>.
3544
3545 This is the primary function for copying scalars, and most other
3546 copy-ish functions and macros use this underneath.
3547
3548 =cut
3549 */
3550
3551 void
3552 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3553 {
3554     register U32 sflags;
3555     register int dtype;
3556     register int stype;
3557
3558     if (sstr == dstr)
3559         return;
3560     SV_CHECK_THINKFIRST(dstr);
3561     if (!sstr)
3562         sstr = &PL_sv_undef;
3563     stype = SvTYPE(sstr);
3564     dtype = SvTYPE(dstr);
3565
3566     SvAMAGIC_off(dstr);
3567
3568     /* There's a lot of redundancy below but we're going for speed here */
3569
3570     switch (stype) {
3571     case SVt_NULL:
3572       undef_sstr:
3573         if (dtype != SVt_PVGV) {
3574             (void)SvOK_off(dstr);
3575             return;
3576         }
3577         break;
3578     case SVt_IV:
3579         if (SvIOK(sstr)) {
3580             switch (dtype) {
3581             case SVt_NULL:
3582                 sv_upgrade(dstr, SVt_IV);
3583                 break;
3584             case SVt_NV:
3585                 sv_upgrade(dstr, SVt_PVNV);
3586                 break;
3587             case SVt_RV:
3588             case SVt_PV:
3589                 sv_upgrade(dstr, SVt_PVIV);
3590                 break;
3591             }
3592             (void)SvIOK_only(dstr);
3593             SvIVX(dstr) = SvIVX(sstr);
3594             if (SvIsUV(sstr))
3595                 SvIsUV_on(dstr);
3596             if (SvTAINTED(sstr))
3597                 SvTAINT(dstr);
3598             return;
3599         }
3600         goto undef_sstr;
3601
3602     case SVt_NV:
3603         if (SvNOK(sstr)) {
3604             switch (dtype) {
3605             case SVt_NULL:
3606             case SVt_IV:
3607                 sv_upgrade(dstr, SVt_NV);
3608                 break;
3609             case SVt_RV:
3610             case SVt_PV:
3611             case SVt_PVIV:
3612                 sv_upgrade(dstr, SVt_PVNV);
3613                 break;
3614             }
3615             SvNVX(dstr) = SvNVX(sstr);
3616             (void)SvNOK_only(dstr);
3617             if (SvTAINTED(sstr))
3618                 SvTAINT(dstr);
3619             return;
3620         }
3621         goto undef_sstr;
3622
3623     case SVt_RV:
3624         if (dtype < SVt_RV)
3625             sv_upgrade(dstr, SVt_RV);
3626         else if (dtype == SVt_PVGV &&
3627                  SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3628             sstr = SvRV(sstr);
3629             if (sstr == dstr) {
3630                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3631                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3632                 {
3633                     GvIMPORTED_on(dstr);
3634                 }
3635                 GvMULTI_on(dstr);
3636                 return;
3637             }
3638             goto glob_assign;
3639         }
3640         break;
3641     case SVt_PV:
3642     case SVt_PVFM:
3643         if (dtype < SVt_PV)
3644             sv_upgrade(dstr, SVt_PV);
3645         break;
3646     case SVt_PVIV:
3647         if (dtype < SVt_PVIV)
3648             sv_upgrade(dstr, SVt_PVIV);
3649         break;
3650     case SVt_PVNV:
3651         if (dtype < SVt_PVNV)
3652             sv_upgrade(dstr, SVt_PVNV);
3653         break;
3654     case SVt_PVAV:
3655     case SVt_PVHV:
3656     case SVt_PVCV:
3657     case SVt_PVIO:
3658         if (PL_op)
3659             Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3660                 OP_NAME(PL_op));
3661         else
3662             Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3663         break;
3664
3665     case SVt_PVGV:
3666         if (dtype <= SVt_PVGV) {
3667   glob_assign:
3668             if (dtype != SVt_PVGV) {
3669                 char *name = GvNAME(sstr);
3670                 STRLEN len = GvNAMELEN(sstr);
3671                 sv_upgrade(dstr, SVt_PVGV);
3672                 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3673                 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3674                 GvNAME(dstr) = savepvn(name, len);
3675                 GvNAMELEN(dstr) = len;
3676                 SvFAKE_on(dstr);        /* can coerce to non-glob */
3677             }
3678             /* ahem, death to those who redefine active sort subs */
3679             else if (PL_curstackinfo->si_type == PERLSI_SORT
3680                      && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3681                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3682                       GvNAME(dstr));
3683
3684 #ifdef GV_UNIQUE_CHECK
3685                 if (GvUNIQUE((GV*)dstr)) {
3686                     Perl_croak(aTHX_ PL_no_modify);
3687                 }
3688 #endif
3689
3690             (void)SvOK_off(dstr);
3691             GvINTRO_off(dstr);          /* one-shot flag */
3692             gp_free((GV*)dstr);
3693             GvGP(dstr) = gp_ref(GvGP(sstr));
3694             if (SvTAINTED(sstr))
3695                 SvTAINT(dstr);
3696             if (GvIMPORTED(dstr) != GVf_IMPORTED
3697                 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3698             {
3699                 GvIMPORTED_on(dstr);
3700             }
3701             GvMULTI_on(dstr);
3702             return;
3703         }
3704         /* FALL THROUGH */
3705
3706     default:
3707         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3708             mg_get(sstr);
3709             if ((int)SvTYPE(sstr) != stype) {
3710                 stype = SvTYPE(sstr);
3711                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3712                     goto glob_assign;
3713             }
3714         }
3715         if (stype == SVt_PVLV)
3716             (void)SvUPGRADE(dstr, SVt_PVNV);
3717         else
3718             (void)SvUPGRADE(dstr, (U32)stype);
3719     }
3720
3721     sflags = SvFLAGS(sstr);
3722
3723     if (sflags & SVf_ROK) {
3724         if (dtype >= SVt_PV) {
3725             if (dtype == SVt_PVGV) {
3726                 SV *sref = SvREFCNT_inc(SvRV(sstr));
3727                 SV *dref = 0;
3728                 int intro = GvINTRO(dstr);
3729
3730 #ifdef GV_UNIQUE_CHECK
3731                 if (GvUNIQUE((GV*)dstr)) {
3732                     Perl_croak(aTHX_ PL_no_modify);
3733                 }
3734 #endif
3735
3736                 if (intro) {
3737                     GvINTRO_off(dstr);  /* one-shot flag */
3738                     GvLINE(dstr) = CopLINE(PL_curcop);
3739                     GvEGV(dstr) = (GV*)dstr;
3740                 }
3741                 GvMULTI_on(dstr);
3742                 switch (SvTYPE(sref)) {
3743                 case SVt_PVAV:
3744                     if (intro)
3745                         SAVESPTR(GvAV(dstr));
3746                     else
3747                         dref = (SV*)GvAV(dstr);
3748                     GvAV(dstr) = (AV*)sref;
3749                     if (!GvIMPORTED_AV(dstr)
3750                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3751                     {
3752                         GvIMPORTED_AV_on(dstr);
3753                     }
3754                     break;
3755                 case SVt_PVHV:
3756                     if (intro)
3757                         SAVESPTR(GvHV(dstr));
3758                     else
3759                         dref = (SV*)GvHV(dstr);
3760                     GvHV(dstr) = (HV*)sref;
3761                     if (!GvIMPORTED_HV(dstr)
3762                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3763                     {
3764                         GvIMPORTED_HV_on(dstr);
3765                     }
3766                     break;
3767                 case SVt_PVCV:
3768                     if (intro) {
3769                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3770                             SvREFCNT_dec(GvCV(dstr));
3771                             GvCV(dstr) = Nullcv;
3772                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3773                             PL_sub_generation++;
3774                         }
3775                         SAVESPTR(GvCV(dstr));
3776                     }
3777                     else
3778                         dref = (SV*)GvCV(dstr);
3779                     if (GvCV(dstr) != (CV*)sref) {
3780                         CV* cv = GvCV(dstr);
3781                         if (cv) {
3782                             if (!GvCVGEN((GV*)dstr) &&
3783                                 (CvROOT(cv) || CvXSUB(cv)))
3784                             {
3785                                 /* ahem, death to those who redefine
3786                                  * active sort subs */
3787                                 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3788                                       PL_sortcop == CvSTART(cv))
3789                                     Perl_croak(aTHX_
3790                                     "Can't redefine active sort subroutine %s",
3791                                           GvENAME((GV*)dstr));
3792                                 /* Redefining a sub - warning is mandatory if
3793                                    it was a const and its value changed. */
3794                                 if (ckWARN(WARN_REDEFINE)
3795                                     || (CvCONST(cv)
3796                                         && (!CvCONST((CV*)sref)
3797                                             || sv_cmp(cv_const_sv(cv),
3798                                                       cv_const_sv((CV*)sref)))))
3799                                 {
3800                                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3801                                         CvCONST(cv)
3802                                         ? "Constant subroutine %s::%s redefined"
3803                                         : "Subroutine %s::%s redefined",
3804                                         HvNAME(GvSTASH((GV*)dstr)),
3805                                         GvENAME((GV*)dstr));
3806                                 }
3807                             }
3808                             if (!intro)
3809                                 cv_ckproto(cv, (GV*)dstr,
3810                                         SvPOK(sref) ? SvPVX(sref) : Nullch);
3811                         }
3812                         GvCV(dstr) = (CV*)sref;
3813                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3814                         GvASSUMECV_on(dstr);
3815                         PL_sub_generation++;
3816                     }
3817                     if (!GvIMPORTED_CV(dstr)
3818                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3819                     {
3820                         GvIMPORTED_CV_on(dstr);
3821                     }
3822                     break;
3823                 case SVt_PVIO:
3824                     if (intro)
3825                         SAVESPTR(GvIOp(dstr));
3826                     else
3827                         dref = (SV*)GvIOp(dstr);
3828                     GvIOp(dstr) = (IO*)sref;
3829                     break;
3830                 case SVt_PVFM:
3831                     if (intro)
3832                         SAVESPTR(GvFORM(dstr));
3833                     else
3834                         dref = (SV*)GvFORM(dstr);
3835                     GvFORM(dstr) = (CV*)sref;
3836                     break;
3837                 default:
3838                     if (intro)
3839                         SAVESPTR(GvSV(dstr));
3840                     else
3841                         dref = (SV*)GvSV(dstr);
3842                     GvSV(dstr) = sref;
3843                     if (!GvIMPORTED_SV(dstr)
3844                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3845                     {
3846                         GvIMPORTED_SV_on(dstr);
3847                     }
3848                     break;
3849                 }
3850                 if (dref)
3851                     SvREFCNT_dec(dref);
3852                 if (intro)
3853                     SAVEFREESV(sref);
3854                 if (SvTAINTED(sstr))
3855                     SvTAINT(dstr);
3856                 return;
3857             }
3858             if (SvPVX(dstr)) {
3859                 (void)SvOOK_off(dstr);          /* backoff */
3860                 if (SvLEN(dstr))
3861                     Safefree(SvPVX(dstr));
3862                 SvLEN(dstr)=SvCUR(dstr)=0;
3863             }
3864         }
3865         (void)SvOK_off(dstr);
3866         SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3867         SvROK_on(dstr);
3868         if (sflags & SVp_NOK) {
3869             SvNOKp_on(dstr);
3870             /* Only set the public OK flag if the source has public OK.  */
3871             if (sflags & SVf_NOK)
3872                 SvFLAGS(dstr) |= SVf_NOK;
3873             SvNVX(dstr) = SvNVX(sstr);
3874         }
3875         if (sflags & SVp_IOK) {
3876             (void)SvIOKp_on(dstr);
3877             if (sflags & SVf_IOK)
3878                 SvFLAGS(dstr) |= SVf_IOK;
3879             if (sflags & SVf_IVisUV)
3880                 SvIsUV_on(dstr);
3881             SvIVX(dstr) = SvIVX(sstr);
3882         }
3883         if (SvAMAGIC(sstr)) {
3884             SvAMAGIC_on(dstr);
3885         }
3886     }
3887     else if (sflags & SVp_POK) {
3888
3889         /*
3890          * Check to see if we can just swipe the string.  If so, it's a
3891          * possible small lose on short strings, but a big win on long ones.
3892          * It might even be a win on short strings if SvPVX(dstr)
3893          * has to be allocated and SvPVX(sstr) has to be freed.
3894          */
3895
3896         if (SvTEMP(sstr) &&             /* slated for free anyway? */
3897             SvREFCNT(sstr) == 1 &&      /* and no other references to it? */
3898             !(sflags & SVf_OOK) &&      /* and not involved in OOK hack? */
3899             SvLEN(sstr)         &&      /* and really is a string */
3900                                 /* and won't be needed again, potentially */
3901             !(PL_op && PL_op->op_type == OP_AASSIGN))
3902         {
3903             if (SvPVX(dstr)) {          /* we know that dtype >= SVt_PV */
3904                 if (SvOOK(dstr)) {
3905                     SvFLAGS(dstr) &= ~SVf_OOK;
3906                     Safefree(SvPVX(dstr) - SvIVX(dstr));
3907                 }
3908                 else if (SvLEN(dstr))
3909                     Safefree(SvPVX(dstr));
3910             }
3911             (void)SvPOK_only(dstr);
3912             SvPV_set(dstr, SvPVX(sstr));
3913             SvLEN_set(dstr, SvLEN(sstr));
3914             SvCUR_set(dstr, SvCUR(sstr));
3915
3916             SvTEMP_off(dstr);
3917             (void)SvOK_off(sstr);       /* NOTE: nukes most SvFLAGS on sstr */
3918             SvPV_set(sstr, Nullch);
3919             SvLEN_set(sstr, 0);
3920             SvCUR_set(sstr, 0);
3921             SvTEMP_off(sstr);
3922         }
3923         else {                          /* have to copy actual string */
3924             STRLEN len = SvCUR(sstr);
3925             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
3926             Move(SvPVX(sstr),SvPVX(dstr),len,char);
3927             SvCUR_set(dstr, len);
3928             *SvEND(dstr) = '\0';
3929             (void)SvPOK_only(dstr);
3930         }
3931         if (sflags & SVf_UTF8)
3932             SvUTF8_on(dstr);
3933         /*SUPPRESS 560*/
3934         if (sflags & SVp_NOK) {
3935             SvNOKp_on(dstr);
3936             if (sflags & SVf_NOK)
3937                 SvFLAGS(dstr) |= SVf_NOK;
3938             SvNVX(dstr) = SvNVX(sstr);
3939         }
3940         if (sflags & SVp_IOK) {
3941             (void)SvIOKp_on(dstr);
3942             if (sflags & SVf_IOK)
3943                 SvFLAGS(dstr) |= SVf_IOK;
3944             if (sflags & SVf_IVisUV)
3945                 SvIsUV_on(dstr);
3946             SvIVX(dstr) = SvIVX(sstr);
3947         }
3948     }
3949     else if (sflags & SVp_IOK) {
3950         if (sflags & SVf_IOK)
3951             (void)SvIOK_only(dstr);
3952         else {
3953             (void)SvOK_off(dstr);
3954             (void)SvIOKp_on(dstr);
3955         }
3956         /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
3957         if (sflags & SVf_IVisUV)
3958             SvIsUV_on(dstr);
3959         SvIVX(dstr) = SvIVX(sstr);
3960         if (sflags & SVp_NOK) {
3961             if (sflags & SVf_NOK)
3962                 (void)SvNOK_on(dstr);
3963             else
3964                 (void)SvNOKp_on(dstr);
3965             SvNVX(dstr) = SvNVX(sstr);
3966         }
3967     }
3968     else if (sflags & SVp_NOK) {
3969         if (sflags & SVf_NOK)
3970             (void)SvNOK_only(dstr);
3971         else {
3972             (void)SvOK_off(dstr);
3973             SvNOKp_on(dstr);
3974         }
3975         SvNVX(dstr) = SvNVX(sstr);
3976     }
3977     else {
3978         if (dtype == SVt_PVGV) {
3979             if (ckWARN(WARN_MISC))
3980                 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
3981         }
3982         else
3983             (void)SvOK_off(dstr);
3984     }
3985     if (SvTAINTED(sstr))
3986         SvTAINT(dstr);
3987 }
3988
3989 /*
3990 =for apidoc sv_setsv_mg
3991
3992 Like C<sv_setsv>, but also handles 'set' magic.
3993
3994 =cut
3995 */
3996
3997 void
3998 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3999 {
4000     sv_setsv(dstr,sstr);
4001     SvSETMAGIC(dstr);
4002 }
4003
4004 /*
4005 =for apidoc sv_setpvn
4006
4007 Copies a string into an SV.  The C<len> parameter indicates the number of
4008 bytes to be copied.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4009
4010 =cut
4011 */
4012
4013 void
4014 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4015 {
4016     register char *dptr;
4017
4018     SV_CHECK_THINKFIRST(sv);
4019     if (!ptr) {
4020         (void)SvOK_off(sv);
4021         return;
4022     }
4023     else {
4024         /* len is STRLEN which is unsigned, need to copy to signed */
4025         IV iv = len;
4026         if (iv < 0)
4027             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4028     }
4029     (void)SvUPGRADE(sv, SVt_PV);
4030
4031     SvGROW(sv, len + 1);
4032     dptr = SvPVX(sv);
4033     Move(ptr,dptr,len,char);
4034     dptr[len] = '\0';
4035     SvCUR_set(sv, len);
4036     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4037     SvTAINT(sv);
4038 }
4039
4040 /*
4041 =for apidoc sv_setpvn_mg
4042
4043 Like C<sv_setpvn>, but also handles 'set' magic.
4044
4045 =cut
4046 */
4047
4048 void
4049 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4050 {
4051     sv_setpvn(sv,ptr,len);
4052     SvSETMAGIC(sv);
4053 }
4054
4055 /*
4056 =for apidoc sv_setpv
4057
4058 Copies a string into an SV.  The string must be null-terminated.  Does not
4059 handle 'set' magic.  See C<sv_setpv_mg>.
4060
4061 =cut
4062 */
4063
4064 void
4065 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4066 {
4067     register STRLEN len;
4068
4069     SV_CHECK_THINKFIRST(sv);
4070     if (!ptr) {
4071         (void)SvOK_off(sv);
4072         return;
4073     }
4074     len = strlen(ptr);
4075     (void)SvUPGRADE(sv, SVt_PV);
4076
4077     SvGROW(sv, len + 1);
4078     Move(ptr,SvPVX(sv),len+1,char);
4079     SvCUR_set(sv, len);
4080     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4081     SvTAINT(sv);
4082 }
4083
4084 /*
4085 =for apidoc sv_setpv_mg
4086
4087 Like C<sv_setpv>, but also handles 'set' magic.
4088
4089 =cut
4090 */
4091
4092 void
4093 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4094 {
4095     sv_setpv(sv,ptr);
4096     SvSETMAGIC(sv);
4097 }
4098
4099 /*
4100 =for apidoc sv_usepvn
4101
4102 Tells an SV to use C<ptr> to find its string value.  Normally the string is
4103 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4104 The C<ptr> should point to memory that was allocated by C<malloc>.  The
4105 string length, C<len>, must be supplied.  This function will realloc the
4106 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4107 the programmer after giving it to sv_usepvn.  Does not handle 'set' magic.
4108 See C<sv_usepvn_mg>.
4109
4110 =cut
4111 */
4112
4113 void
4114 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4115 {
4116     SV_CHECK_THINKFIRST(sv);
4117     (void)SvUPGRADE(sv, SVt_PV);
4118     if (!ptr) {
4119         (void)SvOK_off(sv);
4120         return;
4121     }
4122     (void)SvOOK_off(sv);
4123     if (SvPVX(sv) && SvLEN(sv))
4124         Safefree(SvPVX(sv));
4125     Renew(ptr, len+1, char);
4126     SvPVX(sv) = ptr;
4127     SvCUR_set(sv, len);
4128     SvLEN_set(sv, len+1);
4129     *SvEND(sv) = '\0';
4130     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4131     SvTAINT(sv);
4132 }
4133
4134 /*
4135 =for apidoc sv_usepvn_mg
4136
4137 Like C<sv_usepvn>, but also handles 'set' magic.
4138
4139 =cut
4140 */
4141
4142 void
4143 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4144 {
4145     sv_usepvn(sv,ptr,len);
4146     SvSETMAGIC(sv);
4147 }
4148
4149 /*
4150 =for apidoc sv_force_normal_flags
4151
4152 Undo various types of fakery on an SV: if the PV is a shared string, make
4153 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4154 an xpvmg. The C<flags> parameter gets passed to  C<sv_unref_flags()>
4155 when unrefing. C<sv_force_normal> calls this function with flags set to 0.
4156
4157 =cut
4158 */
4159
4160 void
4161 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4162 {
4163     if (SvREADONLY(sv)) {
4164         if (SvFAKE(sv)) {
4165             char *pvx = SvPVX(sv);
4166             STRLEN len = SvCUR(sv);
4167             U32 hash   = SvUVX(sv);
4168             SvGROW(sv, len + 1);
4169             Move(pvx,SvPVX(sv),len,char);
4170             *SvEND(sv) = '\0';
4171             SvFAKE_off(sv);
4172             SvREADONLY_off(sv);
4173             unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
4174         }
4175         else if (PL_curcop != &PL_compiling)
4176             Perl_croak(aTHX_ PL_no_modify);
4177     }
4178     if (SvROK(sv))
4179         sv_unref_flags(sv, flags);
4180     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4181         sv_unglob(sv);
4182 }
4183
4184 /*
4185 =for apidoc sv_force_normal
4186
4187 Undo various types of fakery on an SV: if the PV is a shared string, make
4188 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4189 an xpvmg. See also C<sv_force_normal_flags>.
4190
4191 =cut
4192 */
4193
4194 void
4195 Perl_sv_force_normal(pTHX_ register SV *sv)
4196 {
4197     sv_force_normal_flags(sv, 0);
4198 }
4199
4200 /*
4201 =for apidoc sv_chop
4202
4203 Efficient removal of characters from the beginning of the string buffer.
4204 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4205 the string buffer.  The C<ptr> becomes the first character of the adjusted
4206 string. Uses the "OOK hack".
4207
4208 =cut
4209 */
4210
4211 void
4212 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
4213 {
4214     register STRLEN delta;
4215
4216     if (!ptr || !SvPOKp(sv))
4217         return;
4218     SV_CHECK_THINKFIRST(sv);
4219     if (SvTYPE(sv) < SVt_PVIV)
4220         sv_upgrade(sv,SVt_PVIV);
4221
4222     if (!SvOOK(sv)) {
4223         if (!SvLEN(sv)) { /* make copy of shared string */
4224             char *pvx = SvPVX(sv);
4225             STRLEN len = SvCUR(sv);
4226             SvGROW(sv, len + 1);
4227             Move(pvx,SvPVX(sv),len,char);
4228             *SvEND(sv) = '\0';
4229         }
4230         SvIVX(sv) = 0;
4231         SvFLAGS(sv) |= SVf_OOK;
4232     }
4233     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
4234     delta = ptr - SvPVX(sv);
4235     SvLEN(sv) -= delta;
4236     SvCUR(sv) -= delta;
4237     SvPVX(sv) += delta;
4238     SvIVX(sv) += delta;
4239 }
4240
4241 /*
4242 =for apidoc sv_catpvn
4243
4244 Concatenates the string onto the end of the string which is in the SV.  The
4245 C<len> indicates number of bytes to copy.  If the SV has the UTF8
4246 status set, then the bytes appended should be valid UTF8.
4247 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
4248
4249 =for apidoc sv_catpvn_flags
4250
4251 Concatenates the string onto the end of the string which is in the SV.  The
4252 C<len> indicates number of bytes to copy.  If the SV has the UTF8
4253 status set, then the bytes appended should be valid UTF8.
4254 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4255 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4256 in terms of this function.
4257
4258 =cut
4259 */
4260
4261 void
4262 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4263 {
4264     STRLEN dlen;
4265     char *dstr;
4266
4267     dstr = SvPV_force_flags(dsv, dlen, flags);
4268     SvGROW(dsv, dlen + slen + 1);
4269     if (sstr == dstr)
4270         sstr = SvPVX(dsv);
4271     Move(sstr, SvPVX(dsv) + dlen, slen, char);
4272     SvCUR(dsv) += slen;
4273     *SvEND(dsv) = '\0';
4274     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
4275     SvTAINT(dsv);
4276 }
4277
4278 /*
4279 =for apidoc sv_catpvn_mg
4280
4281 Like C<sv_catpvn>, but also handles 'set' magic.
4282
4283 =cut
4284 */
4285
4286 void
4287 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4288 {
4289     sv_catpvn(sv,ptr,len);
4290     SvSETMAGIC(sv);
4291 }
4292
4293 /*
4294 =for apidoc sv_catsv
4295
4296 Concatenates the string from SV C<ssv> onto the end of the string in
4297 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
4298 not 'set' magic.  See C<sv_catsv_mg>.
4299
4300 =for apidoc sv_catsv_flags
4301
4302 Concatenates the string from SV C<ssv> onto the end of the string in
4303 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
4304 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4305 and C<sv_catsv_nomg> are implemented in terms of this function.
4306
4307 =cut */
4308
4309 void
4310 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4311 {
4312     char *spv;
4313     STRLEN slen;
4314     if (!ssv)
4315         return;
4316     if ((spv = SvPV(ssv, slen))) {
4317         /*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4318             gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4319             Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4320             get dutf8 = 0x20000000, (i.e.  SVf_UTF8) even though
4321             dsv->sv_flags doesn't have that bit set.
4322                 Andy Dougherty  12 Oct 2001
4323         */
4324         I32 sutf8 = DO_UTF8(ssv);
4325         I32 dutf8;
4326
4327         if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4328             mg_get(dsv);
4329         dutf8 = DO_UTF8(dsv);
4330
4331         if (dutf8 != sutf8) {
4332             if (dutf8) {
4333                 /* Not modifying source SV, so taking a temporary copy. */
4334                 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4335
4336                 sv_utf8_upgrade(csv);
4337                 spv = SvPV(csv, slen);
4338             }
4339             else
4340                 sv_utf8_upgrade_nomg(dsv);
4341         }
4342         sv_catpvn_nomg(dsv, spv, slen);
4343     }
4344 }
4345
4346 /*
4347 =for apidoc sv_catsv_mg
4348
4349 Like C<sv_catsv>, but also handles 'set' magic.
4350
4351 =cut
4352 */
4353
4354 void
4355 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4356 {
4357     sv_catsv(dsv,ssv);
4358     SvSETMAGIC(dsv);
4359 }
4360
4361 /*
4362 =for apidoc sv_catpv
4363
4364 Concatenates the string onto the end of the string which is in the SV.
4365 If the SV has the UTF8 status set, then the bytes appended should be
4366 valid UTF8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
4367
4368 =cut */
4369
4370 void
4371 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4372 {
4373     register STRLEN len;
4374     STRLEN tlen;
4375     char *junk;
4376
4377     if (!ptr)
4378         return;
4379     junk = SvPV_force(sv, tlen);
4380     len = strlen(ptr);
4381     SvGROW(sv, tlen + len + 1);
4382     if (ptr == junk)
4383         ptr = SvPVX(sv);
4384     Move(ptr,SvPVX(sv)+tlen,len+1,char);
4385     SvCUR(sv) += len;
4386     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4387     SvTAINT(sv);
4388 }
4389
4390 /*
4391 =for apidoc sv_catpv_mg
4392
4393 Like C<sv_catpv>, but also handles 'set' magic.
4394
4395 =cut
4396 */
4397
4398 void
4399 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4400 {
4401     sv_catpv(sv,ptr);
4402     SvSETMAGIC(sv);
4403 }
4404
4405 /*
4406 =for apidoc newSV
4407
4408 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4409 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4410 macro.
4411
4412 =cut
4413 */
4414
4415 SV *
4416 Perl_newSV(pTHX_ STRLEN len)
4417 {
4418     register SV *sv;
4419
4420     new_SV(sv);
4421     if (len) {
4422         sv_upgrade(sv, SVt_PV);
4423         SvGROW(sv, len + 1);
4424     }
4425     return sv;
4426 }
4427 /*
4428 =for apidoc sv_magicext
4429
4430 Adds magic to an SV, upgrading it if necessary. Applies the
4431 supplied vtable and returns pointer to the magic added.
4432
4433 Note that sv_magicext will allow things that sv_magic will not.
4434 In particular you can add magic to SvREADONLY SVs and and more than
4435 one instance of the same 'how'
4436
4437 I C<namelen> is greater then zero then a savepvn() I<copy> of C<name> is stored,
4438 if C<namelen> is zero then C<name> is stored as-is and - as another special
4439 case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain
4440 an C<SV*> and has its REFCNT incremented
4441
4442 (This is now used as a subroutine by sv_magic.)
4443
4444 =cut
4445 */
4446 MAGIC * 
4447 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
4448                  const char* name, I32 namlen)
4449 {
4450     MAGIC* mg;
4451
4452     if (SvTYPE(sv) < SVt_PVMG) {
4453         (void)SvUPGRADE(sv, SVt_PVMG);
4454     }
4455     Newz(702,mg, 1, MAGIC);
4456     mg->mg_moremagic = SvMAGIC(sv);
4457     SvMAGIC(sv) = mg;
4458
4459     /* Some magic sontains a reference loop, where the sv and object refer to
4460        each other.  To prevent a reference loop that would prevent such
4461        objects being freed, we look for such loops and if we find one we
4462        avoid incrementing the object refcount. */
4463     if (!obj || obj == sv ||
4464         how == PERL_MAGIC_arylen ||
4465         how == PERL_MAGIC_qr ||
4466         (SvTYPE(obj) == SVt_PVGV &&
4467             (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4468             GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4469             GvFORM(obj) == (CV*)sv)) ||
4470         (how == PERL_MAGIC_tiedscalar &&
4471             SvROK(obj) && (SvRV(obj) == sv || GvIO(SvRV(obj)) == (IO*)sv)))
4472     {
4473         mg->mg_obj = obj;
4474     }
4475     else {
4476         mg->mg_obj = SvREFCNT_inc(obj);
4477         mg->mg_flags |= MGf_REFCOUNTED;
4478     }
4479     mg->mg_type = how;
4480     mg->mg_len = namlen;
4481     if (name) {
4482         if (namlen > 0)
4483             mg->mg_ptr = savepvn(name, namlen);
4484         else if (namlen == HEf_SVKEY)
4485             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4486         else
4487             mg->mg_ptr = (char *) name;
4488     }
4489     mg->mg_virtual = vtable;
4490
4491     mg_magical(sv);
4492     if (SvGMAGICAL(sv))
4493         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4494     return mg;
4495 }
4496
4497 /*
4498 =for apidoc sv_magic
4499
4500 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4501 then adds a new magic item of type C<how> to the head of the magic list.
4502
4503 =cut
4504 */
4505
4506 void
4507 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4508 {
4509     MAGIC* mg;
4510     MGVTBL *vtable = 0;
4511
4512     if (SvREADONLY(sv)) {
4513         if (PL_curcop != &PL_compiling
4514             && how != PERL_MAGIC_regex_global
4515             && how != PERL_MAGIC_bm
4516             && how != PERL_MAGIC_fm
4517             && how != PERL_MAGIC_sv
4518            )
4519         {
4520             Perl_croak(aTHX_ PL_no_modify);
4521         }
4522     }
4523     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4524         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4525             /* sv_magic() refuses to add a magic of the same 'how' as an
4526                existing one
4527              */
4528             if (how == PERL_MAGIC_taint)
4529                 mg->mg_len |= 1;
4530             return;
4531         }
4532     }
4533
4534     switch (how) {
4535     case PERL_MAGIC_sv:
4536         vtable = &PL_vtbl_sv;
4537         break;
4538     case PERL_MAGIC_overload:
4539         vtable = &PL_vtbl_amagic;
4540         break;
4541     case PERL_MAGIC_overload_elem:
4542         vtable = &PL_vtbl_amagicelem;
4543         break;
4544     case PERL_MAGIC_overload_table:
4545         vtable = &PL_vtbl_ovrld;
4546         break;
4547     case PERL_MAGIC_bm:
4548         vtable = &PL_vtbl_bm;
4549         break;
4550     case PERL_MAGIC_regdata:
4551         vtable = &PL_vtbl_regdata;
4552         break;
4553     case PERL_MAGIC_regdatum:
4554         vtable = &PL_vtbl_regdatum;
4555         break;
4556     case PERL_MAGIC_env:
4557         vtable = &PL_vtbl_env;
4558         break;
4559     case PERL_MAGIC_fm:
4560         vtable = &PL_vtbl_fm;
4561         break;
4562     case PERL_MAGIC_envelem:
4563         vtable = &PL_vtbl_envelem;
4564         break;
4565     case PERL_MAGIC_regex_global:
4566         vtable = &PL_vtbl_mglob;
4567         break;
4568     case PERL_MAGIC_isa:
4569         vtable = &PL_vtbl_isa;
4570         break;
4571     case PERL_MAGIC_isaelem:
4572         vtable = &PL_vtbl_isaelem;
4573         break;
4574     case PERL_MAGIC_nkeys:
4575         vtable = &PL_vtbl_nkeys;
4576         break;
4577     case PERL_MAGIC_dbfile:
4578         vtable = 0;
4579         break;
4580     case PERL_MAGIC_dbline:
4581         vtable = &PL_vtbl_dbline;
4582         break;
4583 #ifdef USE_5005THREADS
4584     case PERL_MAGIC_mutex:
4585         vtable = &PL_vtbl_mutex;
4586         break;
4587 #endif /* USE_5005THREADS */
4588 #ifdef USE_LOCALE_COLLATE
4589     case PERL_MAGIC_collxfrm:
4590         vtable = &PL_vtbl_collxfrm;
4591         break;
4592 #endif /* USE_LOCALE_COLLATE */
4593     case PERL_MAGIC_tied:
4594         vtable = &PL_vtbl_pack;
4595         break;
4596     case PERL_MAGIC_tiedelem:
4597     case PERL_MAGIC_tiedscalar:
4598         vtable = &PL_vtbl_packelem;
4599         break;
4600     case PERL_MAGIC_qr:
4601         vtable = &PL_vtbl_regexp;
4602         break;
4603     case PERL_MAGIC_sig:
4604         vtable = &PL_vtbl_sig;
4605         break;
4606     case PERL_MAGIC_sigelem:
4607         vtable = &PL_vtbl_sigelem;
4608         break;
4609     case PERL_MAGIC_taint:
4610         vtable = &PL_vtbl_taint;
4611         break;
4612     case PERL_MAGIC_uvar:
4613         vtable = &PL_vtbl_uvar;
4614         break;
4615     case PERL_MAGIC_vec:
4616         vtable = &PL_vtbl_vec;
4617         break;
4618     case PERL_MAGIC_substr:
4619         vtable = &PL_vtbl_substr;
4620         break;
4621     case PERL_MAGIC_defelem:
4622         vtable = &PL_vtbl_defelem;
4623         break;
4624     case PERL_MAGIC_glob:
4625         vtable = &PL_vtbl_glob;
4626         break;
4627     case PERL_MAGIC_arylen:
4628         vtable = &PL_vtbl_arylen;
4629         break;
4630     case PERL_MAGIC_pos:
4631         vtable = &PL_vtbl_pos;
4632         break;
4633     case PERL_MAGIC_backref:
4634         vtable = &PL_vtbl_backref;
4635         break;
4636     case PERL_MAGIC_ext:
4637         /* Reserved for use by extensions not perl internals.           */
4638         /* Useful for attaching extension internal data to perl vars.   */
4639         /* Note that multiple extensions may clash if magical scalars   */
4640         /* etc holding private data from one are passed to another.     */
4641         break;
4642     default:
4643         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4644     }
4645
4646     /* Rest of work is done else where */
4647     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4648
4649     switch (how) {
4650     case PERL_MAGIC_taint:
4651         mg->mg_len = 1;
4652         break;
4653     case PERL_MAGIC_ext:
4654     case PERL_MAGIC_dbfile:
4655         SvRMAGICAL_on(sv);
4656         break;
4657     }
4658 }
4659
4660 /*
4661 =for apidoc sv_unmagic
4662
4663 Removes all magic of type C<type> from an SV.
4664
4665 =cut
4666 */
4667
4668 int
4669 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4670 {
4671     MAGIC* mg;
4672     MAGIC** mgp;
4673     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4674         return 0;
4675     mgp = &SvMAGIC(sv);
4676     for (mg = *mgp; mg; mg = *mgp) {
4677         if (mg->mg_type == type) {
4678             MGVTBL* vtbl = mg->mg_virtual;
4679             *mgp = mg->mg_moremagic;
4680             if (vtbl && vtbl->svt_free)
4681                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4682             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4683                 if (mg->mg_len > 0)
4684                     Safefree(mg->mg_ptr);
4685                 else if (mg->mg_len == HEf_SVKEY)
4686                     SvREFCNT_dec((SV*)mg->mg_ptr);
4687             }
4688             if (mg->mg_flags & MGf_REFCOUNTED)
4689                 SvREFCNT_dec(mg->mg_obj);
4690             Safefree(mg);
4691         }
4692         else
4693             mgp = &mg->mg_moremagic;
4694     }
4695     if (!SvMAGIC(sv)) {
4696         SvMAGICAL_off(sv);
4697        SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4698     }
4699
4700     return 0;
4701 }
4702
4703 /*
4704 =for apidoc sv_rvweaken
4705
4706 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4707 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4708 push a back-reference to this RV onto the array of backreferences
4709 associated with that magic.
4710
4711 =cut
4712 */
4713
4714 SV *
4715 Perl_sv_rvweaken(pTHX_ SV *sv)
4716 {
4717     SV *tsv;
4718     if (!SvOK(sv))  /* let undefs pass */
4719         return sv;
4720     if (!SvROK(sv))
4721         Perl_croak(aTHX_ "Can't weaken a nonreference");
4722     else if (SvWEAKREF(sv)) {
4723         if (ckWARN(WARN_MISC))
4724             Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
4725         return sv;
4726     }
4727     tsv = SvRV(sv);
4728     sv_add_backref(tsv, sv);
4729     SvWEAKREF_on(sv);
4730     SvREFCNT_dec(tsv);
4731     return sv;
4732 }
4733
4734 /* Give tsv backref magic if it hasn't already got it, then push a
4735  * back-reference to sv onto the array associated with the backref magic.
4736  */
4737
4738 STATIC void
4739 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4740 {
4741     AV *av;
4742     MAGIC *mg;
4743     if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4744         av = (AV*)mg->mg_obj;
4745     else {
4746         av = newAV();
4747         sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4748         SvREFCNT_dec(av);           /* for sv_magic */
4749     }
4750     av_push(av,sv);
4751 }
4752
4753 /* delete a back-reference to ourselves from the backref magic associated
4754  * with the SV we point to.
4755  */
4756
4757 STATIC void
4758 S_sv_del_backref(pTHX_ SV *sv)
4759 {
4760     AV *av;
4761     SV **svp;
4762     I32 i;
4763     SV *tsv = SvRV(sv);
4764     MAGIC *mg = NULL;
4765     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4766         Perl_croak(aTHX_ "panic: del_backref");
4767     av = (AV *)mg->mg_obj;
4768     svp = AvARRAY(av);
4769     i = AvFILLp(av);
4770     while (i >= 0) {
4771         if (svp[i] == sv) {
4772             svp[i] = &PL_sv_undef; /* XXX */
4773         }
4774         i--;
4775     }
4776 }
4777
4778 /*
4779 =for apidoc sv_insert
4780
4781 Inserts a string at the specified offset/length within the SV. Similar to
4782 the Perl substr() function.
4783
4784 =cut
4785 */
4786
4787 void
4788 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4789 {
4790     register char *big;
4791     register char *mid;
4792     register char *midend;
4793     register char *bigend;
4794     register I32 i;
4795     STRLEN curlen;
4796
4797
4798     if (!bigstr)
4799         Perl_croak(aTHX_ "Can't modify non-existent substring");
4800     SvPV_force(bigstr, curlen);
4801     (void)SvPOK_only_UTF8(bigstr);
4802     if (offset + len > curlen) {
4803         SvGROW(bigstr, offset+len+1);
4804         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4805         SvCUR_set(bigstr, offset+len);
4806     }
4807
4808     SvTAINT(bigstr);
4809     i = littlelen - len;
4810     if (i > 0) {                        /* string might grow */
4811         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4812         mid = big + offset + len;
4813         midend = bigend = big + SvCUR(bigstr);
4814         bigend += i;
4815         *bigend = '\0';
4816         while (midend > mid)            /* shove everything down */
4817             *--bigend = *--midend;
4818         Move(little,big+offset,littlelen,char);
4819         SvCUR(bigstr) += i;
4820         SvSETMAGIC(bigstr);
4821         return;
4822     }
4823     else if (i == 0) {
4824         Move(little,SvPVX(bigstr)+offset,len,char);
4825         SvSETMAGIC(bigstr);
4826         return;
4827     }
4828
4829     big = SvPVX(bigstr);
4830     mid = big + offset;
4831     midend = mid + len;
4832     bigend = big + SvCUR(bigstr);
4833
4834     if (midend > bigend)
4835         Perl_croak(aTHX_ "panic: sv_insert");
4836
4837     if (mid - big > bigend - midend) {  /* faster to shorten from end */
4838         if (littlelen) {
4839             Move(little, mid, littlelen,char);
4840             mid += littlelen;
4841         }
4842         i = bigend - midend;
4843         if (i > 0) {
4844             Move(midend, mid, i,char);
4845             mid += i;
4846         }
4847         *mid = '\0';
4848         SvCUR_set(bigstr, mid - big);
4849     }
4850     /*SUPPRESS 560*/
4851     else if ((i = mid - big)) { /* faster from front */
4852         midend -= littlelen;
4853         mid = midend;
4854