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