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