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