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