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