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