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