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