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