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