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