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