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