This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add a new macro SvPV_free() which undoes OOK and free()s the PVX(),
[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 all this if()... if the above
1910            assertion is genuinely always true.  */
1911         if(SvOOK(sv)) {
1912             pv -= iv;
1913             SvFLAGS(sv) &= ~SVf_OOK;
1914         }
1915         Safefree(pv);
1916         SvPV_set(sv, (char*)0);
1917         SvMAGIC_set(sv, magic);
1918         SvSTASH_set(sv, stash);
1919         break;
1920
1921     case SVt_PVIO:
1922         SvANY(sv) = new_XPVIO();
1923         Zero(SvANY(sv), 1, XPVIO);
1924         IoPAGE_LEN(sv)  = 60;
1925         goto set_magic_common;
1926     case SVt_PVFM:
1927         SvANY(sv) = new_XPVFM();
1928         Zero(SvANY(sv), 1, XPVFM);
1929         goto set_magic_common;
1930     case SVt_PVBM:
1931         SvANY(sv) = new_XPVBM();
1932         BmRARE(sv)      = 0;
1933         BmUSEFUL(sv)    = 0;
1934         BmPREVIOUS(sv)  = 0;
1935         goto set_magic_common;
1936     case SVt_PVGV:
1937         SvANY(sv) = new_XPVGV();
1938         GvGP(sv)        = 0;
1939         GvNAME(sv)      = 0;
1940         GvNAMELEN(sv)   = 0;
1941         GvSTASH(sv)     = 0;
1942         GvFLAGS(sv)     = 0;
1943         goto set_magic_common;
1944     case SVt_PVCV:
1945         SvANY(sv) = new_XPVCV();
1946         Zero(SvANY(sv), 1, XPVCV);
1947         goto set_magic_common;
1948     case SVt_PVLV:
1949         SvANY(sv) = new_XPVLV();
1950         LvTARGOFF(sv)   = 0;
1951         LvTARGLEN(sv)   = 0;
1952         LvTARG(sv)      = 0;
1953         LvTYPE(sv)      = 0;
1954         GvGP(sv)        = 0;
1955         GvNAME(sv)      = 0;
1956         GvNAMELEN(sv)   = 0;
1957         GvSTASH(sv)     = 0;
1958         GvFLAGS(sv)     = 0;
1959         /* Fall through.  */
1960         if (0) {
1961         case SVt_PVMG:
1962             SvANY(sv) = new_XPVMG();
1963         }
1964     set_magic_common:
1965         SvMAGIC_set(sv, magic);
1966         SvSTASH_set(sv, stash);
1967         /* Fall through.  */
1968         if (0) {
1969         case SVt_PVNV:
1970             SvANY(sv) = new_XPVNV();
1971         }
1972         SvNV_set(sv, nv);
1973         /* Fall through.  */
1974         if (0) {
1975         case SVt_PVIV:
1976             SvANY(sv) = new_XPVIV();
1977             if (SvNIOK(sv))
1978                 (void)SvIOK_on(sv);
1979             SvNOK_off(sv);
1980         }
1981         SvIV_set(sv, iv);
1982         /* Fall through.  */
1983         if (0) {
1984         case SVt_PV:
1985             SvANY(sv) = new_XPV();
1986         }
1987         SvPV_set(sv, pv);
1988         SvCUR_set(sv, cur);
1989         SvLEN_set(sv, len);
1990         break;
1991     }
1992     return TRUE;
1993 }
1994
1995 /*
1996 =for apidoc sv_backoff
1997
1998 Remove any string offset. You should normally use the C<SvOOK_off> macro
1999 wrapper instead.
2000
2001 =cut
2002 */
2003
2004 int
2005 Perl_sv_backoff(pTHX_ register SV *sv)
2006 {
2007     assert(SvOOK(sv));
2008     if (SvIVX(sv)) {
2009         char *s = SvPVX(sv);
2010         SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
2011         SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
2012         SvIV_set(sv, 0);
2013         Move(s, SvPVX(sv), SvCUR(sv)+1, char);
2014     }
2015     SvFLAGS(sv) &= ~SVf_OOK;
2016     return 0;
2017 }
2018
2019 /*
2020 =for apidoc sv_grow
2021
2022 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
2023 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
2024 Use the C<SvGROW> wrapper instead.
2025
2026 =cut
2027 */
2028
2029 char *
2030 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
2031 {
2032     register char *s;
2033
2034 #ifdef HAS_64K_LIMIT
2035     if (newlen >= 0x10000) {
2036         PerlIO_printf(Perl_debug_log,
2037                       "Allocation too large: %"UVxf"\n", (UV)newlen);
2038         my_exit(1);
2039     }
2040 #endif /* HAS_64K_LIMIT */
2041     if (SvROK(sv))
2042         sv_unref(sv);
2043     if (SvTYPE(sv) < SVt_PV) {
2044         sv_upgrade(sv, SVt_PV);
2045         s = SvPVX(sv);
2046     }
2047     else if (SvOOK(sv)) {       /* pv is offset? */
2048         sv_backoff(sv);
2049         s = SvPVX(sv);
2050         if (newlen > SvLEN(sv))
2051             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
2052 #ifdef HAS_64K_LIMIT
2053         if (newlen >= 0x10000)
2054             newlen = 0xFFFF;
2055 #endif
2056     }
2057     else
2058         s = SvPVX(sv);
2059
2060     if (newlen > SvLEN(sv)) {           /* need more room? */
2061         if (SvLEN(sv) && s) {
2062 #ifdef MYMALLOC
2063             STRLEN l = malloced_size((void*)SvPVX(sv));
2064             if (newlen <= l) {
2065                 SvLEN_set(sv, l);
2066                 return s;
2067             } else
2068 #endif
2069             Renew(s,newlen,char);
2070         }
2071         else {
2072             New(703, s, newlen, char);
2073             if (SvPVX(sv) && SvCUR(sv)) {
2074                 Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
2075             }
2076         }
2077         SvPV_set(sv, s);
2078         SvLEN_set(sv, newlen);
2079     }
2080     return s;
2081 }
2082
2083 /*
2084 =for apidoc sv_setiv
2085
2086 Copies an integer into the given SV, upgrading first if necessary.
2087 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
2088
2089 =cut
2090 */
2091
2092 void
2093 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
2094 {
2095     SV_CHECK_THINKFIRST_COW_DROP(sv);
2096     switch (SvTYPE(sv)) {
2097     case SVt_NULL:
2098         sv_upgrade(sv, SVt_IV);
2099         break;
2100     case SVt_NV:
2101         sv_upgrade(sv, SVt_PVNV);
2102         break;
2103     case SVt_RV:
2104     case SVt_PV:
2105         sv_upgrade(sv, SVt_PVIV);
2106         break;
2107
2108     case SVt_PVGV:
2109     case SVt_PVAV:
2110     case SVt_PVHV:
2111     case SVt_PVCV:
2112     case SVt_PVFM:
2113     case SVt_PVIO:
2114         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
2115                    OP_DESC(PL_op));
2116     }
2117     (void)SvIOK_only(sv);                       /* validate number */
2118     SvIV_set(sv, i);
2119     SvTAINT(sv);
2120 }
2121
2122 /*
2123 =for apidoc sv_setiv_mg
2124
2125 Like C<sv_setiv>, but also handles 'set' magic.
2126
2127 =cut
2128 */
2129
2130 void
2131 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
2132 {
2133     sv_setiv(sv,i);
2134     SvSETMAGIC(sv);
2135 }
2136
2137 /*
2138 =for apidoc sv_setuv
2139
2140 Copies an unsigned integer into the given SV, upgrading first if necessary.
2141 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
2142
2143 =cut
2144 */
2145
2146 void
2147 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
2148 {
2149     /* With these two if statements:
2150        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
2151
2152        without
2153        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
2154
2155        If you wish to remove them, please benchmark to see what the effect is
2156     */
2157     if (u <= (UV)IV_MAX) {
2158        sv_setiv(sv, (IV)u);
2159        return;
2160     }
2161     sv_setiv(sv, 0);
2162     SvIsUV_on(sv);
2163     SvUV_set(sv, u);
2164 }
2165
2166 /*
2167 =for apidoc sv_setuv_mg
2168
2169 Like C<sv_setuv>, but also handles 'set' magic.
2170
2171 =cut
2172 */
2173
2174 void
2175 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
2176 {
2177     /* With these two if statements:
2178        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
2179
2180        without
2181        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
2182
2183        If you wish to remove them, please benchmark to see what the effect is
2184     */
2185     if (u <= (UV)IV_MAX) {
2186        sv_setiv(sv, (IV)u);
2187     } else {
2188        sv_setiv(sv, 0);
2189        SvIsUV_on(sv);
2190        sv_setuv(sv,u);
2191     }
2192     SvSETMAGIC(sv);
2193 }
2194
2195 /*
2196 =for apidoc sv_setnv
2197
2198 Copies a double into the given SV, upgrading first if necessary.
2199 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
2200
2201 =cut
2202 */
2203
2204 void
2205 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
2206 {
2207     SV_CHECK_THINKFIRST_COW_DROP(sv);
2208     switch (SvTYPE(sv)) {
2209     case SVt_NULL:
2210     case SVt_IV:
2211         sv_upgrade(sv, SVt_NV);
2212         break;
2213     case SVt_RV:
2214     case SVt_PV:
2215     case SVt_PVIV:
2216         sv_upgrade(sv, SVt_PVNV);
2217         break;
2218
2219     case SVt_PVGV:
2220     case SVt_PVAV:
2221     case SVt_PVHV:
2222     case SVt_PVCV:
2223     case SVt_PVFM:
2224     case SVt_PVIO:
2225         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
2226                    OP_NAME(PL_op));
2227     }
2228     SvNV_set(sv, num);
2229     (void)SvNOK_only(sv);                       /* validate number */
2230     SvTAINT(sv);
2231 }
2232
2233 /*
2234 =for apidoc sv_setnv_mg
2235
2236 Like C<sv_setnv>, but also handles 'set' magic.
2237
2238 =cut
2239 */
2240
2241 void
2242 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
2243 {
2244     sv_setnv(sv,num);
2245     SvSETMAGIC(sv);
2246 }
2247
2248 /* Print an "isn't numeric" warning, using a cleaned-up,
2249  * printable version of the offending string
2250  */
2251
2252 STATIC void
2253 S_not_a_number(pTHX_ SV *sv)
2254 {
2255      SV *dsv;
2256      char tmpbuf[64];
2257      char *pv;
2258
2259      if (DO_UTF8(sv)) {
2260           dsv = sv_2mortal(newSVpv("", 0));
2261           pv = sv_uni_display(dsv, sv, 10, 0);
2262      } else {
2263           char *d = tmpbuf;
2264           char *limit = tmpbuf + sizeof(tmpbuf) - 8;
2265           /* each *s can expand to 4 chars + "...\0",
2266              i.e. need room for 8 chars */
2267         
2268           char *s, *end;
2269           for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
2270                int ch = *s & 0xFF;
2271                if (ch & 128 && !isPRINT_LC(ch)) {
2272                     *d++ = 'M';
2273                     *d++ = '-';
2274                     ch &= 127;
2275                }
2276                if (ch == '\n') {
2277                     *d++ = '\\';
2278                     *d++ = 'n';
2279                }
2280                else if (ch == '\r') {
2281                     *d++ = '\\';
2282                     *d++ = 'r';
2283                }
2284                else if (ch == '\f') {
2285                     *d++ = '\\';
2286                     *d++ = 'f';
2287                }
2288                else if (ch == '\\') {
2289                     *d++ = '\\';
2290                     *d++ = '\\';
2291                }
2292                else if (ch == '\0') {
2293                     *d++ = '\\';
2294                     *d++ = '0';
2295                }
2296                else if (isPRINT_LC(ch))
2297                     *d++ = ch;
2298                else {
2299                     *d++ = '^';
2300                     *d++ = toCTRL(ch);
2301                }
2302           }
2303           if (s < end) {
2304                *d++ = '.';
2305                *d++ = '.';
2306                *d++ = '.';
2307           }
2308           *d = '\0';
2309           pv = tmpbuf;
2310     }
2311
2312     if (PL_op)
2313         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2314                     "Argument \"%s\" isn't numeric in %s", pv,
2315                     OP_DESC(PL_op));
2316     else
2317         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2318                     "Argument \"%s\" isn't numeric", pv);
2319 }
2320
2321 /*
2322 =for apidoc looks_like_number
2323
2324 Test if the content of an SV looks like a number (or is a number).
2325 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
2326 non-numeric warning), even if your atof() doesn't grok them.
2327
2328 =cut
2329 */
2330
2331 I32
2332 Perl_looks_like_number(pTHX_ SV *sv)
2333 {
2334     register char *sbegin;
2335     STRLEN len;
2336
2337     if (SvPOK(sv)) {
2338         sbegin = SvPVX(sv);
2339         len = SvCUR(sv);
2340     }
2341     else if (SvPOKp(sv))
2342         sbegin = SvPV(sv, len);
2343     else
2344         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
2345     return grok_number(sbegin, len, NULL);
2346 }
2347
2348 /* Actually, ISO C leaves conversion of UV to IV undefined, but
2349    until proven guilty, assume that things are not that bad... */
2350
2351 /*
2352    NV_PRESERVES_UV:
2353
2354    As 64 bit platforms often have an NV that doesn't preserve all bits of
2355    an IV (an assumption perl has been based on to date) it becomes necessary
2356    to remove the assumption that the NV always carries enough precision to
2357    recreate the IV whenever needed, and that the NV is the canonical form.
2358    Instead, IV/UV and NV need to be given equal rights. So as to not lose
2359    precision as a side effect of conversion (which would lead to insanity
2360    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
2361    1) to distinguish between IV/UV/NV slots that have cached a valid
2362       conversion where precision was lost and IV/UV/NV slots that have a
2363       valid conversion which has lost no precision
2364    2) to ensure that if a numeric conversion to one form is requested that
2365       would lose precision, the precise conversion (or differently
2366       imprecise conversion) is also performed and cached, to prevent
2367       requests for different numeric formats on the same SV causing
2368       lossy conversion chains. (lossless conversion chains are perfectly
2369       acceptable (still))
2370
2371
2372    flags are used:
2373    SvIOKp is true if the IV slot contains a valid value
2374    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
2375    SvNOKp is true if the NV slot contains a valid value
2376    SvNOK  is true only if the NV value is accurate
2377
2378    so
2379    while converting from PV to NV, check to see if converting that NV to an
2380    IV(or UV) would lose accuracy over a direct conversion from PV to
2381    IV(or UV). If it would, cache both conversions, return NV, but mark
2382    SV as IOK NOKp (ie not NOK).
2383
2384    While converting from PV to IV, check to see if converting that IV to an
2385    NV would lose accuracy over a direct conversion from PV to NV. If it
2386    would, cache both conversions, flag similarly.
2387
2388    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2389    correctly because if IV & NV were set NV *always* overruled.
2390    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2391    changes - now IV and NV together means that the two are interchangeable:
2392    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
2393
2394    The benefit of this is that operations such as pp_add know that if
2395    SvIOK is true for both left and right operands, then integer addition
2396    can be used instead of floating point (for cases where the result won't
2397    overflow). Before, floating point was always used, which could lead to
2398    loss of precision compared with integer addition.
2399
2400    * making IV and NV equal status should make maths accurate on 64 bit
2401      platforms
2402    * may speed up maths somewhat if pp_add and friends start to use
2403      integers when possible instead of fp. (Hopefully the overhead in
2404      looking for SvIOK and checking for overflow will not outweigh the
2405      fp to integer speedup)
2406    * will slow down integer operations (callers of SvIV) on "inaccurate"
2407      values, as the change from SvIOK to SvIOKp will cause a call into
2408      sv_2iv each time rather than a macro access direct to the IV slot
2409    * should speed up number->string conversion on integers as IV is
2410      favoured when IV and NV are equally accurate
2411
2412    ####################################################################
2413    You had better be using SvIOK_notUV if you want an IV for arithmetic:
2414    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2415    On the other hand, SvUOK is true iff UV.
2416    ####################################################################
2417
2418    Your mileage will vary depending your CPU's relative fp to integer
2419    performance ratio.
2420 */
2421
2422 #ifndef NV_PRESERVES_UV
2423 #  define IS_NUMBER_UNDERFLOW_IV 1
2424 #  define IS_NUMBER_UNDERFLOW_UV 2
2425 #  define IS_NUMBER_IV_AND_UV    2
2426 #  define IS_NUMBER_OVERFLOW_IV  4
2427 #  define IS_NUMBER_OVERFLOW_UV  5
2428
2429 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2430
2431 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
2432 STATIC int
2433 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2434 {
2435     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));
2436     if (SvNVX(sv) < (NV)IV_MIN) {
2437         (void)SvIOKp_on(sv);
2438         (void)SvNOK_on(sv);
2439         SvIV_set(sv, IV_MIN);
2440         return IS_NUMBER_UNDERFLOW_IV;
2441     }
2442     if (SvNVX(sv) > (NV)UV_MAX) {
2443         (void)SvIOKp_on(sv);
2444         (void)SvNOK_on(sv);
2445         SvIsUV_on(sv);
2446         SvUV_set(sv, UV_MAX);
2447         return IS_NUMBER_OVERFLOW_UV;
2448     }
2449     (void)SvIOKp_on(sv);
2450     (void)SvNOK_on(sv);
2451     /* Can't use strtol etc to convert this string.  (See truth table in
2452        sv_2iv  */
2453     if (SvNVX(sv) <= (UV)IV_MAX) {
2454         SvIV_set(sv, I_V(SvNVX(sv)));
2455         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2456             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2457         } else {
2458             /* Integer is imprecise. NOK, IOKp */
2459         }
2460         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2461     }
2462     SvIsUV_on(sv);
2463     SvUV_set(sv, U_V(SvNVX(sv)));
2464     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2465         if (SvUVX(sv) == UV_MAX) {
2466             /* As we know that NVs don't preserve UVs, UV_MAX cannot
2467                possibly be preserved by NV. Hence, it must be overflow.
2468                NOK, IOKp */
2469             return IS_NUMBER_OVERFLOW_UV;
2470         }
2471         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2472     } else {
2473         /* Integer is imprecise. NOK, IOKp */
2474     }
2475     return IS_NUMBER_OVERFLOW_IV;
2476 }
2477 #endif /* !NV_PRESERVES_UV*/
2478
2479 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
2480  * this function provided for binary compatibility only
2481  */
2482
2483 IV
2484 Perl_sv_2iv(pTHX_ register SV *sv)
2485 {
2486     return sv_2iv_flags(sv, SV_GMAGIC);
2487 }
2488
2489 /*
2490 =for apidoc sv_2iv_flags
2491
2492 Return the integer value of an SV, doing any necessary string
2493 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2494 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2495
2496 =cut
2497 */
2498
2499 IV
2500 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2501 {
2502     if (!sv)
2503         return 0;
2504     if (SvGMAGICAL(sv)) {
2505         if (flags & SV_GMAGIC)
2506             mg_get(sv);
2507         if (SvIOKp(sv))
2508             return SvIVX(sv);
2509         if (SvNOKp(sv)) {
2510             return I_V(SvNVX(sv));
2511         }
2512         if (SvPOKp(sv) && SvLEN(sv))
2513             return asIV(sv);
2514         if (!SvROK(sv)) {
2515             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2516                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2517                     report_uninit(sv);
2518             }
2519             return 0;
2520         }
2521     }
2522     if (SvTHINKFIRST(sv)) {
2523         if (SvROK(sv)) {
2524           SV* tmpstr;
2525           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2526                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2527               return SvIV(tmpstr);
2528           return PTR2IV(SvRV(sv));
2529         }
2530         if (SvIsCOW(sv)) {
2531             sv_force_normal_flags(sv, 0);
2532         }
2533         if (SvREADONLY(sv) && !SvOK(sv)) {
2534             if (ckWARN(WARN_UNINITIALIZED))
2535                 report_uninit(sv);
2536             return 0;
2537         }
2538     }
2539     if (SvIOKp(sv)) {
2540         if (SvIsUV(sv)) {
2541             return (IV)(SvUVX(sv));
2542         }
2543         else {
2544             return SvIVX(sv);
2545         }
2546     }
2547     if (SvNOKp(sv)) {
2548         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2549          * without also getting a cached IV/UV from it at the same time
2550          * (ie PV->NV conversion should detect loss of accuracy and cache
2551          * IV or UV at same time to avoid this.  NWC */
2552
2553         if (SvTYPE(sv) == SVt_NV)
2554             sv_upgrade(sv, SVt_PVNV);
2555
2556         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2557         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2558            certainly cast into the IV range at IV_MAX, whereas the correct
2559            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2560            cases go to UV */
2561         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2562             SvIV_set(sv, I_V(SvNVX(sv)));
2563             if (SvNVX(sv) == (NV) SvIVX(sv)
2564 #ifndef NV_PRESERVES_UV
2565                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2566                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2567                 /* Don't flag it as "accurately an integer" if the number
2568                    came from a (by definition imprecise) NV operation, and
2569                    we're outside the range of NV integer precision */
2570 #endif
2571                 ) {
2572                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2573                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2574                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2575                                       PTR2UV(sv),
2576                                       SvNVX(sv),
2577                                       SvIVX(sv)));
2578
2579             } else {
2580                 /* IV not precise.  No need to convert from PV, as NV
2581                    conversion would already have cached IV if it detected
2582                    that PV->IV would be better than PV->NV->IV
2583                    flags already correct - don't set public IOK.  */
2584                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2585                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2586                                       PTR2UV(sv),
2587                                       SvNVX(sv),
2588                                       SvIVX(sv)));
2589             }
2590             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2591                but the cast (NV)IV_MIN rounds to a the value less (more
2592                negative) than IV_MIN which happens to be equal to SvNVX ??
2593                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2594                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2595                (NV)UVX == NVX are both true, but the values differ. :-(
2596                Hopefully for 2s complement IV_MIN is something like
2597                0x8000000000000000 which will be exact. NWC */
2598         }
2599         else {
2600             SvUV_set(sv, U_V(SvNVX(sv)));
2601             if (
2602                 (SvNVX(sv) == (NV) SvUVX(sv))
2603 #ifndef  NV_PRESERVES_UV
2604                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2605                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2606                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2607                 /* Don't flag it as "accurately an integer" if the number
2608                    came from a (by definition imprecise) NV operation, and
2609                    we're outside the range of NV integer precision */
2610 #endif
2611                 )
2612                 SvIOK_on(sv);
2613             SvIsUV_on(sv);
2614           ret_iv_max:
2615             DEBUG_c(PerlIO_printf(Perl_debug_log,
2616                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2617                                   PTR2UV(sv),
2618                                   SvUVX(sv),
2619                                   SvUVX(sv)));
2620             return (IV)SvUVX(sv);
2621         }
2622     }
2623     else if (SvPOKp(sv) && SvLEN(sv)) {
2624         UV value;
2625         int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2626         /* We want to avoid a possible problem when we cache an IV which
2627            may be later translated to an NV, and the resulting NV is not
2628            the same as the direct translation of the initial string
2629            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2630            be careful to ensure that the value with the .456 is around if the
2631            NV value is requested in the future).
2632         
2633            This means that if we cache such an IV, we need to cache the
2634            NV as well.  Moreover, we trade speed for space, and do not
2635            cache the NV if we are sure it's not needed.
2636          */
2637
2638         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2639         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2640              == IS_NUMBER_IN_UV) {
2641             /* It's definitely an integer, only upgrade to PVIV */
2642             if (SvTYPE(sv) < SVt_PVIV)
2643                 sv_upgrade(sv, SVt_PVIV);
2644             (void)SvIOK_on(sv);
2645         } else if (SvTYPE(sv) < SVt_PVNV)
2646             sv_upgrade(sv, SVt_PVNV);
2647
2648         /* If NV preserves UV then we only use the UV value if we know that
2649            we aren't going to call atof() below. If NVs don't preserve UVs
2650            then the value returned may have more precision than atof() will
2651            return, even though value isn't perfectly accurate.  */
2652         if ((numtype & (IS_NUMBER_IN_UV
2653 #ifdef NV_PRESERVES_UV
2654                         | IS_NUMBER_NOT_INT
2655 #endif
2656             )) == IS_NUMBER_IN_UV) {
2657             /* This won't turn off the public IOK flag if it was set above  */
2658             (void)SvIOKp_on(sv);
2659
2660             if (!(numtype & IS_NUMBER_NEG)) {
2661                 /* positive */;
2662                 if (value <= (UV)IV_MAX) {
2663                     SvIV_set(sv, (IV)value);
2664                 } else {
2665                     SvUV_set(sv, value);
2666                     SvIsUV_on(sv);
2667                 }
2668             } else {
2669                 /* 2s complement assumption  */
2670                 if (value <= (UV)IV_MIN) {
2671                     SvIV_set(sv, -(IV)value);
2672                 } else {
2673                     /* Too negative for an IV.  This is a double upgrade, but
2674                        I'm assuming it will be rare.  */
2675                     if (SvTYPE(sv) < SVt_PVNV)
2676                         sv_upgrade(sv, SVt_PVNV);
2677                     SvNOK_on(sv);
2678                     SvIOK_off(sv);
2679                     SvIOKp_on(sv);
2680                     SvNV_set(sv, -(NV)value);
2681                     SvIV_set(sv, IV_MIN);
2682                 }
2683             }
2684         }
2685         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2686            will be in the previous block to set the IV slot, and the next
2687            block to set the NV slot.  So no else here.  */
2688         
2689         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2690             != IS_NUMBER_IN_UV) {
2691             /* It wasn't an (integer that doesn't overflow the UV). */
2692             SvNV_set(sv, Atof(SvPVX(sv)));
2693
2694             if (! numtype && ckWARN(WARN_NUMERIC))
2695                 not_a_number(sv);
2696
2697 #if defined(USE_LONG_DOUBLE)
2698             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2699                                   PTR2UV(sv), SvNVX(sv)));
2700 #else
2701             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2702                                   PTR2UV(sv), SvNVX(sv)));
2703 #endif
2704
2705
2706 #ifdef NV_PRESERVES_UV
2707             (void)SvIOKp_on(sv);
2708             (void)SvNOK_on(sv);
2709             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2710                 SvIV_set(sv, I_V(SvNVX(sv)));
2711                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2712                     SvIOK_on(sv);
2713                 } else {
2714                     /* Integer is imprecise. NOK, IOKp */
2715                 }
2716                 /* UV will not work better than IV */
2717             } else {
2718                 if (SvNVX(sv) > (NV)UV_MAX) {
2719                     SvIsUV_on(sv);
2720                     /* Integer is inaccurate. NOK, IOKp, is UV */
2721                     SvUV_set(sv, UV_MAX);
2722                     SvIsUV_on(sv);
2723                 } else {
2724                     SvUV_set(sv, U_V(SvNVX(sv)));
2725                     /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2726                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2727                         SvIOK_on(sv);
2728                         SvIsUV_on(sv);
2729                     } else {
2730                         /* Integer is imprecise. NOK, IOKp, is UV */
2731                         SvIsUV_on(sv);
2732                     }
2733                 }
2734                 goto ret_iv_max;
2735             }
2736 #else /* NV_PRESERVES_UV */
2737             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2738                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2739                 /* The IV slot will have been set from value returned by
2740                    grok_number above.  The NV slot has just been set using
2741                    Atof.  */
2742                 SvNOK_on(sv);
2743                 assert (SvIOKp(sv));
2744             } else {
2745                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2746                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2747                     /* Small enough to preserve all bits. */
2748                     (void)SvIOKp_on(sv);
2749                     SvNOK_on(sv);
2750                     SvIV_set(sv, I_V(SvNVX(sv)));
2751                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2752                         SvIOK_on(sv);
2753                     /* Assumption: first non-preserved integer is < IV_MAX,
2754                        this NV is in the preserved range, therefore: */
2755                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2756                           < (UV)IV_MAX)) {
2757                         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);
2758                     }
2759                 } else {
2760                     /* IN_UV NOT_INT
2761                          0      0       already failed to read UV.
2762                          0      1       already failed to read UV.
2763                          1      0       you won't get here in this case. IV/UV
2764                                         slot set, public IOK, Atof() unneeded.
2765                          1      1       already read UV.
2766                        so there's no point in sv_2iuv_non_preserve() attempting
2767                        to use atol, strtol, strtoul etc.  */
2768                     if (sv_2iuv_non_preserve (sv, numtype)
2769                         >= IS_NUMBER_OVERFLOW_IV)
2770                     goto ret_iv_max;
2771                 }
2772             }
2773 #endif /* NV_PRESERVES_UV */
2774         }
2775     } else  {
2776         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2777             report_uninit(sv);
2778         if (SvTYPE(sv) < SVt_IV)
2779             /* Typically the caller expects that sv_any is not NULL now.  */
2780             sv_upgrade(sv, SVt_IV);
2781         return 0;
2782     }
2783     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2784         PTR2UV(sv),SvIVX(sv)));
2785     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2786 }
2787
2788 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2789  * this function provided for binary compatibility only
2790  */
2791
2792 UV
2793 Perl_sv_2uv(pTHX_ register SV *sv)
2794 {
2795     return sv_2uv_flags(sv, SV_GMAGIC);
2796 }
2797
2798 /*
2799 =for apidoc sv_2uv_flags
2800
2801 Return the unsigned integer value of an SV, doing any necessary string
2802 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2803 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2804
2805 =cut
2806 */
2807
2808 UV
2809 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2810 {
2811     if (!sv)
2812         return 0;
2813     if (SvGMAGICAL(sv)) {
2814         if (flags & SV_GMAGIC)
2815             mg_get(sv);
2816         if (SvIOKp(sv))
2817             return SvUVX(sv);
2818         if (SvNOKp(sv))
2819             return U_V(SvNVX(sv));
2820         if (SvPOKp(sv) && SvLEN(sv))
2821             return asUV(sv);
2822         if (!SvROK(sv)) {
2823             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2824                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2825                     report_uninit(sv);
2826             }
2827             return 0;
2828         }
2829     }
2830     if (SvTHINKFIRST(sv)) {
2831         if (SvROK(sv)) {
2832           SV* tmpstr;
2833           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2834                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2835               return SvUV(tmpstr);
2836           return PTR2UV(SvRV(sv));
2837         }
2838         if (SvIsCOW(sv)) {
2839             sv_force_normal_flags(sv, 0);
2840         }
2841         if (SvREADONLY(sv) && !SvOK(sv)) {
2842             if (ckWARN(WARN_UNINITIALIZED))
2843                 report_uninit(sv);
2844             return 0;
2845         }
2846     }
2847     if (SvIOKp(sv)) {
2848         if (SvIsUV(sv)) {
2849             return SvUVX(sv);
2850         }
2851         else {
2852             return (UV)SvIVX(sv);
2853         }
2854     }
2855     if (SvNOKp(sv)) {
2856         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2857          * without also getting a cached IV/UV from it at the same time
2858          * (ie PV->NV conversion should detect loss of accuracy and cache
2859          * IV or UV at same time to avoid this. */
2860         /* IV-over-UV optimisation - choose to cache IV if possible */
2861
2862         if (SvTYPE(sv) == SVt_NV)
2863             sv_upgrade(sv, SVt_PVNV);
2864
2865         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2866         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2867             SvIV_set(sv, I_V(SvNVX(sv)));
2868             if (SvNVX(sv) == (NV) SvIVX(sv)
2869 #ifndef NV_PRESERVES_UV
2870                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2871                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2872                 /* Don't flag it as "accurately an integer" if the number
2873                    came from a (by definition imprecise) NV operation, and
2874                    we're outside the range of NV integer precision */
2875 #endif
2876                 ) {
2877                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2878                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2879                                       "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2880                                       PTR2UV(sv),
2881                                       SvNVX(sv),
2882                                       SvIVX(sv)));
2883
2884             } else {
2885                 /* IV not precise.  No need to convert from PV, as NV
2886                    conversion would already have cached IV if it detected
2887                    that PV->IV would be better than PV->NV->IV
2888                    flags already correct - don't set public IOK.  */
2889                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2890                                       "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2891                                       PTR2UV(sv),
2892                                       SvNVX(sv),
2893                                       SvIVX(sv)));
2894             }
2895             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2896                but the cast (NV)IV_MIN rounds to a the value less (more
2897                negative) than IV_MIN which happens to be equal to SvNVX ??
2898                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2899                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2900                (NV)UVX == NVX are both true, but the values differ. :-(
2901                Hopefully for 2s complement IV_MIN is something like
2902                0x8000000000000000 which will be exact. NWC */
2903         }
2904         else {
2905             SvUV_set(sv, U_V(SvNVX(sv)));
2906             if (
2907                 (SvNVX(sv) == (NV) SvUVX(sv))
2908 #ifndef  NV_PRESERVES_UV
2909                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2910                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2911                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2912                 /* Don't flag it as "accurately an integer" if the number
2913                    came from a (by definition imprecise) NV operation, and
2914                    we're outside the range of NV integer precision */
2915 #endif
2916                 )
2917                 SvIOK_on(sv);
2918             SvIsUV_on(sv);
2919             DEBUG_c(PerlIO_printf(Perl_debug_log,
2920                                   "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2921                                   PTR2UV(sv),
2922                                   SvUVX(sv),
2923                                   SvUVX(sv)));
2924         }
2925     }
2926     else if (SvPOKp(sv) && SvLEN(sv)) {
2927         UV value;
2928         int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2929
2930         /* We want to avoid a possible problem when we cache a UV which
2931            may be later translated to an NV, and the resulting NV is not
2932            the translation of the initial data.
2933         
2934            This means that if we cache such a UV, we need to cache the
2935            NV as well.  Moreover, we trade speed for space, and do not
2936            cache the NV if not needed.
2937          */
2938
2939         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2940         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2941              == IS_NUMBER_IN_UV) {
2942             /* It's definitely an integer, only upgrade to PVIV */
2943             if (SvTYPE(sv) < SVt_PVIV)
2944                 sv_upgrade(sv, SVt_PVIV);
2945             (void)SvIOK_on(sv);
2946         } else if (SvTYPE(sv) < SVt_PVNV)
2947             sv_upgrade(sv, SVt_PVNV);
2948
2949         /* If NV preserves UV then we only use the UV value if we know that
2950            we aren't going to call atof() below. If NVs don't preserve UVs
2951            then the value returned may have more precision than atof() will
2952            return, even though it isn't accurate.  */
2953         if ((numtype & (IS_NUMBER_IN_UV
2954 #ifdef NV_PRESERVES_UV
2955                         | IS_NUMBER_NOT_INT
2956 #endif
2957             )) == IS_NUMBER_IN_UV) {
2958             /* This won't turn off the public IOK flag if it was set above  */
2959             (void)SvIOKp_on(sv);
2960
2961             if (!(numtype & IS_NUMBER_NEG)) {
2962                 /* positive */;
2963                 if (value <= (UV)IV_MAX) {
2964                     SvIV_set(sv, (IV)value);
2965                 } else {
2966                     /* it didn't overflow, and it was positive. */
2967                     SvUV_set(sv, value);
2968                     SvIsUV_on(sv);
2969                 }
2970             } else {
2971                 /* 2s complement assumption  */
2972                 if (value <= (UV)IV_MIN) {
2973                     SvIV_set(sv, -(IV)value);
2974                 } else {
2975                     /* Too negative for an IV.  This is a double upgrade, but
2976                        I'm assuming it will be rare.  */
2977                     if (SvTYPE(sv) < SVt_PVNV)
2978                         sv_upgrade(sv, SVt_PVNV);
2979                     SvNOK_on(sv);
2980                     SvIOK_off(sv);
2981                     SvIOKp_on(sv);
2982                     SvNV_set(sv, -(NV)value);
2983                     SvIV_set(sv, IV_MIN);
2984                 }
2985             }
2986         }
2987         
2988         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2989             != IS_NUMBER_IN_UV) {
2990             /* It wasn't an integer, or it overflowed the UV. */
2991             SvNV_set(sv, Atof(SvPVX(sv)));
2992
2993             if (! numtype && ckWARN(WARN_NUMERIC))
2994                     not_a_number(sv);
2995
2996 #if defined(USE_LONG_DOUBLE)
2997             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2998                                   PTR2UV(sv), SvNVX(sv)));
2999 #else
3000             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
3001                                   PTR2UV(sv), SvNVX(sv)));
3002 #endif
3003
3004 #ifdef NV_PRESERVES_UV
3005             (void)SvIOKp_on(sv);
3006             (void)SvNOK_on(sv);
3007             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3008                 SvIV_set(sv, I_V(SvNVX(sv)));
3009                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
3010                     SvIOK_on(sv);
3011                 } else {
3012                     /* Integer is imprecise. NOK, IOKp */
3013                 }
3014                 /* UV will not work better than IV */
3015             } else {
3016                 if (SvNVX(sv) > (NV)UV_MAX) {
3017                     SvIsUV_on(sv);
3018                     /* Integer is inaccurate. NOK, IOKp, is UV */
3019                     SvUV_set(sv, UV_MAX);
3020                     SvIsUV_on(sv);
3021                 } else {
3022                     SvUV_set(sv, U_V(SvNVX(sv)));
3023                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
3024                        NV preservse UV so can do correct comparison.  */
3025                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
3026                         SvIOK_on(sv);
3027                         SvIsUV_on(sv);
3028                     } else {
3029                         /* Integer is imprecise. NOK, IOKp, is UV */
3030                         SvIsUV_on(sv);
3031                     }
3032                 }
3033             }
3034 #else /* NV_PRESERVES_UV */
3035             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3036                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
3037                 /* The UV slot will have been set from value returned by
3038                    grok_number above.  The NV slot has just been set using
3039                    Atof.  */
3040                 SvNOK_on(sv);
3041                 assert (SvIOKp(sv));
3042             } else {
3043                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3044                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3045                     /* Small enough to preserve all bits. */
3046                     (void)SvIOKp_on(sv);
3047                     SvNOK_on(sv);
3048                     SvIV_set(sv, I_V(SvNVX(sv)));
3049                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
3050                         SvIOK_on(sv);
3051                     /* Assumption: first non-preserved integer is < IV_MAX,
3052                        this NV is in the preserved range, therefore: */
3053                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
3054                           < (UV)IV_MAX)) {
3055                         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);
3056                     }
3057                 } else
3058                     sv_2iuv_non_preserve (sv, numtype);
3059             }
3060 #endif /* NV_PRESERVES_UV */
3061         }
3062     }
3063     else  {
3064         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3065             if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3066                 report_uninit(sv);
3067         }
3068         if (SvTYPE(sv) < SVt_IV)
3069             /* Typically the caller expects that sv_any is not NULL now.  */
3070             sv_upgrade(sv, SVt_IV);
3071         return 0;
3072     }
3073
3074     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
3075                           PTR2UV(sv),SvUVX(sv)));
3076     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
3077 }
3078
3079 /*
3080 =for apidoc sv_2nv
3081
3082 Return the num value of an SV, doing any necessary string or integer
3083 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
3084 macros.
3085
3086 =cut
3087 */
3088
3089 NV
3090 Perl_sv_2nv(pTHX_ register SV *sv)
3091 {
3092     if (!sv)
3093         return 0.0;
3094     if (SvGMAGICAL(sv)) {
3095         mg_get(sv);
3096         if (SvNOKp(sv))
3097             return SvNVX(sv);
3098         if (SvPOKp(sv) && SvLEN(sv)) {
3099             if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
3100                 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
3101                 not_a_number(sv);
3102             return Atof(SvPVX(sv));
3103         }
3104         if (SvIOKp(sv)) {
3105             if (SvIsUV(sv))
3106                 return (NV)SvUVX(sv);
3107             else
3108                 return (NV)SvIVX(sv);
3109         }       
3110         if (!SvROK(sv)) {
3111             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3112                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3113                     report_uninit(sv);
3114             }
3115             return 0;
3116         }
3117     }
3118     if (SvTHINKFIRST(sv)) {
3119         if (SvROK(sv)) {
3120           SV* tmpstr;
3121           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
3122                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
3123               return SvNV(tmpstr);
3124           return PTR2NV(SvRV(sv));
3125         }
3126         if (SvIsCOW(sv)) {
3127             sv_force_normal_flags(sv, 0);
3128         }
3129         if (SvREADONLY(sv) && !SvOK(sv)) {
3130             if (ckWARN(WARN_UNINITIALIZED))
3131                 report_uninit(sv);
3132             return 0.0;
3133         }
3134     }
3135     if (SvTYPE(sv) < SVt_NV) {
3136         if (SvTYPE(sv) == SVt_IV)
3137             sv_upgrade(sv, SVt_PVNV);
3138         else
3139             sv_upgrade(sv, SVt_NV);
3140 #ifdef USE_LONG_DOUBLE
3141         DEBUG_c({
3142             STORE_NUMERIC_LOCAL_SET_STANDARD();
3143             PerlIO_printf(Perl_debug_log,
3144                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
3145                           PTR2UV(sv), SvNVX(sv));
3146             RESTORE_NUMERIC_LOCAL();
3147         });
3148 #else
3149         DEBUG_c({
3150             STORE_NUMERIC_LOCAL_SET_STANDARD();
3151             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
3152                           PTR2UV(sv), SvNVX(sv));
3153             RESTORE_NUMERIC_LOCAL();
3154         });
3155 #endif
3156     }
3157     else if (SvTYPE(sv) < SVt_PVNV)
3158         sv_upgrade(sv, SVt_PVNV);
3159     if (SvNOKp(sv)) {
3160         return SvNVX(sv);
3161     }
3162     if (SvIOKp(sv)) {
3163         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
3164 #ifdef NV_PRESERVES_UV
3165         SvNOK_on(sv);
3166 #else
3167         /* Only set the public NV OK flag if this NV preserves the IV  */
3168         /* Check it's not 0xFFFFFFFFFFFFFFFF */
3169         if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
3170                        : (SvIVX(sv) == I_V(SvNVX(sv))))
3171             SvNOK_on(sv);
3172         else
3173             SvNOKp_on(sv);
3174 #endif
3175     }
3176     else if (SvPOKp(sv) && SvLEN(sv)) {
3177         UV value;
3178         int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3179         if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
3180             not_a_number(sv);
3181 #ifdef NV_PRESERVES_UV
3182         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3183             == IS_NUMBER_IN_UV) {
3184             /* It's definitely an integer */
3185             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
3186         } else
3187             SvNV_set(sv, Atof(SvPVX(sv)));
3188         SvNOK_on(sv);
3189 #else
3190         SvNV_set(sv, Atof(SvPVX(sv)));
3191         /* Only set the public NV OK flag if this NV preserves the value in
3192            the PV at least as well as an IV/UV would.
3193            Not sure how to do this 100% reliably. */
3194         /* if that shift count is out of range then Configure's test is
3195            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
3196            UV_BITS */
3197         if (((UV)1 << NV_PRESERVES_UV_BITS) >
3198             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3199             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
3200         } else if (!(numtype & IS_NUMBER_IN_UV)) {
3201             /* Can't use strtol etc to convert this string, so don't try.
3202                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
3203             SvNOK_on(sv);
3204         } else {
3205             /* value has been set.  It may not be precise.  */
3206             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
3207                 /* 2s complement assumption for (UV)IV_MIN  */
3208                 SvNOK_on(sv); /* Integer is too negative.  */
3209             } else {
3210                 SvNOKp_on(sv);
3211                 SvIOKp_on(sv);
3212
3213                 if (numtype & IS_NUMBER_NEG) {
3214                     SvIV_set(sv, -(IV)value);
3215                 } else if (value <= (UV)IV_MAX) {
3216                     SvIV_set(sv, (IV)value);
3217                 } else {
3218                     SvUV_set(sv, value);
3219                     SvIsUV_on(sv);
3220                 }
3221
3222                 if (numtype & IS_NUMBER_NOT_INT) {
3223                     /* I believe that even if the original PV had decimals,
3224                        they are lost beyond the limit of the FP precision.
3225                        However, neither is canonical, so both only get p
3226                        flags.  NWC, 2000/11/25 */
3227                     /* Both already have p flags, so do nothing */
3228                 } else {
3229                     NV nv = SvNVX(sv);
3230                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3231                         if (SvIVX(sv) == I_V(nv)) {
3232                             SvNOK_on(sv);
3233                             SvIOK_on(sv);
3234                         } else {
3235                             SvIOK_on(sv);
3236                             /* It had no "." so it must be integer.  */
3237                         }
3238                     } else {
3239                         /* between IV_MAX and NV(UV_MAX).
3240                            Could be slightly > UV_MAX */
3241
3242                         if (numtype & IS_NUMBER_NOT_INT) {
3243                             /* UV and NV both imprecise.  */
3244                         } else {
3245                             UV nv_as_uv = U_V(nv);
3246
3247                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
3248                                 SvNOK_on(sv);
3249                                 SvIOK_on(sv);
3250                             } else {
3251                                 SvIOK_on(sv);
3252                             }
3253                         }
3254                     }
3255                 }
3256             }
3257         }
3258 #endif /* NV_PRESERVES_UV */
3259     }
3260     else  {
3261         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3262             report_uninit(sv);
3263         if (SvTYPE(sv) < SVt_NV)
3264             /* Typically the caller expects that sv_any is not NULL now.  */
3265             /* XXX Ilya implies that this is a bug in callers that assume this
3266                and ideally should be fixed.  */
3267             sv_upgrade(sv, SVt_NV);
3268         return 0.0;
3269     }
3270 #if defined(USE_LONG_DOUBLE)
3271     DEBUG_c({
3272         STORE_NUMERIC_LOCAL_SET_STANDARD();
3273         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
3274                       PTR2UV(sv), SvNVX(sv));
3275         RESTORE_NUMERIC_LOCAL();
3276     });
3277 #else
3278     DEBUG_c({
3279         STORE_NUMERIC_LOCAL_SET_STANDARD();
3280         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
3281                       PTR2UV(sv), SvNVX(sv));
3282         RESTORE_NUMERIC_LOCAL();
3283     });
3284 #endif
3285     return SvNVX(sv);
3286 }
3287
3288 /* asIV(): extract an integer from the string value of an SV.
3289  * Caller must validate PVX  */
3290
3291 STATIC IV
3292 S_asIV(pTHX_ SV *sv)
3293 {
3294     UV value;
3295     int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3296
3297     if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3298         == IS_NUMBER_IN_UV) {
3299         /* It's definitely an integer */
3300         if (numtype & IS_NUMBER_NEG) {
3301             if (value < (UV)IV_MIN)
3302                 return -(IV)value;
3303         } else {
3304             if (value < (UV)IV_MAX)
3305                 return (IV)value;
3306         }
3307     }
3308     if (!numtype) {
3309         if (ckWARN(WARN_NUMERIC))
3310             not_a_number(sv);
3311     }
3312     return I_V(Atof(SvPVX(sv)));
3313 }
3314
3315 /* asUV(): extract an unsigned integer from the string value of an SV
3316  * Caller must validate PVX  */
3317
3318 STATIC UV
3319 S_asUV(pTHX_ SV *sv)
3320 {
3321     UV value;
3322     int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3323
3324     if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3325         == IS_NUMBER_IN_UV) {
3326         /* It's definitely an integer */
3327         if (!(numtype & IS_NUMBER_NEG))
3328             return value;
3329     }
3330     if (!numtype) {
3331         if (ckWARN(WARN_NUMERIC))
3332             not_a_number(sv);
3333     }
3334     return U_V(Atof(SvPVX(sv)));
3335 }
3336
3337 /*
3338 =for apidoc sv_2pv_nolen
3339
3340 Like C<sv_2pv()>, but doesn't return the length too. You should usually
3341 use the macro wrapper C<SvPV_nolen(sv)> instead.
3342 =cut
3343 */
3344
3345 char *
3346 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
3347 {
3348     STRLEN n_a;
3349     return sv_2pv(sv, &n_a);
3350 }
3351
3352 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
3353  * UV as a string towards the end of buf, and return pointers to start and
3354  * end of it.
3355  *
3356  * We assume that buf is at least TYPE_CHARS(UV) long.
3357  */
3358
3359 static char *
3360 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
3361 {
3362     char *ptr = buf + TYPE_CHARS(UV);
3363     char *ebuf = ptr;
3364     int sign;
3365
3366     if (is_uv)
3367         sign = 0;
3368     else if (iv >= 0) {
3369         uv = iv;
3370         sign = 0;
3371     } else {
3372         uv = -iv;
3373         sign = 1;
3374     }
3375     do {
3376         *--ptr = '0' + (char)(uv % 10);
3377     } while (uv /= 10);
3378     if (sign)
3379         *--ptr = '-';
3380     *peob = ebuf;
3381     return ptr;
3382 }
3383
3384 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
3385  * this function provided for binary compatibility only
3386  */
3387
3388 char *
3389 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
3390 {
3391     return sv_2pv_flags(sv, lp, SV_GMAGIC);
3392 }
3393
3394 /*
3395 =for apidoc sv_2pv_flags
3396
3397 Returns a pointer to the string value of an SV, and sets *lp to its length.
3398 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
3399 if necessary.
3400 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
3401 usually end up here too.
3402
3403 =cut
3404 */
3405
3406 char *
3407 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3408 {
3409     register char *s;
3410     int olderrno;
3411     SV *tsv, *origsv;
3412     char tbuf[64];      /* Must fit sprintf/Gconvert of longest IV/NV */
3413     char *tmpbuf = tbuf;
3414
3415     if (!sv) {
3416         *lp = 0;
3417         return (char *)"";
3418     }
3419     if (SvGMAGICAL(sv)) {
3420         if (flags & SV_GMAGIC)
3421             mg_get(sv);
3422         if (SvPOKp(sv)) {
3423             *lp = SvCUR(sv);
3424             return SvPVX(sv);
3425         }
3426         if (SvIOKp(sv)) {
3427             if (SvIsUV(sv))
3428                 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
3429             else
3430                 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3431             tsv = Nullsv;
3432             goto tokensave;
3433         }
3434         if (SvNOKp(sv)) {
3435             Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3436             tsv = Nullsv;
3437             goto tokensave;
3438         }
3439         if (!SvROK(sv)) {
3440             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3441                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3442                     report_uninit(sv);
3443             }
3444             *lp = 0;
3445             return (char *)"";
3446         }
3447     }
3448     if (SvTHINKFIRST(sv)) {
3449         if (SvROK(sv)) {
3450             SV* tmpstr;
3451             register const char *typestr;
3452             if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3453                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3454                 char *pv = SvPV(tmpstr, *lp);
3455                 if (SvUTF8(tmpstr))
3456                     SvUTF8_on(sv);
3457                 else
3458                     SvUTF8_off(sv);
3459                 return pv;
3460             }
3461             origsv = sv;
3462             sv = (SV*)SvRV(sv);
3463             if (!sv)
3464                 typestr = "NULLREF";
3465             else {
3466                 MAGIC *mg;
3467                 
3468                 switch (SvTYPE(sv)) {
3469                 case SVt_PVMG:
3470                     if ( ((SvFLAGS(sv) &
3471                            (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3472                           == (SVs_OBJECT|SVs_SMG))
3473                          && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3474                         const regexp *re = (regexp *)mg->mg_obj;
3475
3476                         if (!mg->mg_ptr) {
3477                             const char *fptr = "msix";
3478                             char reflags[6];
3479                             char ch;
3480                             int left = 0;
3481                             int right = 4;
3482                             char need_newline = 0;
3483                             U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3484
3485                             while((ch = *fptr++)) {
3486                                 if(reganch & 1) {
3487                                     reflags[left++] = ch;
3488                                 }
3489                                 else {
3490                                     reflags[right--] = ch;
3491                                 }
3492                                 reganch >>= 1;
3493                             }
3494                             if(left != 4) {
3495                                 reflags[left] = '-';
3496                                 left = 5;
3497                             }
3498
3499                             mg->mg_len = re->prelen + 4 + left;
3500                             /*
3501                              * If /x was used, we have to worry about a regex
3502                              * ending with a comment later being embedded
3503                              * within another regex. If so, we don't want this
3504                              * regex's "commentization" to leak out to the
3505                              * right part of the enclosing regex, we must cap
3506                              * it with a newline.
3507                              *
3508                              * So, if /x was used, we scan backwards from the
3509                              * end of the regex. If we find a '#' before we
3510                              * find a newline, we need to add a newline
3511                              * ourself. If we find a '\n' first (or if we
3512                              * don't find '#' or '\n'), we don't need to add
3513                              * anything.  -jfriedl
3514                              */
3515                             if (PMf_EXTENDED & re->reganch)
3516                             {
3517                                 const char *endptr = re->precomp + re->prelen;
3518                                 while (endptr >= re->precomp)
3519                                 {
3520                                     const char c = *(endptr--);
3521                                     if (c == '\n')
3522                                         break; /* don't need another */
3523                                     if (c == '#') {
3524                                         /* we end while in a comment, so we
3525                                            need a newline */
3526                                         mg->mg_len++; /* save space for it */
3527                                         need_newline = 1; /* note to add it */
3528                                         break;
3529                                     }
3530                                 }
3531                             }
3532
3533                             New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3534                             Copy("(?", mg->mg_ptr, 2, char);
3535                             Copy(reflags, mg->mg_ptr+2, left, char);
3536                             Copy(":", mg->mg_ptr+left+2, 1, char);
3537                             Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3538                             if (need_newline)
3539                                 mg->mg_ptr[mg->mg_len - 2] = '\n';
3540                             mg->mg_ptr[mg->mg_len - 1] = ')';
3541                             mg->mg_ptr[mg->mg_len] = 0;
3542                         }
3543                         PL_reginterp_cnt += re->program[0].next_off;
3544
3545                         if (re->reganch & ROPT_UTF8)
3546                             SvUTF8_on(origsv);
3547                         else
3548                             SvUTF8_off(origsv);
3549                         *lp = mg->mg_len;
3550                         return mg->mg_ptr;
3551                     }
3552                                         /* Fall through */
3553                 case SVt_NULL:
3554                 case SVt_IV:
3555                 case SVt_NV:
3556                 case SVt_RV:
3557                 case SVt_PV:
3558                 case SVt_PVIV:
3559                 case SVt_PVNV:
3560                 case SVt_PVBM:  typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3561                 case SVt_PVLV:  typestr = SvROK(sv) ? "REF"
3562                                 /* tied lvalues should appear to be
3563                                  * scalars for backwards compatitbility */
3564                                 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3565                                     ? "SCALAR" : "LVALUE";      break;
3566                 case SVt_PVAV:  typestr = "ARRAY";      break;
3567                 case SVt_PVHV:  typestr = "HASH";       break;
3568                 case SVt_PVCV:  typestr = "CODE";       break;
3569                 case SVt_PVGV:  typestr = "GLOB";       break;
3570                 case SVt_PVFM:  typestr = "FORMAT";     break;
3571                 case SVt_PVIO:  typestr = "IO";         break;
3572                 default:        typestr = "UNKNOWN";    break;
3573                 }
3574                 tsv = NEWSV(0,0);
3575                 if (SvOBJECT(sv)) {
3576                     const char *name = HvNAME(SvSTASH(sv));
3577                     Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3578                                    name ? name : "__ANON__" , typestr, PTR2UV(sv));
3579                 }
3580                 else
3581                     Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3582                 goto tokensaveref;
3583             }
3584             *lp = strlen(typestr);
3585             return (char *)typestr;
3586         }
3587         if (SvREADONLY(sv) && !SvOK(sv)) {
3588             if (ckWARN(WARN_UNINITIALIZED))
3589                 report_uninit(sv);
3590             *lp = 0;
3591             return (char *)"";
3592         }
3593     }
3594     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3595         /* I'm assuming that if both IV and NV are equally valid then
3596            converting the IV is going to be more efficient */
3597         const U32 isIOK = SvIOK(sv);
3598         const U32 isUIOK = SvIsUV(sv);
3599         char buf[TYPE_CHARS(UV)];
3600         char *ebuf, *ptr;
3601
3602         if (SvTYPE(sv) < SVt_PVIV)
3603             sv_upgrade(sv, SVt_PVIV);
3604         if (isUIOK)
3605             ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3606         else
3607             ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3608         SvGROW(sv, (STRLEN)(ebuf - ptr + 1));   /* inlined from sv_setpvn */
3609         Move(ptr,SvPVX(sv),ebuf - ptr,char);
3610         SvCUR_set(sv, ebuf - ptr);
3611         s = SvEND(sv);
3612         *s = '\0';
3613         if (isIOK)
3614             SvIOK_on(sv);
3615         else
3616             SvIOKp_on(sv);
3617         if (isUIOK)
3618             SvIsUV_on(sv);
3619     }
3620     else if (SvNOKp(sv)) {
3621         if (SvTYPE(sv) < SVt_PVNV)
3622             sv_upgrade(sv, SVt_PVNV);
3623         /* The +20 is pure guesswork.  Configure test needed. --jhi */
3624         SvGROW(sv, NV_DIG + 20);
3625         s = SvPVX(sv);
3626         olderrno = errno;       /* some Xenix systems wipe out errno here */
3627 #ifdef apollo
3628         if (SvNVX(sv) == 0.0)
3629             (void)strcpy(s,"0");
3630         else
3631 #endif /*apollo*/
3632         {
3633             Gconvert(SvNVX(sv), NV_DIG, 0, s);
3634         }
3635         errno = olderrno;
3636 #ifdef FIXNEGATIVEZERO
3637         if (*s == '-' && s[1] == '0' && !s[2])
3638             strcpy(s,"0");
3639 #endif
3640         while (*s) s++;
3641 #ifdef hcx
3642         if (s[-1] == '.')
3643             *--s = '\0';
3644 #endif
3645     }
3646     else {
3647         if (ckWARN(WARN_UNINITIALIZED)
3648             && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3649             report_uninit(sv);
3650         *lp = 0;
3651         if (SvTYPE(sv) < SVt_PV)
3652             /* Typically the caller expects that sv_any is not NULL now.  */
3653             sv_upgrade(sv, SVt_PV);
3654         return (char *)"";
3655     }
3656     *lp = s - SvPVX(sv);
3657     SvCUR_set(sv, *lp);
3658     SvPOK_on(sv);
3659     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3660                           PTR2UV(sv),SvPVX(sv)));
3661     return SvPVX(sv);
3662
3663   tokensave:
3664     if (SvROK(sv)) {    /* XXX Skip this when sv_pvn_force calls */
3665         /* Sneaky stuff here */
3666
3667       tokensaveref:
3668         if (!tsv)
3669             tsv = newSVpv(tmpbuf, 0);
3670         sv_2mortal(tsv);
3671         *lp = SvCUR(tsv);
3672         return SvPVX(tsv);
3673     }
3674     else {
3675         dVAR;
3676         STRLEN len;
3677         const char *t;
3678
3679         if (tsv) {
3680             sv_2mortal(tsv);
3681             t = SvPVX(tsv);
3682             len = SvCUR(tsv);
3683         }
3684         else {
3685             t = tmpbuf;
3686             len = strlen(tmpbuf);
3687         }
3688 #ifdef FIXNEGATIVEZERO
3689         if (len == 2 && t[0] == '-' && t[1] == '0') {
3690             t = "0";
3691             len = 1;
3692         }
3693 #endif
3694         (void)SvUPGRADE(sv, SVt_PV);
3695         *lp = len;
3696         s = SvGROW(sv, len + 1);
3697         SvCUR_set(sv, len);
3698         SvPOKp_on(sv);
3699         return strcpy(s, t);
3700     }
3701 }
3702
3703 /*
3704 =for apidoc sv_copypv
3705
3706 Copies a stringified representation of the source SV into the
3707 destination SV.  Automatically performs any necessary mg_get and
3708 coercion of numeric values into strings.  Guaranteed to preserve
3709 UTF-8 flag even from overloaded objects.  Similar in nature to
3710 sv_2pv[_flags] but operates directly on an SV instead of just the
3711 string.  Mostly uses sv_2pv_flags to do its work, except when that
3712 would lose the UTF-8'ness of the PV.
3713
3714 =cut
3715 */
3716
3717 void
3718 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3719 {
3720     STRLEN len;
3721     char *s;
3722     s = SvPV(ssv,len);
3723     sv_setpvn(dsv,s,len);
3724     if (SvUTF8(ssv))
3725         SvUTF8_on(dsv);
3726     else
3727         SvUTF8_off(dsv);
3728 }
3729
3730 /*
3731 =for apidoc sv_2pvbyte_nolen
3732
3733 Return a pointer to the byte-encoded representation of the SV.
3734 May cause the SV to be downgraded from UTF-8 as a side-effect.
3735
3736 Usually accessed via the C<SvPVbyte_nolen> macro.
3737
3738 =cut
3739 */
3740
3741 char *
3742 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3743 {
3744     STRLEN n_a;
3745     return sv_2pvbyte(sv, &n_a);
3746 }
3747
3748 /*
3749 =for apidoc sv_2pvbyte
3750
3751 Return a pointer to the byte-encoded representation of the SV, and set *lp
3752 to its length.  May cause the SV to be downgraded from UTF-8 as a
3753 side-effect.
3754
3755 Usually accessed via the C<SvPVbyte> macro.
3756
3757 =cut
3758 */
3759
3760 char *
3761 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3762 {
3763     sv_utf8_downgrade(sv,0);
3764     return SvPV(sv,*lp);
3765 }
3766
3767 /*
3768 =for apidoc sv_2pvutf8_nolen
3769
3770 Return a pointer to the UTF-8-encoded representation of the SV.
3771 May cause the SV to be upgraded to UTF-8 as a side-effect.
3772
3773 Usually accessed via the C<SvPVutf8_nolen> macro.
3774
3775 =cut
3776 */
3777
3778 char *
3779 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3780 {
3781     STRLEN n_a;
3782     return sv_2pvutf8(sv, &n_a);
3783 }
3784
3785 /*
3786 =for apidoc sv_2pvutf8
3787
3788 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3789 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3790
3791 Usually accessed via the C<SvPVutf8> macro.
3792
3793 =cut
3794 */
3795
3796 char *
3797 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3798 {
3799     sv_utf8_upgrade(sv);
3800     return SvPV(sv,*lp);
3801 }
3802
3803 /*
3804 =for apidoc sv_2bool
3805
3806 This function is only called on magical items, and is only used by
3807 sv_true() or its macro equivalent.
3808
3809 =cut
3810 */
3811
3812 bool
3813 Perl_sv_2bool(pTHX_ register SV *sv)
3814 {
3815     if (SvGMAGICAL(sv))
3816         mg_get(sv);
3817
3818     if (!SvOK(sv))
3819         return 0;
3820     if (SvROK(sv)) {
3821         SV* tmpsv;
3822         if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3823                 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3824             return (bool)SvTRUE(tmpsv);
3825       return SvRV(sv) != 0;
3826     }
3827     if (SvPOKp(sv)) {
3828         register XPV* Xpvtmp;
3829         if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3830                 (*Xpvtmp->xpv_pv > '0' ||
3831                 Xpvtmp->xpv_cur > 1 ||
3832                 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3833             return 1;
3834         else
3835             return 0;
3836     }
3837     else {
3838         if (SvIOKp(sv))
3839             return SvIVX(sv) != 0;
3840         else {
3841             if (SvNOKp(sv))
3842                 return SvNVX(sv) != 0.0;
3843             else
3844                 return FALSE;
3845         }
3846     }
3847 }
3848
3849 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3850  * this function provided for binary compatibility only
3851  */
3852
3853
3854 STRLEN
3855 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3856 {
3857     return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3858 }
3859
3860 /*
3861 =for apidoc sv_utf8_upgrade
3862
3863 Converts the PV of an SV to its UTF-8-encoded form.
3864 Forces the SV to string form if it is not already.
3865 Always sets the SvUTF8 flag to avoid future validity checks even
3866 if all the bytes have hibit clear.
3867
3868 This is not as a general purpose byte encoding to Unicode interface:
3869 use the Encode extension for that.
3870
3871 =for apidoc sv_utf8_upgrade_flags
3872
3873 Converts the PV of an SV to its UTF-8-encoded form.
3874 Forces the SV to string form if it is not already.
3875 Always sets the SvUTF8 flag to avoid future validity checks even
3876 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3877 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3878 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3879
3880 This is not as a general purpose byte encoding to Unicode interface:
3881 use the Encode extension for that.
3882
3883 =cut
3884 */
3885
3886 STRLEN
3887 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3888 {
3889     U8 *s, *t, *e;
3890     int  hibit = 0;
3891
3892     if (sv == &PL_sv_undef)
3893         return 0;
3894     if (!SvPOK(sv)) {
3895         STRLEN len = 0;
3896         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3897             (void) sv_2pv_flags(sv,&len, flags);
3898             if (SvUTF8(sv))
3899                 return len;
3900         } else {
3901             (void) SvPV_force(sv,len);
3902         }
3903     }
3904
3905     if (SvUTF8(sv)) {
3906         return SvCUR(sv);
3907     }
3908
3909     if (SvIsCOW(sv)) {
3910         sv_force_normal_flags(sv, 0);
3911     }
3912
3913     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3914         sv_recode_to_utf8(sv, PL_encoding);
3915     else { /* Assume Latin-1/EBCDIC */
3916          /* This function could be much more efficient if we
3917           * had a FLAG in SVs to signal if there are any hibit
3918           * chars in the PV.  Given that there isn't such a flag
3919           * make the loop as fast as possible. */
3920          s = (U8 *) SvPVX(sv);
3921          e = (U8 *) SvEND(sv);
3922          t = s;
3923          while (t < e) {
3924               U8 ch = *t++;
3925               if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3926                    break;
3927          }
3928          if (hibit) {
3929               STRLEN len;
3930               (void)SvOOK_off(sv);
3931               s = (U8*)SvPVX(sv);
3932               len = SvCUR(sv) + 1; /* Plus the \0 */
3933               SvPV_set(sv, (char*)bytes_to_utf8((U8*)s, &len));
3934               SvCUR_set(sv, len - 1);
3935               if (SvLEN(sv) != 0)
3936                    Safefree(s); /* No longer using what was there before. */
3937               SvLEN_set(sv, len); /* No longer know the real size. */
3938          }
3939          /* Mark as UTF-8 even if no hibit - saves scanning loop */
3940          SvUTF8_on(sv);
3941     }
3942     return SvCUR(sv);
3943 }
3944
3945 /*
3946 =for apidoc sv_utf8_downgrade
3947
3948 Attempts to convert the PV of an SV from characters to bytes.
3949 If the PV contains a character beyond byte, this conversion will fail;
3950 in this case, either returns false or, if C<fail_ok> is not
3951 true, croaks.
3952
3953 This is not as a general purpose Unicode to byte encoding interface:
3954 use the Encode extension for that.
3955
3956 =cut
3957 */
3958
3959 bool
3960 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3961 {
3962     if (SvPOKp(sv) && SvUTF8(sv)) {
3963         if (SvCUR(sv)) {
3964             U8 *s;
3965             STRLEN len;
3966
3967             if (SvIsCOW(sv)) {
3968                 sv_force_normal_flags(sv, 0);
3969             }
3970             s = (U8 *) SvPV(sv, len);
3971             if (!utf8_to_bytes(s, &len)) {
3972                 if (fail_ok)
3973                     return FALSE;
3974                 else {
3975                     if (PL_op)
3976                         Perl_croak(aTHX_ "Wide character in %s",
3977                                    OP_DESC(PL_op));
3978                     else
3979                         Perl_croak(aTHX_ "Wide character");
3980                 }
3981             }
3982             SvCUR_set(sv, len);
3983         }
3984     }
3985     SvUTF8_off(sv);
3986     return TRUE;
3987 }
3988
3989 /*
3990 =for apidoc sv_utf8_encode
3991
3992 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3993 flag off so that it looks like octets again.
3994
3995 =cut
3996 */
3997
3998 void
3999 Perl_sv_utf8_encode(pTHX_ register SV *sv)
4000 {
4001     (void) sv_utf8_upgrade(sv);
4002     if (SvIsCOW(sv)) {
4003         sv_force_normal_flags(sv, 0);
4004     }
4005     if (SvREADONLY(sv)) {
4006         Perl_croak(aTHX_ PL_no_modify);
4007     }
4008     SvUTF8_off(sv);
4009 }
4010
4011 /*
4012 =for apidoc sv_utf8_decode
4013
4014 If the PV of the SV is an octet sequence in UTF-8
4015 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
4016 so that it looks like a character. If the PV contains only single-byte
4017 characters, the C<SvUTF8> flag stays being off.
4018 Scans PV for validity and returns false if the PV is invalid UTF-8.
4019
4020 =cut
4021 */
4022
4023 bool
4024 Perl_sv_utf8_decode(pTHX_ register SV *sv)
4025 {
4026     if (SvPOKp(sv)) {
4027         U8 *c;
4028         U8 *e;
4029
4030         /* The octets may have got themselves encoded - get them back as
4031          * bytes
4032          */
4033         if (!sv_utf8_downgrade(sv, TRUE))
4034             return FALSE;
4035
4036         /* it is actually just a matter of turning the utf8 flag on, but
4037          * we want to make sure everything inside is valid utf8 first.
4038          */
4039         c = (U8 *) SvPVX(sv);
4040         if (!is_utf8_string(c, SvCUR(sv)+1))
4041             return FALSE;
4042         e = (U8 *) SvEND(sv);
4043         while (c < e) {
4044             U8 ch = *c++;
4045             if (!UTF8_IS_INVARIANT(ch)) {
4046                 SvUTF8_on(sv);
4047                 break;
4048             }
4049         }
4050     }
4051     return TRUE;
4052 }
4053
4054 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
4055  * this function provided for binary compatibility only
4056  */
4057
4058 void
4059 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
4060 {
4061     sv_setsv_flags(dstr, sstr, SV_GMAGIC);
4062 }
4063
4064 /*
4065 =for apidoc sv_setsv
4066
4067 Copies the contents of the source SV C<ssv> into the destination SV
4068 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
4069 function if the source SV needs to be reused. Does not handle 'set' magic.
4070 Loosely speaking, it performs a copy-by-value, obliterating any previous
4071 content of the destination.
4072
4073 You probably want to use one of the assortment of wrappers, such as
4074 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4075 C<SvSetMagicSV_nosteal>.
4076
4077 =for apidoc sv_setsv_flags
4078
4079 Copies the contents of the source SV C<ssv> into the destination SV
4080 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
4081 function if the source SV needs to be reused. Does not handle 'set' magic.
4082 Loosely speaking, it performs a copy-by-value, obliterating any previous
4083 content of the destination.
4084 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
4085 C<ssv> if appropriate, else not. If the C<flags> parameter has the
4086 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
4087 and C<sv_setsv_nomg> are implemented in terms of this function.
4088
4089 You probably want to use one of the assortment of wrappers, such as
4090 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4091 C<SvSetMagicSV_nosteal>.
4092
4093 This is the primary function for copying scalars, and most other
4094 copy-ish functions and macros use this underneath.
4095
4096 =cut
4097 */
4098
4099 void
4100 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
4101 {
4102     register U32 sflags;
4103     register int dtype;
4104     register int stype;
4105
4106     if (sstr == dstr)
4107         return;
4108     SV_CHECK_THINKFIRST_COW_DROP(dstr);
4109     if (!sstr)
4110         sstr = &PL_sv_undef;
4111     stype = SvTYPE(sstr);
4112     dtype = SvTYPE(dstr);
4113
4114     SvAMAGIC_off(dstr);
4115     if ( SvVOK(dstr) )
4116     {
4117         /* need to nuke the magic */
4118         mg_free(dstr);
4119         SvRMAGICAL_off(dstr);
4120     }
4121
4122     /* There's a lot of redundancy below but we're going for speed here */
4123
4124     switch (stype) {
4125     case SVt_NULL:
4126       undef_sstr:
4127         if (dtype != SVt_PVGV) {
4128             (void)SvOK_off(dstr);
4129             return;
4130         }
4131         break;
4132     case SVt_IV:
4133         if (SvIOK(sstr)) {
4134             switch (dtype) {
4135             case SVt_NULL:
4136                 sv_upgrade(dstr, SVt_IV);
4137                 break;
4138             case SVt_NV:
4139                 sv_upgrade(dstr, SVt_PVNV);
4140                 break;
4141             case SVt_RV:
4142             case SVt_PV:
4143                 sv_upgrade(dstr, SVt_PVIV);
4144                 break;
4145             }
4146             (void)SvIOK_only(dstr);
4147             SvIV_set(dstr,  SvIVX(sstr));
4148             if (SvIsUV(sstr))
4149                 SvIsUV_on(dstr);
4150             if (SvTAINTED(sstr))
4151                 SvTAINT(dstr);
4152             return;
4153         }
4154         goto undef_sstr;
4155
4156     case SVt_NV:
4157         if (SvNOK(sstr)) {
4158             switch (dtype) {
4159             case SVt_NULL:
4160             case SVt_IV:
4161                 sv_upgrade(dstr, SVt_NV);
4162                 break;
4163             case SVt_RV:
4164             case SVt_PV:
4165             case SVt_PVIV:
4166                 sv_upgrade(dstr, SVt_PVNV);
4167                 break;
4168             }
4169             SvNV_set(dstr, SvNVX(sstr));
4170             (void)SvNOK_only(dstr);
4171             if (SvTAINTED(sstr))
4172                 SvTAINT(dstr);
4173             return;
4174         }
4175         goto undef_sstr;
4176
4177     case SVt_RV:
4178         if (dtype < SVt_RV)
4179             sv_upgrade(dstr, SVt_RV);
4180         else if (dtype == SVt_PVGV &&
4181                  SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
4182             sstr = SvRV(sstr);
4183             if (sstr == dstr) {
4184                 if (GvIMPORTED(dstr) != GVf_IMPORTED
4185                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4186                 {
4187                     GvIMPORTED_on(dstr);
4188                 }
4189                 GvMULTI_on(dstr);
4190                 return;
4191             }
4192             goto glob_assign;
4193         }
4194         break;
4195     case SVt_PVFM:
4196 #ifdef PERL_COPY_ON_WRITE
4197         if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
4198             if (dtype < SVt_PVIV)
4199                 sv_upgrade(dstr, SVt_PVIV);
4200             break;
4201         }
4202         /* Fall through */
4203 #endif
4204     case SVt_PV:
4205         if (dtype < SVt_PV)
4206             sv_upgrade(dstr, SVt_PV);
4207         break;
4208     case SVt_PVIV:
4209         if (dtype < SVt_PVIV)
4210             sv_upgrade(dstr, SVt_PVIV);
4211         break;
4212     case SVt_PVNV:
4213         if (dtype < SVt_PVNV)
4214             sv_upgrade(dstr, SVt_PVNV);
4215         break;
4216     case SVt_PVAV:
4217     case SVt_PVHV:
4218     case SVt_PVCV:
4219     case SVt_PVIO:
4220         if (PL_op)
4221             Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
4222                 OP_NAME(PL_op));
4223         else
4224             Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
4225         break;
4226
4227     case SVt_PVGV:
4228         if (dtype <= SVt_PVGV) {
4229   glob_assign:
4230             if (dtype != SVt_PVGV) {
4231                 char *name = GvNAME(sstr);
4232                 STRLEN len = GvNAMELEN(sstr);
4233                 /* don't upgrade SVt_PVLV: it can hold a glob */
4234                 if (dtype != SVt_PVLV)
4235                     sv_upgrade(dstr, SVt_PVGV);
4236                 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
4237                 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
4238                 GvNAME(dstr) = savepvn(name, len);
4239                 GvNAMELEN(dstr) = len;
4240                 SvFAKE_on(dstr);        /* can coerce to non-glob */
4241             }
4242             /* ahem, death to those who redefine active sort subs */
4243             else if (PL_curstackinfo->si_type == PERLSI_SORT
4244                      && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
4245                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
4246                       GvNAME(dstr));
4247
4248 #ifdef GV_UNIQUE_CHECK
4249                 if (GvUNIQUE((GV*)dstr)) {
4250                     Perl_croak(aTHX_ PL_no_modify);
4251                 }
4252 #endif
4253
4254             (void)SvOK_off(dstr);
4255             GvINTRO_off(dstr);          /* one-shot flag */
4256             gp_free((GV*)dstr);
4257             GvGP(dstr) = gp_ref(GvGP(sstr));
4258             if (SvTAINTED(sstr))
4259                 SvTAINT(dstr);
4260             if (GvIMPORTED(dstr) != GVf_IMPORTED
4261                 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4262             {
4263                 GvIMPORTED_on(dstr);
4264             }
4265             GvMULTI_on(dstr);
4266             return;
4267         }
4268         /* FALL THROUGH */
4269
4270     default:
4271         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4272             mg_get(sstr);
4273             if ((int)SvTYPE(sstr) != stype) {
4274                 stype = SvTYPE(sstr);
4275                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
4276                     goto glob_assign;
4277             }
4278         }
4279         if (stype == SVt_PVLV)
4280             (void)SvUPGRADE(dstr, SVt_PVNV);
4281         else
4282             (void)SvUPGRADE(dstr, (U32)stype);
4283     }
4284
4285     sflags = SvFLAGS(sstr);
4286
4287     if (sflags & SVf_ROK) {
4288         if (dtype >= SVt_PV) {
4289             if (dtype == SVt_PVGV) {
4290                 SV *sref = SvREFCNT_inc(SvRV(sstr));
4291                 SV *dref = 0;
4292                 int intro = GvINTRO(dstr);
4293
4294 #ifdef GV_UNIQUE_CHECK
4295                 if (GvUNIQUE((GV*)dstr)) {
4296                     Perl_croak(aTHX_ PL_no_modify);
4297                 }
4298 #endif
4299
4300                 if (intro) {
4301                     GvINTRO_off(dstr);  /* one-shot flag */
4302                     GvLINE(dstr) = CopLINE(PL_curcop);
4303                     GvEGV(dstr) = (GV*)dstr;
4304                 }
4305                 GvMULTI_on(dstr);
4306                 switch (SvTYPE(sref)) {
4307                 case SVt_PVAV:
4308                     if (intro)
4309                         SAVEGENERICSV(GvAV(dstr));
4310                     else
4311                         dref = (SV*)GvAV(dstr);
4312                     GvAV(dstr) = (AV*)sref;
4313                     if (!GvIMPORTED_AV(dstr)
4314                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4315                     {
4316                         GvIMPORTED_AV_on(dstr);
4317                     }
4318                     break;
4319                 case SVt_PVHV:
4320                     if (intro)
4321                         SAVEGENERICSV(GvHV(dstr));
4322                     else
4323                         dref = (SV*)GvHV(dstr);
4324                     GvHV(dstr) = (HV*)sref;
4325                     if (!GvIMPORTED_HV(dstr)
4326                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4327                     {
4328                         GvIMPORTED_HV_on(dstr);
4329                     }
4330                     break;
4331                 case SVt_PVCV:
4332                     if (intro) {
4333                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
4334                             SvREFCNT_dec(GvCV(dstr));
4335                             GvCV(dstr) = Nullcv;
4336                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4337                             PL_sub_generation++;
4338                         }
4339                         SAVEGENERICSV(GvCV(dstr));
4340                     }
4341                     else
4342                         dref = (SV*)GvCV(dstr);
4343                     if (GvCV(dstr) != (CV*)sref) {
4344                         CV* cv = GvCV(dstr);
4345                         if (cv) {
4346                             if (!GvCVGEN((GV*)dstr) &&
4347                                 (CvROOT(cv) || CvXSUB(cv)))
4348                             {
4349                                 /* ahem, death to those who redefine
4350                                  * active sort subs */
4351                                 if (PL_curstackinfo->si_type == PERLSI_SORT &&
4352                                       PL_sortcop == CvSTART(cv))
4353                                     Perl_croak(aTHX_
4354                                     "Can't redefine active sort subroutine %s",
4355                                           GvENAME((GV*)dstr));
4356                                 /* Redefining a sub - warning is mandatory if
4357                                    it was a const and its value changed. */
4358                                 if (ckWARN(WARN_REDEFINE)
4359                                     || (CvCONST(cv)
4360                                         && (!CvCONST((CV*)sref)
4361                                             || sv_cmp(cv_const_sv(cv),
4362                                                       cv_const_sv((CV*)sref)))))
4363                                 {
4364                                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4365                                         CvCONST(cv)
4366                                         ? "Constant subroutine %s::%s redefined"
4367                                         : "Subroutine %s::%s redefined",
4368                                         HvNAME(GvSTASH((GV*)dstr)),
4369                                         GvENAME((GV*)dstr));
4370                                 }
4371                             }
4372                             if (!intro)
4373                                 cv_ckproto(cv, (GV*)dstr,
4374                                         SvPOK(sref) ? SvPVX(sref) : Nullch);
4375                         }
4376                         GvCV(dstr) = (CV*)sref;
4377                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4378                         GvASSUMECV_on(dstr);
4379                         PL_sub_generation++;
4380                     }
4381                     if (!GvIMPORTED_CV(dstr)
4382                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4383                     {
4384                         GvIMPORTED_CV_on(dstr);
4385                     }
4386                     break;
4387                 case SVt_PVIO:
4388                     if (intro)
4389                         SAVEGENERICSV(GvIOp(dstr));
4390                     else
4391                         dref = (SV*)GvIOp(dstr);
4392                     GvIOp(dstr) = (IO*)sref;
4393                     break;
4394                 case SVt_PVFM:
4395                     if (intro)
4396                         SAVEGENERICSV(GvFORM(dstr));
4397                     else
4398                         dref = (SV*)GvFORM(dstr);
4399                     GvFORM(dstr) = (CV*)sref;
4400                     break;
4401                 default:
4402                     if (intro)
4403                         SAVEGENERICSV(GvSV(dstr));
4404                     else
4405                         dref = (SV*)GvSV(dstr);
4406                     GvSV(dstr) = sref;
4407                     if (!GvIMPORTED_SV(dstr)
4408                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4409                     {
4410                         GvIMPORTED_SV_on(dstr);
4411                     }
4412                     break;
4413                 }
4414                 if (dref)
4415                     SvREFCNT_dec(dref);
4416                 if (SvTAINTED(sstr))
4417                     SvTAINT(dstr);
4418                 return;
4419             }
4420             if (SvPVX(dstr)) {
4421                 SvPV_free(dstr);
4422                 SvLEN_set(dstr, 0);
4423                 SvCUR_set(dstr, 0);
4424             }
4425         }
4426         (void)SvOK_off(dstr);
4427         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4428         SvROK_on(dstr);
4429         if (sflags & SVp_NOK) {
4430             SvNOKp_on(dstr);
4431             /* Only set the public OK flag if the source has public OK.  */
4432             if (sflags & SVf_NOK)
4433                 SvFLAGS(dstr) |= SVf_NOK;
4434             SvNV_set(dstr, SvNVX(sstr));
4435         }
4436         if (sflags & SVp_IOK) {
4437             (void)SvIOKp_on(dstr);
4438             if (sflags & SVf_IOK)
4439                 SvFLAGS(dstr) |= SVf_IOK;
4440             if (sflags & SVf_IVisUV)
4441                 SvIsUV_on(dstr);
4442             SvIV_set(dstr, SvIVX(sstr));
4443         }
4444         if (SvAMAGIC(sstr)) {
4445             SvAMAGIC_on(dstr);
4446         }
4447     }
4448     else if (sflags & SVp_POK) {
4449         bool isSwipe = 0;
4450
4451         /*
4452          * Check to see if we can just swipe the string.  If so, it's a
4453          * possible small lose on short strings, but a big win on long ones.
4454          * It might even be a win on short strings if SvPVX(dstr)
4455          * has to be allocated and SvPVX(sstr) has to be freed.
4456          */
4457
4458         /* Whichever path we take through the next code, we want this true,
4459            and doing it now facilitates the COW check.  */
4460         (void)SvPOK_only(dstr);
4461
4462         if (
4463 #ifdef PERL_COPY_ON_WRITE
4464             (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4465             &&
4466 #endif
4467             !(isSwipe =
4468                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
4469                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4470                  (!(flags & SV_NOSTEAL)) &&
4471                                         /* and we're allowed to steal temps */
4472                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4473                  SvLEN(sstr)    &&        /* and really is a string */
4474                                 /* and won't be needed again, potentially */
4475               !(PL_op && PL_op->op_type == OP_AASSIGN))
4476 #ifdef PERL_COPY_ON_WRITE
4477             && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4478                  && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4479                  && SvTYPE(sstr) >= SVt_PVIV)
4480 #endif
4481             ) {
4482             /* Failed the swipe test, and it's not a shared hash key either.
4483                Have to copy the string.  */
4484             STRLEN len = SvCUR(sstr);
4485             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
4486             Move(SvPVX(sstr),SvPVX(dstr),len,char);
4487             SvCUR_set(dstr, len);
4488             *SvEND(dstr) = '\0';
4489         } else {
4490             /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
4491                be true in here.  */
4492 #ifdef PERL_COPY_ON_WRITE
4493             /* Either it's a shared hash key, or it's suitable for
4494                copy-on-write or we can swipe the string.  */
4495             if (DEBUG_C_TEST) {
4496                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4497                 sv_dump(sstr);
4498                 sv_dump(dstr);
4499             }
4500             if (!isSwipe) {
4501                 /* I believe I should acquire a global SV mutex if
4502                    it's a COW sv (not a shared hash key) to stop
4503                    it going un copy-on-write.
4504                    If the source SV has gone un copy on write between up there
4505                    and down here, then (assert() that) it is of the correct
4506                    form to make it copy on write again */
4507                 if ((sflags & (SVf_FAKE | SVf_READONLY))
4508                     != (SVf_FAKE | SVf_READONLY)) {
4509                     SvREADONLY_on(sstr);
4510                     SvFAKE_on(sstr);
4511                     /* Make the source SV into a loop of 1.
4512                        (about to become 2) */
4513                     SV_COW_NEXT_SV_SET(sstr, sstr);
4514                 }
4515             }
4516 #endif
4517             /* Initial code is common.  */
4518             if (SvPVX(dstr)) {          /* we know that dtype >= SVt_PV */
4519                 if (SvOOK(dstr)) {
4520                     SvFLAGS(dstr) &= ~SVf_OOK;
4521                     Safefree(SvPVX(dstr) - SvIVX(dstr));
4522                 }
4523                 else if (SvLEN(dstr))
4524                     Safefree(SvPVX(dstr));
4525             }
4526
4527 #ifdef PERL_COPY_ON_WRITE
4528             if (!isSwipe) {
4529                 /* making another shared SV.  */
4530                 STRLEN cur = SvCUR(sstr);
4531                 STRLEN len = SvLEN(sstr);
4532                 assert (SvTYPE(dstr) >= SVt_PVIV);
4533                 if (len) {
4534                     /* SvIsCOW_normal */
4535                     /* splice us in between source and next-after-source.  */
4536                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4537                     SV_COW_NEXT_SV_SET(sstr, dstr);
4538                     SvPV_set(dstr, SvPVX(sstr));
4539                 } else {
4540                     /* SvIsCOW_shared_hash */
4541                     UV hash = SvUVX(sstr);
4542                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4543                                           "Copy on write: Sharing hash\n"));
4544                     SvPV_set(dstr,
4545                              sharepvn(SvPVX(sstr),
4546                                       (sflags & SVf_UTF8?-cur:cur), hash));
4547                     SvUV_set(dstr, hash);
4548                 }
4549                 SvLEN_set(dstr, len);
4550                 SvCUR_set(dstr, cur);
4551                 SvREADONLY_on(dstr);
4552                 SvFAKE_on(dstr);
4553                 /* Relesase a global SV mutex.  */
4554             }
4555             else
4556 #endif
4557                 {       /* Passes the swipe test.  */
4558                 SvPV_set(dstr, SvPVX(sstr));
4559                 SvLEN_set(dstr, SvLEN(sstr));
4560                 SvCUR_set(dstr, SvCUR(sstr));
4561
4562                 SvTEMP_off(dstr);
4563                 (void)SvOK_off(sstr);   /* NOTE: nukes most SvFLAGS on sstr */
4564                 SvPV_set(sstr, Nullch);
4565                 SvLEN_set(sstr, 0);
4566                 SvCUR_set(sstr, 0);
4567                 SvTEMP_off(sstr);
4568             }
4569         }
4570         if (sflags & SVf_UTF8)
4571             SvUTF8_on(dstr);
4572         /*SUPPRESS 560*/
4573         if (sflags & SVp_NOK) {
4574             SvNOKp_on(dstr);
4575             if (sflags & SVf_NOK)
4576                 SvFLAGS(dstr) |= SVf_NOK;
4577             SvNV_set(dstr, SvNVX(sstr));
4578         }
4579         if (sflags & SVp_IOK) {
4580             (void)SvIOKp_on(dstr);
4581             if (sflags & SVf_IOK)
4582                 SvFLAGS(dstr) |= SVf_IOK;
4583             if (sflags & SVf_IVisUV)
4584                 SvIsUV_on(dstr);
4585             SvIV_set(dstr, SvIVX(sstr));
4586         }
4587         if (SvVOK(sstr)) {
4588             MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4589             sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4590                         smg->mg_ptr, smg->mg_len);
4591             SvRMAGICAL_on(dstr);
4592         }
4593     }
4594     else if (sflags & SVp_IOK) {
4595         if (sflags & SVf_IOK)
4596             (void)SvIOK_only(dstr);
4597         else {
4598             (void)SvOK_off(dstr);
4599             (void)SvIOKp_on(dstr);
4600         }
4601         /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4602         if (sflags & SVf_IVisUV)
4603             SvIsUV_on(dstr);
4604         SvIV_set(dstr, SvIVX(sstr));
4605         if (sflags & SVp_NOK) {
4606             if (sflags & SVf_NOK)
4607                 (void)SvNOK_on(dstr);
4608             else
4609                 (void)SvNOKp_on(dstr);
4610             SvNV_set(dstr, SvNVX(sstr));
4611         }
4612     }
4613     else if (sflags & SVp_NOK) {
4614         if (sflags & SVf_NOK)
4615             (void)SvNOK_only(dstr);
4616         else {
4617             (void)SvOK_off(dstr);
4618             SvNOKp_on(dstr);
4619         }
4620         SvNV_set(dstr, SvNVX(sstr));
4621     }
4622     else {
4623         if (dtype == SVt_PVGV) {
4624             if (ckWARN(WARN_MISC))
4625                 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4626         }
4627         else
4628             (void)SvOK_off(dstr);
4629     }
4630     if (SvTAINTED(sstr))
4631         SvTAINT(dstr);
4632 }
4633
4634 /*
4635 =for apidoc sv_setsv_mg
4636
4637 Like C<sv_setsv>, but also handles 'set' magic.
4638
4639 =cut
4640 */
4641
4642 void
4643 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4644 {
4645     sv_setsv(dstr,sstr);
4646     SvSETMAGIC(dstr);
4647 }
4648
4649 #ifdef PERL_COPY_ON_WRITE
4650 SV *
4651 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4652 {
4653     STRLEN cur = SvCUR(sstr);
4654     STRLEN len = SvLEN(sstr);
4655     register char *new_pv;
4656
4657     if (DEBUG_C_TEST) {
4658         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4659                       sstr, dstr);
4660         sv_dump(sstr);
4661         if (dstr)
4662                     sv_dump(dstr);
4663     }
4664
4665     if (dstr) {
4666         if (SvTHINKFIRST(dstr))
4667             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4668         else if (SvPVX(dstr))
4669             Safefree(SvPVX(dstr));
4670     }
4671     else
4672         new_SV(dstr);
4673     (void)SvUPGRADE (dstr, SVt_PVIV);
4674
4675     assert (SvPOK(sstr));
4676     assert (SvPOKp(sstr));
4677     assert (!SvIOK(sstr));
4678     assert (!SvIOKp(sstr));
4679     assert (!SvNOK(sstr));
4680     assert (!SvNOKp(sstr));
4681
4682     if (SvIsCOW(sstr)) {
4683
4684         if (SvLEN(sstr) == 0) {
4685             /* source is a COW shared hash key.  */
4686             UV hash = SvUVX(sstr);
4687             DEBUG_C(PerlIO_printf(Perl_debug_log,
4688                                   "Fast copy on write: Sharing hash\n"));
4689             SvUV_set(dstr, hash);
4690             new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash);
4691             goto common_exit;
4692         }
4693         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4694     } else {
4695         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4696         (void)SvUPGRADE (sstr, SVt_PVIV);
4697         SvREADONLY_on(sstr);
4698         SvFAKE_on(sstr);
4699         DEBUG_C(PerlIO_printf(Perl_debug_log,
4700                               "Fast copy on write: Converting sstr to COW\n"));
4701         SV_COW_NEXT_SV_SET(dstr, sstr);
4702     }
4703     SV_COW_NEXT_SV_SET(sstr, dstr);
4704     new_pv = SvPVX(sstr);
4705
4706   common_exit:
4707     SvPV_set(dstr, new_pv);
4708     SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4709     if (SvUTF8(sstr))
4710         SvUTF8_on(dstr);
4711     SvLEN_set(dstr, len);
4712     SvCUR_set(dstr, cur);
4713     if (DEBUG_C_TEST) {
4714         sv_dump(dstr);
4715     }
4716     return dstr;
4717 }
4718 #endif
4719
4720 /*
4721 =for apidoc sv_setpvn
4722
4723 Copies a string into an SV.  The C<len> parameter indicates the number of
4724 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4725 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4726
4727 =cut
4728 */
4729
4730 void
4731 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4732 {
4733     register char *dptr;
4734
4735     SV_CHECK_THINKFIRST_COW_DROP(sv);
4736     if (!ptr) {
4737         (void)SvOK_off(sv);
4738         return;
4739     }
4740     else {
4741         /* len is STRLEN which is unsigned, need to copy to signed */
4742         IV iv = len;
4743         if (iv < 0)
4744             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4745     }
4746     (void)SvUPGRADE(sv, SVt_PV);
4747
4748     SvGROW(sv, len + 1);
4749     dptr = SvPVX(sv);
4750     Move(ptr,dptr,len,char);
4751     dptr[len] = '\0';
4752     SvCUR_set(sv, len);
4753     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4754     SvTAINT(sv);
4755 }
4756
4757 /*
4758 =for apidoc sv_setpvn_mg
4759
4760 Like C<sv_setpvn>, but also handles 'set' magic.
4761