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