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