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