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