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