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