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