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