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