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