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