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