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