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