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