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