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