Remove directory depth check from configure.com.
[perl.git] / sv.c
1 /*    sv.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall
5  *    and others
6  *
7  *    You may distribute under the terms of either the GNU General Public
8  *    License or the Artistic License, as specified in the README file.
9  *
10  */
11
12 /*
13  * 'I wonder what the Entish is for "yes" and "no",' he thought.
14  *                                                      --Pippin
15  *
16  *     [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
17  */
18
19 /*
20  *
21  *
22  * This file contains the code that creates, manipulates and destroys
23  * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
24  * structure of an SV, so their creation and destruction is handled
25  * here; higher-level functions are in av.c, hv.c, and so on. Opcode
26  * level functions (eg. substr, split, join) for each of the types are
27  * in the pp*.c files.
28  */
29
30 #include "EXTERN.h"
31 #define PERL_IN_SV_C
32 #include "perl.h"
33 #include "regcomp.h"
34 #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         break;
1655     default: NOOP;
1656     }
1657     (void)SvIOK_only(sv);                       /* validate number */
1658     SvIV_set(sv, i);
1659     SvTAINT(sv);
1660 }
1661
1662 /*
1663 =for apidoc sv_setiv_mg
1664
1665 Like C<sv_setiv>, but also handles 'set' magic.
1666
1667 =cut
1668 */
1669
1670 void
1671 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1672 {
1673     PERL_ARGS_ASSERT_SV_SETIV_MG;
1674
1675     sv_setiv(sv,i);
1676     SvSETMAGIC(sv);
1677 }
1678
1679 /*
1680 =for apidoc sv_setuv
1681
1682 Copies an unsigned integer into the given SV, upgrading first if necessary.
1683 Does not handle 'set' magic.  See also C<L</sv_setuv_mg>>.
1684
1685 =cut
1686 */
1687
1688 void
1689 Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1690 {
1691     PERL_ARGS_ASSERT_SV_SETUV;
1692
1693     /* With the if statement to ensure that integers are stored as IVs whenever
1694        possible:
1695        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1696
1697        without
1698        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1699
1700        If you wish to remove the following if statement, so that this routine
1701        (and its callers) always return UVs, please benchmark to see what the
1702        effect is. Modern CPUs may be different. Or may not :-)
1703     */
1704     if (u <= (UV)IV_MAX) {
1705        sv_setiv(sv, (IV)u);
1706        return;
1707     }
1708     sv_setiv(sv, 0);
1709     SvIsUV_on(sv);
1710     SvUV_set(sv, u);
1711 }
1712
1713 /*
1714 =for apidoc sv_setuv_mg
1715
1716 Like C<sv_setuv>, but also handles 'set' magic.
1717
1718 =cut
1719 */
1720
1721 void
1722 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1723 {
1724     PERL_ARGS_ASSERT_SV_SETUV_MG;
1725
1726     sv_setuv(sv,u);
1727     SvSETMAGIC(sv);
1728 }
1729
1730 /*
1731 =for apidoc sv_setnv
1732
1733 Copies a double into the given SV, upgrading first if necessary.
1734 Does not handle 'set' magic.  See also C<L</sv_setnv_mg>>.
1735
1736 =cut
1737 */
1738
1739 void
1740 Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1741 {
1742     PERL_ARGS_ASSERT_SV_SETNV;
1743
1744     SV_CHECK_THINKFIRST_COW_DROP(sv);
1745     switch (SvTYPE(sv)) {
1746     case SVt_NULL:
1747     case SVt_IV:
1748         sv_upgrade(sv, SVt_NV);
1749         break;
1750     case SVt_PV:
1751     case SVt_PVIV:
1752         sv_upgrade(sv, SVt_PVNV);
1753         break;
1754
1755     case SVt_PVGV:
1756         if (!isGV_with_GP(sv))
1757             break;
1758     case SVt_PVAV:
1759     case SVt_PVHV:
1760     case SVt_PVCV:
1761     case SVt_PVFM:
1762     case SVt_PVIO:
1763         /* diag_listed_as: Can't coerce %s to %s in %s */
1764         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1765                    OP_DESC(PL_op));
1766         break;
1767     default: NOOP;
1768     }
1769     SvNV_set(sv, num);
1770     (void)SvNOK_only(sv);                       /* validate number */
1771     SvTAINT(sv);
1772 }
1773
1774 /*
1775 =for apidoc sv_setnv_mg
1776
1777 Like C<sv_setnv>, but also handles 'set' magic.
1778
1779 =cut
1780 */
1781
1782 void
1783 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1784 {
1785     PERL_ARGS_ASSERT_SV_SETNV_MG;
1786
1787     sv_setnv(sv,num);
1788     SvSETMAGIC(sv);
1789 }
1790
1791 /* Return a cleaned-up, printable version of sv, for non-numeric, or
1792  * not incrementable warning display.
1793  * Originally part of S_not_a_number().
1794  * The return value may be != tmpbuf.
1795  */
1796
1797 STATIC const char *
1798 S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1799     const char *pv;
1800
1801      PERL_ARGS_ASSERT_SV_DISPLAY;
1802
1803      if (DO_UTF8(sv)) {
1804           SV *dsv = newSVpvs_flags("", SVs_TEMP);
1805           pv = sv_uni_display(dsv, sv, 32, UNI_DISPLAY_ISPRINT);
1806      } else {
1807           char *d = tmpbuf;
1808           const char * const limit = tmpbuf + tmpbuf_size - 8;
1809           /* each *s can expand to 4 chars + "...\0",
1810              i.e. need room for 8 chars */
1811         
1812           const char *s = SvPVX_const(sv);
1813           const char * const end = s + SvCUR(sv);
1814           for ( ; s < end && d < limit; s++ ) {
1815                int ch = *s & 0xFF;
1816                if (! isASCII(ch) && !isPRINT_LC(ch)) {
1817                     *d++ = 'M';
1818                     *d++ = '-';
1819
1820                     /* Map to ASCII "equivalent" of Latin1 */
1821                     ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1822                }
1823                if (ch == '\n') {
1824                     *d++ = '\\';
1825                     *d++ = 'n';
1826                }
1827                else if (ch == '\r') {
1828                     *d++ = '\\';
1829                     *d++ = 'r';
1830                }
1831                else if (ch == '\f') {
1832                     *d++ = '\\';
1833                     *d++ = 'f';
1834                }
1835                else if (ch == '\\') {
1836                     *d++ = '\\';
1837                     *d++ = '\\';
1838                }
1839                else if (ch == '\0') {
1840                     *d++ = '\\';
1841                     *d++ = '0';
1842                }
1843                else if (isPRINT_LC(ch))
1844                     *d++ = ch;
1845                else {
1846                     *d++ = '^';
1847                     *d++ = toCTRL(ch);
1848                }
1849           }
1850           if (s < end) {
1851                *d++ = '.';
1852                *d++ = '.';
1853                *d++ = '.';
1854           }
1855           *d = '\0';
1856           pv = tmpbuf;
1857     }
1858
1859     return pv;
1860 }
1861
1862 /* Print an "isn't numeric" warning, using a cleaned-up,
1863  * printable version of the offending string
1864  */
1865
1866 STATIC void
1867 S_not_a_number(pTHX_ SV *const sv)
1868 {
1869      char tmpbuf[64];
1870      const char *pv;
1871
1872      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1873
1874      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1875
1876     if (PL_op)
1877         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1878                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1879                     "Argument \"%s\" isn't numeric in %s", pv,
1880                     OP_DESC(PL_op));
1881     else
1882         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1883                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1884                     "Argument \"%s\" isn't numeric", pv);
1885 }
1886
1887 STATIC void
1888 S_not_incrementable(pTHX_ SV *const sv) {
1889      char tmpbuf[64];
1890      const char *pv;
1891
1892      PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1893
1894      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1895
1896      Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1897                  "Argument \"%s\" treated as 0 in increment (++)", pv);
1898 }
1899
1900 /*
1901 =for apidoc looks_like_number
1902
1903 Test if the content of an SV looks like a number (or is a number).
1904 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1905 non-numeric warning), even if your C<atof()> doesn't grok them.  Get-magic is
1906 ignored.
1907
1908 =cut
1909 */
1910
1911 I32
1912 Perl_looks_like_number(pTHX_ SV *const sv)
1913 {
1914     const char *sbegin;
1915     STRLEN len;
1916     int numtype;
1917
1918     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1919
1920     if (SvPOK(sv) || SvPOKp(sv)) {
1921         sbegin = SvPV_nomg_const(sv, len);
1922     }
1923     else
1924         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1925     numtype = grok_number(sbegin, len, NULL);
1926     return ((numtype & IS_NUMBER_TRAILING)) ? 0 : numtype;
1927 }
1928
1929 STATIC bool
1930 S_glob_2number(pTHX_ GV * const gv)
1931 {
1932     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1933
1934     /* We know that all GVs stringify to something that is not-a-number,
1935         so no need to test that.  */
1936     if (ckWARN(WARN_NUMERIC))
1937     {
1938         SV *const buffer = sv_newmortal();
1939         gv_efullname3(buffer, gv, "*");
1940         not_a_number(buffer);
1941     }
1942     /* We just want something true to return, so that S_sv_2iuv_common
1943         can tail call us and return true.  */
1944     return TRUE;
1945 }
1946
1947 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1948    until proven guilty, assume that things are not that bad... */
1949
1950 /*
1951    NV_PRESERVES_UV:
1952
1953    As 64 bit platforms often have an NV that doesn't preserve all bits of
1954    an IV (an assumption perl has been based on to date) it becomes necessary
1955    to remove the assumption that the NV always carries enough precision to
1956    recreate the IV whenever needed, and that the NV is the canonical form.
1957    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1958    precision as a side effect of conversion (which would lead to insanity
1959    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1960    1) to distinguish between IV/UV/NV slots that have a valid conversion cached
1961       where precision was lost, and IV/UV/NV slots that have a valid conversion
1962       which has lost no precision
1963    2) to ensure that if a numeric conversion to one form is requested that
1964       would lose precision, the precise conversion (or differently
1965       imprecise conversion) is also performed and cached, to prevent
1966       requests for different numeric formats on the same SV causing
1967       lossy conversion chains. (lossless conversion chains are perfectly
1968       acceptable (still))
1969
1970
1971    flags are used:
1972    SvIOKp is true if the IV slot contains a valid value
1973    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1974    SvNOKp is true if the NV slot contains a valid value
1975    SvNOK  is true only if the NV value is accurate
1976
1977    so
1978    while converting from PV to NV, check to see if converting that NV to an
1979    IV(or UV) would lose accuracy over a direct conversion from PV to
1980    IV(or UV). If it would, cache both conversions, return NV, but mark
1981    SV as IOK NOKp (ie not NOK).
1982
1983    While converting from PV to IV, check to see if converting that IV to an
1984    NV would lose accuracy over a direct conversion from PV to NV. If it
1985    would, cache both conversions, flag similarly.
1986
1987    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1988    correctly because if IV & NV were set NV *always* overruled.
1989    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1990    changes - now IV and NV together means that the two are interchangeable:
1991    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1992
1993    The benefit of this is that operations such as pp_add know that if
1994    SvIOK is true for both left and right operands, then integer addition
1995    can be used instead of floating point (for cases where the result won't
1996    overflow). Before, floating point was always used, which could lead to
1997    loss of precision compared with integer addition.
1998
1999    * making IV and NV equal status should make maths accurate on 64 bit
2000      platforms
2001    * may speed up maths somewhat if pp_add and friends start to use
2002      integers when possible instead of fp. (Hopefully the overhead in
2003      looking for SvIOK and checking for overflow will not outweigh the
2004      fp to integer speedup)
2005    * will slow down integer operations (callers of SvIV) on "inaccurate"
2006      values, as the change from SvIOK to SvIOKp will cause a call into
2007      sv_2iv each time rather than a macro access direct to the IV slot
2008    * should speed up number->string conversion on integers as IV is
2009      favoured when IV and NV are equally accurate
2010
2011    ####################################################################
2012    You had better be using SvIOK_notUV if you want an IV for arithmetic:
2013    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2014    On the other hand, SvUOK is true iff UV.
2015    ####################################################################
2016
2017    Your mileage will vary depending your CPU's relative fp to integer
2018    performance ratio.
2019 */
2020
2021 #ifndef NV_PRESERVES_UV
2022 #  define IS_NUMBER_UNDERFLOW_IV 1
2023 #  define IS_NUMBER_UNDERFLOW_UV 2
2024 #  define IS_NUMBER_IV_AND_UV    2
2025 #  define IS_NUMBER_OVERFLOW_IV  4
2026 #  define IS_NUMBER_OVERFLOW_UV  5
2027
2028 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2029
2030 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
2031 STATIC int
2032 S_sv_2iuv_non_preserve(pTHX_ SV *const sv
2033 #  ifdef DEBUGGING
2034                        , I32 numtype
2035 #  endif
2036                        )
2037 {
2038     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
2039     PERL_UNUSED_CONTEXT;
2040
2041     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));
2042     if (SvNVX(sv) < (NV)IV_MIN) {
2043         (void)SvIOKp_on(sv);
2044         (void)SvNOK_on(sv);
2045         SvIV_set(sv, IV_MIN);
2046         return IS_NUMBER_UNDERFLOW_IV;
2047     }
2048     if (SvNVX(sv) > (NV)UV_MAX) {
2049         (void)SvIOKp_on(sv);
2050         (void)SvNOK_on(sv);
2051         SvIsUV_on(sv);
2052         SvUV_set(sv, UV_MAX);
2053         return IS_NUMBER_OVERFLOW_UV;
2054     }
2055     (void)SvIOKp_on(sv);
2056     (void)SvNOK_on(sv);
2057     /* Can't use strtol etc to convert this string.  (See truth table in
2058        sv_2iv  */
2059     if (SvNVX(sv) <= (UV)IV_MAX) {
2060         SvIV_set(sv, I_V(SvNVX(sv)));
2061         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2062             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2063         } else {
2064             /* Integer is imprecise. NOK, IOKp */
2065         }
2066         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2067     }
2068     SvIsUV_on(sv);
2069     SvUV_set(sv, U_V(SvNVX(sv)));
2070     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2071         if (SvUVX(sv) == UV_MAX) {
2072             /* As we know that NVs don't preserve UVs, UV_MAX cannot
2073                possibly be preserved by NV. Hence, it must be overflow.
2074                NOK, IOKp */
2075             return IS_NUMBER_OVERFLOW_UV;
2076         }
2077         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2078     } else {
2079         /* Integer is imprecise. NOK, IOKp */
2080     }
2081     return IS_NUMBER_OVERFLOW_IV;
2082 }
2083 #endif /* !NV_PRESERVES_UV*/
2084
2085 /* If numtype is infnan, set the NV of the sv accordingly.
2086  * If numtype is anything else, try setting the NV using Atof(PV). */
2087 #ifdef USING_MSVC6
2088 #  pragma warning(push)
2089 #  pragma warning(disable:4756;disable:4056)
2090 #endif
2091 static void
2092 S_sv_setnv(pTHX_ SV* sv, int numtype)
2093 {
2094     bool pok = cBOOL(SvPOK(sv));
2095     bool nok = FALSE;
2096 #ifdef NV_INF
2097     if ((numtype & IS_NUMBER_INFINITY)) {
2098         SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
2099         nok = TRUE;
2100     } else
2101 #endif
2102 #ifdef NV_NAN
2103     if ((numtype & IS_NUMBER_NAN)) {
2104         SvNV_set(sv, NV_NAN);
2105         nok = TRUE;
2106     } else
2107 #endif
2108     if (pok) {
2109         SvNV_set(sv, Atof(SvPVX_const(sv)));
2110         /* Purposefully no true nok here, since we don't want to blow
2111          * away the possible IOK/UV of an existing sv. */
2112     }
2113     if (nok) {
2114         SvNOK_only(sv); /* No IV or UV please, this is pure infnan. */
2115         if (pok)
2116             SvPOK_on(sv); /* PV is okay, though. */
2117     }
2118 }
2119 #ifdef USING_MSVC6
2120 #  pragma warning(pop)
2121 #endif
2122
2123 STATIC bool
2124 S_sv_2iuv_common(pTHX_ SV *const sv)
2125 {
2126     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2127
2128     if (SvNOKp(sv)) {
2129         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2130          * without also getting a cached IV/UV from it at the same time
2131          * (ie PV->NV conversion should detect loss of accuracy and cache
2132          * IV or UV at same time to avoid this. */
2133         /* IV-over-UV optimisation - choose to cache IV if possible */
2134
2135         if (SvTYPE(sv) == SVt_NV)
2136             sv_upgrade(sv, SVt_PVNV);
2137
2138         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2139         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2140            certainly cast into the IV range at IV_MAX, whereas the correct
2141            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2142            cases go to UV */
2143 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2144         if (Perl_isnan(SvNVX(sv))) {
2145             SvUV_set(sv, 0);
2146             SvIsUV_on(sv);
2147             return FALSE;
2148         }
2149 #endif
2150         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2151             SvIV_set(sv, I_V(SvNVX(sv)));
2152             if (SvNVX(sv) == (NV) SvIVX(sv)
2153 #ifndef NV_PRESERVES_UV
2154                 && SvIVX(sv) != IV_MIN /* avoid negating IV_MIN below */
2155                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2156                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2157                 /* Don't flag it as "accurately an integer" if the number
2158                    came from a (by definition imprecise) NV operation, and
2159                    we're outside the range of NV integer precision */
2160 #endif
2161                 ) {
2162                 if (SvNOK(sv))
2163                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2164                 else {
2165                     /* scalar has trailing garbage, eg "42a" */
2166                 }
2167                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2168                                       "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (precise)\n",
2169                                       PTR2UV(sv),
2170                                       SvNVX(sv),
2171                                       SvIVX(sv)));
2172
2173             } else {
2174                 /* IV not precise.  No need to convert from PV, as NV
2175                    conversion would already have cached IV if it detected
2176                    that PV->IV would be better than PV->NV->IV
2177                    flags already correct - don't set public IOK.  */
2178                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2179                                       "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (imprecise)\n",
2180                                       PTR2UV(sv),
2181                                       SvNVX(sv),
2182                                       SvIVX(sv)));
2183             }
2184             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2185                but the cast (NV)IV_MIN rounds to a the value less (more
2186                negative) than IV_MIN which happens to be equal to SvNVX ??
2187                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2188                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2189                (NV)UVX == NVX are both true, but the values differ. :-(
2190                Hopefully for 2s complement IV_MIN is something like
2191                0x8000000000000000 which will be exact. NWC */
2192         }
2193         else {
2194             SvUV_set(sv, U_V(SvNVX(sv)));
2195             if (
2196                 (SvNVX(sv) == (NV) SvUVX(sv))
2197 #ifndef  NV_PRESERVES_UV
2198                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2199                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2200                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2201                 /* Don't flag it as "accurately an integer" if the number
2202                    came from a (by definition imprecise) NV operation, and
2203                    we're outside the range of NV integer precision */
2204 #endif
2205                 && SvNOK(sv)
2206                 )
2207                 SvIOK_on(sv);
2208             SvIsUV_on(sv);
2209             DEBUG_c(PerlIO_printf(Perl_debug_log,
2210                                   "0x%" UVxf " 2iv(%" UVuf " => %" IVdf ") (as unsigned)\n",
2211                                   PTR2UV(sv),
2212                                   SvUVX(sv),
2213                                   SvUVX(sv)));
2214         }
2215     }
2216     else if (SvPOKp(sv)) {
2217         UV value;
2218         int numtype;
2219         const char *s = SvPVX_const(sv);
2220         const STRLEN cur = SvCUR(sv);
2221
2222         /* short-cut for a single digit string like "1" */
2223
2224         if (cur == 1) {
2225             char c = *s;
2226             if (isDIGIT(c)) {
2227                 if (SvTYPE(sv) < SVt_PVIV)
2228                     sv_upgrade(sv, SVt_PVIV);
2229                 (void)SvIOK_on(sv);
2230                 SvIV_set(sv, (IV)(c - '0'));
2231                 return FALSE;
2232             }
2233         }
2234
2235         numtype = grok_number(s, cur, &value);
2236         /* We want to avoid a possible problem when we cache an IV/ a UV which
2237            may be later translated to an NV, and the resulting NV is not
2238            the same as the direct translation of the initial string
2239            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2240            be careful to ensure that the value with the .456 is around if the
2241            NV value is requested in the future).
2242         
2243            This means that if we cache such an IV/a UV, we need to cache the
2244            NV as well.  Moreover, we trade speed for space, and do not
2245            cache the NV if we are sure it's not needed.
2246          */
2247
2248         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2249         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2250              == IS_NUMBER_IN_UV) {
2251             /* It's definitely an integer, only upgrade to PVIV */
2252             if (SvTYPE(sv) < SVt_PVIV)
2253                 sv_upgrade(sv, SVt_PVIV);
2254             (void)SvIOK_on(sv);
2255         } else if (SvTYPE(sv) < SVt_PVNV)
2256             sv_upgrade(sv, SVt_PVNV);
2257
2258         if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
2259             if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING)))
2260                 not_a_number(sv);
2261             S_sv_setnv(aTHX_ sv, numtype);
2262             return FALSE;
2263         }
2264
2265         /* If NVs preserve UVs then we only use the UV value if we know that
2266            we aren't going to call atof() below. If NVs don't preserve UVs
2267            then the value returned may have more precision than atof() will
2268            return, even though value isn't perfectly accurate.  */
2269         if ((numtype & (IS_NUMBER_IN_UV
2270 #ifdef NV_PRESERVES_UV
2271                         | IS_NUMBER_NOT_INT
2272 #endif
2273             )) == IS_NUMBER_IN_UV) {
2274             /* This won't turn off the public IOK flag if it was set above  */
2275             (void)SvIOKp_on(sv);
2276
2277             if (!(numtype & IS_NUMBER_NEG)) {
2278                 /* positive */;
2279                 if (value <= (UV)IV_MAX) {
2280                     SvIV_set(sv, (IV)value);
2281                 } else {
2282                     /* it didn't overflow, and it was positive. */
2283                     SvUV_set(sv, value);
2284                     SvIsUV_on(sv);
2285                 }
2286             } else {
2287                 /* 2s complement assumption  */
2288                 if (value <= (UV)IV_MIN) {
2289                     SvIV_set(sv, value == (UV)IV_MIN
2290                                     ? IV_MIN : -(IV)value);
2291                 } else {
2292                     /* Too negative for an IV.  This is a double upgrade, but
2293                        I'm assuming it will be rare.  */
2294                     if (SvTYPE(sv) < SVt_PVNV)
2295                         sv_upgrade(sv, SVt_PVNV);
2296                     SvNOK_on(sv);
2297                     SvIOK_off(sv);
2298                     SvIOKp_on(sv);
2299                     SvNV_set(sv, -(NV)value);
2300                     SvIV_set(sv, IV_MIN);
2301                 }
2302             }
2303         }
2304         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2305            will be in the previous block to set the IV slot, and the next
2306            block to set the NV slot.  So no else here.  */
2307         
2308         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2309             != IS_NUMBER_IN_UV) {
2310             /* It wasn't an (integer that doesn't overflow the UV). */
2311             S_sv_setnv(aTHX_ sv, numtype);
2312
2313             if (! numtype && ckWARN(WARN_NUMERIC))
2314                 not_a_number(sv);
2315
2316             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" NVgf ")\n",
2317                                   PTR2UV(sv), SvNVX(sv)));
2318
2319 #ifdef NV_PRESERVES_UV
2320             (void)SvIOKp_on(sv);
2321             (void)SvNOK_on(sv);
2322 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2323             if (Perl_isnan(SvNVX(sv))) {
2324                 SvUV_set(sv, 0);
2325                 SvIsUV_on(sv);
2326                 return FALSE;
2327             }
2328 #endif
2329             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2330                 SvIV_set(sv, I_V(SvNVX(sv)));
2331                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2332                     SvIOK_on(sv);
2333                 } else {
2334                     NOOP;  /* Integer is imprecise. NOK, IOKp */
2335                 }
2336                 /* UV will not work better than IV */
2337             } else {
2338                 if (SvNVX(sv) > (NV)UV_MAX) {
2339                     SvIsUV_on(sv);
2340                     /* Integer is inaccurate. NOK, IOKp, is UV */
2341                     SvUV_set(sv, UV_MAX);
2342                 } else {
2343                     SvUV_set(sv, U_V(SvNVX(sv)));
2344                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2345                        NV preservse UV so can do correct comparison.  */
2346                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2347                         SvIOK_on(sv);
2348                     } else {
2349                         NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
2350                     }
2351                 }
2352                 SvIsUV_on(sv);
2353             }
2354 #else /* NV_PRESERVES_UV */
2355             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2356                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2357                 /* The IV/UV slot will have been set from value returned by
2358                    grok_number above.  The NV slot has just been set using
2359                    Atof.  */
2360                 SvNOK_on(sv);
2361                 assert (SvIOKp(sv));
2362             } else {
2363                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2364                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2365                     /* Small enough to preserve all bits. */
2366                     (void)SvIOKp_on(sv);
2367                     SvNOK_on(sv);
2368                     SvIV_set(sv, I_V(SvNVX(sv)));
2369                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2370                         SvIOK_on(sv);
2371                     /* Assumption: first non-preserved integer is < IV_MAX,
2372                        this NV is in the preserved range, therefore: */
2373                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2374                           < (UV)IV_MAX)) {
2375                         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);
2376                     }
2377                 } else {
2378                     /* IN_UV NOT_INT
2379                          0      0       already failed to read UV.
2380                          0      1       already failed to read UV.
2381                          1      0       you won't get here in this case. IV/UV
2382                                         slot set, public IOK, Atof() unneeded.
2383                          1      1       already read UV.
2384                        so there's no point in sv_2iuv_non_preserve() attempting
2385                        to use atol, strtol, strtoul etc.  */
2386 #  ifdef DEBUGGING
2387                     sv_2iuv_non_preserve (sv, numtype);
2388 #  else
2389                     sv_2iuv_non_preserve (sv);
2390 #  endif
2391                 }
2392             }
2393 #endif /* NV_PRESERVES_UV */
2394         /* It might be more code efficient to go through the entire logic above
2395            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2396            gets complex and potentially buggy, so more programmer efficient
2397            to do it this way, by turning off the public flags:  */
2398         if (!numtype)
2399             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2400         }
2401     }
2402     else  {
2403         if (isGV_with_GP(sv))
2404             return glob_2number(MUTABLE_GV(sv));
2405
2406         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2407                 report_uninit(sv);
2408         if (SvTYPE(sv) < SVt_IV)
2409             /* Typically the caller expects that sv_any is not NULL now.  */
2410             sv_upgrade(sv, SVt_IV);
2411         /* Return 0 from the caller.  */
2412         return TRUE;
2413     }
2414     return FALSE;
2415 }
2416
2417 /*
2418 =for apidoc sv_2iv_flags
2419
2420 Return the integer value of an SV, doing any necessary string
2421 conversion.  If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2422 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2423
2424 =cut
2425 */
2426
2427 IV
2428 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2429 {
2430     PERL_ARGS_ASSERT_SV_2IV_FLAGS;
2431
2432     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2433          && SvTYPE(sv) != SVt_PVFM);
2434
2435     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2436         mg_get(sv);
2437
2438     if (SvROK(sv)) {
2439         if (SvAMAGIC(sv)) {
2440             SV * tmpstr;
2441             if (flags & SV_SKIP_OVERLOAD)
2442                 return 0;
2443             tmpstr = AMG_CALLunary(sv, numer_amg);
2444             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2445                 return SvIV(tmpstr);
2446             }
2447         }
2448         return PTR2IV(SvRV(sv));
2449     }
2450
2451     if (SvVALID(sv) || isREGEXP(sv)) {
2452         /* FBMs use the space for SvIVX and SvNVX for other purposes, so
2453            must not let them cache IVs.
2454            In practice they are extremely unlikely to actually get anywhere
2455            accessible by user Perl code - the only way that I'm aware of is when
2456            a constant subroutine which is used as the second argument to index.
2457
2458            Regexps have no SvIVX and SvNVX fields.
2459         */
2460         assert(isREGEXP(sv) || SvPOKp(sv));
2461         {
2462             UV value;
2463             const char * const ptr =
2464                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2465             const int numtype
2466                 = grok_number(ptr, SvCUR(sv), &value);
2467
2468             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2469                 == IS_NUMBER_IN_UV) {
2470                 /* It's definitely an integer */
2471                 if (numtype & IS_NUMBER_NEG) {
2472                     if (value < (UV)IV_MIN)
2473                         return -(IV)value;
2474                 } else {
2475                     if (value < (UV)IV_MAX)
2476                         return (IV)value;
2477                 }
2478             }
2479
2480             /* Quite wrong but no good choices. */
2481             if ((numtype & IS_NUMBER_INFINITY)) {
2482                 return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX;
2483             } else if ((numtype & IS_NUMBER_NAN)) {
2484                 return 0; /* So wrong. */
2485             }
2486
2487             if (!numtype) {
2488                 if (ckWARN(WARN_NUMERIC))
2489                     not_a_number(sv);
2490             }
2491             return I_V(Atof(ptr));
2492         }
2493     }
2494
2495     if (SvTHINKFIRST(sv)) {
2496         if (SvREADONLY(sv) && !SvOK(sv)) {
2497             if (ckWARN(WARN_UNINITIALIZED))
2498                 report_uninit(sv);
2499             return 0;
2500         }
2501     }
2502
2503     if (!SvIOKp(sv)) {
2504         if (S_sv_2iuv_common(aTHX_ sv))
2505             return 0;
2506     }
2507
2508     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" IVdf ")\n",
2509         PTR2UV(sv),SvIVX(sv)));
2510     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2511 }
2512
2513 /*
2514 =for apidoc sv_2uv_flags
2515
2516 Return the unsigned integer value of an SV, doing any necessary string
2517 conversion.  If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2518 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2519
2520 =cut
2521 */
2522
2523 UV
2524 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2525 {
2526     PERL_ARGS_ASSERT_SV_2UV_FLAGS;
2527
2528     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2529         mg_get(sv);
2530
2531     if (SvROK(sv)) {
2532         if (SvAMAGIC(sv)) {
2533             SV *tmpstr;
2534             if (flags & SV_SKIP_OVERLOAD)
2535                 return 0;
2536             tmpstr = AMG_CALLunary(sv, numer_amg);
2537             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2538                 return SvUV(tmpstr);
2539             }
2540         }
2541         return PTR2UV(SvRV(sv));
2542     }
2543
2544     if (SvVALID(sv) || isREGEXP(sv)) {
2545         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2546            the same flag bit as SVf_IVisUV, so must not let them cache IVs.  
2547            Regexps have no SvIVX and SvNVX fields. */
2548         assert(isREGEXP(sv) || SvPOKp(sv));
2549         {
2550             UV value;
2551             const char * const ptr =
2552                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2553             const int numtype
2554                 = grok_number(ptr, SvCUR(sv), &value);
2555
2556             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2557                 == IS_NUMBER_IN_UV) {
2558                 /* It's definitely an integer */
2559                 if (!(numtype & IS_NUMBER_NEG))
2560                     return value;
2561             }
2562
2563             /* Quite wrong but no good choices. */
2564             if ((numtype & IS_NUMBER_INFINITY)) {
2565                 return UV_MAX; /* So wrong. */
2566             } else if ((numtype & IS_NUMBER_NAN)) {
2567                 return 0; /* So wrong. */
2568             }
2569
2570             if (!numtype) {
2571                 if (ckWARN(WARN_NUMERIC))
2572                     not_a_number(sv);
2573             }
2574             return U_V(Atof(ptr));
2575         }
2576     }
2577
2578     if (SvTHINKFIRST(sv)) {
2579         if (SvREADONLY(sv) && !SvOK(sv)) {
2580             if (ckWARN(WARN_UNINITIALIZED))
2581                 report_uninit(sv);
2582             return 0;
2583         }
2584     }
2585
2586     if (!SvIOKp(sv)) {
2587         if (S_sv_2iuv_common(aTHX_ sv))
2588             return 0;
2589     }
2590
2591     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2uv(%" UVuf ")\n",
2592                           PTR2UV(sv),SvUVX(sv)));
2593     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2594 }
2595
2596 /*
2597 =for apidoc sv_2nv_flags
2598
2599 Return the num value of an SV, doing any necessary string or integer
2600 conversion.  If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2601 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2602
2603 =cut
2604 */
2605
2606 NV
2607 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2608 {
2609     PERL_ARGS_ASSERT_SV_2NV_FLAGS;
2610
2611     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2612          && SvTYPE(sv) != SVt_PVFM);
2613     if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
2614         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2615            the same flag bit as SVf_IVisUV, so must not let them cache NVs.
2616            Regexps have no SvIVX and SvNVX fields.  */
2617         const char *ptr;
2618         if (flags & SV_GMAGIC)
2619             mg_get(sv);
2620         if (SvNOKp(sv))
2621             return SvNVX(sv);
2622         if (SvPOKp(sv) && !SvIOKp(sv)) {
2623             ptr = SvPVX_const(sv);
2624           grokpv:
2625             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2626                 !grok_number(ptr, SvCUR(sv), NULL))
2627                 not_a_number(sv);
2628             return Atof(ptr);
2629         }
2630         if (SvIOKp(sv)) {
2631             if (SvIsUV(sv))
2632                 return (NV)SvUVX(sv);
2633             else
2634                 return (NV)SvIVX(sv);
2635         }
2636         if (SvROK(sv)) {
2637             goto return_rok;
2638         }
2639         if (isREGEXP(sv)) {
2640             ptr = RX_WRAPPED((REGEXP *)sv);
2641             goto grokpv;
2642         }
2643         assert(SvTYPE(sv) >= SVt_PVMG);
2644         /* This falls through to the report_uninit near the end of the
2645            function. */
2646     } else if (SvTHINKFIRST(sv)) {
2647         if (SvROK(sv)) {
2648         return_rok:
2649             if (SvAMAGIC(sv)) {
2650                 SV *tmpstr;
2651                 if (flags & SV_SKIP_OVERLOAD)
2652                     return 0;
2653                 tmpstr = AMG_CALLunary(sv, numer_amg);
2654                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2655                     return SvNV(tmpstr);
2656                 }
2657             }
2658             return PTR2NV(SvRV(sv));
2659         }
2660         if (SvREADONLY(sv) && !SvOK(sv)) {
2661             if (ckWARN(WARN_UNINITIALIZED))
2662                 report_uninit(sv);
2663             return 0.0;
2664         }
2665     }
2666     if (SvTYPE(sv) < SVt_NV) {
2667         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2668         sv_upgrade(sv, SVt_NV);
2669         DEBUG_c({
2670             STORE_NUMERIC_LOCAL_SET_STANDARD();
2671             PerlIO_printf(Perl_debug_log,
2672                           "0x%" UVxf " num(%" NVgf ")\n",
2673                           PTR2UV(sv), SvNVX(sv));
2674             RESTORE_NUMERIC_LOCAL();
2675         });
2676     }
2677     else if (SvTYPE(sv) < SVt_PVNV)
2678         sv_upgrade(sv, SVt_PVNV);
2679     if (SvNOKp(sv)) {
2680         return SvNVX(sv);
2681     }
2682     if (SvIOKp(sv)) {
2683         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2684 #ifdef NV_PRESERVES_UV
2685         if (SvIOK(sv))
2686             SvNOK_on(sv);
2687         else
2688             SvNOKp_on(sv);
2689 #else
2690         /* Only set the public NV OK flag if this NV preserves the IV  */
2691         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2692         if (SvIOK(sv) &&
2693             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2694                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2695             SvNOK_on(sv);
2696         else
2697             SvNOKp_on(sv);
2698 #endif
2699     }
2700     else if (SvPOKp(sv)) {
2701         UV value;
2702         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2703         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2704             not_a_number(sv);
2705 #ifdef NV_PRESERVES_UV
2706         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2707             == IS_NUMBER_IN_UV) {
2708             /* It's definitely an integer */
2709             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2710         } else {
2711             S_sv_setnv(aTHX_ sv, numtype);
2712         }
2713         if (numtype)
2714             SvNOK_on(sv);
2715         else
2716             SvNOKp_on(sv);
2717 #else
2718         SvNV_set(sv, Atof(SvPVX_const(sv)));
2719         /* Only set the public NV OK flag if this NV preserves the value in
2720            the PV at least as well as an IV/UV would.
2721            Not sure how to do this 100% reliably. */
2722         /* if that shift count is out of range then Configure's test is
2723            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2724            UV_BITS */
2725         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2726             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2727             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2728         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2729             /* Can't use strtol etc to convert this string, so don't try.
2730                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2731             SvNOK_on(sv);
2732         } else {
2733             /* value has been set.  It may not be precise.  */
2734             if ((numtype & IS_NUMBER_NEG) && (value >= (UV)IV_MIN)) {
2735                 /* 2s complement assumption for (UV)IV_MIN  */
2736                 SvNOK_on(sv); /* Integer is too negative.  */
2737             } else {
2738                 SvNOKp_on(sv);
2739                 SvIOKp_on(sv);
2740
2741                 if (numtype & IS_NUMBER_NEG) {
2742                     /* -IV_MIN is undefined, but we should never reach
2743                      * this point with both IS_NUMBER_NEG and value ==
2744                      * (UV)IV_MIN */
2745                     assert(value != (UV)IV_MIN);
2746                     SvIV_set(sv, -(IV)value);
2747                 } else if (value <= (UV)IV_MAX) {
2748                     SvIV_set(sv, (IV)value);
2749                 } else {
2750                     SvUV_set(sv, value);
2751                     SvIsUV_on(sv);
2752                 }
2753
2754                 if (numtype & IS_NUMBER_NOT_INT) {
2755                     /* I believe that even if the original PV had decimals,
2756                        they are lost beyond the limit of the FP precision.
2757                        However, neither is canonical, so both only get p
2758                        flags.  NWC, 2000/11/25 */
2759                     /* Both already have p flags, so do nothing */
2760                 } else {
2761                     const NV nv = SvNVX(sv);
2762                     /* XXX should this spot have NAN_COMPARE_BROKEN, too? */
2763                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2764                         if (SvIVX(sv) == I_V(nv)) {
2765                             SvNOK_on(sv);
2766                         } else {
2767                             /* It had no "." so it must be integer.  */
2768                         }
2769                         SvIOK_on(sv);
2770                     } else {
2771                         /* between IV_MAX and NV(UV_MAX).
2772                            Could be slightly > UV_MAX */
2773
2774                         if (numtype & IS_NUMBER_NOT_INT) {
2775                             /* UV and NV both imprecise.  */
2776                         } else {
2777                             const UV nv_as_uv = U_V(nv);
2778
2779                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2780                                 SvNOK_on(sv);
2781                             }
2782                             SvIOK_on(sv);
2783                         }
2784                     }
2785                 }
2786             }
2787         }
2788         /* It might be more code efficient to go through the entire logic above
2789            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2790            gets complex and potentially buggy, so more programmer efficient
2791            to do it this way, by turning off the public flags:  */
2792         if (!numtype)
2793             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2794 #endif /* NV_PRESERVES_UV */
2795     }
2796     else  {
2797         if (isGV_with_GP(sv)) {
2798             glob_2number(MUTABLE_GV(sv));
2799             return 0.0;
2800         }
2801
2802         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2803             report_uninit(sv);
2804         assert (SvTYPE(sv) >= SVt_NV);
2805         /* Typically the caller expects that sv_any is not NULL now.  */
2806         /* XXX Ilya implies that this is a bug in callers that assume this
2807            and ideally should be fixed.  */
2808         return 0.0;
2809     }
2810     DEBUG_c({
2811         STORE_NUMERIC_LOCAL_SET_STANDARD();
2812         PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2nv(%" NVgf ")\n",
2813                       PTR2UV(sv), SvNVX(sv));
2814         RESTORE_NUMERIC_LOCAL();
2815     });
2816     return SvNVX(sv);
2817 }
2818
2819 /*
2820 =for apidoc sv_2num
2821
2822 Return an SV with the numeric value of the source SV, doing any necessary
2823 reference or overload conversion.  The caller is expected to have handled
2824 get-magic already.
2825
2826 =cut
2827 */
2828
2829 SV *
2830 Perl_sv_2num(pTHX_ SV *const sv)
2831 {
2832     PERL_ARGS_ASSERT_SV_2NUM;
2833
2834     if (!SvROK(sv))
2835         return sv;
2836     if (SvAMAGIC(sv)) {
2837         SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2838         TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2839         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2840             return sv_2num(tmpsv);
2841     }
2842     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2843 }
2844
2845 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2846  * UV as a string towards the end of buf, and return pointers to start and
2847  * end of it.
2848  *
2849  * We assume that buf is at least TYPE_CHARS(UV) long.
2850  */
2851
2852 static char *
2853 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2854 {
2855     char *ptr = buf + TYPE_CHARS(UV);
2856     char * const ebuf = ptr;
2857     int sign;
2858
2859     PERL_ARGS_ASSERT_UIV_2BUF;
2860
2861     if (is_uv)
2862         sign = 0;
2863     else if (iv >= 0) {
2864         uv = iv;
2865         sign = 0;
2866     } else {
2867         uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv);
2868         sign = 1;
2869     }
2870     do {
2871         *--ptr = '0' + (char)(uv % 10);
2872     } while (uv /= 10);
2873     if (sign)
2874         *--ptr = '-';
2875     *peob = ebuf;
2876     return ptr;
2877 }
2878
2879 /* Helper for sv_2pv_flags and sv_vcatpvfn_flags.  If the NV is an
2880  * infinity or a not-a-number, writes the appropriate strings to the
2881  * buffer, including a zero byte.  On success returns the written length,
2882  * excluding the zero byte, on failure (not an infinity, not a nan)
2883  * returns zero, assert-fails on maxlen being too short.
2884  *
2885  * XXX for "Inf", "-Inf", and "NaN", we could have three read-only
2886  * shared string constants we point to, instead of generating a new
2887  * string for each instance. */
2888 STATIC size_t
2889 S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char plus) {
2890     char* s = buffer;
2891     assert(maxlen >= 4);
2892     if (Perl_isinf(nv)) {
2893         if (nv < 0) {
2894             if (maxlen < 5) /* "-Inf\0"  */
2895                 return 0;
2896             *s++ = '-';
2897         } else if (plus) {
2898             *s++ = '+';
2899         }
2900         *s++ = 'I';
2901         *s++ = 'n';
2902         *s++ = 'f';
2903     }
2904     else if (Perl_isnan(nv)) {
2905         *s++ = 'N';
2906         *s++ = 'a';
2907         *s++ = 'N';
2908         /* XXX optionally output the payload mantissa bits as
2909          * "(unsigned)" (to match the nan("...") C99 function,
2910          * or maybe as "(0xhhh...)"  would make more sense...
2911          * provide a format string so that the user can decide?
2912          * NOTE: would affect the maxlen and assert() logic.*/
2913     }
2914     else {
2915       return 0;
2916     }
2917     assert((s == buffer + 3) || (s == buffer + 4));
2918     *s++ = 0;
2919     return s - buffer - 1; /* -1: excluding the zero byte */
2920 }
2921
2922 /*
2923 =for apidoc sv_2pv_flags
2924
2925 Returns a pointer to the string value of an SV, and sets C<*lp> to its length.
2926 If flags has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.  Coerces C<sv> to a
2927 string if necessary.  Normally invoked via the C<SvPV_flags> macro.
2928 C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
2929
2930 =cut
2931 */
2932
2933 char *
2934 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
2935 {
2936     char *s;
2937
2938     PERL_ARGS_ASSERT_SV_2PV_FLAGS;
2939
2940     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2941          && SvTYPE(sv) != SVt_PVFM);
2942     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2943         mg_get(sv);
2944     if (SvROK(sv)) {
2945         if (SvAMAGIC(sv)) {
2946             SV *tmpstr;
2947             if (flags & SV_SKIP_OVERLOAD)
2948                 return NULL;
2949             tmpstr = AMG_CALLunary(sv, string_amg);
2950             TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2951             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2952                 /* Unwrap this:  */
2953                 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2954                  */
2955
2956                 char *pv;
2957                 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2958                     if (flags & SV_CONST_RETURN) {
2959                         pv = (char *) SvPVX_const(tmpstr);
2960                     } else {
2961                         pv = (flags & SV_MUTABLE_RETURN)
2962                             ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2963                     }
2964                     if (lp)
2965                         *lp = SvCUR(tmpstr);
2966                 } else {
2967                     pv = sv_2pv_flags(tmpstr, lp, flags);
2968                 }
2969                 if (SvUTF8(tmpstr))
2970                     SvUTF8_on(sv);
2971                 else
2972                     SvUTF8_off(sv);
2973                 return pv;
2974             }
2975         }
2976         {
2977             STRLEN len;
2978             char *retval;
2979             char *buffer;
2980             SV *const referent = SvRV(sv);
2981
2982             if (!referent) {
2983                 len = 7;
2984                 retval = buffer = savepvn("NULLREF", len);
2985             } else if (SvTYPE(referent) == SVt_REGEXP &&
2986                        (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
2987                         amagic_is_enabled(string_amg))) {
2988                 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2989
2990                 assert(re);
2991                         
2992                 /* If the regex is UTF-8 we want the containing scalar to
2993                    have an UTF-8 flag too */
2994                 if (RX_UTF8(re))
2995                     SvUTF8_on(sv);
2996                 else
2997                     SvUTF8_off(sv);     
2998
2999                 if (lp)
3000                     *lp = RX_WRAPLEN(re);
3001  
3002                 return RX_WRAPPED(re);
3003             } else {
3004                 const char *const typestr = sv_reftype(referent, 0);
3005                 const STRLEN typelen = strlen(typestr);
3006                 UV addr = PTR2UV(referent);
3007                 const char *stashname = NULL;
3008                 STRLEN stashnamelen = 0; /* hush, gcc */
3009                 const char *buffer_end;
3010
3011                 if (SvOBJECT(referent)) {
3012                     const HEK *const name = HvNAME_HEK(SvSTASH(referent));
3013
3014                     if (name) {
3015                         stashname = HEK_KEY(name);
3016                         stashnamelen = HEK_LEN(name);
3017
3018                         if (HEK_UTF8(name)) {
3019                             SvUTF8_on(sv);
3020                         } else {
3021                             SvUTF8_off(sv);
3022                         }
3023                     } else {
3024                         stashname = "__ANON__";
3025                         stashnamelen = 8;
3026                     }
3027                     len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
3028                         + 2 * sizeof(UV) + 2 /* )\0 */;
3029                 } else {
3030                     len = typelen + 3 /* (0x */
3031                         + 2 * sizeof(UV) + 2 /* )\0 */;
3032                 }
3033
3034                 Newx(buffer, len, char);
3035                 buffer_end = retval = buffer + len;
3036
3037                 /* Working backwards  */
3038                 *--retval = '\0';
3039                 *--retval = ')';
3040                 do {
3041                     *--retval = PL_hexdigit[addr & 15];
3042                 } while (addr >>= 4);
3043                 *--retval = 'x';
3044                 *--retval = '0';
3045                 *--retval = '(';
3046
3047                 retval -= typelen;
3048                 memcpy(retval, typestr, typelen);
3049
3050                 if (stashname) {
3051                     *--retval = '=';
3052                     retval -= stashnamelen;
3053                     memcpy(retval, stashname, stashnamelen);
3054                 }
3055                 /* retval may not necessarily have reached the start of the
3056                    buffer here.  */
3057                 assert (retval >= buffer);
3058
3059                 len = buffer_end - retval - 1; /* -1 for that \0  */
3060             }
3061             if (lp)
3062                 *lp = len;
3063             SAVEFREEPV(buffer);
3064             return retval;
3065         }
3066     }
3067
3068     if (SvPOKp(sv)) {
3069         if (lp)
3070             *lp = SvCUR(sv);
3071         if (flags & SV_MUTABLE_RETURN)
3072             return SvPVX_mutable(sv);
3073         if (flags & SV_CONST_RETURN)
3074             return (char *)SvPVX_const(sv);
3075         return SvPVX(sv);
3076     }
3077
3078     if (SvIOK(sv)) {
3079         /* I'm assuming that if both IV and NV are equally valid then
3080            converting the IV is going to be more efficient */
3081         const U32 isUIOK = SvIsUV(sv);
3082         char buf[TYPE_CHARS(UV)];
3083         char *ebuf, *ptr;
3084         STRLEN len;
3085
3086         if (SvTYPE(sv) < SVt_PVIV)
3087             sv_upgrade(sv, SVt_PVIV);
3088         ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
3089         len = ebuf - ptr;
3090         /* inlined from sv_setpvn */
3091         s = SvGROW_mutable(sv, len + 1);
3092         Move(ptr, s, len, char);
3093         s += len;
3094         *s = '\0';
3095         SvPOK_on(sv);
3096     }
3097     else if (SvNOK(sv)) {
3098         if (SvTYPE(sv) < SVt_PVNV)
3099             sv_upgrade(sv, SVt_PVNV);
3100         if (SvNVX(sv) == 0.0
3101 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3102             && !Perl_isnan(SvNVX(sv))
3103 #endif
3104         ) {
3105             s = SvGROW_mutable(sv, 2);
3106             *s++ = '0';
3107             *s = '\0';
3108         } else {
3109             STRLEN len;
3110             STRLEN size = 5; /* "-Inf\0" */
3111
3112             s = SvGROW_mutable(sv, size);
3113             len = S_infnan_2pv(SvNVX(sv), s, size, 0);
3114             if (len > 0) {
3115                 s += len;
3116                 SvPOK_on(sv);
3117             }
3118             else {
3119                 /* some Xenix systems wipe out errno here */
3120                 dSAVE_ERRNO;
3121
3122                 size =
3123                     1 + /* sign */
3124                     1 + /* "." */
3125                     NV_DIG +
3126                     1 + /* "e" */
3127                     1 + /* sign */
3128                     5 + /* exponent digits */
3129                     1 + /* \0 */
3130                     2; /* paranoia */
3131
3132                 s = SvGROW_mutable(sv, size);
3133 #ifndef USE_LOCALE_NUMERIC
3134                 SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3135
3136                 SvPOK_on(sv);
3137 #else
3138                 {
3139                     bool local_radix;
3140                     DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3141                     STORE_LC_NUMERIC_SET_TO_NEEDED();
3142
3143                     local_radix = PL_numeric_local && PL_numeric_radix_sv;
3144                     if (local_radix && SvLEN(PL_numeric_radix_sv) > 1) {
3145                         size += SvLEN(PL_numeric_radix_sv) - 1;
3146                         s = SvGROW_mutable(sv, size);
3147                     }
3148
3149                     SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3150
3151                     /* If the radix character is UTF-8, and actually is in the
3152                      * output, turn on the UTF-8 flag for the scalar */
3153                     if (   local_radix
3154                         && SvUTF8(PL_numeric_radix_sv)
3155                         && instr(s, SvPVX_const(PL_numeric_radix_sv)))
3156                     {
3157                         SvUTF8_on(sv);
3158                     }
3159
3160                     RESTORE_LC_NUMERIC();
3161                 }
3162
3163                 /* We don't call SvPOK_on(), because it may come to
3164                  * pass that the locale changes so that the
3165                  * stringification we just did is no longer correct.  We
3166                  * will have to re-stringify every time it is needed */
3167 #endif
3168                 RESTORE_ERRNO;
3169             }
3170             while (*s) s++;
3171         }
3172     }
3173     else if (isGV_with_GP(sv)) {
3174         GV *const gv = MUTABLE_GV(sv);
3175         SV *const buffer = sv_newmortal();
3176
3177         gv_efullname3(buffer, gv, "*");
3178
3179         assert(SvPOK(buffer));
3180         if (SvUTF8(buffer))
3181             SvUTF8_on(sv);
3182         if (lp)
3183             *lp = SvCUR(buffer);
3184         return SvPVX(buffer);
3185     }
3186     else if (isREGEXP(sv)) {
3187         if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
3188         return RX_WRAPPED((REGEXP *)sv);
3189     }
3190     else {
3191         if (lp)
3192             *lp = 0;
3193         if (flags & SV_UNDEF_RETURNS_NULL)
3194             return NULL;
3195         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3196             report_uninit(sv);
3197         /* Typically the caller expects that sv_any is not NULL now.  */
3198         if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
3199             sv_upgrade(sv, SVt_PV);
3200         return (char *)"";
3201     }
3202
3203     {
3204         const STRLEN len = s - SvPVX_const(sv);
3205         if (lp) 
3206             *lp = len;
3207         SvCUR_set(sv, len);
3208     }
3209     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2pv(%s)\n",
3210                           PTR2UV(sv),SvPVX_const(sv)));
3211     if (flags & SV_CONST_RETURN)
3212         return (char *)SvPVX_const(sv);
3213     if (flags & SV_MUTABLE_RETURN)
3214         return SvPVX_mutable(sv);
3215     return SvPVX(sv);
3216 }
3217
3218 /*
3219 =for apidoc sv_copypv
3220
3221 Copies a stringified representation of the source SV into the
3222 destination SV.  Automatically performs any necessary C<mg_get> and
3223 coercion of numeric values into strings.  Guaranteed to preserve
3224 C<UTF8> flag even from overloaded objects.  Similar in nature to
3225 C<sv_2pv[_flags]> but operates directly on an SV instead of just the
3226 string.  Mostly uses C<sv_2pv_flags> to do its work, except when that
3227 would lose the UTF-8'ness of the PV.
3228
3229 =for apidoc sv_copypv_nomg
3230
3231 Like C<sv_copypv>, but doesn't invoke get magic first.
3232
3233 =for apidoc sv_copypv_flags
3234
3235 Implementation of C<sv_copypv> and C<sv_copypv_nomg>.  Calls get magic iff flags
3236 has the C<SV_GMAGIC> bit set.
3237
3238 =cut
3239 */
3240
3241 void
3242 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3243 {
3244     STRLEN len;
3245     const char *s;
3246
3247     PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3248
3249     s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC));
3250     sv_setpvn(dsv,s,len);
3251     if (SvUTF8(ssv))
3252         SvUTF8_on(dsv);
3253     else
3254         SvUTF8_off(dsv);
3255 }
3256
3257 /*
3258 =for apidoc sv_2pvbyte
3259
3260 Return a pointer to the byte-encoded representation of the SV, and set C<*lp>
3261 to its length.  May cause the SV to be downgraded from UTF-8 as a
3262 side-effect.
3263
3264 Usually accessed via the C<SvPVbyte> macro.
3265
3266 =cut
3267 */
3268
3269 char *
3270 Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
3271 {
3272     PERL_ARGS_ASSERT_SV_2PVBYTE;
3273
3274     SvGETMAGIC(sv);
3275     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3276      || isGV_with_GP(sv) || SvROK(sv)) {
3277         SV *sv2 = sv_newmortal();
3278         sv_copypv_nomg(sv2,sv);
3279         sv = sv2;
3280     }
3281     sv_utf8_downgrade(sv,0);
3282     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3283 }
3284
3285 /*
3286 =for apidoc sv_2pvutf8
3287
3288 Return a pointer to the UTF-8-encoded representation of the SV, and set C<*lp>
3289 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3290
3291 Usually accessed via the C<SvPVutf8> macro.
3292
3293 =cut
3294 */
3295
3296 char *
3297 Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
3298 {
3299     PERL_ARGS_ASSERT_SV_2PVUTF8;
3300
3301     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3302      || isGV_with_GP(sv) || SvROK(sv))
3303         sv = sv_mortalcopy(sv);
3304     else
3305         SvGETMAGIC(sv);
3306     sv_utf8_upgrade_nomg(sv);
3307     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3308 }
3309
3310
3311 /*
3312 =for apidoc sv_2bool
3313
3314 This macro is only used by C<sv_true()> or its macro equivalent, and only if
3315 the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>.
3316 It calls C<sv_2bool_flags> with the C<SV_GMAGIC> flag.
3317
3318 =for apidoc sv_2bool_flags
3319
3320 This function is only used by C<sv_true()> and friends,  and only if
3321 the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>.  If the flags
3322 contain C<SV_GMAGIC>, then it does an C<mg_get()> first.
3323
3324
3325 =cut
3326 */
3327
3328 bool
3329 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
3330 {
3331     PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3332
3333     restart:
3334     if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3335
3336     if (!SvOK(sv))
3337         return 0;
3338     if (SvROK(sv)) {
3339         if (SvAMAGIC(sv)) {
3340             SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3341             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
3342                 bool svb;
3343                 sv = tmpsv;
3344                 if(SvGMAGICAL(sv)) {
3345                     flags = SV_GMAGIC;
3346                     goto restart; /* call sv_2bool */
3347                 }
3348                 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
3349                 else if(!SvOK(sv)) {
3350                     svb = 0;
3351                 }
3352                 else if(SvPOK(sv)) {
3353                     svb = SvPVXtrue(sv);
3354                 }
3355                 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
3356                     svb = (SvIOK(sv) && SvIVX(sv) != 0)
3357                         || (SvNOK(sv) && SvNVX(sv) != 0.0);
3358                 }
3359                 else {
3360                     flags = 0;
3361                     goto restart; /* call sv_2bool_nomg */
3362                 }
3363                 return cBOOL(svb);
3364             }
3365         }
3366         return SvRV(sv) != 0;
3367     }
3368     if (isREGEXP(sv))
3369         return
3370           RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
3371     return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
3372 }
3373
3374 /*
3375 =for apidoc sv_utf8_upgrade
3376
3377 Converts the PV of an SV to its UTF-8-encoded form.
3378 Forces the SV to string form if it is not already.
3379 Will C<mg_get> on C<sv> if appropriate.
3380 Always sets the C<SvUTF8> flag to avoid future validity checks even
3381 if the whole string is the same in UTF-8 as not.
3382 Returns the number of bytes in the converted string
3383
3384 This is not a general purpose byte encoding to Unicode interface:
3385 use the Encode extension for that.
3386
3387 =for apidoc sv_utf8_upgrade_nomg
3388
3389 Like C<sv_utf8_upgrade>, but doesn't do magic on C<sv>.
3390
3391 =for apidoc sv_utf8_upgrade_flags
3392
3393 Converts the PV of an SV to its UTF-8-encoded form.
3394 Forces the SV to string form if it is not already.
3395 Always sets the SvUTF8 flag to avoid future validity checks even
3396 if all the bytes are invariant in UTF-8.
3397 If C<flags> has C<SV_GMAGIC> bit set,
3398 will C<mg_get> on C<sv> if appropriate, else not.
3399
3400 If C<flags> has C<SV_FORCE_UTF8_UPGRADE> set, this function assumes that the PV
3401 will expand when converted to UTF-8, and skips the extra work of checking for
3402 that.  Typically this flag is used by a routine that has already parsed the
3403 string and found such characters, and passes this information on so that the
3404 work doesn't have to be repeated.
3405
3406 Returns the number of bytes in the converted string.
3407
3408 This is not a general purpose byte encoding to Unicode interface:
3409 use the Encode extension for that.
3410
3411 =for apidoc sv_utf8_upgrade_flags_grow
3412
3413 Like C<sv_utf8_upgrade_flags>, but has an additional parameter C<extra>, which is
3414 the number of unused bytes the string of C<sv> is guaranteed to have free after
3415 it upon return.  This allows the caller to reserve extra space that it intends
3416 to fill, to avoid extra grows.
3417
3418 C<sv_utf8_upgrade>, C<sv_utf8_upgrade_nomg>, and C<sv_utf8_upgrade_flags>
3419 are implemented in terms of this function.
3420
3421 Returns the number of bytes in the converted string (not including the spares).
3422
3423 =cut
3424
3425 (One might think that the calling routine could pass in the position of the
3426 first variant character when it has set SV_FORCE_UTF8_UPGRADE, so it wouldn't
3427 have to be found again.  But that is not the case, because typically when the
3428 caller is likely to use this flag, it won't be calling this routine unless it
3429 finds something that won't fit into a byte.  Otherwise it tries to not upgrade
3430 and just use bytes.  But some things that do fit into a byte are variants in
3431 utf8, and the caller may not have been keeping track of these.)
3432
3433 If the routine itself changes the string, it adds a trailing C<NUL>.  Such a
3434 C<NUL> isn't guaranteed due to having other routines do the work in some input
3435 cases, or if the input is already flagged as being in utf8.
3436
3437 The speed of this could perhaps be improved for many cases if someone wanted to
3438 write a fast function that counts the number of variant characters in a string,
3439 especially if it could return the position of the first one.
3440
3441 */
3442
3443 STRLEN
3444 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3445 {
3446     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3447
3448     if (sv == &PL_sv_undef)
3449         return 0;
3450     if (!SvPOK_nog(sv)) {
3451         STRLEN len = 0;
3452         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3453             (void) sv_2pv_flags(sv,&len, flags);
3454             if (SvUTF8(sv)) {
3455                 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3456                 return len;
3457             }
3458         } else {
3459             (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3460         }
3461     }
3462
3463     if (SvUTF8(sv)) {
3464         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3465         return SvCUR(sv);
3466     }
3467
3468     if (SvIsCOW(sv)) {
3469         S_sv_uncow(aTHX_ sv, 0);
3470     }
3471
3472     if (SvCUR(sv) == 0) {
3473         if (extra) SvGROW(sv, extra);
3474     } else { /* Assume Latin-1/EBCDIC */
3475         /* This function could be much more efficient if we
3476          * had a FLAG in SVs to signal if there are any variant
3477          * chars in the PV.  Given that there isn't such a flag
3478          * make the loop as fast as possible (although there are certainly ways
3479          * to speed this up, eg. through vectorization) */
3480         U8 * s = (U8 *) SvPVX_const(sv);
3481         U8 * e = (U8 *) SvEND(sv);
3482         U8 *t = s;
3483         STRLEN two_byte_count = 0;
3484         
3485         if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3486
3487         /* See if really will need to convert to utf8.  We mustn't rely on our
3488          * incoming SV being well formed and having a trailing '\0', as certain
3489          * code in pp_formline can send us partially built SVs. */
3490
3491         while (t < e) {
3492             const U8 ch = *t++;
3493             if (NATIVE_BYTE_IS_INVARIANT(ch)) continue;
3494
3495             t--;    /* t already incremented; re-point to first variant */
3496             two_byte_count = 1;
3497             goto must_be_utf8;
3498         }
3499
3500         /* utf8 conversion not needed because all are invariants.  Mark as
3501          * UTF-8 even if no variant - saves scanning loop */
3502         SvUTF8_on(sv);
3503         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3504         return SvCUR(sv);
3505
3506       must_be_utf8:
3507
3508         /* Here, the string should be converted to utf8, either because of an
3509          * input flag (two_byte_count = 0), or because a character that
3510          * requires 2 bytes was found (two_byte_count = 1).  t points either to
3511          * the beginning of the string (if we didn't examine anything), or to
3512          * the first variant.  In either case, everything from s to t - 1 will
3513          * occupy only 1 byte each on output.
3514          *
3515          * There are two main ways to convert.  One is to create a new string
3516          * and go through the input starting from the beginning, appending each
3517          * converted value onto the new string as we go along.  It's probably
3518          * best to allocate enough space in the string for the worst possible
3519          * case rather than possibly running out of space and having to
3520          * reallocate and then copy what we've done so far.  Since everything
3521          * from s to t - 1 is invariant, the destination can be initialized
3522          * with these using a fast memory copy
3523          *
3524          * The other way is to figure out exactly how big the string should be
3525          * by parsing the entire input.  Then you don't have to make it big
3526          * enough to handle the worst possible case, and more importantly, if
3527          * the string you already have is large enough, you don't have to
3528          * allocate a new string, you can copy the last character in the input
3529          * string to the final position(s) that will be occupied by the
3530          * converted string and go backwards, stopping at t, since everything
3531          * before that is invariant.
3532          *
3533          * There are advantages and disadvantages to each method.
3534          *
3535          * In the first method, we can allocate a new string, do the memory
3536          * copy from the s to t - 1, and then proceed through the rest of the
3537          * string byte-by-byte.
3538          *
3539          * In the second method, we proceed through the rest of the input
3540          * string just calculating how big the converted string will be.  Then
3541          * there are two cases:
3542          *  1)  if the string has enough extra space to handle the converted
3543          *      value.  We go backwards through the string, converting until we
3544          *      get to the position we are at now, and then stop.  If this
3545          *      position is far enough along in the string, this method is
3546          *      faster than the other method.  If the memory copy were the same
3547          *      speed as the byte-by-byte loop, that position would be about
3548          *      half-way, as at the half-way mark, parsing to the end and back
3549          *      is one complete string's parse, the same amount as starting
3550          *      over and going all the way through.  Actually, it would be
3551          *      somewhat less than half-way, as it's faster to just count bytes
3552          *      than to also copy, and we don't have the overhead of allocating
3553          *      a new string, changing the scalar to use it, and freeing the
3554          *      existing one.  But if the memory copy is fast, the break-even
3555          *      point is somewhere after half way.  The counting loop could be
3556          *      sped up by vectorization, etc, to move the break-even point
3557          *      further towards the beginning.
3558          *  2)  if the string doesn't have enough space to handle the converted
3559          *      value.  A new string will have to be allocated, and one might
3560          *      as well, given that, start from the beginning doing the first
3561          *      method.  We've spent extra time parsing the string and in
3562          *      exchange all we've gotten is that we know precisely how big to
3563          *      make the new one.  Perl is more optimized for time than space,
3564          *      so this case is a loser.
3565          * So what I've decided to do is not use the 2nd method unless it is
3566          * guaranteed that a new string won't have to be allocated, assuming
3567          * the worst case.  I also decided not to put any more conditions on it
3568          * than this, for now.  It seems likely that, since the worst case is
3569          * twice as big as the unknown portion of the string (plus 1), we won't
3570          * be guaranteed enough space, causing us to go to the first method,
3571          * unless the string is short, or the first variant character is near
3572          * the end of it.  In either of these cases, it seems best to use the
3573          * 2nd method.  The only circumstance I can think of where this would
3574          * be really slower is if the string had once had much more data in it
3575          * than it does now, but there is still a substantial amount in it  */
3576
3577         {
3578             STRLEN invariant_head = t - s;
3579             STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3580             if (SvLEN(sv) < size) {
3581
3582                 /* Here, have decided to allocate a new string */
3583
3584                 U8 *dst;
3585                 U8 *d;
3586
3587                 Newx(dst, size, U8);
3588
3589                 /* If no known invariants at the beginning of the input string,
3590                  * set so starts from there.  Otherwise, can use memory copy to
3591                  * get up to where we are now, and then start from here */
3592
3593                 if (invariant_head == 0) {
3594                     d = dst;
3595                 } else {
3596                     Copy(s, dst, invariant_head, char);
3597                     d = dst + invariant_head;
3598                 }
3599
3600                 while (t < e) {
3601                     append_utf8_from_native_byte(*t, &d);
3602                     t++;
3603                 }
3604                 *d = '\0';
3605                 SvPV_free(sv); /* No longer using pre-existing string */
3606                 SvPV_set(sv, (char*)dst);
3607                 SvCUR_set(sv, d - dst);
3608                 SvLEN_set(sv, size);
3609             } else {
3610
3611                 /* Here, have decided to get the exact size of the string.
3612                  * Currently this happens only when we know that there is
3613                  * guaranteed enough space to fit the converted string, so
3614                  * don't have to worry about growing.  If two_byte_count is 0,
3615                  * then t points to the first byte of the string which hasn't
3616                  * been examined yet.  Otherwise two_byte_count is 1, and t
3617                  * points to the first byte in the string that will expand to
3618                  * two.  Depending on this, start examining at t or 1 after t.
3619                  * */
3620
3621                 U8 *d = t + two_byte_count;
3622
3623
3624                 /* Count up the remaining bytes that expand to two */
3625
3626                 while (d < e) {
3627                     const U8 chr = *d++;
3628                     if (! NATIVE_BYTE_IS_INVARIANT(chr)) two_byte_count++;
3629                 }
3630
3631                 /* The string will expand by just the number of bytes that
3632                  * occupy two positions.  But we are one afterwards because of
3633                  * the increment just above.  This is the place to put the
3634                  * trailing NUL, and to set the length before we decrement */
3635
3636                 d += two_byte_count;
3637                 SvCUR_set(sv, d - s);
3638                 *d-- = '\0';
3639
3640
3641                 /* Having decremented d, it points to the position to put the
3642                  * very last byte of the expanded string.  Go backwards through
3643                  * the string, copying and expanding as we go, stopping when we
3644                  * get to the part that is invariant the rest of the way down */
3645
3646                 e--;
3647                 while (e >= t) {
3648                     if (NATIVE_BYTE_IS_INVARIANT(*e)) {
3649                         *d-- = *e;
3650                     } else {
3651                         *d-- = UTF8_EIGHT_BIT_LO(*e);
3652                         *d-- = UTF8_EIGHT_BIT_HI(*e);
3653                     }
3654                     e--;
3655                 }
3656             }
3657
3658             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3659                 /* Update pos. We do it at the end rather than during
3660                  * the upgrade, to avoid slowing down the common case
3661                  * (upgrade without pos).
3662                  * pos can be stored as either bytes or characters.  Since
3663                  * this was previously a byte string we can just turn off
3664                  * the bytes flag. */
3665                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3666                 if (mg) {
3667                     mg->mg_flags &= ~MGf_BYTES;
3668                 }
3669                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3670                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3671             }
3672         }
3673     }
3674
3675     /* Mark as UTF-8 even if no variant - saves scanning loop */
3676     SvUTF8_on(sv);
3677     return SvCUR(sv);
3678 }
3679
3680 /*
3681 =for apidoc sv_utf8_downgrade
3682
3683 Attempts to convert the PV of an SV from characters to bytes.
3684 If the PV contains a character that cannot fit
3685 in a byte, this conversion will fail;
3686 in this case, either returns false or, if C<fail_ok> is not
3687 true, croaks.
3688
3689 This is not a general purpose Unicode to byte encoding interface:
3690 use the C<Encode> extension for that.
3691
3692 =cut
3693 */
3694
3695 bool
3696 Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
3697 {
3698     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3699
3700     if (SvPOKp(sv) && SvUTF8(sv)) {
3701         if (SvCUR(sv)) {
3702             U8 *s;
3703             STRLEN len;
3704             int mg_flags = SV_GMAGIC;
3705
3706             if (SvIsCOW(sv)) {
3707                 S_sv_uncow(aTHX_ sv, 0);
3708             }
3709             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3710                 /* update pos */
3711                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3712                 if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
3713                         mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
3714                                                 SV_GMAGIC|SV_CONST_RETURN);
3715                         mg_flags = 0; /* sv_pos_b2u does get magic */
3716                 }
3717                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3718                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3719
3720             }
3721             s = (U8 *) SvPV_flags(sv, len, mg_flags);
3722
3723             if (!utf8_to_bytes(s, &len)) {
3724                 if (fail_ok)
3725                     return FALSE;
3726                 else {
3727                     if (PL_op)
3728                         Perl_croak(aTHX_ "Wide character in %s",
3729                                    OP_DESC(PL_op));
3730                     else
3731                         Perl_croak(aTHX_ "Wide character");
3732                 }
3733             }
3734             SvCUR_set(sv, len);
3735         }
3736     }
3737     SvUTF8_off(sv);
3738     return TRUE;
3739 }
3740
3741 /*
3742 =for apidoc sv_utf8_encode
3743
3744 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3745 flag off so that it looks like octets again.
3746
3747 =cut
3748 */
3749
3750 void
3751 Perl_sv_utf8_encode(pTHX_ SV *const sv)
3752 {
3753     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3754
3755     if (SvREADONLY(sv)) {
3756         sv_force_normal_flags(sv, 0);
3757     }
3758     (void) sv_utf8_upgrade(sv);
3759     SvUTF8_off(sv);
3760 }
3761
3762 /*
3763 =for apidoc sv_utf8_decode
3764
3765 If the PV of the SV is an octet sequence in Perl's extended UTF-8
3766 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3767 so that it looks like a character.  If the PV contains only single-byte
3768 characters, the C<SvUTF8> flag stays off.
3769 Scans PV for validity and returns FALSE if the PV is invalid UTF-8.
3770
3771 =cut
3772 */
3773
3774 bool
3775 Perl_sv_utf8_decode(pTHX_ SV *const sv)
3776 {
3777     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3778
3779     if (SvPOKp(sv)) {
3780         const U8 *start, *c;
3781
3782         /* The octets may have got themselves encoded - get them back as
3783          * bytes
3784          */
3785         if (!sv_utf8_downgrade(sv, TRUE))
3786             return FALSE;
3787
3788         /* it is actually just a matter of turning the utf8 flag on, but
3789          * we want to make sure everything inside is valid utf8 first.
3790          */
3791         c = start = (const U8 *) SvPVX_const(sv);
3792         if (!is_utf8_string(c, SvCUR(sv)))
3793             return FALSE;
3794         if (! is_utf8_invariant_string(c, SvCUR(sv))) {
3795             SvUTF8_on(sv);
3796         }
3797         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3798             /* XXX Is this dead code?  XS_utf8_decode calls SvSETMAGIC
3799                    after this, clearing pos.  Does anything on CPAN
3800                    need this? */
3801             /* adjust pos to the start of a UTF8 char sequence */
3802             MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3803             if (mg) {
3804                 I32 pos = mg->mg_len;
3805                 if (pos > 0) {
3806                     for (c = start + pos; c > start; c--) {
3807                         if (UTF8_IS_START(*c))
3808                             break;
3809                     }
3810                     mg->mg_len  = c - start;
3811                 }
3812             }
3813             if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3814                 magic_setutf8(sv,mg); /* clear UTF8 cache */
3815         }
3816     }
3817     return TRUE;
3818 }
3819
3820 /*
3821 =for apidoc sv_setsv
3822
3823 Copies the contents of the source SV C<ssv> into the destination SV
3824 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3825 function if the source SV needs to be reused.  Does not handle 'set' magic on
3826 destination SV.  Calls 'get' magic on source SV.  Loosely speaking, it
3827 performs a copy-by-value, obliterating any previous content of the
3828 destination.
3829
3830 You probably want to use one of the assortment of wrappers, such as
3831 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3832 C<SvSetMagicSV_nosteal>.
3833
3834 =for apidoc sv_setsv_flags
3835
3836 Copies the contents of the source SV C<ssv> into the destination SV
3837 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3838 function if the source SV needs to be reused.  Does not handle 'set' magic.
3839 Loosely speaking, it performs a copy-by-value, obliterating any previous
3840 content of the destination.
3841 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3842 C<ssv> if appropriate, else not.  If the C<flags>
3843 parameter has the C<SV_NOSTEAL> bit set then the
3844 buffers of temps will not be stolen.  C<sv_setsv>
3845 and C<sv_setsv_nomg> are implemented in terms of this function.
3846
3847 You probably want to use one of the assortment of wrappers, such as
3848 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3849 C<SvSetMagicSV_nosteal>.
3850
3851 This is the primary function for copying scalars, and most other
3852 copy-ish functions and macros use this underneath.
3853
3854 =cut
3855 */
3856
3857 static void
3858 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3859 {
3860     I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3861     HV *old_stash = NULL;
3862
3863     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3864
3865     if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3866         const char * const name = GvNAME(sstr);
3867         const STRLEN len = GvNAMELEN(sstr);
3868         {
3869             if (dtype >= SVt_PV) {
3870                 SvPV_free(dstr);
3871                 SvPV_set(dstr, 0);
3872                 SvLEN_set(dstr, 0);
3873                 SvCUR_set(dstr, 0);
3874             }
3875             SvUPGRADE(dstr, SVt_PVGV);
3876             (void)SvOK_off(dstr);
3877             isGV_with_GP_on(dstr);
3878         }
3879         GvSTASH(dstr) = GvSTASH(sstr);
3880         if (GvSTASH(dstr))
3881             Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3882         gv_name_set(MUTABLE_GV(dstr), name, len,
3883                         GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
3884         SvFAKE_on(dstr);        /* can coerce to non-glob */
3885     }
3886
3887     if(GvGP(MUTABLE_GV(sstr))) {
3888         /* If source has method cache entry, clear it */
3889         if(GvCVGEN(sstr)) {
3890             SvREFCNT_dec(GvCV(sstr));
3891             GvCV_set(sstr, NULL);
3892             GvCVGEN(sstr) = 0;
3893         }
3894         /* If source has a real method, then a method is
3895            going to change */
3896         else if(
3897          GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3898         ) {
3899             mro_changes = 1;
3900         }
3901     }
3902
3903     /* If dest already had a real method, that's a change as well */
3904     if(
3905         !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3906      && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3907     ) {
3908         mro_changes = 1;
3909     }
3910
3911     /* We don't need to check the name of the destination if it was not a
3912        glob to begin with. */
3913     if(dtype == SVt_PVGV) {
3914         const char * const name = GvNAME((const GV *)dstr);
3915         if(
3916             strEQ(name,"ISA")
3917          /* The stash may have been detached from the symbol table, so
3918             check its name. */
3919          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3920         )
3921             mro_changes = 2;
3922         else {
3923             const STRLEN len = GvNAMELEN(dstr);
3924             if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3925              || (len == 1 && name[0] == ':')) {
3926                 mro_changes = 3;
3927
3928                 /* Set aside the old stash, so we can reset isa caches on
3929                    its subclasses. */
3930                 if((old_stash = GvHV(dstr)))
3931                     /* Make sure we do not lose it early. */
3932                     SvREFCNT_inc_simple_void_NN(
3933                      sv_2mortal((SV *)old_stash)
3934                     );
3935             }
3936         }
3937
3938         SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
3939     }
3940
3941     /* freeing dstr's GP might free sstr (e.g. *x = $x),
3942      * so temporarily protect it */
3943     ENTER;
3944     SAVEFREESV(SvREFCNT_inc_simple_NN(sstr));
3945     gp_free(MUTABLE_GV(dstr));
3946     GvINTRO_off(dstr);          /* one-shot flag */
3947     GvGP_set(dstr, gp_ref(GvGP(sstr)));
3948     LEAVE;
3949
3950     if (SvTAINTED(sstr))
3951         SvTAINT(dstr);
3952     if (GvIMPORTED(dstr) != GVf_IMPORTED
3953         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3954         {
3955             GvIMPORTED_on(dstr);
3956         }
3957     GvMULTI_on(dstr);
3958     if(mro_changes == 2) {
3959       if (GvAV((const GV *)sstr)) {
3960         MAGIC *mg;
3961         SV * const sref = (SV *)GvAV((const GV *)dstr);
3962         if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3963             if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3964                 AV * const ary = newAV();
3965                 av_push(ary, mg->mg_obj); /* takes the refcount */
3966                 mg->mg_obj = (SV *)ary;
3967             }
3968             av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3969         }
3970         else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3971       }
3972       mro_isa_changed_in(GvSTASH(dstr));
3973     }
3974     else if(mro_changes == 3) {
3975         HV * const stash = GvHV(dstr);
3976         if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3977             mro_package_moved(
3978                 stash, old_stash,
3979                 (GV *)dstr, 0
3980             );
3981     }
3982     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3983     if (GvIO(dstr) && dtype == SVt_PVGV) {
3984         DEBUG_o(Perl_deb(aTHX_
3985                         "glob_assign_glob clearing PL_stashcache\n"));
3986         /* It's a cache. It will rebuild itself quite happily.
3987            It's a lot of effort to work out exactly which key (or keys)
3988            might be invalidated by the creation of the this file handle.
3989          */
3990         hv_clear(PL_stashcache);
3991     }
3992     return;
3993 }
3994
3995 void
3996 Perl_gv_setref(pTHX_ SV *const dstr, SV *const sstr)
3997 {
3998     SV * const sref = SvRV(sstr);
3999     SV *dref;
4000     const int intro = GvINTRO(dstr);
4001     SV **location;
4002     U8 import_flag = 0;
4003     const U32 stype = SvTYPE(sref);
4004
4005     PERL_ARGS_ASSERT_GV_SETREF;
4006
4007     if (intro) {
4008         GvINTRO_off(dstr);      /* one-shot flag */
4009         GvLINE(dstr) = CopLINE(PL_curcop);
4010         GvEGV(dstr) = MUTABLE_GV(dstr);
4011     }
4012     GvMULTI_on(dstr);
4013     switch (stype) {
4014     case SVt_PVCV:
4015         location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
4016         import_flag = GVf_IMPORTED_CV;
4017         goto common;
4018     case SVt_PVHV:
4019         location = (SV **) &GvHV(dstr);
4020         import_flag = GVf_IMPORTED_HV;
4021         goto common;
4022     case SVt_PVAV:
4023         location = (SV **) &GvAV(dstr);
4024         import_flag = GVf_IMPORTED_AV;
4025         goto common;
4026     case SVt_PVIO:
4027         location = (SV **) &GvIOp(dstr);
4028         goto common;
4029     case SVt_PVFM:
4030         location = (SV **) &GvFORM(dstr);
4031         goto common;
4032     default:
4033         location = &GvSV(dstr);
4034         import_flag = GVf_IMPORTED_SV;
4035     common:
4036         if (intro) {
4037             if (stype == SVt_PVCV) {
4038                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
4039                 if (GvCVGEN(dstr)) {
4040                     SvREFCNT_dec(GvCV(dstr));
4041                     GvCV_set(dstr, NULL);
4042                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4043                 }
4044             }
4045             /* SAVEt_GVSLOT takes more room on the savestack and has more
4046                overhead in leave_scope than SAVEt_GENERIC_SV.  But for CVs
4047                leave_scope needs access to the GV so it can reset method
4048                caches.  We must use SAVEt_GVSLOT whenever the type is
4049                SVt_PVCV, even if the stash is anonymous, as the stash may
4050                gain a name somehow before leave_scope. */
4051             if (stype == SVt_PVCV) {
4052                 /* There is no save_pushptrptrptr.  Creating it for this
4053                    one call site would be overkill.  So inline the ss add
4054                    routines here. */
4055                 dSS_ADD;
4056                 SS_ADD_PTR(dstr);
4057                 SS_ADD_PTR(location);
4058                 SS_ADD_PTR(SvREFCNT_inc(*location));
4059                 SS_ADD_UV(SAVEt_GVSLOT);
4060                 SS_ADD_END(4);
4061             }
4062             else SAVEGENERICSV(*location);
4063         }
4064         dref = *location;
4065         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
4066             CV* const cv = MUTABLE_CV(*location);
4067             if (cv) {
4068                 if (!GvCVGEN((const GV *)dstr) &&
4069                     (CvROOT(cv) || CvXSUB(cv)) &&
4070                     /* redundant check that avoids creating the extra SV
4071                        most of the time: */
4072                     (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
4073                     {
4074                         SV * const new_const_sv =
4075                             CvCONST((const CV *)sref)
4076                                  ? cv_const_sv((const CV *)sref)
4077                                  : NULL;
4078                         HV * const stash = GvSTASH((const GV *)dstr);
4079                         report_redefined_cv(
4080                            sv_2mortal(
4081                              stash
4082                                ? Perl_newSVpvf(aTHX_
4083                                     "%" HEKf "::%" HEKf,
4084                                     HEKfARG(HvNAME_HEK(stash)),
4085                                     HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr))))
4086                                : Perl_newSVpvf(aTHX_
4087                                     "%" HEKf,
4088                                     HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr))))
4089                            ),
4090                            cv,
4091                            CvCONST((const CV *)sref) ? &new_const_sv : NULL
4092                         );
4093                     }
4094                 if (!intro)
4095                     cv_ckproto_len_flags(cv, (const GV *)dstr,
4096                                    SvPOK(sref) ? CvPROTO(sref) : NULL,
4097                                    SvPOK(sref) ? CvPROTOLEN(sref) : 0,
4098                                    SvPOK(sref) ? SvUTF8(sref) : 0);
4099             }
4100             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4101             GvASSUMECV_on(dstr);
4102             if(GvSTASH(dstr)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
4103                 if (intro && GvREFCNT(dstr) > 1) {
4104                     /* temporary remove extra savestack's ref */
4105                     --GvREFCNT(dstr);
4106                     gv_method_changed(dstr);
4107                     ++GvREFCNT(dstr);
4108                 }
4109                 else gv_method_changed(dstr);
4110             }
4111         }
4112         *location = SvREFCNT_inc_simple_NN(sref);
4113         if (import_flag && !(GvFLAGS(dstr) & import_flag)
4114             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
4115             GvFLAGS(dstr) |= import_flag;
4116         }
4117
4118         if (stype == SVt_PVHV) {
4119             const char * const name = GvNAME((GV*)dstr);
4120             const STRLEN len = GvNAMELEN(dstr);
4121             if (
4122                 (
4123                    (len > 1 && name[len-2] == ':' && name[len-1] == ':')
4124                 || (len == 1 && name[0] == ':')
4125                 )
4126              && (!dref || HvENAME_get(dref))
4127             ) {
4128                 mro_package_moved(
4129                     (HV *)sref, (HV *)dref,
4130                     (GV *)dstr, 0
4131                 );
4132             }
4133         }
4134         else if (
4135             stype == SVt_PVAV && sref != dref
4136          && strEQ(GvNAME((GV*)dstr), "ISA")
4137          /* The stash may have been detached from the symbol table, so
4138             check its name before doing anything. */
4139          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
4140         ) {
4141             MAGIC *mg;
4142             MAGIC * const omg = dref && SvSMAGICAL(dref)
4143                                  ? mg_find(dref, PERL_MAGIC_isa)
4144                                  : NULL;
4145             if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
4146                 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
4147                     AV * const ary = newAV();
4148                     av_push(ary, mg->mg_obj); /* takes the refcount */
4149                     mg->mg_obj = (SV *)ary;
4150                 }
4151                 if (omg) {
4152                     if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
4153                         SV **svp = AvARRAY((AV *)omg->mg_obj);
4154                         I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
4155                         while (items--)
4156                             av_push(
4157                              (AV *)mg->mg_obj,
4158                              SvREFCNT_inc_simple_NN(*svp++)
4159                             );
4160                     }
4161                     else
4162                         av_push(
4163                          (AV *)mg->mg_obj,
4164                          SvREFCNT_inc_simple_NN(omg->mg_obj)
4165                         );
4166                 }
4167                 else
4168                     av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
4169             }
4170             else
4171             {
4172                 SSize_t i;
4173                 sv_magic(
4174                  sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
4175                 );
4176                 for (i = 0; i <= AvFILL(sref); ++i) {
4177                     SV **elem = av_fetch ((AV*)sref, i, 0);
4178                     if (elem) {
4179                         sv_magic(
4180                           *elem, sref, PERL_MAGIC_isaelem, NULL, i
4181                         );
4182                     }
4183                 }
4184                 mg = mg_find(sref, PERL_MAGIC_isa);
4185             }
4186             /* Since the *ISA assignment could have affected more than
4187                one stash, don't call mro_isa_changed_in directly, but let
4188                magic_clearisa do it for us, as it already has the logic for
4189                dealing with globs vs arrays of globs. */
4190             assert(mg);
4191             Perl_magic_clearisa(aTHX_ NULL, mg);
4192         }
4193         else if (stype == SVt_PVIO) {
4194             DEBUG_o(Perl_deb(aTHX_ "gv_setref clearing PL_stashcache\n"));
4195             /* It's a cache. It will rebuild itself quite happily.
4196                It's a lot of effort to work out exactly which key (or keys)
4197                might be invalidated by the creation of the this file handle.
4198             */
4199             hv_clear(PL_stashcache);
4200         }
4201         break;
4202     }
4203     if (!intro) SvREFCNT_dec(dref);
4204     if (SvTAINTED(sstr))
4205         SvTAINT(dstr);
4206     return;
4207 }
4208
4209
4210
4211
4212 #ifdef PERL_DEBUG_READONLY_COW
4213 # include <sys/mman.h>
4214
4215 # ifndef PERL_MEMORY_DEBUG_HEADER_SIZE
4216 #  define PERL_MEMORY_DEBUG_HEADER_SIZE 0
4217 # endif
4218
4219 void
4220 Perl_sv_buf_to_ro(pTHX_ SV *sv)
4221 {
4222     struct perl_memory_debug_header * const header =
4223         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4224     const MEM_SIZE len = header->size;
4225     PERL_ARGS_ASSERT_SV_BUF_TO_RO;
4226 # ifdef PERL_TRACK_MEMPOOL
4227     if (!header->readonly) header->readonly = 1;
4228 # endif
4229     if (mprotect(header, len, PROT_READ))
4230         Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
4231                          header, len, errno);
4232 }
4233
4234 static void
4235 S_sv_buf_to_rw(pTHX_ SV *sv)
4236 {
4237     struct perl_memory_debug_header * const header =
4238         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4239     const MEM_SIZE len = header->size;
4240     PERL_ARGS_ASSERT_SV_BUF_TO_RW;
4241     if (mprotect(header, len, PROT_READ|PROT_WRITE))
4242         Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
4243                          header, len, errno);
4244 # ifdef PERL_TRACK_MEMPOOL
4245     header->readonly = 0;
4246 # endif
4247 }
4248
4249 #else
4250 # define sv_buf_to_ro(sv)       NOOP
4251 # define sv_buf_to_rw(sv)       NOOP
4252 #endif
4253
4254 void
4255 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
4256 {
4257     U32 sflags;
4258     int dtype;
4259     svtype stype;
4260     unsigned int both_type;
4261
4262     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
4263
4264     if (UNLIKELY( sstr == dstr ))
4265         return;
4266
4267     if (UNLIKELY( !sstr ))
4268         sstr = &PL_sv_undef;
4269
4270     stype = SvTYPE(sstr);
4271     dtype = SvTYPE(dstr);
4272     both_type = (stype | dtype);
4273
4274     /* with these values, we can check that both SVs are NULL/IV (and not
4275      * freed) just by testing the or'ed types */
4276     STATIC_ASSERT_STMT(SVt_NULL == 0);
4277     STATIC_ASSERT_STMT(SVt_IV   == 1);
4278     if (both_type <= 1) {
4279         /* both src and dst are UNDEF/IV/RV, so we can do a lot of
4280          * special-casing */
4281         U32 sflags;
4282         U32 new_dflags;
4283         SV *old_rv = NULL;
4284
4285         /* minimal subset of SV_CHECK_THINKFIRST_COW_DROP(dstr) */
4286         if (SvREADONLY(dstr))
4287             Perl_croak_no_modify();
4288         if (SvROK(dstr)) {
4289             if (SvWEAKREF(dstr))
4290                 sv_unref_flags(dstr, 0);
4291             else
4292                 old_rv = SvRV(dstr);
4293         }
4294
4295         assert(!SvGMAGICAL(sstr));
4296         assert(!SvGMAGICAL(dstr));
4297
4298         sflags = SvFLAGS(sstr);
4299         if (sflags & (SVf_IOK|SVf_ROK)) {
4300             SET_SVANY_FOR_BODYLESS_IV(dstr);
4301             new_dflags = SVt_IV;
4302
4303             if (sflags & SVf_ROK) {
4304                 dstr->sv_u.svu_rv = SvREFCNT_inc(SvRV(sstr));
4305                 new_dflags |= SVf_ROK;
4306             }
4307             else {
4308                 /* both src and dst are <= SVt_IV, so sv_any points to the
4309                  * head; so access the head directly
4310                  */
4311                 assert(    &(sstr->sv_u.svu_iv)
4312                         == &(((XPVIV*) SvANY(sstr))->xiv_iv));
4313                 assert(    &(dstr->sv_u.svu_iv)
4314                         == &(((XPVIV*) SvANY(dstr))->xiv_iv));
4315                 dstr->sv_u.svu_iv = sstr->sv_u.svu_iv;
4316                 new_dflags |= (SVf_IOK|SVp_IOK|(sflags & SVf_IVisUV));
4317             }
4318         }
4319         else {
4320             new_dflags = dtype; /* turn off everything except the type */
4321         }
4322         SvFLAGS(dstr) = new_dflags;
4323         SvREFCNT_dec(old_rv);
4324
4325         return;
4326     }
4327
4328     if (UNLIKELY(both_type == SVTYPEMASK)) {
4329         if (SvIS_FREED(dstr)) {
4330             Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
4331                        " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
4332         }
4333         if (SvIS_FREED(sstr)) {
4334             Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
4335                        (void*)sstr, (void*)dstr);
4336         }
4337     }
4338
4339
4340
4341     SV_CHECK_THINKFIRST_COW_DROP(dstr);
4342     dtype = SvTYPE(dstr); /* THINKFIRST may have changed type */
4343
4344     /* There's a lot of redundancy below but we're going for speed here */
4345
4346     switch (stype) {
4347     case SVt_NULL:
4348       undef_sstr:
4349         if (LIKELY( dtype != SVt_PVGV && dtype != SVt_PVLV )) {
4350             (void)SvOK_off(dstr);
4351             return;
4352         }
4353         break;
4354     case SVt_IV:
4355         if (SvIOK(sstr)) {
4356             switch (dtype) {
4357             case SVt_NULL:
4358                 /* For performance, we inline promoting to type SVt_IV. */
4359                 /* We're starting from SVt_NULL, so provided that define is
4360                  * actual 0, we don't have to unset any SV type flags
4361                  * to promote to SVt_IV. */
4362                 STATIC_ASSERT_STMT(SVt_NULL == 0);
4363                 SET_SVANY_FOR_BODYLESS_IV(dstr);
4364                 SvFLAGS(dstr) |= SVt_IV;
4365                 break;
4366             case SVt_NV:
4367             case SVt_PV:
4368                 sv_upgrade(dstr, SVt_PVIV);
4369                 break;
4370             case SVt_PVGV:
4371             case SVt_PVLV:
4372                 goto end_of_first_switch;
4373             }
4374             (void)SvIOK_only(dstr);
4375             SvIV_set(dstr,  SvIVX(sstr));
4376             if (SvIsUV(sstr))
4377                 SvIsUV_on(dstr);
4378             /* SvTAINTED can only be true if the SV has taint magic, which in
4379                turn means that the SV type is PVMG (or greater). This is the
4380                case statement for SVt_IV, so this cannot be true (whatever gcov
4381                may say).  */
4382             assert(!SvTAINTED(sstr));
4383             return;
4384         }
4385         if (!SvROK(sstr))
4386             goto undef_sstr;
4387         if (dtype < SVt_PV && dtype != SVt_IV)
4388             sv_upgrade(dstr, SVt_IV);
4389         break;
4390
4391     case SVt_NV:
4392         if (LIKELY( SvNOK(sstr) )) {
4393             switch (dtype) {
4394             case SVt_NULL:
4395             case SVt_IV:
4396                 sv_upgrade(dstr, SVt_NV);
4397                 break;
4398             case SVt_PV:
4399             case SVt_PVIV:
4400                 sv_upgrade(dstr, SVt_PVNV);
4401                 break;
4402             case SVt_PVGV:
4403             case SVt_PVLV:
4404                 goto end_of_first_switch;
4405             }
4406             SvNV_set(dstr, SvNVX(sstr));
4407             (void)SvNOK_only(dstr);
4408             /* SvTAINTED can only be true if the SV has taint magic, which in
4409                turn means that the SV type is PVMG (or greater). This is the
4410                case statement for SVt_NV, so this cannot be true (whatever gcov
4411                may say).  */
4412             assert(!SvTAINTED(sstr));
4413             return;
4414         }
4415         goto undef_sstr;
4416
4417     case SVt_PV:
4418         if (dtype < SVt_PV)
4419             sv_upgrade(dstr, SVt_PV);
4420         break;
4421     case SVt_PVIV:
4422         if (dtype < SVt_PVIV)
4423             sv_upgrade(dstr, SVt_PVIV);
4424         break;
4425     case SVt_PVNV:
4426         if (dtype < SVt_PVNV)
4427             sv_upgrade(dstr, SVt_PVNV);
4428         break;
4429     default:
4430         {
4431         const char * const type = sv_reftype(sstr,0);
4432         if (PL_op)
4433             /* diag_listed_as: Bizarre copy of %s */
4434             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4435         else
4436             Perl_croak(aTHX_ "Bizarre copy of %s", type);
4437         }
4438         NOT_REACHED; /* NOTREACHED */
4439
4440     case SVt_REGEXP:
4441       upgregexp:
4442         if (dtype < SVt_REGEXP)
4443         {
4444             if (dtype >= SVt_PV) {
4445                 SvPV_free(dstr);
4446                 SvPV_set(dstr, 0);
4447                 SvLEN_set(dstr, 0);
4448                 SvCUR_set(dstr, 0);
4449             }
4450             sv_upgrade(dstr, SVt_REGEXP);
4451         }
4452         break;
4453
4454         case SVt_INVLIST:
4455     case SVt_PVLV:
4456     case SVt_PVGV:
4457     case SVt_PVMG:
4458         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4459             mg_get(sstr);
4460             if (SvTYPE(sstr) != stype)
4461                 stype = SvTYPE(sstr);
4462         }
4463         if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4464                     glob_assign_glob(dstr, sstr, dtype);
4465                     return;
4466         }
4467         if (stype == SVt_PVLV)
4468         {
4469             if (isREGEXP(sstr)) goto upgregexp;
4470             SvUPGRADE(dstr, SVt_PVNV);
4471         }
4472         else
4473             SvUPGRADE(dstr, (svtype)stype);
4474     }
4475  end_of_first_switch:
4476
4477     /* dstr may have been upgraded.  */
4478     dtype = SvTYPE(dstr);
4479     sflags = SvFLAGS(sstr);
4480
4481     if (UNLIKELY( dtype == SVt_PVCV )) {
4482         /* Assigning to a subroutine sets the prototype.  */
4483         if (SvOK(sstr)) {
4484             STRLEN len;
4485             const char *const ptr = SvPV_const(sstr, len);
4486
4487             SvGROW(dstr, len + 1);
4488             Copy(ptr, SvPVX(dstr), len + 1, char);
4489             SvCUR_set(dstr, len);
4490             SvPOK_only(dstr);
4491             SvFLAGS(dstr) |= sflags & SVf_UTF8;
4492             CvAUTOLOAD_off(dstr);
4493         } else {
4494             SvOK_off(dstr);
4495         }
4496     }
4497     else if (UNLIKELY(dtype == SVt_PVAV || dtype == SVt_PVHV
4498              || dtype == SVt_PVFM))
4499     {
4500         const char * const type = sv_reftype(dstr,0);
4501         if (PL_op)
4502             /* diag_listed_as: Cannot copy to %s */
4503             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4504         else
4505             Perl_croak(aTHX_ "Cannot copy to %s", type);
4506     } else if (sflags & SVf_ROK) {
4507         if (isGV_with_GP(dstr)
4508             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4509             sstr = SvRV(sstr);
4510             if (sstr == dstr) {
4511                 if (GvIMPORTED(dstr) != GVf_IMPORTED
4512                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4513                 {
4514                     GvIMPORTED_on(dstr);
4515                 }
4516                 GvMULTI_on(dstr);
4517                 return;
4518             }
4519             glob_assign_glob(dstr, sstr, dtype);
4520             return;
4521         }
4522
4523         if (dtype >= SVt_PV) {
4524             if (isGV_with_GP(dstr)) {
4525                 gv_setref(dstr, sstr);
4526                 return;
4527             }
4528             if (SvPVX_const(dstr)) {
4529                 SvPV_free(dstr);
4530                 SvLEN_set(dstr, 0);
4531                 SvCUR_set(dstr, 0);
4532             }
4533         }
4534         (void)SvOK_off(dstr);
4535         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4536         SvFLAGS(dstr) |= sflags & SVf_ROK;
4537         assert(!(sflags & SVp_NOK));
4538         assert(!(sflags & SVp_IOK));
4539         assert(!(sflags & SVf_NOK));
4540         assert(!(sflags & SVf_IOK));
4541     }
4542     else if (isGV_with_GP(dstr)) {
4543         if (!(sflags & SVf_OK)) {
4544             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4545                            "Undefined value assigned to typeglob");
4546         }
4547         else {
4548             GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
4549             if (dstr != (const SV *)gv) {
4550                 const char * const name = GvNAME((const GV *)dstr);
4551                 const STRLEN len = GvNAMELEN(dstr);
4552                 HV *old_stash = NULL;
4553                 bool reset_isa = FALSE;
4554                 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4555                  || (len == 1 && name[0] == ':')) {
4556                     /* Set aside the old stash, so we can reset isa caches
4557                        on its subclasses. */
4558                     if((old_stash = GvHV(dstr))) {
4559                         /* Make sure we do not lose it early. */
4560                         SvREFCNT_inc_simple_void_NN(
4561                          sv_2mortal((SV *)old_stash)
4562                         );
4563                     }
4564                     reset_isa = TRUE;
4565                 }
4566
4567                 if (GvGP(dstr)) {
4568                     SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
4569                     gp_free(MUTABLE_GV(dstr));
4570                 }
4571                 GvGP_set(dstr, gp_ref(GvGP(gv)));
4572
4573                 if (reset_isa) {
4574                     HV * const stash = GvHV(dstr);
4575                     if(
4576                         old_stash ? (HV *)HvENAME_get(old_stash) : stash
4577                     )
4578                         mro_package_moved(
4579                          stash, old_stash,
4580                          (GV *)dstr, 0
4581                         );
4582                 }
4583             }
4584         }
4585     }
4586     else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4587           && (stype == SVt_REGEXP || isREGEXP(sstr))) {
4588         reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4589     }
4590     else if (sflags & SVp_POK) {
4591         const STRLEN cur = SvCUR(sstr);
4592         const STRLEN len = SvLEN(sstr);
4593
4594         /*
4595          * We have three basic ways to copy the string:
4596          *
4597          *  1. Swipe
4598          *  2. Copy-on-write
4599          *  3. Actual copy
4600          * 
4601          * Which we choose is based on various factors.  The following
4602          * things are listed in order of speed, fastest to slowest:
4603          *  - Swipe
4604          *  - Copying a short string
4605          *  - Copy-on-write bookkeeping
4606          *  - malloc
4607          *  - Copying a long string
4608          * 
4609          * We swipe the string (steal the string buffer) if the SV on the
4610          * rhs is about to be freed anyway (TEMP and refcnt==1).  This is a
4611          * big win on long strings.  It should be a win on short strings if
4612          * SvPVX_const(dstr) has to be allocated.  If not, it should not 
4613          * slow things down, as SvPVX_const(sstr) would have been freed
4614          * soon anyway.
4615          * 
4616          * We also steal the buffer from a PADTMP (operator target) if it
4617          * is ‘long enough’.  For short strings, a swipe does not help
4618          * here, as it causes more malloc calls the next time the target
4619          * is used.  Benchmarks show that even if SvPVX_const(dstr) has to
4620          * be allocated it is still not worth swiping PADTMPs for short
4621          * strings, as the savings here are small.
4622          * 
4623          * If swiping is not an option, then we see whether it is
4624          * worth using copy-on-write.  If the lhs already has a buf-
4625          * fer big enough and the string is short, we skip it and fall back
4626          * to method 3, since memcpy is faster for short strings than the
4627          * later bookkeeping overhead that copy-on-write entails.
4628
4629          * If the rhs is not a copy-on-write string yet, then we also
4630          * consider whether the buffer is too large relative to the string
4631          * it holds.  Some operations such as readline allocate a large
4632          * buffer in the expectation of reusing it.  But turning such into
4633          * a COW buffer is counter-productive because it increases memory
4634          * usage by making readline allocate a new large buffer the sec-
4635          * ond time round.  So, if the buffer is too large, again, we use
4636          * method 3 (copy).
4637          * 
4638          * Finally, if there is no buffer on the left, or the buffer is too 
4639          * small, then we use copy-on-write and make both SVs share the
4640          * string buffer.
4641          *
4642          */
4643
4644         /* Whichever path we take through the next code, we want this true,
4645            and doing it now facilitates the COW check.  */
4646         (void)SvPOK_only(dstr);
4647
4648         if (
4649                  (              /* Either ... */
4650                                 /* slated for free anyway (and not COW)? */
4651                     (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
4652                                 /* or a swipable TARG */
4653                  || ((sflags &
4654                            (SVs_PADTMP|SVf_READONLY|SVf_PROTECT|SVf_IsCOW))
4655                        == SVs_PADTMP
4656                                 /* whose buffer is worth stealing */
4657                      && CHECK_COWBUF_THRESHOLD(cur,len)
4658                     )
4659                  ) &&
4660                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4661                  (!(flags & SV_NOSTEAL)) &&
4662                                         /* and we're allowed to steal temps */
4663                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4664                  len)             /* and really is a string */
4665         {       /* Passes the swipe test.  */
4666             if (SvPVX_const(dstr))      /* we know that dtype >= SVt_PV */
4667                 SvPV_free(dstr);
4668             SvPV_set(dstr, SvPVX_mutable(sstr));
4669             SvLEN_set(dstr, SvLEN(sstr));
4670             SvCUR_set(dstr, SvCUR(sstr));
4671
4672             SvTEMP_off(dstr);
4673             (void)SvOK_off(sstr);       /* NOTE: nukes most SvFLAGS on sstr */
4674             SvPV_set(sstr, NULL);
4675             SvLEN_set(sstr, 0);
4676             SvCUR_set(sstr, 0);
4677             SvTEMP_off(sstr);
4678         }
4679         else if (flags & SV_COW_SHARED_HASH_KEYS
4680               &&
4681 #ifdef PERL_COPY_ON_WRITE
4682                  (sflags & SVf_IsCOW
4683                    ? (!len ||
4684                        (  (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
4685                           /* If this is a regular (non-hek) COW, only so
4686                              many COW "copies" are possible. */
4687                        && CowREFCNT(sstr) != SV_COW_REFCNT_MAX  ))
4688                    : (  (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4689                      && !(SvFLAGS(dstr) & SVf_BREAK)
4690                      && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len
4691                      && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
4692                     ))
4693 #else
4694                  sflags & SVf_IsCOW
4695               && !(SvFLAGS(dstr) & SVf_BREAK)
4696 #endif
4697             ) {
4698             /* Either it's a shared hash key, or it's suitable for
4699                copy-on-write.  */
4700             if (DEBUG_C_TEST) {
4701                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4702                 sv_dump(sstr);
4703                 sv_dump(dstr);
4704             }
4705 #ifdef PERL_ANY_COW
4706             if (!(sflags & SVf_IsCOW)) {
4707                     SvIsCOW_on(sstr);
4708                     CowREFCNT(sstr) = 0;
4709             }
4710 #endif
4711             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
4712                 SvPV_free(dstr);
4713             }
4714
4715 #ifdef PERL_ANY_COW
4716             if (len) {
4717                     if (sflags & SVf_IsCOW) {
4718                         sv_buf_to_rw(sstr);
4719                     }
4720                     CowREFCNT(sstr)++;
4721                     SvPV_set(dstr, SvPVX_mutable(sstr));
4722                     sv_buf_to_ro(sstr);
4723             } else
4724 #endif
4725             {
4726                     /* SvIsCOW_shared_hash */
4727                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4728                                           "Copy on write: Sharing hash\n"));
4729
4730                     assert (SvTYPE(dstr) >= SVt_PV);
4731                     SvPV_set(dstr,
4732                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4733             }
4734             SvLEN_set(dstr, len);
4735             SvCUR_set(dstr, cur);
4736             SvIsCOW_on(dstr);
4737         } else {
4738             /* Failed the swipe test, and we cannot do copy-on-write either.
4739                Have to copy the string.  */
4740             SvGROW(dstr, cur + 1);      /* inlined from sv_setpvn */
4741             Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
4742             SvCUR_set(dstr, cur);
4743             *SvEND(dstr) = '\0';
4744         }
4745         if (sflags & SVp_NOK) {
4746             SvNV_set(dstr, SvNVX(sstr));
4747         }
4748         if (sflags & SVp_IOK) {
4749             SvIV_set(dstr, SvIVX(sstr));
4750             if (sflags & SVf_IVisUV)
4751                 SvIsUV_on(dstr);
4752         }
4753         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4754         {
4755             const MAGIC * const smg = SvVSTRING_mg(sstr);
4756             if (smg) {
4757                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4758                          smg->mg_ptr, smg->mg_len);
4759                 SvRMAGICAL_on(dstr);
4760             }
4761         }
4762     }
4763     else if (sflags & (SVp_IOK|SVp_NOK)) {
4764         (void)SvOK_off(dstr);
4765         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4766         if (sflags & SVp_IOK) {
4767             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4768             SvIV_set(dstr, SvIVX(sstr));
4769         }
4770         if (sflags & SVp_NOK) {
4771             SvNV_set(dstr, SvNVX(sstr));
4772         }
4773     }
4774     else {
4775         if (isGV_with_GP(sstr)) {
4776             gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4777         }
4778         else
4779             (void)SvOK_off(dstr);
4780     }
4781     if (SvTAINTED(sstr))
4782         SvTAINT(dstr);
4783 }
4784
4785
4786 /*
4787 =for apidoc sv_set_undef
4788
4789 Equivalent to C<sv_setsv(sv, &PL_sv_undef)>, but more efficient.
4790 Doesn't handle set magic.
4791
4792 The perl equivalent is C<$sv = undef;>. Note that it doesn't free any string
4793 buffer, unlike C<undef $sv>.
4794
4795 Introduced in perl 5.26.0.
4796
4797 =cut
4798 */
4799
4800 void
4801 Perl_sv_set_undef(pTHX_ SV *sv)
4802 {
4803     U32 type = SvTYPE(sv);
4804
4805     PERL_ARGS_ASSERT_SV_SET_UNDEF;
4806
4807     /* shortcut, NULL, IV, RV */
4808
4809     if (type <= SVt_IV) {
4810         assert(!SvGMAGICAL(sv));
4811         if (SvREADONLY(sv))
4812             Perl_croak_no_modify();
4813
4814         if (SvROK(sv)) {
4815             if (SvWEAKREF(sv))
4816                 sv_unref_flags(sv, 0);
4817             else {
4818                 SV *rv = SvRV(sv);
4819                 SvFLAGS(sv) = type; /* quickly turn off all flags */
4820                 SvREFCNT_dec_NN(rv);
4821                 return;
4822             }
4823         }
4824         SvFLAGS(sv) = type; /* quickly turn off all flags */
4825         return;
4826     }
4827
4828     if (SvIS_FREED(sv))
4829         Perl_croak(aTHX_ "panic: attempt to undefine a freed scalar %p",
4830             (void *)sv);
4831
4832     SV_CHECK_THINKFIRST_COW_DROP(sv);
4833
4834     if (isGV_with_GP(sv))
4835         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4836                        "Undefined value assigned to typeglob");
4837
4838     SvOK_off(sv);
4839 }
4840
4841
4842
4843 /*
4844 =for apidoc sv_setsv_mg
4845
4846 Like C<sv_setsv>, but also handles 'set' magic.
4847
4848 =cut
4849 */
4850
4851 void
4852 Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr)
4853 {
4854     PERL_ARGS_ASSERT_SV_SETSV_MG;
4855
4856     sv_setsv(dstr,sstr);
4857     SvSETMAGIC(dstr);
4858 }
4859
4860 #ifdef PERL_ANY_COW
4861 #  define SVt_COW SVt_PV
4862 SV *
4863 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4864 {
4865     STRLEN cur = SvCUR(sstr);
4866     STRLEN len = SvLEN(sstr);
4867     char *new_pv;
4868 #if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_COPY_ON_WRITE)
4869     const bool already = cBOOL(SvIsCOW(sstr));
4870 #endif
4871
4872     PERL_ARGS_ASSERT_SV_SETSV_COW;
4873
4874     if (DEBUG_C_TEST) {
4875         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4876                       (void*)sstr, (void*)dstr);
4877         sv_dump(sstr);
4878         if (dstr)
4879                     sv_dump(dstr);
4880     }
4881
4882     if (dstr) {
4883         if (SvTHINKFIRST(dstr))
4884             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4885         else if (SvPVX_const(dstr))
4886             Safefree(SvPVX_mutable(dstr));
4887     }
4888     else
4889         new_SV(dstr);
4890     SvUPGRADE(dstr, SVt_COW);
4891
4892     assert (SvPOK(sstr));
4893     assert (SvPOKp(sstr));
4894
4895     if (SvIsCOW(sstr)) {
4896
4897         if (SvLEN(sstr) == 0) {
4898             /* source is a COW shared hash key.  */
4899             DEBUG_C(PerlIO_printf(Perl_debug_log,
4900                                   "Fast copy on write: Sharing hash\n"));
4901             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4902             goto common_exit;
4903         }
4904         assert(SvCUR(sstr)+1 < SvLEN(sstr));
4905         assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX);
4906     } else {
4907         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4908         SvUPGRADE(sstr, SVt_COW);
4909         SvIsCOW_on(sstr);
4910         DEBUG_C(PerlIO_printf(Perl_debug_log,
4911                               "Fast copy on write: Converting sstr to COW\n"));
4912         CowREFCNT(sstr) = 0;    
4913     }
4914 #  ifdef PERL_DEBUG_READONLY_COW
4915     if (already) sv_buf_to_rw(sstr);
4916 #  endif
4917     CowREFCNT(sstr)++;  
4918     new_pv = SvPVX_mutable(sstr);
4919     sv_buf_to_ro(sstr);
4920
4921   common_exit:
4922     SvPV_set(dstr, new_pv);
4923     SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
4924     if (SvUTF8(sstr))
4925         SvUTF8_on(dstr);
4926     SvLEN_set(dstr, len);
4927     SvCUR_set(dstr, cur);
4928     if (DEBUG_C_TEST) {
4929         sv_dump(dstr);
4930     }
4931     return dstr;
4932 }
4933 #endif
4934
4935 /*
4936 =for apidoc sv_setpv_bufsize
4937
4938 Sets the SV to be a string of cur bytes length, with at least
4939 len bytes available. Ensures that there is a null byte at SvEND.
4940 Returns a char * pointer to the SvPV buffer.
4941
4942 =cut
4943 */
4944
4945 char *
4946 Perl_sv_setpv_bufsize(pTHX_ SV *const sv, const STRLEN cur, const STRLEN len)
4947 {
4948     char *pv;
4949
4950     PERL_ARGS_ASSERT_SV_SETPV_BUFSIZE;
4951
4952     SV_CHECK_THINKFIRST_COW_DROP(sv);
4953     SvUPGRADE(sv, SVt_PV);
4954     pv = SvGROW(sv, len + 1);
4955     SvCUR_set(sv, cur);
4956     *(SvEND(sv))= '\0';
4957     (void)SvPOK_only_UTF8(sv);                /* validate pointer */
4958
4959     SvTAINT(sv);
4960     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4961     return pv;
4962 }
4963
4964 /*
4965 =for apidoc sv_setpvn
4966
4967 Copies a string (possibly containing embedded C<NUL> characters) into an SV.
4968 The C<len> parameter indicates the number of
4969 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4970 undefined.  Does not handle 'set' magic.  See C<L</sv_setpvn_mg>>.
4971
4972 =cut
4973 */
4974
4975 void
4976 Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4977 {
4978     char *dptr;
4979
4980     PERL_ARGS_ASSERT_SV_SETPVN;
4981
4982     SV_CHECK_THINKFIRST_COW_DROP(sv);
4983     if (!ptr) {
4984         (void)SvOK_off(sv);
4985         return;
4986     }
4987     else {
4988         /* len is STRLEN which is unsigned, need to copy to signed */
4989         const IV iv = len;
4990         if (iv < 0)
4991             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
4992                        IVdf, iv);
4993     }
4994     SvUPGRADE(sv, SVt_PV);
4995
4996     dptr = SvGROW(sv, len + 1);
4997     Move(ptr,dptr,len,char);
4998     dptr[len] = '\0';
4999     SvCUR_set(sv, len);
5000     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5001     SvTAINT(sv);
5002     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
5003 }
5004
5005 /*
5006 =for apidoc sv_setpvn_mg
5007
5008 Like C<sv_setpvn>, but also handles 'set' magic.
5009
5010 =cut
5011 */
5012
5013 void
5014 Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
5015 {
5016     PERL_ARGS_ASSERT_SV_SETPVN_MG;
5017
5018     sv_setpvn(sv,ptr,len);
5019     SvSETMAGIC(sv);
5020 }
5021
5022 /*
5023 =for apidoc sv_setpv
5024
5025 Copies a string into an SV.  The string must be terminated with a C<NUL>
5026 character, and not contain embeded C<NUL>'s.
5027 Does not handle 'set' magic.  See C<L</sv_setpv_mg>>.
5028
5029 =cut
5030 */
5031
5032 void
5033 Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
5034 {
5035     STRLEN len;
5036
5037     PERL_ARGS_ASSERT_SV_SETPV;
5038
5039     SV_CHECK_THINKFIRST_COW_DROP(sv);
5040     if (!ptr) {
5041         (void)SvOK_off(sv);
5042         return;
5043     }
5044     len = strlen(ptr);
5045     SvUPGRADE(sv, SVt_PV);
5046
5047     SvGROW(sv, len + 1);
5048     Move(ptr,SvPVX(sv),len+1,char);
5049     SvCUR_set(sv, len);
5050     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5051     SvTAINT(sv);
5052     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
5053 }
5054
5055 /*
5056 =for apidoc sv_setpv_mg
5057
5058 Like C<sv_setpv>, but also handles 'set' magic.
5059
5060 =cut
5061 */
5062
5063 void
5064 Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
5065 {
5066     PERL_ARGS_ASSERT_SV_SETPV_MG;
5067
5068     sv_setpv(sv,ptr);
5069     SvSETMAGIC(sv);
5070 }
5071
5072 void
5073 Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
5074 {
5075     PERL_ARGS_ASSERT_SV_SETHEK;
5076
5077     if (!hek) {
5078         return;
5079     }
5080
5081     if (HEK_LEN(hek) == HEf_SVKEY) {
5082         sv_setsv(sv, *(SV**)HEK_KEY(hek));
5083         return;
5084     } else {
5085         const int flags = HEK_FLAGS(hek);
5086         if (flags & HVhek_WASUTF8) {
5087             STRLEN utf8_len = HEK_LEN(hek);
5088             char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
5089             sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
5090             SvUTF8_on(sv);
5091             return;
5092         } else if (flags & HVhek_UNSHARED) {
5093             sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
5094             if (HEK_UTF8(hek))
5095                 SvUTF8_on(sv);
5096             else SvUTF8_off(sv);
5097             return;
5098         }
5099         {
5100             SV_CHECK_THINKFIRST_COW_DROP(sv);
5101             SvUPGRADE(sv, SVt_PV);
5102             SvPV_free(sv);
5103             SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
5104             SvCUR_set(sv, HEK_LEN(hek));
5105             SvLEN_set(sv, 0);
5106             SvIsCOW_on(sv);
5107             SvPOK_on(sv);
5108             if (HEK_UTF8(hek))
5109                 SvUTF8_on(sv);
5110             else SvUTF8_off(sv);
5111             return;
5112         }
5113     }
5114 }
5115
5116
5117 /*
5118 =for apidoc sv_usepvn_flags
5119
5120 Tells an SV to use C<ptr> to find its string value.  Normally the
5121 string is stored inside the SV, but sv_usepvn allows the SV to use an
5122 outside string.  C<ptr> should point to memory that was allocated
5123 by L<C<Newx>|perlclib/Memory Management and String Handling>.  It must be
5124 the start of a C<Newx>-ed block of memory, and not a pointer to the
5125 middle of it (beware of L<C<OOK>|perlguts/Offsets> and copy-on-write),
5126 and not be from a non-C<Newx> memory allocator like C<malloc>.  The
5127 string length, C<len>, must be supplied.  By default this function
5128 will C<Renew> (i.e. realloc, move) the memory pointed to by C<ptr>,
5129 so that pointer should not be freed or used by the programmer after
5130 giving it to C<sv_usepvn>, and neither should any pointers from "behind"
5131 that pointer (e.g. ptr + 1) be used.
5132
5133 If S<C<flags & SV_SMAGIC>> is true, will call C<SvSETMAGIC>.  If
5134 S<C<flags> & SV_HAS_TRAILING_NUL>> is true, then C<ptr[len]> must be C<NUL>,
5135 and the realloc
5136 will be skipped (i.e. the buffer is actually at least 1 byte longer than
5137 C<len>, and already meets the requirements for storing in C<SvPVX>).
5138
5139 =cut
5140 */
5141
5142 void
5143 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
5144 {
5145     STRLEN allocate;
5146
5147     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
5148
5149     SV_CHECK_THINKFIRST_COW_DROP(sv);
5150     SvUPGRADE(sv, SVt_PV);
5151     if (!ptr) {
5152         (void)SvOK_off(sv);
5153         if (flags & SV_SMAGIC)
5154             SvSETMAGIC(sv);
5155         return;
5156     }
5157     if (SvPVX_const(sv))
5158         SvPV_free(sv);
5159
5160 #ifdef DEBUGGING
5161     if (flags & SV_HAS_TRAILING_NUL)
5162         assert(ptr[len] == '\0');
5163 #endif
5164
5165     allocate = (flags & SV_HAS_TRAILING_NUL)
5166         ? len + 1 :
5167 #ifdef Perl_safesysmalloc_size
5168         len + 1;
5169 #else 
5170         PERL_STRLEN_ROUNDUP(len + 1);
5171 #endif
5172     if (flags & SV_HAS_TRAILING_NUL) {
5173         /* It's long enough - do nothing.
5174            Specifically Perl_newCONSTSUB is relying on this.  */
5175     } else {
5176 #ifdef DEBUGGING
5177         /* Force a move to shake out bugs in callers.  */
5178         char *new_ptr = (char*)safemalloc(allocate);
5179         Copy(ptr, new_ptr, len, char);
5180         PoisonFree(ptr,len,char);
5181         Safefree(ptr);
5182         ptr = new_ptr;
5183 #else
5184         ptr = (char*) saferealloc (ptr, allocate);
5185 #endif
5186     }
5187 #ifdef Perl_safesysmalloc_size
5188     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
5189 #else
5190     SvLEN_set(sv, allocate);
5191 #endif
5192     SvCUR_set(sv, len);
5193     SvPV_set(sv, ptr);
5194     if (!(flags & SV_HAS_TRAILING_NUL)) {
5195         ptr[len] = '\0';
5196     }
5197     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5198     SvTAINT(sv);
5199     if (flags & SV_SMAGIC)
5200         SvSETMAGIC(sv);
5201 }
5202
5203 /*
5204 =for apidoc sv_force_normal_flags
5205
5206 Undo various types of fakery on an SV, where fakery means
5207 "more than" a string: if the PV is a shared string, make
5208 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5209 an C<xpvmg>; if we're a copy-on-write scalar, this is the on-write time when
5210 we do the copy, and is also used locally; if this is a
5211 vstring, drop the vstring magic.  If C<SV_COW_DROP_PV> is set
5212 then a copy-on-write scalar drops its PV buffer (if any) and becomes
5213 C<SvPOK_off> rather than making a copy.  (Used where this
5214 scalar is about to be set to some other value.)  In addition,
5215 the C<flags> parameter gets passed to C<sv_unref_flags()>
5216 when unreffing.  C<sv_force_normal> calls this function
5217 with flags set to 0.
5218
5219 This function is expected to be used to signal to perl that this SV is
5220 about to be written to, and any extra book-keeping needs to be taken care
5221 of.  Hence, it croaks on read-only values.
5222
5223 =cut
5224 */
5225
5226 static void
5227 S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
5228 {
5229     assert(SvIsCOW(sv));
5230     {
5231 #ifdef PERL_ANY_COW
5232         const char * const pvx = SvPVX_const(sv);
5233         const STRLEN len = SvLEN(sv);
5234         const STRLEN cur = SvCUR(sv);
5235
5236         if (DEBUG_C_TEST) {
5237                 PerlIO_printf(Perl_debug_log,
5238                               "Copy on write: Force normal %ld\n",
5239                               (long) flags);
5240                 sv_dump(sv);
5241         }
5242         SvIsCOW_off(sv);
5243 # ifdef PERL_COPY_ON_WRITE
5244         if (len) {
5245             /* Must do this first, since the CowREFCNT uses SvPVX and
5246             we need to write to CowREFCNT, or de-RO the whole buffer if we are
5247             the only owner left of the buffer. */
5248             sv_buf_to_rw(sv); /* NOOP if RO-ing not supported */
5249             {
5250                 U8 cowrefcnt = CowREFCNT(sv);
5251                 if(cowrefcnt != 0) {
5252                     cowrefcnt--;
5253                     CowREFCNT(sv) = cowrefcnt;
5254                     sv_buf_to_ro(sv);
5255                     goto copy_over;
5256                 }
5257             }
5258             /* Else we are the only owner of the buffer. */
5259         }
5260         else
5261 # endif
5262         {
5263             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
5264             copy_over:
5265             SvPV_set(sv, NULL);
5266             SvCUR_set(sv, 0);
5267             SvLEN_set(sv, 0);
5268             if (flags & SV_COW_DROP_PV) {
5269                 /* OK, so we don't need to copy our buffer.  */
5270                 SvPOK_off(sv);
5271             } else {
5272                 SvGROW(sv, cur + 1);
5273                 Move(pvx,SvPVX(sv),cur,char);
5274                 SvCUR_set(sv, cur);
5275                 *SvEND(sv) = '\0';
5276             }
5277             if (len) {
5278             } else {
5279                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5280             }
5281             if (DEBUG_C_TEST) {
5282                 sv_dump(sv);
5283             }
5284         }
5285 #else
5286             const char * const pvx = SvPVX_const(sv);
5287             const STRLEN len = SvCUR(sv);
5288             SvIsCOW_off(sv);
5289             SvPV_set(sv, NULL);
5290             SvLEN_set(sv, 0);
5291             if (flags & SV_COW_DROP_PV) {
5292                 /* OK, so we don't need to copy our buffer.  */
5293                 SvPOK_off(sv);
5294             } else {
5295                 SvGROW(sv, len + 1);
5296                 Move(pvx,SvPVX(sv),len,char);
5297                 *SvEND(sv) = '\0';
5298             }
5299             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5300 #endif
5301     }
5302 }
5303
5304 void
5305 Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
5306 {
5307     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
5308
5309     if (SvREADONLY(sv))
5310         Perl_croak_no_modify();
5311     else if (SvIsCOW(sv) && LIKELY(SvTYPE(sv) != SVt_PVHV))
5312         S_sv_uncow(aTHX_ sv, flags);
5313     if (SvROK(sv))
5314         sv_unref_flags(sv, flags);
5315     else if (SvFAKE(sv) && isGV_with_GP(sv))
5316         sv_unglob(sv, flags);
5317     else if (SvFAKE(sv) && isREGEXP(sv)) {
5318         /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
5319            to sv_unglob. We only need it here, so inline it.  */
5320         const bool islv = SvTYPE(sv) == SVt_PVLV;
5321         const svtype new_type =
5322           islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
5323         SV *const temp = newSV_type(new_type);
5324         regexp *const temp_p = ReANY((REGEXP *)sv);
5325
5326         if (new_type == SVt_PVMG) {
5327             SvMAGIC_set(temp, SvMAGIC(sv));
5328             SvMAGIC_set(sv, NULL);
5329             SvSTASH_set(temp, SvSTASH(sv));
5330             SvSTASH_set(sv, NULL);
5331         }
5332         if (!islv) SvCUR_set(temp, SvCUR(sv));
5333         /* Remember that SvPVX is in the head, not the body.  But
5334            RX_WRAPPED is in the body. */
5335         assert(ReANY((REGEXP *)sv)->mother_re);
5336         /* Their buffer is already owned by someone else. */
5337         if (flags & SV_COW_DROP_PV) {
5338             /* SvLEN is already 0.  For SVt_REGEXP, we have a brand new
5339                zeroed body.  For SVt_PVLV, it should have been set to 0
5340                before turning into a regexp. */
5341             assert(!SvLEN(islv ? sv : temp));
5342             sv->sv_u.svu_pv = 0;
5343         }
5344         else {
5345             sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
5346             SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
5347             SvPOK_on(sv);
5348         }
5349
5350         /* Now swap the rest of the bodies. */
5351
5352         SvFAKE_off(sv);
5353         if (!islv) {
5354             SvFLAGS(sv) &= ~SVTYPEMASK;
5355             SvFLAGS(sv) |= new_type;
5356             SvANY(sv) = SvANY(temp);
5357         }
5358
5359         SvFLAGS(temp) &= ~(SVTYPEMASK);
5360         SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
5361         SvANY(temp) = temp_p;
5362         temp->sv_u.svu_rx = (regexp *)temp_p;
5363
5364         SvREFCNT_dec_NN(temp);
5365     }
5366     else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
5367 }
5368
5369 /*
5370 =for apidoc sv_chop
5371
5372 Efficient removal of characters from the beginning of the string buffer.
5373 C<SvPOK(sv)>, or at least C<SvPOKp(sv)>, must be true and C<ptr> must be a
5374 pointer to somewhere inside the string buffer.  C<ptr> becomes the first
5375 character of the adjusted string.  Uses the C<OOK> hack.  On return, only
5376 C<SvPOK(sv)> and C<SvPOKp(sv)> among the C<OK> flags will be true.
5377
5378 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
5379 refer to the same chunk of data.
5380
5381 The unfortunate similarity of this function's name to that of Perl's C<chop>
5382 operator is strictly coincidental.  This function works from the left;
5383 C<chop> works from the right.
5384
5385 =cut
5386 */
5387
5388 void
5389 Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
5390 {
5391     STRLEN delta;
5392     STRLEN old_delta;
5393     U8 *p;
5394 #ifdef DEBUGGING
5395     const U8 *evacp;
5396     STRLEN evacn;
5397 #endif
5398     STRLEN max_delta;
5399
5400     PERL_ARGS_ASSERT_SV_CHOP;
5401
5402     if (!ptr || !SvPOKp(sv))
5403         return;
5404     delta = ptr - SvPVX_const(sv);
5405     if (!delta) {
5406         /* Nothing to do.  */
5407         return;
5408     }
5409     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
5410     if (delta > max_delta)
5411         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
5412                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
5413     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
5414     SV_CHECK_THINKFIRST(sv);
5415     SvPOK_only_UTF8(sv);
5416
5417     if (!SvOOK(sv)) {
5418         if (!SvLEN(sv)) { /* make copy of shared string */
5419             const char *pvx = SvPVX_const(sv);
5420             const STRLEN len = SvCUR(sv);
5421             SvGROW(sv, len + 1);
5422             Move(pvx,SvPVX(sv),len,char);
5423             *SvEND(sv) = '\0';
5424         }
5425         SvOOK_on(sv);
5426         old_delta = 0;
5427     } else {
5428         SvOOK_offset(sv, old_delta);
5429     }
5430     SvLEN_set(sv, SvLEN(sv) - delta);
5431     SvCUR_set(sv, SvCUR(sv) - delta);
5432     SvPV_set(sv, SvPVX(sv) + delta);
5433
5434     p = (U8 *)SvPVX_const(sv);
5435
5436 #ifdef DEBUGGING
5437     /* how many bytes were evacuated?  we will fill them with sentinel
5438        bytes, except for the part holding the new offset of course. */
5439     evacn = delta;
5440     if (old_delta)
5441         evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
5442     assert(evacn);
5443     assert(evacn <= delta + old_delta);
5444     evacp = p - evacn;
5445 #endif
5446
5447     /* This sets 'delta' to the accumulated value of all deltas so far */
5448     delta += old_delta;
5449     assert(delta);
5450
5451     /* If 'delta' fits in a byte, store it just prior to the new beginning of
5452      * the string; otherwise store a 0 byte there and store 'delta' just prior
5453      * to that, using as many bytes as a STRLEN occupies.  Thus it overwrites a
5454      * portion of the chopped part of the string */
5455     if (delta < 0x100) {
5456         *--p = (U8) delta;
5457     } else {
5458         *--p = 0;
5459         p -= sizeof(STRLEN);
5460         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
5461     }
5462
5463 #ifdef DEBUGGING
5464     /* Fill the preceding buffer with sentinals to verify that no-one is
5465        using it.  */
5466     while (p > evacp) {
5467         --p;
5468         *p = (U8)PTR2UV(p);
5469     }
5470 #endif
5471 }
5472
5473 /*
5474 =for apidoc sv_catpvn
5475
5476 Concatenates the string onto the end of the string which is in the SV.
5477 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
5478 status set, then the bytes appended should be valid UTF-8.
5479 Handles 'get' magic, but not 'set' magic.  See C<L</sv_catpvn_mg>>.
5480
5481 =for apidoc sv_catpvn_flags
5482
5483 Concatenates the string onto the end of the string which is in the SV.  The
5484 C<len> indicates number of bytes to copy.
5485
5486 By default, the string appended is assumed to be valid UTF-8 if the SV has
5487 the UTF-8 status set, and a string of bytes otherwise.  One can force the
5488 appended string to be interpreted as UTF-8 by supplying the C<SV_CATUTF8>
5489 flag, and as bytes by supplying the C<SV_CATBYTES> flag; the SV or the
5490 string appended will be upgraded to UTF-8 if necessary.
5491
5492 If C<flags> has the C<SV_SMAGIC> bit set, will
5493 C<mg_set> on C<dsv> afterwards if appropriate.
5494 C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5495 in terms of this function.
5496
5497 =cut
5498 */
5499
5500 void
5501 Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
5502 {
5503     STRLEN dlen;
5504     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5505
5506     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5507     assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5508
5509     if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
5510       if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
5511          sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5512          dlen = SvCUR(dsv);
5513       }
5514       else SvGROW(dsv, dlen + slen + 3);
5515       if (sstr == dstr)
5516         sstr = SvPVX_const(dsv);
5517       Move(sstr, SvPVX(dsv) + dlen, slen, char);
5518       SvCUR_set(dsv, SvCUR(dsv) + slen);
5519     }
5520     else {
5521         /* We inline bytes_to_utf8, to avoid an extra malloc. */
5522         const char * const send = sstr + slen;
5523         U8 *d;
5524
5525         /* Something this code does not account for, which I think is
5526            impossible; it would require the same pv to be treated as
5527            bytes *and* utf8, which would indicate a bug elsewhere. */
5528         assert(sstr != dstr);
5529
5530         SvGROW(dsv, dlen + slen * 2 + 3);
5531         d = (U8 *)SvPVX(dsv) + dlen;
5532
5533         while (sstr < send) {
5534             append_utf8_from_native_byte(*sstr, &d);
5535             sstr++;
5536         }
5537         SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5538     }
5539     *SvEND(dsv) = '\0';
5540     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
5541     SvTAINT(dsv);
5542     if (flags & SV_SMAGIC)
5543         SvSETMAGIC(dsv);
5544 }
5545
5546 /*
5547 =for apidoc sv_catsv
5548
5549 Concatenates the string from SV C<ssv> onto the end of the string in SV
5550 C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5551 Handles 'get' magic on both SVs, but no 'set' magic.  See C<L</sv_catsv_mg>>
5552 and C<L</sv_catsv_nomg>>.
5553
5554 =for apidoc sv_catsv_flags
5555
5556 Concatenates the string from SV C<ssv> onto the end of the string in SV
5557 C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5558 If C<flags> has the C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if
5559 appropriate.  If C<flags> has the C<SV_SMAGIC> bit set, C<mg_set> will be called on
5560 the modified SV afterward, if appropriate.  C<sv_catsv>, C<sv_catsv_nomg>,
5561 and C<sv_catsv_mg> are implemented in terms of this function.
5562
5563 =cut */
5564
5565 void
5566 Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
5567 {
5568     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5569
5570     if (ssv) {
5571         STRLEN slen;
5572         const char *spv = SvPV_flags_const(ssv, slen, flags);
5573         if (flags & SV_GMAGIC)
5574                 SvGETMAGIC(dsv);
5575         sv_catpvn_flags(dsv, spv, slen,
5576                             DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
5577         if (flags & SV_SMAGIC)
5578                 SvSETMAGIC(dsv);
5579     }
5580 }
5581
5582 /*
5583 =for apidoc sv_catpv
5584
5585 Concatenates the C<NUL>-terminated string onto the end of the string which is
5586 in the SV.
5587 If the SV has the UTF-8 status set, then the bytes appended should be
5588 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See
5589 C<L</sv_catpv_mg>>.
5590
5591 =cut */
5592
5593 void
5594 Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
5595 {
5596     STRLEN len;
5597     STRLEN tlen;
5598     char *junk;
5599
5600     PERL_ARGS_ASSERT_SV_CATPV;
5601
5602     if (!ptr)
5603         return;
5604     junk = SvPV_force(sv, tlen);
5605     len = strlen(ptr);
5606     SvGROW(sv, tlen + len + 1);
5607