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