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