Fix hardcoded "/" in a filepath that causes ext/List/Util/t/p_tainted.t
[perl.git] / sv.c
1 /*    sv.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  * "I wonder what the Entish is for 'yes' and 'no'," he thought.
10  *
11  *
12  * This file contains the code that creates, manipulates and destroys
13  * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
14  * structure of an SV, so their creation and destruction is handled
15  * here; higher-level functions are in av.c, hv.c, and so on. Opcode
16  * level functions (eg. substr, split, join) for each of the types are
17  * in the pp*.c files.
18  */
19
20 #include "EXTERN.h"
21 #define PERL_IN_SV_C
22 #include "perl.h"
23 #include "regcomp.h"
24
25 #define FCALL *f
26
27 #ifdef __Lynx__
28 /* Missing proto on LynxOS */
29   char *gconvert(double, int, int,  char *);
30 #endif
31
32 #ifdef PERL_UTF8_CACHE_ASSERT
33 /* The cache element 0 is the Unicode offset;
34  * the cache element 1 is the byte offset of the element 0;
35  * the cache element 2 is the Unicode length of the substring;
36  * the cache element 3 is the byte length of the substring;
37  * The checking of the substring side would be good
38  * but substr() has enough code paths to make my head spin;
39  * if adding more checks watch out for the following tests:
40  *   t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
41  *   lib/utf8.t lib/Unicode/Collate/t/index.t
42  * --jhi
43  */
44 #define ASSERT_UTF8_CACHE(cache) \
45         STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
46 #else
47 #define ASSERT_UTF8_CACHE(cache) NOOP
48 #endif
49
50 #ifdef PERL_OLD_COPY_ON_WRITE
51 #define SV_COW_NEXT_SV(sv)      INT2PTR(SV *,SvUVX(sv))
52 #define SV_COW_NEXT_SV_SET(current,next)        SvUV_set(current, PTR2UV(next))
53 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
54    on-write.  */
55 #endif
56
57 /* ============================================================================
58
59 =head1 Allocation and deallocation of SVs.
60
61 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
62 av, hv...) contains type and reference count information, as well as a
63 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
64 specific to each type.
65
66 In all but the most memory-paranoid configuations (ex: PURIFY), this
67 allocation is done using arenas, which by default are approximately 4K
68 chunks of memory parcelled up into N heads or bodies (of same size).
69 Sv-bodies are allocated by their sv-type, guaranteeing size
70 consistency needed to allocate safely from arrays.
71
72 The first slot in each arena is reserved, and is used to hold a link
73 to the next arena.  In the case of heads, the unused first slot also
74 contains some flags and a note of the number of slots.  Snaked through
75 each arena chain is a linked list of free items; when this becomes
76 empty, an extra arena is allocated and divided up into N items which
77 are threaded into the free list.
78
79 The following global variables are associated with arenas:
80
81     PL_sv_arenaroot     pointer to list of SV arenas
82     PL_sv_root          pointer to list of free SV structures
83
84     PL_body_arenaroots[]  array of pointers to list of arenas, 1 per svtype
85     PL_body_roots[]       array of pointers to list of free bodies of svtype
86                           arrays are indexed by the svtype needed
87
88 Note that some of the larger and more rarely used body types (eg
89 xpvio) are not allocated using arenas, but are instead just
90 malloc()/free()ed as required.
91
92 In addition, a few SV heads are not allocated from an arena, but are
93 instead directly created as static or auto variables, eg PL_sv_undef.
94 The size of arenas can be changed from the default by setting
95 PERL_ARENA_SIZE appropriately at compile time.
96
97 The SV arena serves the secondary purpose of allowing still-live SVs
98 to be located and destroyed during final cleanup.
99
100 At the lowest level, the macros new_SV() and del_SV() grab and free
101 an SV head.  (If debugging with -DD, del_SV() calls the function S_del_sv()
102 to return the SV to the free list with error checking.) new_SV() calls
103 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
104 SVs in the free list have their SvTYPE field set to all ones.
105
106 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
107 that allocate and return individual body types. Normally these are mapped
108 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
109 instead mapped directly to malloc()/free() if PURIFY is defined. The
110 new/del functions remove from, or add to, the appropriate PL_foo_root
111 list, and call more_xiv() etc to add a new arena if the list is empty.
112
113 At the time of very final cleanup, sv_free_arenas() is called from
114 perl_destruct() to physically free all the arenas allocated since the
115 start of the interpreter.
116
117 Manipulation of any of the PL_*root pointers is protected by enclosing
118 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
119 if threads are enabled.
120
121 The function visit() scans the SV arenas list, and calls a specified
122 function for each SV it finds which is still live - ie which has an SvTYPE
123 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
124 following functions (specified as [function that calls visit()] / [function
125 called by visit() for each SV]):
126
127     sv_report_used() / do_report_used()
128                         dump all remaining SVs (debugging aid)
129
130     sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
131                         Attempt to free all objects pointed to by RVs,
132                         and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
133                         try to do the same for all objects indirectly
134                         referenced by typeglobs too.  Called once from
135                         perl_destruct(), prior to calling sv_clean_all()
136                         below.
137
138     sv_clean_all() / do_clean_all()
139                         SvREFCNT_dec(sv) each remaining SV, possibly
140                         triggering an sv_free(). It also sets the
141                         SVf_BREAK flag on the SV to indicate that the
142                         refcnt has been artificially lowered, and thus
143                         stopping sv_free() from giving spurious warnings
144                         about SVs which unexpectedly have a refcnt
145                         of zero.  called repeatedly from perl_destruct()
146                         until there are no SVs left.
147
148 =head2 Arena allocator API Summary
149
150 Private API to rest of sv.c
151
152     new_SV(),  del_SV(),
153
154     new_XIV(), del_XIV(),
155     new_XNV(), del_XNV(),
156     etc
157
158 Public API:
159
160     sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
161
162
163 =cut
164
165 ============================================================================ */
166
167
168
169 /*
170  * "A time to plant, and a time to uproot what was planted..."
171  */
172
173 /*
174  * nice_chunk and nice_chunk size need to be set
175  * and queried under the protection of sv_mutex
176  */
177 void
178 Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
179 {
180     dVAR;
181     void *new_chunk;
182     U32 new_chunk_size;
183     LOCK_SV_MUTEX;
184     new_chunk = (void *)(chunk);
185     new_chunk_size = (chunk_size);
186     if (new_chunk_size > PL_nice_chunk_size) {
187         Safefree(PL_nice_chunk);
188         PL_nice_chunk = (char *) new_chunk;
189         PL_nice_chunk_size = new_chunk_size;
190     } else {
191         Safefree(chunk);
192     }
193     UNLOCK_SV_MUTEX;
194 }
195
196 #ifdef DEBUG_LEAKING_SCALARS
197 #  define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
198 #else
199 #  define FREE_SV_DEBUG_FILE(sv)
200 #endif
201
202 #ifdef PERL_POISON
203 #  define SvARENA_CHAIN(sv)     ((sv)->sv_u.svu_rv)
204 /* Whilst I'd love to do this, it seems that things like to check on
205    unreferenced scalars
206 #  define POSION_SV_HEAD(sv)    Poison(sv, 1, struct STRUCT_SV)
207 */
208 #  define POSION_SV_HEAD(sv)    Poison(&SvANY(sv), 1, void *), \
209                                 Poison(&SvREFCNT(sv), 1, U32)
210 #else
211 #  define SvARENA_CHAIN(sv)     SvANY(sv)
212 #  define POSION_SV_HEAD(sv)
213 #endif
214
215 #define plant_SV(p) \
216     STMT_START {                                        \
217         FREE_SV_DEBUG_FILE(p);                          \
218         POSION_SV_HEAD(p);                              \
219         SvARENA_CHAIN(p) = (void *)PL_sv_root;          \
220         SvFLAGS(p) = SVTYPEMASK;                        \
221         PL_sv_root = (p);                               \
222         --PL_sv_count;                                  \
223     } STMT_END
224
225 /* sv_mutex must be held while calling uproot_SV() */
226 #define uproot_SV(p) \
227     STMT_START {                                        \
228         (p) = PL_sv_root;                               \
229         PL_sv_root = (SV*)SvARENA_CHAIN(p);                     \
230         ++PL_sv_count;                                  \
231     } STMT_END
232
233
234 /* make some more SVs by adding another arena */
235
236 /* sv_mutex must be held while calling more_sv() */
237 STATIC SV*
238 S_more_sv(pTHX)
239 {
240     dVAR;
241     SV* sv;
242
243     if (PL_nice_chunk) {
244         sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
245         PL_nice_chunk = 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 void
2929 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
2930 {
2931     dVAR;
2932     register U32 sflags;
2933     register int dtype;
2934     register int stype;
2935
2936     if (sstr == dstr)
2937         return;
2938     SV_CHECK_THINKFIRST_COW_DROP(dstr);
2939     if (!sstr)
2940         sstr = &PL_sv_undef;
2941     stype = SvTYPE(sstr);
2942     dtype = SvTYPE(dstr);
2943
2944     SvAMAGIC_off(dstr);
2945     if ( SvVOK(dstr) )
2946     {
2947         /* need to nuke the magic */
2948         mg_free(dstr);
2949         SvRMAGICAL_off(dstr);
2950     }
2951
2952     /* There's a lot of redundancy below but we're going for speed here */
2953
2954     switch (stype) {
2955     case SVt_NULL:
2956       undef_sstr:
2957         if (dtype != SVt_PVGV) {
2958             (void)SvOK_off(dstr);
2959             return;
2960         }
2961         break;
2962     case SVt_IV:
2963         if (SvIOK(sstr)) {
2964             switch (dtype) {
2965             case SVt_NULL:
2966                 sv_upgrade(dstr, SVt_IV);
2967                 break;
2968             case SVt_NV:
2969                 sv_upgrade(dstr, SVt_PVNV);
2970                 break;
2971             case SVt_RV:
2972             case SVt_PV:
2973                 sv_upgrade(dstr, SVt_PVIV);
2974                 break;
2975             }
2976             (void)SvIOK_only(dstr);
2977             SvIV_set(dstr,  SvIVX(sstr));
2978             if (SvIsUV(sstr))
2979                 SvIsUV_on(dstr);
2980             if (SvTAINTED(sstr))
2981                 SvTAINT(dstr);
2982             return;
2983         }
2984         goto undef_sstr;
2985
2986     case SVt_NV:
2987         if (SvNOK(sstr)) {
2988             switch (dtype) {
2989             case SVt_NULL:
2990             case SVt_IV:
2991                 sv_upgrade(dstr, SVt_NV);
2992                 break;
2993             case SVt_RV:
2994             case SVt_PV:
2995             case SVt_PVIV:
2996                 sv_upgrade(dstr, SVt_PVNV);
2997                 break;
2998             }
2999             SvNV_set(dstr, SvNVX(sstr));
3000             (void)SvNOK_only(dstr);
3001             if (SvTAINTED(sstr))
3002                 SvTAINT(dstr);
3003             return;
3004         }
3005         goto undef_sstr;
3006
3007     case SVt_RV:
3008         if (dtype < SVt_RV)
3009             sv_upgrade(dstr, SVt_RV);
3010         else if (dtype == SVt_PVGV &&
3011                  SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3012             sstr = SvRV(sstr);
3013             if (sstr == dstr) {
3014                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3015                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3016                 {
3017                     GvIMPORTED_on(dstr);
3018                 }
3019                 GvMULTI_on(dstr);
3020                 return;
3021             }
3022             goto glob_assign;
3023         }
3024         break;
3025     case SVt_PVFM:
3026 #ifdef PERL_OLD_COPY_ON_WRITE
3027         if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3028             if (dtype < SVt_PVIV)
3029                 sv_upgrade(dstr, SVt_PVIV);
3030             break;
3031         }
3032         /* Fall through */
3033 #endif
3034     case SVt_PV:
3035         if (dtype < SVt_PV)
3036             sv_upgrade(dstr, SVt_PV);
3037         break;
3038     case SVt_PVIV:
3039         if (dtype < SVt_PVIV)
3040             sv_upgrade(dstr, SVt_PVIV);
3041         break;
3042     case SVt_PVNV:
3043         if (dtype < SVt_PVNV)
3044             sv_upgrade(dstr, SVt_PVNV);
3045         break;
3046     case SVt_PVAV:
3047     case SVt_PVHV:
3048     case SVt_PVCV:
3049     case SVt_PVIO:
3050         {
3051         const char * const type = sv_reftype(sstr,0);
3052         if (PL_op)
3053             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3054         else
3055             Perl_croak(aTHX_ "Bizarre copy of %s", type);
3056         }
3057         break;
3058
3059     case SVt_PVGV:
3060         if (dtype <= SVt_PVGV) {
3061   glob_assign:
3062             if (dtype != SVt_PVGV) {
3063                 const char * const name = GvNAME(sstr);
3064                 const STRLEN len = GvNAMELEN(sstr);
3065                 /* don't upgrade SVt_PVLV: it can hold a glob */
3066                 if (dtype != SVt_PVLV)
3067                     sv_upgrade(dstr, SVt_PVGV);
3068                 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3069                 GvSTASH(dstr) = GvSTASH(sstr);
3070                 if (GvSTASH(dstr))
3071                     Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3072                 GvNAME(dstr) = savepvn(name, len);
3073                 GvNAMELEN(dstr) = len;
3074                 SvFAKE_on(dstr);        /* can coerce to non-glob */
3075             }
3076
3077 #ifdef GV_UNIQUE_CHECK
3078                 if (GvUNIQUE((GV*)dstr)) {
3079                     Perl_croak(aTHX_ PL_no_modify);
3080                 }
3081 #endif
3082
3083             (void)SvOK_off(dstr);
3084             GvINTRO_off(dstr);          /* one-shot flag */
3085             gp_free((GV*)dstr);
3086             GvGP(dstr) = gp_ref(GvGP(sstr));
3087             if (SvTAINTED(sstr))
3088                 SvTAINT(dstr);
3089             if (GvIMPORTED(dstr) != GVf_IMPORTED
3090                 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3091             {
3092                 GvIMPORTED_on(dstr);
3093             }
3094             GvMULTI_on(dstr);
3095             return;
3096         }
3097         /* FALL THROUGH */
3098
3099     default:
3100         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3101             mg_get(sstr);
3102             if ((int)SvTYPE(sstr) != stype) {
3103                 stype = SvTYPE(sstr);
3104                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3105                     goto glob_assign;
3106             }
3107         }
3108         if (stype == SVt_PVLV)
3109             SvUPGRADE(dstr, SVt_PVNV);
3110         else
3111             SvUPGRADE(dstr, (U32)stype);
3112     }
3113
3114     sflags = SvFLAGS(sstr);
3115
3116     if (sflags & SVf_ROK) {
3117         if (dtype >= SVt_PV) {
3118             if (dtype == SVt_PVGV) {
3119                 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3120                 SV *dref = NULL;
3121                 const int intro = GvINTRO(dstr);
3122
3123 #ifdef GV_UNIQUE_CHECK
3124                 if (GvUNIQUE((GV*)dstr)) {
3125                     Perl_croak(aTHX_ PL_no_modify);
3126                 }
3127 #endif
3128
3129                 if (intro) {
3130                     GvINTRO_off(dstr);  /* one-shot flag */
3131                     GvLINE(dstr) = CopLINE(PL_curcop);
3132                     GvEGV(dstr) = (GV*)dstr;
3133                 }
3134                 GvMULTI_on(dstr);
3135                 switch (SvTYPE(sref)) {
3136                 case SVt_PVAV:
3137                     if (intro)
3138                         SAVEGENERICSV(GvAV(dstr));
3139                     else
3140                         dref = (SV*)GvAV(dstr);
3141                     GvAV(dstr) = (AV*)sref;
3142                     if (!GvIMPORTED_AV(dstr)
3143                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3144                     {
3145                         GvIMPORTED_AV_on(dstr);
3146                     }
3147                     break;
3148                 case SVt_PVHV:
3149                     if (intro)
3150                         SAVEGENERICSV(GvHV(dstr));
3151                     else
3152                         dref = (SV*)GvHV(dstr);
3153                     GvHV(dstr) = (HV*)sref;
3154                     if (!GvIMPORTED_HV(dstr)
3155                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3156                     {
3157                         GvIMPORTED_HV_on(dstr);
3158                     }
3159                     break;
3160                 case SVt_PVCV:
3161                     if (intro) {
3162                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3163                             SvREFCNT_dec(GvCV(dstr));
3164                             GvCV(dstr) = Nullcv;
3165                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3166                             PL_sub_generation++;
3167                         }
3168                         SAVEGENERICSV(GvCV(dstr));
3169                     }
3170                     else
3171                         dref = (SV*)GvCV(dstr);
3172                     if (GvCV(dstr) != (CV*)sref) {
3173                         CV* const cv = GvCV(dstr);
3174                         if (cv) {
3175                             if (!GvCVGEN((GV*)dstr) &&
3176                                 (CvROOT(cv) || CvXSUB(cv)))
3177                             {
3178                                 /* Redefining a sub - warning is mandatory if
3179                                    it was a const and its value changed. */
3180                                 if (CvCONST(cv) && CvCONST((CV*)sref)
3181                                     && cv_const_sv(cv)
3182                                     == cv_const_sv((CV*)sref)) {
3183                                     /* They are 2 constant subroutines
3184                                        generated from the same constant.
3185                                        This probably means that they are
3186                                        really the "same" proxy subroutine
3187                                        instantiated in 2 places. Most likely
3188                                        this is when a constant is exported
3189                                        twice.  Don't warn.  */
3190                                 }
3191                                 else if (ckWARN(WARN_REDEFINE)
3192                                     || (CvCONST(cv)
3193                                         && (!CvCONST((CV*)sref)
3194                                             || sv_cmp(cv_const_sv(cv),
3195                                                       cv_const_sv((CV*)sref)))))
3196                                 {
3197                                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3198                                         CvCONST(cv)
3199                                         ? "Constant subroutine %s::%s redefined"
3200                                         : "Subroutine %s::%s redefined",
3201                                         HvNAME_get(GvSTASH((GV*)dstr)),
3202                                         GvENAME((GV*)dstr));
3203                                 }
3204                             }
3205                             if (!intro)
3206                                 cv_ckproto(cv, (GV*)dstr,
3207                                            SvPOK(sref)
3208                                            ? SvPVX_const(sref) : Nullch);
3209                         }
3210                         GvCV(dstr) = (CV*)sref;
3211                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3212                         GvASSUMECV_on(dstr);
3213                         PL_sub_generation++;
3214                     }
3215                     if (!GvIMPORTED_CV(dstr)
3216                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3217                     {
3218                         GvIMPORTED_CV_on(dstr);
3219                     }
3220                     break;
3221                 case SVt_PVIO:
3222                     if (intro)
3223                         SAVEGENERICSV(GvIOp(dstr));
3224                     else
3225                         dref = (SV*)GvIOp(dstr);
3226                     GvIOp(dstr) = (IO*)sref;
3227                     break;
3228                 case SVt_PVFM:
3229                     if (intro)
3230                         SAVEGENERICSV(GvFORM(dstr));
3231                     else
3232                         dref = (SV*)GvFORM(dstr);
3233                     GvFORM(dstr) = (CV*)sref;
3234                     break;
3235                 default:
3236                     if (intro)
3237                         SAVEGENERICSV(GvSV(dstr));
3238                     else
3239                         dref = (SV*)GvSV(dstr);
3240                     GvSV(dstr) = sref;
3241                     if (!GvIMPORTED_SV(dstr)
3242                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3243                     {
3244                         GvIMPORTED_SV_on(dstr);
3245                     }
3246                     break;
3247                 }
3248                 if (dref)
3249                     SvREFCNT_dec(dref);
3250                 if (SvTAINTED(sstr))
3251                     SvTAINT(dstr);
3252                 return;
3253             }
3254             if (SvPVX_const(dstr)) {
3255                 SvPV_free(dstr);
3256                 SvLEN_set(dstr, 0);
3257                 SvCUR_set(dstr, 0);
3258             }
3259         }
3260         (void)SvOK_off(dstr);
3261         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3262         SvROK_on(dstr);
3263         if (sflags & SVp_NOK) {
3264             SvNOKp_on(dstr);
3265             /* Only set the public OK flag if the source has public OK.  */
3266             if (sflags & SVf_NOK)
3267                 SvFLAGS(dstr) |= SVf_NOK;
3268             SvNV_set(dstr, SvNVX(sstr));
3269         }
3270         if (sflags & SVp_IOK) {
3271             (void)SvIOKp_on(dstr);
3272             if (sflags & SVf_IOK)
3273                 SvFLAGS(dstr) |= SVf_IOK;
3274             if (sflags & SVf_IVisUV)
3275                 SvIsUV_on(dstr);
3276             SvIV_set(dstr, SvIVX(sstr));
3277         }
3278         if (SvAMAGIC(sstr)) {
3279             SvAMAGIC_on(dstr);
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 & SVf_UTF8)
3404             SvUTF8_on(dstr);
3405         if (sflags & SVp_NOK) {
3406             SvNOKp_on(dstr);
3407             if (sflags & SVf_NOK)
3408                 SvFLAGS(dstr) |= SVf_NOK;
3409             SvNV_set(dstr, SvNVX(sstr));
3410         }
3411         if (sflags & SVp_IOK) {
3412             (void)SvIOKp_on(dstr);
3413             if (sflags & SVf_IOK)
3414                 SvFLAGS(dstr) |= SVf_IOK;
3415             if (sflags & SVf_IVisUV)
3416                 SvIsUV_on(dstr);
3417             SvIV_set(dstr, SvIVX(sstr));
3418         }
3419         if (SvVOK(sstr)) {
3420             const MAGIC * const smg = mg_find(sstr,PERL_MAGIC_vstring);
3421             sv_magic(dstr, NULL, PERL_MAGIC_vstring,
3422                         smg->mg_ptr, smg->mg_len);
3423             SvRMAGICAL_on(dstr);
3424         }
3425     }
3426     else if (sflags & SVp_IOK) {
3427         if (sflags & SVf_IOK)
3428             (void)SvIOK_only(dstr);
3429         else {
3430             (void)SvOK_off(dstr);
3431             (void)SvIOKp_on(dstr);
3432         }
3433         /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
3434         if (sflags & SVf_IVisUV)
3435             SvIsUV_on(dstr);
3436         SvIV_set(dstr, SvIVX(sstr));
3437         if (sflags & SVp_NOK) {
3438             if (sflags & SVf_NOK)
3439                 (void)SvNOK_on(dstr);
3440             else
3441                 (void)SvNOKp_on(dstr);
3442             SvNV_set(dstr, SvNVX(sstr));
3443         }
3444     }
3445     else if (sflags & SVp_NOK) {
3446         if (sflags & SVf_NOK)
3447             (void)SvNOK_only(dstr);
3448         else {
3449             (void)SvOK_off(dstr);
3450             SvNOKp_on(dstr);
3451         }
3452         SvNV_set(dstr, SvNVX(sstr));
3453     }
3454     else {
3455         if (dtype == SVt_PVGV) {
3456             if (ckWARN(WARN_MISC))
3457                 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
3458         }
3459         else
3460             (void)SvOK_off(dstr);
3461     }
3462     if (SvTAINTED(sstr))
3463         SvTAINT(dstr);
3464 }
3465
3466 /*
3467 =for apidoc sv_setsv_mg
3468
3469 Like C<sv_setsv>, but also handles 'set' magic.
3470
3471 =cut
3472 */
3473
3474 void
3475 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3476 {
3477     sv_setsv(dstr,sstr);
3478     SvSETMAGIC(dstr);
3479 }
3480
3481 #ifdef PERL_OLD_COPY_ON_WRITE
3482 SV *
3483 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
3484 {
3485     STRLEN cur = SvCUR(sstr);
3486     STRLEN len = SvLEN(sstr);
3487     register char *new_pv;
3488
3489     if (DEBUG_C_TEST) {
3490         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
3491                       sstr, dstr);
3492         sv_dump(sstr);
3493         if (dstr)
3494                     sv_dump(dstr);
3495     }
3496
3497     if (dstr) {
3498         if (SvTHINKFIRST(dstr))
3499             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
3500         else if (SvPVX_const(dstr))
3501             Safefree(SvPVX_const(dstr));
3502     }
3503     else
3504         new_SV(dstr);
3505     SvUPGRADE(dstr, SVt_PVIV);
3506
3507     assert (SvPOK(sstr));
3508     assert (SvPOKp(sstr));
3509     assert (!SvIOK(sstr));
3510     assert (!SvIOKp(sstr));
3511     assert (!SvNOK(sstr));
3512     assert (!SvNOKp(sstr));
3513
3514     if (SvIsCOW(sstr)) {
3515
3516         if (SvLEN(sstr) == 0) {
3517             /* source is a COW shared hash key.  */
3518             DEBUG_C(PerlIO_printf(Perl_debug_log,
3519                                   "Fast copy on write: Sharing hash\n"));
3520             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
3521             goto common_exit;
3522         }
3523         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3524     } else {
3525         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
3526         SvUPGRADE(sstr, SVt_PVIV);
3527         SvREADONLY_on(sstr);
3528         SvFAKE_on(sstr);
3529         DEBUG_C(PerlIO_printf(Perl_debug_log,
3530                               "Fast copy on write: Converting sstr to COW\n"));
3531         SV_COW_NEXT_SV_SET(dstr, sstr);
3532     }
3533     SV_COW_NEXT_SV_SET(sstr, dstr);
3534     new_pv = SvPVX_mutable(sstr);
3535
3536   common_exit:
3537     SvPV_set(dstr, new_pv);
3538     SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
3539     if (SvUTF8(sstr))
3540         SvUTF8_on(dstr);
3541     SvLEN_set(dstr, len);
3542     SvCUR_set(dstr, cur);
3543     if (DEBUG_C_TEST) {
3544         sv_dump(dstr);
3545     }
3546     return dstr;
3547 }
3548 #endif
3549
3550 /*
3551 =for apidoc sv_setpvn
3552
3553 Copies a string into an SV.  The C<len> parameter indicates the number of
3554 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
3555 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
3556
3557 =cut
3558 */
3559
3560 void
3561 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3562 {
3563     dVAR;
3564     register char *dptr;
3565
3566     SV_CHECK_THINKFIRST_COW_DROP(sv);
3567     if (!ptr) {
3568         (void)SvOK_off(sv);
3569         return;
3570     }
3571     else {
3572         /* len is STRLEN which is unsigned, need to copy to signed */
3573         const IV iv = len;
3574         if (iv < 0)
3575             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3576     }
3577     SvUPGRADE(sv, SVt_PV);
3578
3579     dptr = SvGROW(sv, len + 1);
3580     Move(ptr,dptr,len,char);
3581     dptr[len] = '\0';
3582     SvCUR_set(sv, len);
3583     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3584     SvTAINT(sv);
3585 }
3586
3587 /*
3588 =for apidoc sv_setpvn_mg
3589
3590 Like C<sv_setpvn>, but also handles 'set' magic.
3591
3592 =cut
3593 */
3594
3595 void
3596 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3597 {
3598     sv_setpvn(sv,ptr,len);
3599     SvSETMAGIC(sv);
3600 }
3601
3602 /*
3603 =for apidoc sv_setpv
3604
3605 Copies a string into an SV.  The string must be null-terminated.  Does not
3606 handle 'set' magic.  See C<sv_setpv_mg>.
3607
3608 =cut
3609 */
3610
3611 void
3612 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3613 {
3614     dVAR;
3615     register STRLEN len;
3616
3617     SV_CHECK_THINKFIRST_COW_DROP(sv);
3618     if (!ptr) {
3619         (void)SvOK_off(sv);
3620         return;
3621     }
3622     len = strlen(ptr);
3623     SvUPGRADE(sv, SVt_PV);
3624
3625     SvGROW(sv, len + 1);
3626     Move(ptr,SvPVX(sv),len+1,char);
3627     SvCUR_set(sv, len);
3628     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3629     SvTAINT(sv);
3630 }
3631
3632 /*
3633 =for apidoc sv_setpv_mg
3634
3635 Like C<sv_setpv>, but also handles 'set' magic.
3636
3637 =cut
3638 */
3639
3640 void
3641 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3642 {
3643     sv_setpv(sv,ptr);
3644     SvSETMAGIC(sv);
3645 }
3646
3647 /*
3648 =for apidoc sv_usepvn
3649
3650 Tells an SV to use C<ptr> to find its string value.  Normally the string is
3651 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3652 The C<ptr> should point to memory that was allocated by C<malloc>.  The
3653 string length, C<len>, must be supplied.  This function will realloc the
3654 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3655 the programmer after giving it to sv_usepvn.  Does not handle 'set' magic.
3656 See C<sv_usepvn_mg>.
3657
3658 =cut
3659 */
3660
3661 void
3662 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3663 {
3664     dVAR;
3665     STRLEN allocate;
3666     SV_CHECK_THINKFIRST_COW_DROP(sv);
3667     SvUPGRADE(sv, SVt_PV);
3668     if (!ptr) {
3669         (void)SvOK_off(sv);
3670         return;
3671     }
3672     if (SvPVX_const(sv))
3673         SvPV_free(sv);
3674
3675     allocate = PERL_STRLEN_ROUNDUP(len + 1);
3676     ptr = saferealloc (ptr, allocate);
3677     SvPV_set(sv, ptr);
3678     SvCUR_set(sv, len);
3679     SvLEN_set(sv, allocate);
3680     *SvEND(sv) = '\0';
3681     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3682     SvTAINT(sv);
3683 }
3684
3685 /*
3686 =for apidoc sv_usepvn_mg
3687
3688 Like C<sv_usepvn>, but also handles 'set' magic.
3689
3690 =cut
3691 */
3692
3693 void
3694 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3695 {
3696     sv_usepvn(sv,ptr,len);
3697     SvSETMAGIC(sv);
3698 }
3699
3700 #ifdef PERL_OLD_COPY_ON_WRITE
3701 /* Need to do this *after* making the SV normal, as we need the buffer
3702    pointer to remain valid until after we've copied it.  If we let go too early,
3703    another thread could invalidate it by unsharing last of the same hash key
3704    (which it can do by means other than releasing copy-on-write Svs)
3705    or by changing the other copy-on-write SVs in the loop.  */
3706 STATIC void
3707 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
3708 {
3709     if (len) { /* this SV was SvIsCOW_normal(sv) */
3710          /* we need to find the SV pointing to us.  */
3711         SV * const current = SV_COW_NEXT_SV(after);
3712
3713         if (current == sv) {
3714             /* The SV we point to points back to us (there were only two of us
3715                in the loop.)
3716                Hence other SV is no longer copy on write either.  */
3717             SvFAKE_off(after);
3718             SvREADONLY_off(after);
3719         } else {
3720             /* We need to follow the pointers around the loop.  */
3721             SV *next;
3722             while ((next = SV_COW_NEXT_SV(current)) != sv) {
3723                 assert (next);
3724                 current = next;
3725                  /* don't loop forever if the structure is bust, and we have
3726                     a pointer into a closed loop.  */
3727                 assert (current != after);
3728                 assert (SvPVX_const(current) == pvx);
3729             }
3730             /* Make the SV before us point to the SV after us.  */
3731             SV_COW_NEXT_SV_SET(current, after);
3732         }
3733     } else {
3734         unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
3735     }
3736 }
3737
3738 int
3739 Perl_sv_release_IVX(pTHX_ register SV *sv)
3740 {
3741     if (SvIsCOW(sv))
3742         sv_force_normal_flags(sv, 0);
3743     SvOOK_off(sv);
3744     return 0;
3745 }
3746 #endif
3747 /*
3748 =for apidoc sv_force_normal_flags
3749
3750 Undo various types of fakery on an SV: if the PV is a shared string, make
3751 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
3752 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
3753 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
3754 then a copy-on-write scalar drops its PV buffer (if any) and becomes
3755 SvPOK_off rather than making a copy. (Used where this scalar is about to be
3756 set to some other value.) In addition, the C<flags> parameter gets passed to
3757 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
3758 with flags set to 0.
3759
3760 =cut
3761 */
3762
3763 void
3764 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3765 {
3766     dVAR;
3767 #ifdef PERL_OLD_COPY_ON_WRITE
3768     if (SvREADONLY(sv)) {
3769         /* At this point I believe I should acquire a global SV mutex.  */
3770         if (SvFAKE(sv)) {
3771             const char * const pvx = SvPVX_const(sv);
3772             const STRLEN len = SvLEN(sv);
3773             const STRLEN cur = SvCUR(sv);
3774             SV * const next = SV_COW_NEXT_SV(sv);   /* next COW sv in the loop. */
3775             if (DEBUG_C_TEST) {
3776                 PerlIO_printf(Perl_debug_log,
3777                               "Copy on write: Force normal %ld\n",
3778                               (long) flags);
3779                 sv_dump(sv);
3780             }
3781             SvFAKE_off(sv);
3782             SvREADONLY_off(sv);
3783             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
3784             SvPV_set(sv, NULL);
3785             SvLEN_set(sv, 0);
3786             if (flags & SV_COW_DROP_PV) {
3787                 /* OK, so we don't need to copy our buffer.  */
3788                 SvPOK_off(sv);
3789             } else {
3790                 SvGROW(sv, cur + 1);
3791                 Move(pvx,SvPVX(sv),cur,char);
3792                 SvCUR_set(sv, cur);
3793                 *SvEND(sv) = '\0';
3794             }
3795             sv_release_COW(sv, pvx, len, next);
3796             if (DEBUG_C_TEST) {
3797                 sv_dump(sv);
3798             }
3799         }
3800         else if (IN_PERL_RUNTIME)
3801             Perl_croak(aTHX_ PL_no_modify);
3802         /* At this point I believe that I can drop the global SV mutex.  */
3803     }
3804 #else
3805     if (SvREADONLY(sv)) {
3806         if (SvFAKE(sv)) {
3807             const char * const pvx = SvPVX_const(sv);
3808             const STRLEN len = SvCUR(sv);
3809             SvFAKE_off(sv);
3810             SvREADONLY_off(sv);
3811             SvPV_set(sv, Nullch);
3812             SvLEN_set(sv, 0);
3813             SvGROW(sv, len + 1);
3814             Move(pvx,SvPVX(sv),len,char);
3815             *SvEND(sv) = '\0';
3816             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
3817         }
3818         else if (IN_PERL_RUNTIME)
3819             Perl_croak(aTHX_ PL_no_modify);
3820     }
3821 #endif
3822     if (SvROK(sv))
3823         sv_unref_flags(sv, flags);
3824     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3825         sv_unglob(sv);
3826 }
3827
3828 /*
3829 =for apidoc sv_chop
3830
3831 Efficient removal of characters from the beginning of the string buffer.
3832 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3833 the string buffer.  The C<ptr> becomes the first character of the adjusted
3834 string. Uses the "OOK hack".
3835 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
3836 refer to the same chunk of data.
3837
3838 =cut
3839 */
3840
3841 void
3842 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
3843 {
3844     register STRLEN delta;
3845     if (!ptr || !SvPOKp(sv))
3846         return;
3847     delta = ptr - SvPVX_const(sv);
3848     SV_CHECK_THINKFIRST(sv);
3849     if (SvTYPE(sv) < SVt_PVIV)
3850         sv_upgrade(sv,SVt_PVIV);
3851
3852     if (!SvOOK(sv)) {
3853         if (!SvLEN(sv)) { /* make copy of shared string */
3854             const char *pvx = SvPVX_const(sv);
3855             const STRLEN len = SvCUR(sv);
3856             SvGROW(sv, len + 1);
3857             Move(pvx,SvPVX(sv),len,char);
3858             *SvEND(sv) = '\0';
3859         }
3860         SvIV_set(sv, 0);
3861         /* Same SvOOK_on but SvOOK_on does a SvIOK_off
3862            and we do that anyway inside the SvNIOK_off
3863         */
3864         SvFLAGS(sv) |= SVf_OOK;
3865     }
3866     SvNIOK_off(sv);
3867     SvLEN_set(sv, SvLEN(sv) - delta);
3868     SvCUR_set(sv, SvCUR(sv) - delta);
3869     SvPV_set(sv, SvPVX(sv) + delta);
3870     SvIV_set(sv, SvIVX(sv) + delta);
3871 }
3872
3873 /*
3874 =for apidoc sv_catpvn
3875
3876 Concatenates the string onto the end of the string which is in the SV.  The
3877 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
3878 status set, then the bytes appended should be valid UTF-8.
3879 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
3880
3881 =for apidoc sv_catpvn_flags
3882
3883 Concatenates the string onto the end of the string which is in the SV.  The
3884 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
3885 status set, then the bytes appended should be valid UTF-8.
3886 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
3887 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
3888 in terms of this function.
3889
3890 =cut
3891 */
3892
3893 void
3894 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
3895 {
3896     dVAR;
3897     STRLEN dlen;
3898     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
3899
3900     SvGROW(dsv, dlen + slen + 1);
3901     if (sstr == dstr)
3902         sstr = SvPVX_const(dsv);
3903     Move(sstr, SvPVX(dsv) + dlen, slen, char);
3904     SvCUR_set(dsv, SvCUR(dsv) + slen);
3905     *SvEND(dsv) = '\0';
3906     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
3907     SvTAINT(dsv);
3908     if (flags & SV_SMAGIC)
3909         SvSETMAGIC(dsv);
3910 }
3911
3912 /*
3913 =for apidoc sv_catsv
3914
3915 Concatenates the string from SV C<ssv> onto the end of the string in
3916 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
3917 not 'set' magic.  See C<sv_catsv_mg>.
3918
3919 =for apidoc sv_catsv_flags
3920
3921 Concatenates the string from SV C<ssv> onto the end of the string in
3922 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
3923 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
3924 and C<sv_catsv_nomg> are implemented in terms of this function.
3925
3926 =cut */
3927
3928 void
3929 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
3930 {
3931     dVAR;
3932     if (ssv) {
3933         STRLEN slen;
3934         const char *spv = SvPV_const(ssv, slen);
3935         if (spv) {
3936             /*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
3937                 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
3938                 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
3939                 get dutf8 = 0x20000000, (i.e.  SVf_UTF8) even though
3940                 dsv->sv_flags doesn't have that bit set.
3941                 Andy Dougherty  12 Oct 2001
3942             */
3943             const I32 sutf8 = DO_UTF8(ssv);
3944             I32 dutf8;
3945
3946             if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
3947                 mg_get(dsv);
3948             dutf8 = DO_UTF8(dsv);
3949
3950             if (dutf8 != sutf8) {
3951                 if (dutf8) {
3952                     /* Not modifying source SV, so taking a temporary copy. */
3953                     SV* const csv = sv_2mortal(newSVpvn(spv, slen));
3954
3955                     sv_utf8_upgrade(csv);
3956                     spv = SvPV_const(csv, slen);
3957                 }
3958                 else
3959                     sv_utf8_upgrade_nomg(dsv);
3960             }
3961             sv_catpvn_nomg(dsv, spv, slen);
3962         }
3963     }
3964     if (flags & SV_SMAGIC)
3965         SvSETMAGIC(dsv);
3966 }
3967
3968 /*
3969 =for apidoc sv_catpv
3970
3971 Concatenates the string onto the end of the string which is in the SV.
3972 If the SV has the UTF-8 status set, then the bytes appended should be
3973 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
3974
3975 =cut */
3976
3977 void
3978 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3979 {
3980     dVAR;
3981     register STRLEN len;
3982     STRLEN tlen;
3983     char *junk;
3984
3985     if (!ptr)
3986         return;
3987     junk = SvPV_force(sv, tlen);
3988     len = strlen(ptr);
3989     SvGROW(sv, tlen + len + 1);
3990     if (ptr == junk)
3991         ptr = SvPVX_const(sv);
3992     Move(ptr,SvPVX(sv)+tlen,len+1,char);
3993     SvCUR_set(sv, SvCUR(sv) + len);
3994     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3995     SvTAINT(sv);
3996 }
3997
3998 /*
3999 =for apidoc sv_catpv_mg
4000
4001 Like C<sv_catpv>, but also handles 'set' magic.
4002
4003 =cut
4004 */
4005
4006 void
4007 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4008 {
4009     sv_catpv(sv,ptr);
4010     SvSETMAGIC(sv);
4011 }
4012
4013 /*
4014 =for apidoc newSV
4015
4016 Creates a new SV.  A non-zero C<len> parameter indicates the number of
4017 bytes of preallocated string space the SV should have.  An extra byte for a
4018 trailing NUL is also reserved.  (SvPOK is not set for the SV even if string
4019 space is allocated.)  The reference count for the new SV is set to 1.
4020
4021 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
4022 parameter, I<x>, a debug aid which allowed callers to identify themselves.
4023 This aid has been superseded by a new build option, PERL_MEM_LOG (see
4024 L<perlhack/PERL_MEM_LOG>).  The older API is still there for use in XS
4025 modules supporting older perls.
4026
4027 =cut
4028 */
4029
4030 SV *
4031 Perl_newSV(pTHX_ STRLEN len)
4032 {
4033     dVAR;
4034     register SV *sv;
4035
4036     new_SV(sv);
4037     if (len) {
4038         sv_upgrade(sv, SVt_PV);
4039         SvGROW(sv, len + 1);
4040     }
4041     return sv;
4042 }
4043 /*
4044 =for apidoc sv_magicext
4045
4046 Adds magic to an SV, upgrading it if necessary. Applies the
4047 supplied vtable and returns a pointer to the magic added.
4048
4049 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4050 In particular, you can add magic to SvREADONLY SVs, and add more than
4051 one instance of the same 'how'.
4052
4053 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4054 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4055 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4056 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4057
4058 (This is now used as a subroutine by C<sv_magic>.)
4059
4060 =cut
4061 */
4062 MAGIC * 
4063 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
4064                  const char* name, I32 namlen)
4065 {
4066     dVAR;
4067     MAGIC* mg;
4068
4069     if (SvTYPE(sv) < SVt_PVMG) {
4070         SvUPGRADE(sv, SVt_PVMG);
4071     }
4072     Newxz(mg, 1, MAGIC);
4073     mg->mg_moremagic = SvMAGIC(sv);
4074     SvMAGIC_set(sv, mg);
4075
4076     /* Sometimes a magic contains a reference loop, where the sv and
4077        object refer to each other.  To prevent a reference loop that
4078        would prevent such objects being freed, we look for such loops
4079        and if we find one we avoid incrementing the object refcount.
4080
4081        Note we cannot do this to avoid self-tie loops as intervening RV must
4082        have its REFCNT incremented to keep it in existence.
4083
4084     */
4085     if (!obj || obj == sv ||
4086         how == PERL_MAGIC_arylen ||
4087         how == PERL_MAGIC_qr ||
4088         how == PERL_MAGIC_symtab ||
4089         (SvTYPE(obj) == SVt_PVGV &&
4090             (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4091             GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4092             GvFORM(obj) == (CV*)sv)))
4093     {
4094         mg->mg_obj = obj;
4095     }
4096     else {
4097         mg->mg_obj = SvREFCNT_inc(obj);
4098         mg->mg_flags |= MGf_REFCOUNTED;
4099     }
4100
4101     /* Normal self-ties simply pass a null object, and instead of
4102        using mg_obj directly, use the SvTIED_obj macro to produce a
4103        new RV as needed.  For glob "self-ties", we are tieing the PVIO
4104        with an RV obj pointing to the glob containing the PVIO.  In
4105        this case, to avoid a reference loop, we need to weaken the
4106        reference.
4107     */
4108
4109     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4110         obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4111     {
4112       sv_rvweaken(obj);
4113     }
4114
4115     mg->mg_type = how;
4116     mg->mg_len = namlen;
4117     if (name) {
4118         if (namlen > 0)
4119             mg->mg_ptr = savepvn(name, namlen);
4120         else if (namlen == HEf_SVKEY)
4121             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4122         else
4123             mg->mg_ptr = (char *) name;
4124     }
4125     mg->mg_virtual = vtable;
4126
4127     mg_magical(sv);
4128     if (SvGMAGICAL(sv))
4129         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4130     return mg;
4131 }
4132
4133 /*
4134 =for apidoc sv_magic
4135
4136 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4137 then adds a new magic item of type C<how> to the head of the magic list.
4138
4139 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4140 handling of the C<name> and C<namlen> arguments.
4141
4142 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4143 to add more than one instance of the same 'how'.
4144
4145 =cut
4146 */
4147
4148 void
4149 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4150 {
4151     dVAR;
4152     const MGVTBL *vtable;
4153     MAGIC* mg;
4154
4155 #ifdef PERL_OLD_COPY_ON_WRITE
4156     if (SvIsCOW(sv))
4157         sv_force_normal_flags(sv, 0);
4158 #endif
4159     if (SvREADONLY(sv)) {
4160         if (
4161             /* its okay to attach magic to shared strings; the subsequent
4162              * upgrade to PVMG will unshare the string */
4163             !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4164
4165             && IN_PERL_RUNTIME
4166             && how != PERL_MAGIC_regex_global
4167             && how != PERL_MAGIC_bm
4168             && how != PERL_MAGIC_fm
4169             && how != PERL_MAGIC_sv
4170             && how != PERL_MAGIC_backref
4171            )
4172         {
4173             Perl_croak(aTHX_ PL_no_modify);
4174         }
4175     }
4176     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4177         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4178             /* sv_magic() refuses to add a magic of the same 'how' as an
4179                existing one
4180              */
4181             if (how == PERL_MAGIC_taint)
4182                 mg->mg_len |= 1;
4183             return;
4184         }
4185     }
4186
4187     switch (how) {
4188     case PERL_MAGIC_sv:
4189         vtable = &PL_vtbl_sv;
4190         break;
4191     case PERL_MAGIC_overload:
4192         vtable = &PL_vtbl_amagic;
4193         break;
4194     case PERL_MAGIC_overload_elem:
4195         vtable = &PL_vtbl_amagicelem;
4196         break;
4197     case PERL_MAGIC_overload_table:
4198         vtable = &PL_vtbl_ovrld;
4199         break;
4200     case PERL_MAGIC_bm:
4201         vtable = &PL_vtbl_bm;
4202         break;
4203     case PERL_MAGIC_regdata:
4204         vtable = &PL_vtbl_regdata;
4205         break;
4206     case PERL_MAGIC_regdatum:
4207         vtable = &PL_vtbl_regdatum;
4208         break;
4209     case PERL_MAGIC_env:
4210         vtable = &PL_vtbl_env;
4211         break;
4212     case PERL_MAGIC_fm:
4213         vtable = &PL_vtbl_fm;
4214         break;
4215     case PERL_MAGIC_envelem:
4216         vtable = &PL_vtbl_envelem;
4217         break;
4218     case PERL_MAGIC_regex_global:
4219         vtable = &PL_vtbl_mglob;
4220         break;
4221     case PERL_MAGIC_isa:
4222         vtable = &PL_vtbl_isa;
4223         break;
4224     case PERL_MAGIC_isaelem:
4225         vtable = &PL_vtbl_isaelem;
4226         break;
4227     case PERL_MAGIC_nkeys:
4228         vtable = &PL_vtbl_nkeys;
4229         break;
4230     case PERL_MAGIC_dbfile:
4231         vtable = NULL;
4232         break;
4233     case PERL_MAGIC_dbline:
4234         vtable = &PL_vtbl_dbline;
4235         break;
4236 #ifdef USE_LOCALE_COLLATE
4237     case PERL_MAGIC_collxfrm:
4238         vtable = &PL_vtbl_collxfrm;
4239         break;
4240 #endif /* USE_LOCALE_COLLATE */
4241     case PERL_MAGIC_tied:
4242         vtable = &PL_vtbl_pack;
4243         break;
4244     case PERL_MAGIC_tiedelem:
4245     case PERL_MAGIC_tiedscalar:
4246         vtable = &PL_vtbl_packelem;
4247         break;
4248     case PERL_MAGIC_qr:
4249         vtable = &PL_vtbl_regexp;
4250         break;
4251     case PERL_MAGIC_sig:
4252         vtable = &PL_vtbl_sig;
4253         break;
4254     case PERL_MAGIC_sigelem:
4255         vtable = &PL_vtbl_sigelem;
4256         break;
4257     case PERL_MAGIC_taint:
4258         vtable = &PL_vtbl_taint;
4259         break;
4260     case PERL_MAGIC_uvar:
4261         vtable = &PL_vtbl_uvar;
4262         break;
4263     case PERL_MAGIC_vec:
4264         vtable = &PL_vtbl_vec;
4265         break;
4266     case PERL_MAGIC_arylen_p:
4267     case PERL_MAGIC_rhash:
4268     case PERL_MAGIC_symtab:
4269     case PERL_MAGIC_vstring:
4270         vtable = NULL;
4271         break;
4272     case PERL_MAGIC_utf8:
4273         vtable = &PL_vtbl_utf8;
4274         break;
4275     case PERL_MAGIC_substr:
4276         vtable = &PL_vtbl_substr;
4277         break;
4278     case PERL_MAGIC_defelem:
4279         vtable = &PL_vtbl_defelem;
4280         break;
4281     case PERL_MAGIC_glob:
4282         vtable = &PL_vtbl_glob;
4283         break;
4284     case PERL_MAGIC_arylen:
4285         vtable = &PL_vtbl_arylen;
4286         break;
4287     case PERL_MAGIC_pos:
4288         vtable = &PL_vtbl_pos;
4289         break;
4290     case PERL_MAGIC_backref:
4291         vtable = &PL_vtbl_backref;
4292         break;
4293     case PERL_MAGIC_ext:
4294         /* Reserved for use by extensions not perl internals.           */
4295         /* Useful for attaching extension internal data to perl vars.   */
4296         /* Note that multiple extensions may clash if magical scalars   */
4297         /* etc holding private data from one are passed to another.     */
4298         vtable = NULL;
4299         break;
4300     default:
4301         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4302     }
4303
4304     /* Rest of work is done else where */
4305     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4306
4307     switch (how) {
4308     case PERL_MAGIC_taint:
4309         mg->mg_len = 1;
4310         break;
4311     case PERL_MAGIC_ext:
4312     case PERL_MAGIC_dbfile:
4313         SvRMAGICAL_on(sv);
4314         break;
4315     }
4316 }
4317
4318 /*
4319 =for apidoc sv_unmagic
4320
4321 Removes all magic of type C<type> from an SV.
4322
4323 =cut
4324 */
4325
4326 int
4327 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4328 {
4329     MAGIC* mg;
4330     MAGIC** mgp;
4331     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4332         return 0;
4333     mgp = &SvMAGIC(sv);
4334     for (mg = *mgp; mg; mg = *mgp) {
4335         if (mg->mg_type == type) {
4336             const MGVTBL* const vtbl = mg->mg_virtual;
4337             *mgp = mg->mg_moremagic;
4338             if (vtbl && vtbl->svt_free)
4339                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4340             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4341                 if (mg->mg_len > 0)
4342                     Safefree(mg->mg_ptr);
4343                 else if (mg->mg_len == HEf_SVKEY)
4344                     SvREFCNT_dec((SV*)mg->mg_ptr);
4345                 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
4346                     Safefree(mg->mg_ptr);
4347             }
4348             if (mg->mg_flags & MGf_REFCOUNTED)
4349                 SvREFCNT_dec(mg->mg_obj);
4350             Safefree(mg);
4351         }
4352         else
4353             mgp = &mg->mg_moremagic;
4354     }
4355     if (!SvMAGIC(sv)) {
4356         SvMAGICAL_off(sv);
4357         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4358         SvMAGIC_set(sv, NULL);
4359     }
4360
4361     return 0;
4362 }
4363
4364 /*
4365 =for apidoc sv_rvweaken
4366
4367 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4368 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4369 push a back-reference to this RV onto the array of backreferences
4370 associated with that magic.
4371
4372 =cut
4373 */
4374
4375 SV *
4376 Perl_sv_rvweaken(pTHX_ SV *sv)
4377 {
4378     SV *tsv;
4379     if (!SvOK(sv))  /* let undefs pass */
4380         return sv;
4381     if (!SvROK(sv))
4382         Perl_croak(aTHX_ "Can't weaken a nonreference");
4383     else if (SvWEAKREF(sv)) {
4384         if (ckWARN(WARN_MISC))
4385             Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
4386         return sv;
4387     }
4388     tsv = SvRV(sv);
4389     Perl_sv_add_backref(aTHX_ tsv, sv);
4390     SvWEAKREF_on(sv);
4391     SvREFCNT_dec(tsv);
4392     return sv;
4393 }
4394
4395 /* Give tsv backref magic if it hasn't already got it, then push a
4396  * back-reference to sv onto the array associated with the backref magic.
4397  */
4398
4399 void
4400 Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4401 {
4402     dVAR;
4403     AV *av;
4404
4405     if (SvTYPE(tsv) == SVt_PVHV) {
4406         AV **const avp = Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
4407
4408         av = *avp;
4409         if (!av) {
4410             /* There is no AV in the offical place - try a fixup.  */
4411             MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
4412
4413             if (mg) {
4414                 /* Aha. They've got it stowed in magic.  Bring it back.  */
4415                 av = (AV*)mg->mg_obj;
4416                 /* Stop mg_free decreasing the refernce count.  */
4417                 mg->mg_obj = NULL;
4418                 /* Stop mg_free even calling the destructor, given that
4419                    there's no AV to free up.  */
4420                 mg->mg_virtual = 0;
4421                 sv_unmagic(tsv, PERL_MAGIC_backref);
4422             } else {
4423                 av = newAV();
4424                 AvREAL_off(av);
4425                 SvREFCNT_inc(av);
4426             }
4427             *avp = av;
4428         }
4429     } else {
4430         const MAGIC *const mg
4431             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
4432         if (mg)
4433             av = (AV*)mg->mg_obj;
4434         else {
4435             av = newAV();
4436             AvREAL_off(av);
4437             sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4438             /* av now has a refcnt of 2, which avoids it getting freed
4439              * before us during global cleanup. The extra ref is removed
4440              * by magic_killbackrefs() when tsv is being freed */
4441         }
4442     }
4443     if (AvFILLp(av) >= AvMAX(av)) {
4444         av_extend(av, AvFILLp(av)+1);
4445     }
4446     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
4447 }
4448
4449 /* delete a back-reference to ourselves from the backref magic associated
4450  * with the SV we point to.
4451  */
4452
4453 STATIC void
4454 S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
4455 {
4456     dVAR;
4457     AV *av = NULL;
4458     SV **svp;
4459     I32 i;
4460
4461     if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
4462         av = *Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
4463         /* We mustn't attempt to "fix up" the hash here by moving the
4464            backreference array back to the hv_aux structure, as that is stored
4465            in the main HvARRAY(), and hfreentries assumes that no-one
4466            reallocates HvARRAY() while it is running.  */
4467     }
4468     if (!av) {
4469         const MAGIC *const mg
4470             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
4471         if (mg)
4472             av = (AV *)mg->mg_obj;
4473     }
4474     if (!av) {
4475         if (PL_in_clean_all)
4476             return;
4477         Perl_croak(aTHX_ "panic: del_backref");
4478     }
4479
4480     if (SvIS_FREED(av))
4481         return;
4482
4483     svp = AvARRAY(av);
4484     /* We shouldn't be in here more than once, but for paranoia reasons lets
4485        not assume this.  */
4486     for (i = AvFILLp(av); i >= 0; i--) {
4487         if (svp[i] == sv) {
4488             const SSize_t fill = AvFILLp(av);
4489             if (i != fill) {
4490                 /* We weren't the last entry.
4491                    An unordered list has this property that you can take the
4492                    last element off the end to fill the hole, and it's still
4493                    an unordered list :-)
4494                 */
4495                 svp[i] = svp[fill];
4496             }
4497             svp[fill] = Nullsv;
4498             AvFILLp(av) = fill - 1;
4499         }
4500     }
4501 }
4502
4503 int
4504 Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *av)
4505 {
4506     SV **svp = AvARRAY(av);
4507
4508     PERL_UNUSED_ARG(sv);
4509
4510     /* Not sure why the av can get freed ahead of its sv, but somehow it does
4511        in ext/B/t/bytecode.t test 15 (involving print <DATA>)  */
4512     if (svp && !SvIS_FREED(av)) {
4513         SV *const *const last = svp + AvFILLp(av);
4514
4515         while (svp <= last) {
4516             if (*svp) {
4517                 SV *const referrer = *svp;
4518                 if (SvWEAKREF(referrer)) {
4519                     /* XXX Should we check that it hasn't changed? */
4520                     SvRV_set(referrer, 0);
4521                     SvOK_off(referrer);
4522                     SvWEAKREF_off(referrer);
4523                 } else if (SvTYPE(referrer) == SVt_PVGV ||
4524                            SvTYPE(referrer) == SVt_PVLV) {
4525                     /* You lookin' at me?  */
4526                     assert(GvSTASH(referrer));
4527                     assert(GvSTASH(referrer) == (HV*)sv);
4528                     GvSTASH(referrer) = 0;
4529                 } else {
4530                     Perl_croak(aTHX_
4531                                "panic: magic_killbackrefs (flags=%"UVxf")",
4532                                (UV)SvFLAGS(referrer));
4533                 }
4534
4535                 *svp = Nullsv;
4536             }
4537             svp++;
4538         }
4539     }
4540     SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
4541     return 0;
4542 }
4543
4544 /*
4545 =for apidoc sv_insert
4546
4547 Inserts a string at the specified offset/length within the SV. Similar to
4548 the Perl substr() function.
4549
4550 =cut
4551 */
4552
4553 void
4554 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
4555 {
4556     dVAR;
4557     register char *big;
4558     register char *mid;
4559     register char *midend;
4560     register char *bigend;
4561     register I32 i;
4562     STRLEN curlen;
4563
4564
4565     if (!bigstr)
4566         Perl_croak(aTHX_ "Can't modify non-existent substring");
4567     SvPV_force(bigstr, curlen);
4568     (void)SvPOK_only_UTF8(bigstr);
4569     if (offset + len > curlen) {
4570         SvGROW(bigstr, offset+len+1);
4571         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4572         SvCUR_set(bigstr, offset+len);
4573     }
4574
4575     SvTAINT(bigstr);
4576     i = littlelen - len;
4577     if (i > 0) {                        /* string might grow */
4578         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4579         mid = big + offset + len;
4580         midend = bigend = big + SvCUR(bigstr);
4581         bigend += i;
4582         *bigend = '\0';
4583         while (midend > mid)            /* shove everything down */
4584             *--bigend = *--midend;
4585         Move(little,big+offset,littlelen,char);
4586         SvCUR_set(bigstr, SvCUR(bigstr) + i);
4587         SvSETMAGIC(bigstr);
4588         return;
4589     }
4590     else if (i == 0) {
4591         Move(little,SvPVX(bigstr)+offset,len,char);
4592         SvSETMAGIC(bigstr);
4593         return;
4594     }
4595
4596     big = SvPVX(bigstr);
4597     mid = big + offset;
4598     midend = mid + len;
4599     bigend = big + SvCUR(bigstr);
4600
4601     if (midend > bigend)
4602         Perl_croak(aTHX_ "panic: sv_insert");
4603
4604     if (mid - big > bigend - midend) {  /* faster to shorten from end */
4605         if (littlelen) {
4606             Move(little, mid, littlelen,char);
4607             mid += littlelen;
4608         }
4609         i = bigend - midend;
4610         if (i > 0) {
4611             Move(midend, mid, i,char);
4612             mid += i;
4613         }
4614         *mid = '\0';
4615         SvCUR_set(bigstr, mid - big);
4616     }
4617     else if ((i = mid - big)) { /* faster from front */
4618         midend -= littlelen;
4619         mid = midend;
4620         sv_chop(bigstr,midend-i);
4621         big += i;
4622         while (i--)
4623             *--midend = *--big;
4624         if (littlelen)
4625             Move(little, mid, littlelen,char);
4626     }
4627     else if (littlelen) {
4628         midend -= littlelen;
4629         sv_chop(bigstr,midend);
4630         Move(little,midend,littlelen,char);
4631     }
4632     else {
4633         sv_chop(bigstr,midend);
4634     }
4635     SvSETMAGIC(bigstr);
4636 }
4637
4638 /*
4639 =for apidoc sv_replace
4640
4641 Make the first argument a copy of the second, then delete the original.
4642 The target SV physically takes over ownership of the body of the source SV
4643 and inherits its flags; however, the target keeps any magic it owns,
4644 and any magic in the source is discarded.
4645 Note that this is a rather specialist SV copying operation; most of the
4646 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
4647
4648 =cut
4649 */
4650
4651 void
4652 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4653 {
4654     dVAR;
4655     const U32 refcnt = SvREFCNT(sv);
4656     SV_CHECK_THINKFIRST_COW_DROP(sv);
4657     if (SvREFCNT(nsv) != 1) {
4658         Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
4659                    UVuf " != 1)", (UV) SvREFCNT(nsv));
4660     }
4661     if (SvMAGICAL(sv)) {
4662         if (SvMAGICAL(nsv))
4663             mg_free(nsv);
4664         else
4665             sv_upgrade(nsv, SVt_PVMG);
4666         SvMAGIC_set(nsv, SvMAGIC(sv));
4667         SvFLAGS(nsv) |= SvMAGICAL(sv);
4668         SvMAGICAL_off(sv);
4669         SvMAGIC_set(sv, NULL);
4670     }
4671     SvREFCNT(sv) = 0;
4672     sv_clear(sv);
4673     assert(!SvREFCNT(sv));
4674 #ifdef DEBUG_LEAKING_SCALARS
4675     sv->sv_flags  = nsv->sv_flags;
4676     sv->sv_any    = nsv->sv_any;
4677     sv->sv_refcnt = nsv->sv_refcnt;
4678     sv->sv_u      = nsv->sv_u;
4679 #else
4680     StructCopy(nsv,sv,SV);
4681 #endif
4682     /* Currently could join these into one piece of pointer arithmetic, but
4683        it would be unclear.  */
4684     if(SvTYPE(sv) == SVt_IV)
4685         SvANY(sv)
4686             = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
4687     else if (SvTYPE(sv) == SVt_RV) {
4688         SvANY(sv) = &sv->sv_u.svu_rv;
4689     }
4690         
4691
4692 #ifdef PERL_OLD_COPY_ON_WRITE
4693     if (SvIsCOW_normal(nsv)) {
4694         /* We need to follow the pointers around the loop to make the
4695            previous SV point to sv, rather than nsv.  */
4696         SV *next;
4697         SV *current = nsv;
4698         while ((next = SV_COW_NEXT_SV(current)) != nsv) {
4699             assert(next);
4700             current = next;
4701             assert(SvPVX_const(current) == SvPVX_const(nsv));
4702         }
4703         /* Make the SV before us point to the SV after us.  */
4704         if (DEBUG_C_TEST) {
4705             PerlIO_printf(Perl_debug_log, "previous is\n");
4706             sv_dump(current);
4707             PerlIO_printf(Perl_debug_log,
4708                           "move it from 0x%"UVxf" to 0x%"UVxf"\n",
4709                           (UV) SV_COW_NEXT_SV(current), (UV) sv);
4710         }
4711         SV_COW_NEXT_SV_SET(current, sv);
4712     }
4713 #endif
4714     SvREFCNT(sv) = refcnt;
4715     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
4716     SvREFCNT(nsv) = 0;
4717     del_SV(nsv);
4718 }
4719
4720 /*
4721 =for apidoc sv_clear
4722
4723 Clear an SV: call any destructors, free up any memory used by the body,
4724 and free the body itself. The SV's head is I<not> freed, although
4725 its type is set to all 1's so that it won't inadvertently be assumed
4726 to be live during global destruction etc.
4727 This function should only be called when REFCNT is zero. Most of the time
4728 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
4729 instead.
4730
4731 =cut
4732 */
4733
4734 void
4735 Perl_sv_clear(pTHX_ register SV *sv)
4736 {
4737     dVAR;
4738     const U32 type = SvTYPE(sv);
4739     const struct body_details *const sv_type_details
4740         = bodies_by_type + type;
4741
4742     assert(sv);
4743     assert(SvREFCNT(sv) == 0);
4744
4745     if (type <= SVt_IV)
4746         return;
4747
4748     if (SvOBJECT(sv)) {
4749         if (PL_defstash) {              /* Still have a symbol table? */
4750             dSP;
4751             HV* stash;
4752             do {        
4753                 CV* destructor;
4754                 stash = SvSTASH(sv);
4755                 destructor = StashHANDLER(stash,DESTROY);
4756                 if (destructor) {
4757                     SV* const tmpref = newRV(sv);
4758                     SvREADONLY_on(tmpref);   /* DESTROY() could be naughty */
4759                     ENTER;
4760                     PUSHSTACKi(PERLSI_DESTROY);
4761                     EXTEND(SP, 2);
4762                     PUSHMARK(SP);
4763                     PUSHs(tmpref);
4764                     PUTBACK;
4765                     call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
4766                 
4767                 
4768                     POPSTACK;
4769                     SPAGAIN;
4770                     LEAVE;
4771                     if(SvREFCNT(tmpref) < 2) {
4772                         /* tmpref is not kept alive! */
4773                         SvREFCNT(sv)--;
4774                         SvRV_set(tmpref, NULL);
4775                         SvROK_off(tmpref);
4776                     }
4777                     SvREFCNT_dec(tmpref);
4778                 }
4779             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4780
4781
4782             if (SvREFCNT(sv)) {
4783                 if (PL_in_clean_objs)
4784                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4785                           HvNAME_get(stash));
4786                 /* DESTROY gave object new lease on life */
4787                 return;
4788             }