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