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