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