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