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