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