regcomp.c: Don't read outside array bound
[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 #ifndef HAS_C99
39 # if defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L && !defined(__VMS)
40 #  define HAS_C99 1
41 # endif
42 #endif
43 #ifdef HAS_C99
44 # include <stdint.h>
45 #endif
46
47 #ifdef __Lynx__
48 /* Missing proto on LynxOS */
49   char *gconvert(double, int, int,  char *);
50 #endif
51
52 #ifdef PERL_NEW_COPY_ON_WRITE
53 #   ifndef SV_COW_THRESHOLD
54 #    define SV_COW_THRESHOLD                    0   /* COW iff len > K */
55 #   endif
56 #   ifndef SV_COWBUF_THRESHOLD
57 #    define SV_COWBUF_THRESHOLD                 1250 /* COW iff len > K */
58 #   endif
59 #   ifndef SV_COW_MAX_WASTE_THRESHOLD
60 #    define SV_COW_MAX_WASTE_THRESHOLD          80   /* COW iff (len - cur) < K */
61 #   endif
62 #   ifndef SV_COWBUF_WASTE_THRESHOLD
63 #    define SV_COWBUF_WASTE_THRESHOLD           80   /* COW iff (len - cur) < K */
64 #   endif
65 #   ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD
66 #    define SV_COW_MAX_WASTE_FACTOR_THRESHOLD   2    /* COW iff len < (cur * K) */
67 #   endif
68 #   ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD
69 #    define SV_COWBUF_WASTE_FACTOR_THRESHOLD    2    /* COW iff len < (cur * K) */
70 #   endif
71 #endif
72 /* Work around compiler warnings about unsigned >= THRESHOLD when thres-
73    hold is 0. */
74 #if SV_COW_THRESHOLD
75 # define GE_COW_THRESHOLD(cur) ((cur) >= SV_COW_THRESHOLD)
76 #else
77 # define GE_COW_THRESHOLD(cur) 1
78 #endif
79 #if SV_COWBUF_THRESHOLD
80 # define GE_COWBUF_THRESHOLD(cur) ((cur) >= SV_COWBUF_THRESHOLD)
81 #else
82 # define GE_COWBUF_THRESHOLD(cur) 1
83 #endif
84 #if SV_COW_MAX_WASTE_THRESHOLD
85 # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COW_MAX_WASTE_THRESHOLD)
86 #else
87 # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) 1
88 #endif
89 #if SV_COWBUF_WASTE_THRESHOLD
90 # define GE_COWBUF_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COWBUF_WASTE_THRESHOLD)
91 #else
92 # define GE_COWBUF_WASTE_THRESHOLD(cur,len) 1
93 #endif
94 #if SV_COW_MAX_WASTE_FACTOR_THRESHOLD
95 # define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COW_MAX_WASTE_FACTOR_THRESHOLD * (cur))
96 #else
97 # define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) 1
98 #endif
99 #if SV_COWBUF_WASTE_FACTOR_THRESHOLD
100 # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COWBUF_WASTE_FACTOR_THRESHOLD * (cur))
101 #else
102 # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) 1
103 #endif
104
105 #define CHECK_COW_THRESHOLD(cur,len) (\
106     GE_COW_THRESHOLD((cur)) && \
107     GE_COW_MAX_WASTE_THRESHOLD((cur),(len)) && \
108     GE_COW_MAX_WASTE_FACTOR_THRESHOLD((cur),(len)) \
109 )
110 #define CHECK_COWBUF_THRESHOLD(cur,len) (\
111     GE_COWBUF_THRESHOLD((cur)) && \
112     GE_COWBUF_WASTE_THRESHOLD((cur),(len)) && \
113     GE_COWBUF_WASTE_FACTOR_THRESHOLD((cur),(len)) \
114 )
115 /* void Gconvert: on Linux at least, gcvt (which Gconvert gets deffed to),
116  * has a mandatory return value, even though that value is just the same
117  * as the buf arg */
118
119 #ifdef PERL_UTF8_CACHE_ASSERT
120 /* if adding more checks watch out for the following tests:
121  *   t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
122  *   lib/utf8.t lib/Unicode/Collate/t/index.t
123  * --jhi
124  */
125 #   define ASSERT_UTF8_CACHE(cache) \
126     STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
127                               assert((cache)[2] <= (cache)[3]); \
128                               assert((cache)[3] <= (cache)[1]);} \
129                               } STMT_END
130 #else
131 #   define ASSERT_UTF8_CACHE(cache) NOOP
132 #endif
133
134 #ifdef PERL_OLD_COPY_ON_WRITE
135 #define SV_COW_NEXT_SV(sv)      INT2PTR(SV *,SvUVX(sv))
136 #define SV_COW_NEXT_SV_SET(current,next)        SvUV_set(current, PTR2UV(next))
137 #endif
138
139 /* ============================================================================
140
141 =head1 Allocation and deallocation of SVs.
142 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
143 sv, av, hv...) contains type and reference count information, and for
144 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
145 contains fields specific to each type.  Some types store all they need
146 in the head, so don't have a body.
147
148 In all but the most memory-paranoid configurations (ex: PURIFY), heads
149 and bodies are allocated out of arenas, which by default are
150 approximately 4K chunks of memory parcelled up into N heads or bodies.
151 Sv-bodies are allocated by their sv-type, guaranteeing size
152 consistency needed to allocate safely from arrays.
153
154 For SV-heads, the first slot in each arena is reserved, and holds a
155 link to the next arena, some flags, and a note of the number of slots.
156 Snaked through each arena chain is a linked list of free items; when
157 this becomes empty, an extra arena is allocated and divided up into N
158 items which are threaded into the free list.
159
160 SV-bodies are similar, but they use arena-sets by default, which
161 separate the link and info from the arena itself, and reclaim the 1st
162 slot in the arena.  SV-bodies are further described later.
163
164 The following global variables are associated with arenas:
165
166  PL_sv_arenaroot     pointer to list of SV arenas
167  PL_sv_root          pointer to list of free SV structures
168
169  PL_body_arenas      head of linked-list of body arenas
170  PL_body_roots[]     array of pointers to list of free bodies of svtype
171                      arrays are indexed by the svtype needed
172
173 A few special SV heads are not allocated from an arena, but are
174 instead directly created in the interpreter structure, eg PL_sv_undef.
175 The size of arenas can be changed from the default by setting
176 PERL_ARENA_SIZE appropriately at compile time.
177
178 The SV arena serves the secondary purpose of allowing still-live SVs
179 to be located and destroyed during final cleanup.
180
181 At the lowest level, the macros new_SV() and del_SV() grab and free
182 an SV head.  (If debugging with -DD, del_SV() calls the function S_del_sv()
183 to return the SV to the free list with error checking.) new_SV() calls
184 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
185 SVs in the free list have their SvTYPE field set to all ones.
186
187 At the time of very final cleanup, sv_free_arenas() is called from
188 perl_destruct() to physically free all the arenas allocated since the
189 start of the interpreter.
190
191 The function visit() scans the SV arenas list, and calls a specified
192 function for each SV it finds which is still live - ie which has an SvTYPE
193 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
194 following functions (specified as [function that calls visit()] / [function
195 called by visit() for each SV]):
196
197     sv_report_used() / do_report_used()
198                         dump all remaining SVs (debugging aid)
199
200     sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
201                       do_clean_named_io_objs(),do_curse()
202                         Attempt to free all objects pointed to by RVs,
203                         try to do the same for all objects indir-
204                         ectly referenced by typeglobs too, and
205                         then do a final sweep, cursing any
206                         objects that remain.  Called once from
207                         perl_destruct(), prior to calling sv_clean_all()
208                         below.
209
210     sv_clean_all() / do_clean_all()
211                         SvREFCNT_dec(sv) each remaining SV, possibly
212                         triggering an sv_free(). It also sets the
213                         SVf_BREAK flag on the SV to indicate that the
214                         refcnt has been artificially lowered, and thus
215                         stopping sv_free() from giving spurious warnings
216                         about SVs which unexpectedly have a refcnt
217                         of zero.  called repeatedly from perl_destruct()
218                         until there are no SVs left.
219
220 =head2 Arena allocator API Summary
221
222 Private API to rest of sv.c
223
224     new_SV(),  del_SV(),
225
226     new_XPVNV(), del_XPVGV(),
227     etc
228
229 Public API:
230
231     sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
232
233 =cut
234
235  * ========================================================================= */
236
237 /*
238  * "A time to plant, and a time to uproot what was planted..."
239  */
240
241 #ifdef PERL_MEM_LOG
242 #  define MEM_LOG_NEW_SV(sv, file, line, func)  \
243             Perl_mem_log_new_sv(sv, file, line, func)
244 #  define MEM_LOG_DEL_SV(sv, file, line, func)  \
245             Perl_mem_log_del_sv(sv, file, line, func)
246 #else
247 #  define MEM_LOG_NEW_SV(sv, file, line, func)  NOOP
248 #  define MEM_LOG_DEL_SV(sv, file, line, func)  NOOP
249 #endif
250
251 #ifdef DEBUG_LEAKING_SCALARS
252 #  define FREE_SV_DEBUG_FILE(sv) STMT_START { \
253         if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \
254     } STMT_END
255 #  define DEBUG_SV_SERIAL(sv)                                               \
256     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n",    \
257             PTR2UV(sv), (long)(sv)->sv_debug_serial))
258 #else
259 #  define FREE_SV_DEBUG_FILE(sv)
260 #  define DEBUG_SV_SERIAL(sv)   NOOP
261 #endif
262
263 #ifdef PERL_POISON
264 #  define SvARENA_CHAIN(sv)     ((sv)->sv_u.svu_rv)
265 #  define SvARENA_CHAIN_SET(sv,val)     (sv)->sv_u.svu_rv = MUTABLE_SV((val))
266 /* Whilst I'd love to do this, it seems that things like to check on
267    unreferenced scalars
268 #  define POSION_SV_HEAD(sv)    PoisonNew(sv, 1, struct STRUCT_SV)
269 */
270 #  define POSION_SV_HEAD(sv)    PoisonNew(&SvANY(sv), 1, void *), \
271                                 PoisonNew(&SvREFCNT(sv), 1, U32)
272 #else
273 #  define SvARENA_CHAIN(sv)     SvANY(sv)
274 #  define SvARENA_CHAIN_SET(sv,val)     SvANY(sv) = (void *)(val)
275 #  define POSION_SV_HEAD(sv)
276 #endif
277
278 /* Mark an SV head as unused, and add to free list.
279  *
280  * If SVf_BREAK is set, skip adding it to the free list, as this SV had
281  * its refcount artificially decremented during global destruction, so
282  * there may be dangling pointers to it. The last thing we want in that
283  * case is for it to be reused. */
284
285 #define plant_SV(p) \
286     STMT_START {                                        \
287         const U32 old_flags = SvFLAGS(p);                       \
288         MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__);  \
289         DEBUG_SV_SERIAL(p);                             \
290         FREE_SV_DEBUG_FILE(p);                          \
291         POSION_SV_HEAD(p);                              \
292         SvFLAGS(p) = SVTYPEMASK;                        \
293         if (!(old_flags & SVf_BREAK)) {         \
294             SvARENA_CHAIN_SET(p, PL_sv_root);   \
295             PL_sv_root = (p);                           \
296         }                                               \
297         --PL_sv_count;                                  \
298     } STMT_END
299
300 #define uproot_SV(p) \
301     STMT_START {                                        \
302         (p) = PL_sv_root;                               \
303         PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p));              \
304         ++PL_sv_count;                                  \
305     } STMT_END
306
307
308 /* make some more SVs by adding another arena */
309
310 STATIC SV*
311 S_more_sv(pTHX)
312 {
313     SV* sv;
314     char *chunk;                /* must use New here to match call to */
315     Newx(chunk,PERL_ARENA_SIZE,char);  /* Safefree() in sv_free_arenas() */
316     sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
317     uproot_SV(sv);
318     return sv;
319 }
320
321 /* new_SV(): return a new, empty SV head */
322
323 #ifdef DEBUG_LEAKING_SCALARS
324 /* provide a real function for a debugger to play with */
325 STATIC SV*
326 S_new_SV(pTHX_ const char *file, int line, const char *func)
327 {
328     SV* sv;
329
330     if (PL_sv_root)
331         uproot_SV(sv);
332     else
333         sv = S_more_sv(aTHX);
334     SvANY(sv) = 0;
335     SvREFCNT(sv) = 1;
336     SvFLAGS(sv) = 0;
337     sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
338     sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
339                 ? PL_parser->copline
340                 :  PL_curcop
341                     ? CopLINE(PL_curcop)
342                     : 0
343             );
344     sv->sv_debug_inpad = 0;
345     sv->sv_debug_parent = NULL;
346     sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
347
348     sv->sv_debug_serial = PL_sv_serial++;
349
350     MEM_LOG_NEW_SV(sv, file, line, func);
351     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
352             PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
353
354     return sv;
355 }
356 #  define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
357
358 #else
359 #  define new_SV(p) \
360     STMT_START {                                        \
361         if (PL_sv_root)                                 \
362             uproot_SV(p);                               \
363         else                                            \
364             (p) = S_more_sv(aTHX);                      \
365         SvANY(p) = 0;                                   \
366         SvREFCNT(p) = 1;                                \
367         SvFLAGS(p) = 0;                                 \
368         MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__);  \
369     } STMT_END
370 #endif
371
372
373 /* del_SV(): return an empty SV head to the free list */
374
375 #ifdef DEBUGGING
376
377 #define del_SV(p) \
378     STMT_START {                                        \
379         if (DEBUG_D_TEST)                               \
380             del_sv(p);                                  \
381         else                                            \
382             plant_SV(p);                                \
383     } STMT_END
384
385 STATIC void
386 S_del_sv(pTHX_ SV *p)
387 {
388     PERL_ARGS_ASSERT_DEL_SV;
389
390     if (DEBUG_D_TEST) {
391         SV* sva;
392         bool ok = 0;
393         for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
394             const SV * const sv = sva + 1;
395             const SV * const svend = &sva[SvREFCNT(sva)];
396             if (p >= sv && p < svend) {
397                 ok = 1;
398                 break;
399             }
400         }
401         if (!ok) {
402             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
403                              "Attempt to free non-arena SV: 0x%"UVxf
404                              pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
405             return;
406         }
407     }
408     plant_SV(p);
409 }
410
411 #else /* ! DEBUGGING */
412
413 #define del_SV(p)   plant_SV(p)
414
415 #endif /* DEBUGGING */
416
417
418 /*
419 =head1 SV Manipulation Functions
420
421 =for apidoc sv_add_arena
422
423 Given a chunk of memory, link it to the head of the list of arenas,
424 and split it into a list of free SVs.
425
426 =cut
427 */
428
429 static void
430 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
431 {
432     SV *const sva = MUTABLE_SV(ptr);
433     SV* sv;
434     SV* svend;
435
436     PERL_ARGS_ASSERT_SV_ADD_ARENA;
437
438     /* The first SV in an arena isn't an SV. */
439     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
440     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
441     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
442
443     PL_sv_arenaroot = sva;
444     PL_sv_root = sva + 1;
445
446     svend = &sva[SvREFCNT(sva) - 1];
447     sv = sva + 1;
448     while (sv < svend) {
449         SvARENA_CHAIN_SET(sv, (sv + 1));
450 #ifdef DEBUGGING
451         SvREFCNT(sv) = 0;
452 #endif
453         /* Must always set typemask because it's always checked in on cleanup
454            when the arenas are walked looking for objects.  */
455         SvFLAGS(sv) = SVTYPEMASK;
456         sv++;
457     }
458     SvARENA_CHAIN_SET(sv, 0);
459 #ifdef DEBUGGING
460     SvREFCNT(sv) = 0;
461 #endif
462     SvFLAGS(sv) = SVTYPEMASK;
463 }
464
465 /* visit(): call the named function for each non-free SV in the arenas
466  * whose flags field matches the flags/mask args. */
467
468 STATIC I32
469 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
470 {
471     SV* sva;
472     I32 visited = 0;
473
474     PERL_ARGS_ASSERT_VISIT;
475
476     for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
477         const SV * const svend = &sva[SvREFCNT(sva)];
478         SV* sv;
479         for (sv = sva + 1; sv < svend; ++sv) {
480             if (SvTYPE(sv) != (svtype)SVTYPEMASK
481                     && (sv->sv_flags & mask) == flags
482                     && SvREFCNT(sv))
483             {
484                 (*f)(aTHX_ sv);
485                 ++visited;
486             }
487         }
488     }
489     return visited;
490 }
491
492 #ifdef DEBUGGING
493
494 /* called by sv_report_used() for each live SV */
495
496 static void
497 do_report_used(pTHX_ SV *const sv)
498 {
499     if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
500         PerlIO_printf(Perl_debug_log, "****\n");
501         sv_dump(sv);
502     }
503 }
504 #endif
505
506 /*
507 =for apidoc sv_report_used
508
509 Dump the contents of all SVs not yet freed (debugging aid).
510
511 =cut
512 */
513
514 void
515 Perl_sv_report_used(pTHX)
516 {
517 #ifdef DEBUGGING
518     visit(do_report_used, 0, 0);
519 #else
520     PERL_UNUSED_CONTEXT;
521 #endif
522 }
523
524 /* called by sv_clean_objs() for each live SV */
525
526 static void
527 do_clean_objs(pTHX_ SV *const ref)
528 {
529     assert (SvROK(ref));
530     {
531         SV * const target = SvRV(ref);
532         if (SvOBJECT(target)) {
533             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
534             if (SvWEAKREF(ref)) {
535                 sv_del_backref(target, ref);
536                 SvWEAKREF_off(ref);
537                 SvRV_set(ref, NULL);
538             } else {
539                 SvROK_off(ref);
540                 SvRV_set(ref, NULL);
541                 SvREFCNT_dec_NN(target);
542             }
543         }
544     }
545 }
546
547
548 /* clear any slots in a GV which hold objects - except IO;
549  * called by sv_clean_objs() for each live GV */
550
551 static void
552 do_clean_named_objs(pTHX_ SV *const sv)
553 {
554     SV *obj;
555     assert(SvTYPE(sv) == SVt_PVGV);
556     assert(isGV_with_GP(sv));
557     if (!GvGP(sv))
558         return;
559
560     /* freeing GP entries may indirectly free the current GV;
561      * hold onto it while we mess with the GP slots */
562     SvREFCNT_inc(sv);
563
564     if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
565         DEBUG_D((PerlIO_printf(Perl_debug_log,
566                 "Cleaning named glob SV object:\n "), sv_dump(obj)));
567         GvSV(sv) = NULL;
568         SvREFCNT_dec_NN(obj);
569     }
570     if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
571         DEBUG_D((PerlIO_printf(Perl_debug_log,
572                 "Cleaning named glob AV object:\n "), sv_dump(obj)));
573         GvAV(sv) = NULL;
574         SvREFCNT_dec_NN(obj);
575     }
576     if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
577         DEBUG_D((PerlIO_printf(Perl_debug_log,
578                 "Cleaning named glob HV object:\n "), sv_dump(obj)));
579         GvHV(sv) = NULL;
580         SvREFCNT_dec_NN(obj);
581     }
582     if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
583         DEBUG_D((PerlIO_printf(Perl_debug_log,
584                 "Cleaning named glob CV object:\n "), sv_dump(obj)));
585         GvCV_set(sv, NULL);
586         SvREFCNT_dec_NN(obj);
587     }
588     SvREFCNT_dec_NN(sv); /* undo the inc above */
589 }
590
591 /* clear any IO slots in a GV which hold objects (except stderr, defout);
592  * called by sv_clean_objs() for each live GV */
593
594 static void
595 do_clean_named_io_objs(pTHX_ SV *const sv)
596 {
597     SV *obj;
598     assert(SvTYPE(sv) == SVt_PVGV);
599     assert(isGV_with_GP(sv));
600     if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
601         return;
602
603     SvREFCNT_inc(sv);
604     if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
605         DEBUG_D((PerlIO_printf(Perl_debug_log,
606                 "Cleaning named glob IO object:\n "), sv_dump(obj)));
607         GvIOp(sv) = NULL;
608         SvREFCNT_dec_NN(obj);
609     }
610     SvREFCNT_dec_NN(sv); /* undo the inc above */
611 }
612
613 /* Void wrapper to pass to visit() */
614 static void
615 do_curse(pTHX_ SV * const sv) {
616     if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
617      || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
618         return;
619     (void)curse(sv, 0);
620 }
621
622 /*
623 =for apidoc sv_clean_objs
624
625 Attempt to destroy all objects not yet freed.
626
627 =cut
628 */
629
630 void
631 Perl_sv_clean_objs(pTHX)
632 {
633     GV *olddef, *olderr;
634     PL_in_clean_objs = TRUE;
635     visit(do_clean_objs, SVf_ROK, SVf_ROK);
636     /* Some barnacles may yet remain, clinging to typeglobs.
637      * Run the non-IO destructors first: they may want to output
638      * error messages, close files etc */
639     visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
640     visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
641     /* And if there are some very tenacious barnacles clinging to arrays,
642        closures, or what have you.... */
643     visit(do_curse, SVs_OBJECT, SVs_OBJECT);
644     olddef = PL_defoutgv;
645     PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
646     if (olddef && isGV_with_GP(olddef))
647         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
648     olderr = PL_stderrgv;
649     PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
650     if (olderr && isGV_with_GP(olderr))
651         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
652     SvREFCNT_dec(olddef);
653     PL_in_clean_objs = FALSE;
654 }
655
656 /* called by sv_clean_all() for each live SV */
657
658 static void
659 do_clean_all(pTHX_ SV *const sv)
660 {
661     if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
662         /* don't clean pid table and strtab */
663         return;
664     }
665     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
666     SvFLAGS(sv) |= SVf_BREAK;
667     SvREFCNT_dec_NN(sv);
668 }
669
670 /*
671 =for apidoc sv_clean_all
672
673 Decrement the refcnt of each remaining SV, possibly triggering a
674 cleanup.  This function may have to be called multiple times to free
675 SVs which are in complex self-referential hierarchies.
676
677 =cut
678 */
679
680 I32
681 Perl_sv_clean_all(pTHX)
682 {
683     I32 cleaned;
684     PL_in_clean_all = TRUE;
685     cleaned = visit(do_clean_all, 0,0);
686     return cleaned;
687 }
688
689 /*
690   ARENASETS: a meta-arena implementation which separates arena-info
691   into struct arena_set, which contains an array of struct
692   arena_descs, each holding info for a single arena.  By separating
693   the meta-info from the arena, we recover the 1st slot, formerly
694   borrowed for list management.  The arena_set is about the size of an
695   arena, avoiding the needless malloc overhead of a naive linked-list.
696
697   The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
698   memory in the last arena-set (1/2 on average).  In trade, we get
699   back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
700   smaller types).  The recovery of the wasted space allows use of
701   small arenas for large, rare body types, by changing array* fields
702   in body_details_by_type[] below.
703 */
704 struct arena_desc {
705     char       *arena;          /* the raw storage, allocated aligned */
706     size_t      size;           /* its size ~4k typ */
707     svtype      utype;          /* bodytype stored in arena */
708 };
709
710 struct arena_set;
711
712 /* Get the maximum number of elements in set[] such that struct arena_set
713    will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
714    therefore likely to be 1 aligned memory page.  */
715
716 #define ARENAS_PER_SET  ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
717                           - 2 * sizeof(int)) / sizeof (struct arena_desc))
718
719 struct arena_set {
720     struct arena_set* next;
721     unsigned int   set_size;    /* ie ARENAS_PER_SET */
722     unsigned int   curr;        /* index of next available arena-desc */
723     struct arena_desc set[ARENAS_PER_SET];
724 };
725
726 /*
727 =for apidoc sv_free_arenas
728
729 Deallocate the memory used by all arenas.  Note that all the individual SV
730 heads and bodies within the arenas must already have been freed.
731
732 =cut
733
734 */
735 void
736 Perl_sv_free_arenas(pTHX)
737 {
738     SV* sva;
739     SV* svanext;
740     unsigned int i;
741
742     /* Free arenas here, but be careful about fake ones.  (We assume
743        contiguity of the fake ones with the corresponding real ones.) */
744
745     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
746         svanext = MUTABLE_SV(SvANY(sva));
747         while (svanext && SvFAKE(svanext))
748             svanext = MUTABLE_SV(SvANY(svanext));
749
750         if (!SvFAKE(sva))
751             Safefree(sva);
752     }
753
754     {
755         struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
756
757         while (aroot) {
758             struct arena_set *current = aroot;
759             i = aroot->curr;
760             while (i--) {
761                 assert(aroot->set[i].arena);
762                 Safefree(aroot->set[i].arena);
763             }
764             aroot = aroot->next;
765             Safefree(current);
766         }
767     }
768     PL_body_arenas = 0;
769
770     i = PERL_ARENA_ROOTS_SIZE;
771     while (i--)
772         PL_body_roots[i] = 0;
773
774     PL_sv_arenaroot = 0;
775     PL_sv_root = 0;
776 }
777
778 /*
779   Here are mid-level routines that manage the allocation of bodies out
780   of the various arenas.  There are 5 kinds of arenas:
781
782   1. SV-head arenas, which are discussed and handled above
783   2. regular body arenas
784   3. arenas for reduced-size bodies
785   4. Hash-Entry arenas
786
787   Arena types 2 & 3 are chained by body-type off an array of
788   arena-root pointers, which is indexed by svtype.  Some of the
789   larger/less used body types are malloced singly, since a large
790   unused block of them is wasteful.  Also, several svtypes dont have
791   bodies; the data fits into the sv-head itself.  The arena-root
792   pointer thus has a few unused root-pointers (which may be hijacked
793   later for arena types 4,5)
794
795   3 differs from 2 as an optimization; some body types have several
796   unused fields in the front of the structure (which are kept in-place
797   for consistency).  These bodies can be allocated in smaller chunks,
798   because the leading fields arent accessed.  Pointers to such bodies
799   are decremented to point at the unused 'ghost' memory, knowing that
800   the pointers are used with offsets to the real memory.
801
802
803 =head1 SV-Body Allocation
804
805 =cut
806
807 Allocation of SV-bodies is similar to SV-heads, differing as follows;
808 the allocation mechanism is used for many body types, so is somewhat
809 more complicated, it uses arena-sets, and has no need for still-live
810 SV detection.
811
812 At the outermost level, (new|del)_X*V macros return bodies of the
813 appropriate type.  These macros call either (new|del)_body_type or
814 (new|del)_body_allocated macro pairs, depending on specifics of the
815 type.  Most body types use the former pair, the latter pair is used to
816 allocate body types with "ghost fields".
817
818 "ghost fields" are fields that are unused in certain types, and
819 consequently don't need to actually exist.  They are declared because
820 they're part of a "base type", which allows use of functions as
821 methods.  The simplest examples are AVs and HVs, 2 aggregate types
822 which don't use the fields which support SCALAR semantics.
823
824 For these types, the arenas are carved up into appropriately sized
825 chunks, we thus avoid wasted memory for those unaccessed members.
826 When bodies are allocated, we adjust the pointer back in memory by the
827 size of the part not allocated, so it's as if we allocated the full
828 structure.  (But things will all go boom if you write to the part that
829 is "not there", because you'll be overwriting the last members of the
830 preceding structure in memory.)
831
832 We calculate the correction using the STRUCT_OFFSET macro on the first
833 member present.  If the allocated structure is smaller (no initial NV
834 actually allocated) then the net effect is to subtract the size of the NV
835 from the pointer, to return a new pointer as if an initial NV were actually
836 allocated.  (We were using structures named *_allocated for this, but
837 this turned out to be a subtle bug, because a structure without an NV
838 could have a lower alignment constraint, but the compiler is allowed to
839 optimised accesses based on the alignment constraint of the actual pointer
840 to the full structure, for example, using a single 64 bit load instruction
841 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
842
843 This is the same trick as was used for NV and IV bodies.  Ironically it
844 doesn't need to be used for NV bodies any more, because NV is now at
845 the start of the structure.  IV bodies don't need it either, because
846 they are no longer allocated.
847
848 In turn, the new_body_* allocators call S_new_body(), which invokes
849 new_body_inline macro, which takes a lock, and takes a body off the
850 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
851 necessary to refresh an empty list.  Then the lock is released, and
852 the body is returned.
853
854 Perl_more_bodies allocates a new arena, and carves it up into an array of N
855 bodies, which it strings into a linked list.  It looks up arena-size
856 and body-size from the body_details table described below, thus
857 supporting the multiple body-types.
858
859 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
860 the (new|del)_X*V macros are mapped directly to malloc/free.
861
862 For each sv-type, struct body_details bodies_by_type[] carries
863 parameters which control these aspects of SV handling:
864
865 Arena_size determines whether arenas are used for this body type, and if
866 so, how big they are.  PURIFY or PERL_ARENA_SIZE=0 set this field to
867 zero, forcing individual mallocs and frees.
868
869 Body_size determines how big a body is, and therefore how many fit into
870 each arena.  Offset carries the body-pointer adjustment needed for
871 "ghost fields", and is used in *_allocated macros.
872
873 But its main purpose is to parameterize info needed in
874 Perl_sv_upgrade().  The info here dramatically simplifies the function
875 vs the implementation in 5.8.8, making it table-driven.  All fields
876 are used for this, except for arena_size.
877
878 For the sv-types that have no bodies, arenas are not used, so those
879 PL_body_roots[sv_type] are unused, and can be overloaded.  In
880 something of a special case, SVt_NULL is borrowed for HE arenas;
881 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
882 bodies_by_type[SVt_NULL] slot is not used, as the table is not
883 available in hv.c.
884
885 */
886
887 struct body_details {
888     U8 body_size;       /* Size to allocate  */
889     U8 copy;            /* Size of structure to copy (may be shorter)  */
890     U8 offset;
891     unsigned int type : 4;          /* We have space for a sanity check.  */
892     unsigned int cant_upgrade : 1;  /* Cannot upgrade this type */
893     unsigned int zero_nv : 1;       /* zero the NV when upgrading from this */
894     unsigned int arena : 1;         /* Allocated from an arena */
895     size_t arena_size;              /* Size of arena to allocate */
896 };
897
898 #define HADNV FALSE
899 #define NONV TRUE
900
901
902 #ifdef PURIFY
903 /* With -DPURFIY we allocate everything directly, and don't use arenas.
904    This seems a rather elegant way to simplify some of the code below.  */
905 #define HASARENA FALSE
906 #else
907 #define HASARENA TRUE
908 #endif
909 #define NOARENA FALSE
910
911 /* Size the arenas to exactly fit a given number of bodies.  A count
912    of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
913    simplifying the default.  If count > 0, the arena is sized to fit
914    only that many bodies, allowing arenas to be used for large, rare
915    bodies (XPVFM, XPVIO) without undue waste.  The arena size is
916    limited by PERL_ARENA_SIZE, so we can safely oversize the
917    declarations.
918  */
919 #define FIT_ARENA0(body_size)                           \
920     ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
921 #define FIT_ARENAn(count,body_size)                     \
922     ( count * body_size <= PERL_ARENA_SIZE)             \
923     ? count * body_size                                 \
924     : FIT_ARENA0 (body_size)
925 #define FIT_ARENA(count,body_size)                      \
926     count                                               \
927     ? FIT_ARENAn (count, body_size)                     \
928     : FIT_ARENA0 (body_size)
929
930 /* Calculate the length to copy. Specifically work out the length less any
931    final padding the compiler needed to add.  See the comment in sv_upgrade
932    for why copying the padding proved to be a bug.  */
933
934 #define copy_length(type, last_member) \
935         STRUCT_OFFSET(type, last_member) \
936         + sizeof (((type*)SvANY((const SV *)0))->last_member)
937
938 static const struct body_details bodies_by_type[] = {
939     /* HEs use this offset for their arena.  */
940     { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
941
942     /* IVs are in the head, so the allocation size is 0.  */
943     { 0,
944       sizeof(IV), /* This is used to copy out the IV body.  */
945       STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
946       NOARENA /* IVS don't need an arena  */, 0
947     },
948
949     { sizeof(NV), sizeof(NV),
950       STRUCT_OFFSET(XPVNV, xnv_u),
951       SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
952
953     { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
954       copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
955       + STRUCT_OFFSET(XPV, xpv_cur),
956       SVt_PV, FALSE, NONV, HASARENA,
957       FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
958
959     { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur),
960       copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur),
961       + STRUCT_OFFSET(XPV, xpv_cur),
962       SVt_INVLIST, TRUE, NONV, HASARENA,
963       FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) },
964
965     { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
966       copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
967       + STRUCT_OFFSET(XPV, xpv_cur),
968       SVt_PVIV, FALSE, NONV, HASARENA,
969       FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
970
971     { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
972       copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
973       + STRUCT_OFFSET(XPV, xpv_cur),
974       SVt_PVNV, FALSE, HADNV, HASARENA,
975       FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
976
977     { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
978       HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
979
980     { sizeof(regexp),
981       sizeof(regexp),
982       0,
983       SVt_REGEXP, TRUE, NONV, HASARENA,
984       FIT_ARENA(0, sizeof(regexp))
985     },
986
987     { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
988       HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
989     
990     { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
991       HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
992
993     { sizeof(XPVAV),
994       copy_length(XPVAV, xav_alloc),
995       0,
996       SVt_PVAV, TRUE, NONV, HASARENA,
997       FIT_ARENA(0, sizeof(XPVAV)) },
998
999     { sizeof(XPVHV),
1000       copy_length(XPVHV, xhv_max),
1001       0,
1002       SVt_PVHV, TRUE, NONV, HASARENA,
1003       FIT_ARENA(0, sizeof(XPVHV)) },
1004
1005     { sizeof(XPVCV),
1006       sizeof(XPVCV),
1007       0,
1008       SVt_PVCV, TRUE, NONV, HASARENA,
1009       FIT_ARENA(0, sizeof(XPVCV)) },
1010
1011     { sizeof(XPVFM),
1012       sizeof(XPVFM),
1013       0,
1014       SVt_PVFM, TRUE, NONV, NOARENA,
1015       FIT_ARENA(20, sizeof(XPVFM)) },
1016
1017     { sizeof(XPVIO),
1018       sizeof(XPVIO),
1019       0,
1020       SVt_PVIO, TRUE, NONV, HASARENA,
1021       FIT_ARENA(24, sizeof(XPVIO)) },
1022 };
1023
1024 #define new_body_allocated(sv_type)             \
1025     (void *)((char *)S_new_body(aTHX_ sv_type)  \
1026              - bodies_by_type[sv_type].offset)
1027
1028 /* return a thing to the free list */
1029
1030 #define del_body(thing, root)                           \
1031     STMT_START {                                        \
1032         void ** const thing_copy = (void **)thing;      \
1033         *thing_copy = *root;                            \
1034         *root = (void*)thing_copy;                      \
1035     } STMT_END
1036
1037 #ifdef PURIFY
1038
1039 #define new_XNV()       safemalloc(sizeof(XPVNV))
1040 #define new_XPVNV()     safemalloc(sizeof(XPVNV))
1041 #define new_XPVMG()     safemalloc(sizeof(XPVMG))
1042
1043 #define del_XPVGV(p)    safefree(p)
1044
1045 #else /* !PURIFY */
1046
1047 #define new_XNV()       new_body_allocated(SVt_NV)
1048 #define new_XPVNV()     new_body_allocated(SVt_PVNV)
1049 #define new_XPVMG()     new_body_allocated(SVt_PVMG)
1050
1051 #define del_XPVGV(p)    del_body(p + bodies_by_type[SVt_PVGV].offset,   \
1052                                  &PL_body_roots[SVt_PVGV])
1053
1054 #endif /* PURIFY */
1055
1056 /* no arena for you! */
1057
1058 #define new_NOARENA(details) \
1059         safemalloc((details)->body_size + (details)->offset)
1060 #define new_NOARENAZ(details) \
1061         safecalloc((details)->body_size + (details)->offset, 1)
1062
1063 void *
1064 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
1065                   const size_t arena_size)
1066 {
1067     void ** const root = &PL_body_roots[sv_type];
1068     struct arena_desc *adesc;
1069     struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1070     unsigned int curr;
1071     char *start;
1072     const char *end;
1073     const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1074 #if defined(DEBUGGING) && defined(PERL_GLOBAL_STRUCT)
1075     dVAR;
1076 #endif
1077 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1078     static bool done_sanity_check;
1079
1080     /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1081      * variables like done_sanity_check. */
1082     if (!done_sanity_check) {
1083         unsigned int i = SVt_LAST;
1084
1085         done_sanity_check = TRUE;
1086
1087         while (i--)
1088             assert (bodies_by_type[i].type == i);
1089     }
1090 #endif
1091
1092     assert(arena_size);
1093
1094     /* may need new arena-set to hold new arena */
1095     if (!aroot || aroot->curr >= aroot->set_size) {
1096         struct arena_set *newroot;
1097         Newxz(newroot, 1, struct arena_set);
1098         newroot->set_size = ARENAS_PER_SET;
1099         newroot->next = aroot;
1100         aroot = newroot;
1101         PL_body_arenas = (void *) newroot;
1102         DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1103     }
1104
1105     /* ok, now have arena-set with at least 1 empty/available arena-desc */
1106     curr = aroot->curr++;
1107     adesc = &(aroot->set[curr]);
1108     assert(!adesc->arena);
1109     
1110     Newx(adesc->arena, good_arena_size, char);
1111     adesc->size = good_arena_size;
1112     adesc->utype = sv_type;
1113     DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n", 
1114                           curr, (void*)adesc->arena, (UV)good_arena_size));
1115
1116     start = (char *) adesc->arena;
1117
1118     /* Get the address of the byte after the end of the last body we can fit.
1119        Remember, this is integer division:  */
1120     end = start + good_arena_size / body_size * body_size;
1121
1122     /* computed count doesn't reflect the 1st slot reservation */
1123 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1124     DEBUG_m(PerlIO_printf(Perl_debug_log,
1125                           "arena %p end %p arena-size %d (from %d) type %d "
1126                           "size %d ct %d\n",
1127                           (void*)start, (void*)end, (int)good_arena_size,
1128                           (int)arena_size, sv_type, (int)body_size,
1129                           (int)good_arena_size / (int)body_size));
1130 #else
1131     DEBUG_m(PerlIO_printf(Perl_debug_log,
1132                           "arena %p end %p arena-size %d type %d size %d ct %d\n",
1133                           (void*)start, (void*)end,
1134                           (int)arena_size, sv_type, (int)body_size,
1135                           (int)good_arena_size / (int)body_size));
1136 #endif
1137     *root = (void *)start;
1138
1139     while (1) {
1140         /* Where the next body would start:  */
1141         char * const next = start + body_size;
1142
1143         if (next >= end) {
1144             /* This is the last body:  */
1145             assert(next == end);
1146
1147             *(void **)start = 0;
1148             return *root;
1149         }
1150
1151         *(void**) start = (void *)next;
1152         start = next;
1153     }
1154 }
1155
1156 /* grab a new thing from the free list, allocating more if necessary.
1157    The inline version is used for speed in hot routines, and the
1158    function using it serves the rest (unless PURIFY).
1159 */
1160 #define new_body_inline(xpv, sv_type) \
1161     STMT_START { \
1162         void ** const r3wt = &PL_body_roots[sv_type]; \
1163         xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \
1164           ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1165                                              bodies_by_type[sv_type].body_size,\
1166                                              bodies_by_type[sv_type].arena_size)); \
1167         *(r3wt) = *(void**)(xpv); \
1168     } STMT_END
1169
1170 #ifndef PURIFY
1171
1172 STATIC void *
1173 S_new_body(pTHX_ const svtype sv_type)
1174 {
1175     void *xpv;
1176     new_body_inline(xpv, sv_type);
1177     return xpv;
1178 }
1179
1180 #endif
1181
1182 static const struct body_details fake_rv =
1183     { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1184
1185 /*
1186 =for apidoc sv_upgrade
1187
1188 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1189 SV, then copies across as much information as possible from the old body.
1190 It croaks if the SV is already in a more complex form than requested.  You
1191 generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
1192 before calling C<sv_upgrade>, and hence does not croak.  See also
1193 C<svtype>.
1194
1195 =cut
1196 */
1197
1198 void
1199 Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
1200 {
1201     void*       old_body;
1202     void*       new_body;
1203     const svtype old_type = SvTYPE(sv);
1204     const struct body_details *new_type_details;
1205     const struct body_details *old_type_details
1206         = bodies_by_type + old_type;
1207     SV *referant = NULL;
1208
1209     PERL_ARGS_ASSERT_SV_UPGRADE;
1210
1211     if (old_type == new_type)
1212         return;
1213
1214     /* This clause was purposefully added ahead of the early return above to
1215        the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1216        inference by Nick I-S that it would fix other troublesome cases. See
1217        changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1218
1219        Given that shared hash key scalars are no longer PVIV, but PV, there is
1220        no longer need to unshare so as to free up the IVX slot for its proper
1221        purpose. So it's safe to move the early return earlier.  */
1222
1223     if (new_type > SVt_PVMG && SvIsCOW(sv)) {
1224         sv_force_normal_flags(sv, 0);
1225     }
1226
1227     old_body = SvANY(sv);
1228
1229     /* Copying structures onto other structures that have been neatly zeroed
1230        has a subtle gotcha. Consider XPVMG
1231
1232        +------+------+------+------+------+-------+-------+
1233        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
1234        +------+------+------+------+------+-------+-------+
1235        0      4      8     12     16     20      24      28
1236
1237        where NVs are aligned to 8 bytes, so that sizeof that structure is
1238        actually 32 bytes long, with 4 bytes of padding at the end:
1239
1240        +------+------+------+------+------+-------+-------+------+
1241        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
1242        +------+------+------+------+------+-------+-------+------+
1243        0      4      8     12     16     20      24      28     32
1244
1245        so what happens if you allocate memory for this structure:
1246
1247        +------+------+------+------+------+-------+-------+------+------+...
1248        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
1249        +------+------+------+------+------+-------+-------+------+------+...
1250        0      4      8     12     16     20      24      28     32     36
1251
1252        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1253        expect, because you copy the area marked ??? onto GP. Now, ??? may have
1254        started out as zero once, but it's quite possible that it isn't. So now,
1255        rather than a nicely zeroed GP, you have it pointing somewhere random.
1256        Bugs ensue.
1257
1258        (In fact, GP ends up pointing at a previous GP structure, because the
1259        principle cause of the padding in XPVMG getting garbage is a copy of
1260        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1261        this happens to be moot because XPVGV has been re-ordered, with GP
1262        no longer after STASH)
1263
1264        So we are careful and work out the size of used parts of all the
1265        structures.  */
1266
1267     switch (old_type) {
1268     case SVt_NULL:
1269         break;
1270     case SVt_IV:
1271         if (SvROK(sv)) {
1272             referant = SvRV(sv);
1273             old_type_details = &fake_rv;
1274             if (new_type == SVt_NV)
1275                 new_type = SVt_PVNV;
1276         } else {
1277             if (new_type < SVt_PVIV) {
1278                 new_type = (new_type == SVt_NV)
1279                     ? SVt_PVNV : SVt_PVIV;
1280             }
1281         }
1282         break;
1283     case SVt_NV:
1284         if (new_type < SVt_PVNV) {
1285             new_type = SVt_PVNV;
1286         }
1287         break;
1288     case SVt_PV:
1289         assert(new_type > SVt_PV);
1290         assert(SVt_IV < SVt_PV);
1291         assert(SVt_NV < SVt_PV);
1292         break;
1293     case SVt_PVIV:
1294         break;
1295     case SVt_PVNV:
1296         break;
1297     case SVt_PVMG:
1298         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1299            there's no way that it can be safely upgraded, because perl.c
1300            expects to Safefree(SvANY(PL_mess_sv))  */
1301         assert(sv != PL_mess_sv);
1302         /* This flag bit is used to mean other things in other scalar types.
1303            Given that it only has meaning inside the pad, it shouldn't be set
1304            on anything that can get upgraded.  */
1305         assert(!SvPAD_TYPED(sv));
1306         break;
1307     default:
1308         if (UNLIKELY(old_type_details->cant_upgrade))
1309             Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1310                        sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1311     }
1312
1313     if (UNLIKELY(old_type > new_type))
1314         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1315                 (int)old_type, (int)new_type);
1316
1317     new_type_details = bodies_by_type + new_type;
1318
1319     SvFLAGS(sv) &= ~SVTYPEMASK;
1320     SvFLAGS(sv) |= new_type;
1321
1322     /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1323        the return statements above will have triggered.  */
1324     assert (new_type != SVt_NULL);
1325     switch (new_type) {
1326     case SVt_IV:
1327         assert(old_type == SVt_NULL);
1328         SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1329         SvIV_set(sv, 0);
1330         return;
1331     case SVt_NV:
1332         assert(old_type == SVt_NULL);
1333         SvANY(sv) = new_XNV();
1334         SvNV_set(sv, 0);
1335         return;
1336     case SVt_PVHV:
1337     case SVt_PVAV:
1338         assert(new_type_details->body_size);
1339
1340 #ifndef PURIFY  
1341         assert(new_type_details->arena);
1342         assert(new_type_details->arena_size);
1343         /* This points to the start of the allocated area.  */
1344         new_body_inline(new_body, new_type);
1345         Zero(new_body, new_type_details->body_size, char);
1346         new_body = ((char *)new_body) - new_type_details->offset;
1347 #else
1348         /* We always allocated the full length item with PURIFY. To do this
1349            we fake things so that arena is false for all 16 types..  */
1350         new_body = new_NOARENAZ(new_type_details);
1351 #endif
1352         SvANY(sv) = new_body;
1353         if (new_type == SVt_PVAV) {
1354             AvMAX(sv)   = -1;
1355             AvFILLp(sv) = -1;
1356             AvREAL_only(sv);
1357             if (old_type_details->body_size) {
1358                 AvALLOC(sv) = 0;
1359             } else {
1360                 /* It will have been zeroed when the new body was allocated.
1361                    Lets not write to it, in case it confuses a write-back
1362                    cache.  */
1363             }
1364         } else {
1365             assert(!SvOK(sv));
1366             SvOK_off(sv);
1367 #ifndef NODEFAULT_SHAREKEYS
1368             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
1369 #endif
1370             /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
1371             HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
1372         }
1373
1374         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1375            The target created by newSVrv also is, and it can have magic.
1376            However, it never has SvPVX set.
1377         */
1378         if (old_type == SVt_IV) {
1379             assert(!SvROK(sv));
1380         } else if (old_type >= SVt_PV) {
1381             assert(SvPVX_const(sv) == 0);
1382         }
1383
1384         if (old_type >= SVt_PVMG) {
1385             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1386             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1387         } else {
1388             sv->sv_u.svu_array = NULL; /* or svu_hash  */
1389         }
1390         break;
1391
1392     case SVt_PVIV:
1393         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1394            no route from NV to PVIV, NOK can never be true  */
1395         assert(!SvNOKp(sv));
1396         assert(!SvNOK(sv));
1397     case SVt_PVIO:
1398     case SVt_PVFM:
1399     case SVt_PVGV:
1400     case SVt_PVCV:
1401     case SVt_PVLV:
1402     case SVt_INVLIST:
1403     case SVt_REGEXP:
1404     case SVt_PVMG:
1405     case SVt_PVNV:
1406     case SVt_PV:
1407
1408         assert(new_type_details->body_size);
1409         /* We always allocated the full length item with PURIFY. To do this
1410            we fake things so that arena is false for all 16 types..  */
1411         if(new_type_details->arena) {
1412             /* This points to the start of the allocated area.  */
1413             new_body_inline(new_body, new_type);
1414             Zero(new_body, new_type_details->body_size, char);
1415             new_body = ((char *)new_body) - new_type_details->offset;
1416         } else {
1417             new_body = new_NOARENAZ(new_type_details);
1418         }
1419         SvANY(sv) = new_body;
1420
1421         if (old_type_details->copy) {
1422             /* There is now the potential for an upgrade from something without
1423                an offset (PVNV or PVMG) to something with one (PVCV, PVFM)  */
1424             int offset = old_type_details->offset;
1425             int length = old_type_details->copy;
1426
1427             if (new_type_details->offset > old_type_details->offset) {
1428                 const int difference
1429                     = new_type_details->offset - old_type_details->offset;
1430                 offset += difference;
1431                 length -= difference;
1432             }
1433             assert (length >= 0);
1434                 
1435             Copy((char *)old_body + offset, (char *)new_body + offset, length,
1436                  char);
1437         }
1438
1439 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1440         /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1441          * correct 0.0 for us.  Otherwise, if the old body didn't have an
1442          * NV slot, but the new one does, then we need to initialise the
1443          * freshly created NV slot with whatever the correct bit pattern is
1444          * for 0.0  */
1445         if (old_type_details->zero_nv && !new_type_details->zero_nv
1446             && !isGV_with_GP(sv))
1447             SvNV_set(sv, 0);
1448 #endif
1449
1450         if (UNLIKELY(new_type == SVt_PVIO)) {
1451             IO * const io = MUTABLE_IO(sv);
1452             GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1453
1454             SvOBJECT_on(io);
1455             /* Clear the stashcache because a new IO could overrule a package
1456                name */
1457             DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
1458             hv_clear(PL_stashcache);
1459
1460             SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1461             IoPAGE_LEN(sv) = 60;
1462         }
1463         if (UNLIKELY(new_type == SVt_REGEXP))
1464             sv->sv_u.svu_rx = (regexp *)new_body;
1465         else if (old_type < SVt_PV) {
1466             /* referant will be NULL unless the old type was SVt_IV emulating
1467                SVt_RV */
1468             sv->sv_u.svu_rv = referant;
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 (old_type > SVt_IV) {
1477 #ifdef PURIFY
1478         safefree(old_body);
1479 #else
1480         /* Note that there is an assumption that all bodies of types that
1481            can be upgraded came from arenas. Only the more complex non-
1482            upgradable types are allowed to be directly malloc()ed.  */
1483         assert(old_type_details->arena);
1484         del_body((void*)((char*)old_body + old_type_details->offset),
1485                  &PL_body_roots[old_type]);
1486 #endif
1487     }
1488 }
1489
1490 /*
1491 =for apidoc sv_backoff
1492
1493 Remove any string offset.  You should normally use the C<SvOOK_off> macro
1494 wrapper instead.
1495
1496 =cut
1497 */
1498
1499 int
1500 Perl_sv_backoff(SV *const sv)
1501 {
1502     STRLEN delta;
1503     const char * const s = SvPVX_const(sv);
1504
1505     PERL_ARGS_ASSERT_SV_BACKOFF;
1506
1507     assert(SvOOK(sv));
1508     assert(SvTYPE(sv) != SVt_PVHV);
1509     assert(SvTYPE(sv) != SVt_PVAV);
1510
1511     SvOOK_offset(sv, delta);
1512     
1513     SvLEN_set(sv, SvLEN(sv) + delta);
1514     SvPV_set(sv, SvPVX(sv) - delta);
1515     Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1516     SvFLAGS(sv) &= ~SVf_OOK;
1517     return 0;
1518 }
1519
1520 /*
1521 =for apidoc sv_grow
1522
1523 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1524 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1525 Use the C<SvGROW> wrapper instead.
1526
1527 =cut
1528 */
1529
1530 static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
1531
1532 char *
1533 Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
1534 {
1535     char *s;
1536
1537     PERL_ARGS_ASSERT_SV_GROW;
1538
1539     if (SvROK(sv))
1540         sv_unref(sv);
1541     if (SvTYPE(sv) < SVt_PV) {
1542         sv_upgrade(sv, SVt_PV);
1543         s = SvPVX_mutable(sv);
1544     }
1545     else if (SvOOK(sv)) {       /* pv is offset? */
1546         sv_backoff(sv);
1547         s = SvPVX_mutable(sv);
1548         if (newlen > SvLEN(sv))
1549             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1550     }
1551     else
1552     {
1553         if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0);
1554         s = SvPVX_mutable(sv);
1555     }
1556
1557 #ifdef PERL_NEW_COPY_ON_WRITE
1558     /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1559      * to store the COW count. So in general, allocate one more byte than
1560      * asked for, to make it likely this byte is always spare: and thus
1561      * make more strings COW-able.
1562      * If the new size is a big power of two, don't bother: we assume the
1563      * caller wanted a nice 2^N sized block and will be annoyed at getting
1564      * 2^N+1 */
1565     if (newlen & 0xff)
1566         newlen++;
1567 #endif
1568
1569 #if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size)
1570 #define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1571 #endif
1572
1573     if (newlen > SvLEN(sv)) {           /* need more room? */
1574         STRLEN minlen = SvCUR(sv);
1575         minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1576         if (newlen < minlen)
1577             newlen = minlen;
1578 #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1579
1580         /* Don't round up on the first allocation, as odds are pretty good that
1581          * the initial request is accurate as to what is really needed */
1582         if (SvLEN(sv)) {
1583             newlen = PERL_STRLEN_ROUNDUP(newlen);
1584         }
1585 #endif
1586         if (SvLEN(sv) && s) {
1587             s = (char*)saferealloc(s, newlen);
1588         }
1589         else {
1590             s = (char*)safemalloc(newlen);
1591             if (SvPVX_const(sv) && SvCUR(sv)) {
1592                 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1593             }
1594         }
1595         SvPV_set(sv, s);
1596 #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1597         /* Do this here, do it once, do it right, and then we will never get
1598            called back into sv_grow() unless there really is some growing
1599            needed.  */
1600         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1601 #else
1602         SvLEN_set(sv, newlen);
1603 #endif
1604     }
1605     return s;
1606 }
1607
1608 /*
1609 =for apidoc sv_setiv
1610
1611 Copies an integer into the given SV, upgrading first if necessary.
1612 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1613
1614 =cut
1615 */
1616
1617 void
1618 Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
1619 {
1620     PERL_ARGS_ASSERT_SV_SETIV;
1621
1622     SV_CHECK_THINKFIRST_COW_DROP(sv);
1623     switch (SvTYPE(sv)) {
1624     case SVt_NULL:
1625     case SVt_NV:
1626         sv_upgrade(sv, SVt_IV);
1627         break;
1628     case SVt_PV:
1629         sv_upgrade(sv, SVt_PVIV);
1630         break;
1631
1632     case SVt_PVGV:
1633         if (!isGV_with_GP(sv))
1634             break;
1635     case SVt_PVAV:
1636     case SVt_PVHV:
1637     case SVt_PVCV:
1638     case SVt_PVFM:
1639     case SVt_PVIO:
1640         /* diag_listed_as: Can't coerce %s to %s in %s */
1641         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1642                    OP_DESC(PL_op));
1643     default: NOOP;
1644     }
1645     (void)SvIOK_only(sv);                       /* validate number */
1646     SvIV_set(sv, i);
1647     SvTAINT(sv);
1648 }
1649
1650 /*
1651 =for apidoc sv_setiv_mg
1652
1653 Like C<sv_setiv>, but also handles 'set' magic.
1654
1655 =cut
1656 */
1657
1658 void
1659 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1660 {
1661     PERL_ARGS_ASSERT_SV_SETIV_MG;
1662
1663     sv_setiv(sv,i);
1664     SvSETMAGIC(sv);
1665 }
1666
1667 /*
1668 =for apidoc sv_setuv
1669
1670 Copies an unsigned integer into the given SV, upgrading first if necessary.
1671 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1672
1673 =cut
1674 */
1675
1676 void
1677 Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1678 {
1679     PERL_ARGS_ASSERT_SV_SETUV;
1680
1681     /* With the if statement to ensure that integers are stored as IVs whenever
1682        possible:
1683        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1684
1685        without
1686        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1687
1688        If you wish to remove the following if statement, so that this routine
1689        (and its callers) always return UVs, please benchmark to see what the
1690        effect is. Modern CPUs may be different. Or may not :-)
1691     */
1692     if (u <= (UV)IV_MAX) {
1693        sv_setiv(sv, (IV)u);
1694        return;
1695     }
1696     sv_setiv(sv, 0);
1697     SvIsUV_on(sv);
1698     SvUV_set(sv, u);
1699 }
1700
1701 /*
1702 =for apidoc sv_setuv_mg
1703
1704 Like C<sv_setuv>, but also handles 'set' magic.
1705
1706 =cut
1707 */
1708
1709 void
1710 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1711 {
1712     PERL_ARGS_ASSERT_SV_SETUV_MG;
1713
1714     sv_setuv(sv,u);
1715     SvSETMAGIC(sv);
1716 }
1717
1718 /*
1719 =for apidoc sv_setnv
1720
1721 Copies a double into the given SV, upgrading first if necessary.
1722 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1723
1724 =cut
1725 */
1726
1727 void
1728 Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1729 {
1730     PERL_ARGS_ASSERT_SV_SETNV;
1731
1732     SV_CHECK_THINKFIRST_COW_DROP(sv);
1733     switch (SvTYPE(sv)) {
1734     case SVt_NULL:
1735     case SVt_IV:
1736         sv_upgrade(sv, SVt_NV);
1737         break;
1738     case SVt_PV:
1739     case SVt_PVIV:
1740         sv_upgrade(sv, SVt_PVNV);
1741         break;
1742
1743     case SVt_PVGV:
1744         if (!isGV_with_GP(sv))
1745             break;
1746     case SVt_PVAV:
1747     case SVt_PVHV:
1748     case SVt_PVCV:
1749     case SVt_PVFM:
1750     case SVt_PVIO:
1751         /* diag_listed_as: Can't coerce %s to %s in %s */
1752         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1753                    OP_DESC(PL_op));
1754     default: NOOP;
1755     }
1756     SvNV_set(sv, num);
1757     (void)SvNOK_only(sv);                       /* validate number */
1758     SvTAINT(sv);
1759 }
1760
1761 /*
1762 =for apidoc sv_setnv_mg
1763
1764 Like C<sv_setnv>, but also handles 'set' magic.
1765
1766 =cut
1767 */
1768
1769 void
1770 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1771 {
1772     PERL_ARGS_ASSERT_SV_SETNV_MG;
1773
1774     sv_setnv(sv,num);
1775     SvSETMAGIC(sv);
1776 }
1777
1778 /* Return a cleaned-up, printable version of sv, for non-numeric, or
1779  * not incrementable warning display.
1780  * Originally part of S_not_a_number().
1781  * The return value may be != tmpbuf.
1782  */
1783
1784 STATIC const char *
1785 S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1786     const char *pv;
1787
1788      PERL_ARGS_ASSERT_SV_DISPLAY;
1789
1790      if (DO_UTF8(sv)) {
1791           SV *dsv = newSVpvs_flags("", SVs_TEMP);
1792           pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
1793      } else {
1794           char *d = tmpbuf;
1795           const char * const limit = tmpbuf + tmpbuf_size - 8;
1796           /* each *s can expand to 4 chars + "...\0",
1797              i.e. need room for 8 chars */
1798         
1799           const char *s = SvPVX_const(sv);
1800           const char * const end = s + SvCUR(sv);
1801           for ( ; s < end && d < limit; s++ ) {
1802                int ch = *s & 0xFF;
1803                if (! isASCII(ch) && !isPRINT_LC(ch)) {
1804                     *d++ = 'M';
1805                     *d++ = '-';
1806
1807                     /* Map to ASCII "equivalent" of Latin1 */
1808                     ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1809                }
1810                if (ch == '\n') {
1811                     *d++ = '\\';
1812                     *d++ = 'n';
1813                }
1814                else if (ch == '\r') {
1815                     *d++ = '\\';
1816                     *d++ = 'r';
1817                }
1818                else if (ch == '\f') {
1819                     *d++ = '\\';
1820                     *d++ = 'f';
1821                }
1822                else if (ch == '\\') {
1823                     *d++ = '\\';
1824                     *d++ = '\\';
1825                }
1826                else if (ch == '\0') {
1827                     *d++ = '\\';
1828                     *d++ = '0';
1829                }
1830                else if (isPRINT_LC(ch))
1831                     *d++ = ch;
1832                else {
1833                     *d++ = '^';
1834                     *d++ = toCTRL(ch);
1835                }
1836           }
1837           if (s < end) {
1838                *d++ = '.';
1839                *d++ = '.';
1840                *d++ = '.';
1841           }
1842           *d = '\0';
1843           pv = tmpbuf;
1844     }
1845
1846     return pv;
1847 }
1848
1849 /* Print an "isn't numeric" warning, using a cleaned-up,
1850  * printable version of the offending string
1851  */
1852
1853 STATIC void
1854 S_not_a_number(pTHX_ SV *const sv)
1855 {
1856      char tmpbuf[64];
1857      const char *pv;
1858
1859      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1860
1861      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1862
1863     if (PL_op)
1864         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1865                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1866                     "Argument \"%s\" isn't numeric in %s", pv,
1867                     OP_DESC(PL_op));
1868     else
1869         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1870                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1871                     "Argument \"%s\" isn't numeric", pv);
1872 }
1873
1874 STATIC void
1875 S_not_incrementable(pTHX_ SV *const sv) {
1876      char tmpbuf[64];
1877      const char *pv;
1878
1879      PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1880
1881      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1882
1883      Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1884                  "Argument \"%s\" treated as 0 in increment (++)", pv);
1885 }
1886
1887 /*
1888 =for apidoc looks_like_number
1889
1890 Test if the content of an SV looks like a number (or is a number).
1891 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1892 non-numeric warning), even if your atof() doesn't grok them.  Get-magic is
1893 ignored.
1894
1895 =cut
1896 */
1897
1898 I32
1899 Perl_looks_like_number(pTHX_ SV *const sv)
1900 {
1901     const char *sbegin;
1902     STRLEN len;
1903
1904     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1905
1906     if (SvPOK(sv) || SvPOKp(sv)) {
1907         sbegin = SvPV_nomg_const(sv, len);
1908     }
1909     else
1910         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1911     return grok_number(sbegin, len, NULL);
1912 }
1913
1914 STATIC bool
1915 S_glob_2number(pTHX_ GV * const gv)
1916 {
1917     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1918
1919     /* We know that all GVs stringify to something that is not-a-number,
1920         so no need to test that.  */
1921     if (ckWARN(WARN_NUMERIC))
1922     {
1923         SV *const buffer = sv_newmortal();
1924         gv_efullname3(buffer, gv, "*");
1925         not_a_number(buffer);
1926     }
1927     /* We just want something true to return, so that S_sv_2iuv_common
1928         can tail call us and return true.  */
1929     return TRUE;
1930 }
1931
1932 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1933    until proven guilty, assume that things are not that bad... */
1934
1935 /*
1936    NV_PRESERVES_UV:
1937
1938    As 64 bit platforms often have an NV that doesn't preserve all bits of
1939    an IV (an assumption perl has been based on to date) it becomes necessary
1940    to remove the assumption that the NV always carries enough precision to
1941    recreate the IV whenever needed, and that the NV is the canonical form.
1942    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1943    precision as a side effect of conversion (which would lead to insanity
1944    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1945    1) to distinguish between IV/UV/NV slots that have a valid conversion cached
1946       where precision was lost, and IV/UV/NV slots that have a valid conversion
1947       which has lost no precision
1948    2) to ensure that if a numeric conversion to one form is requested that
1949       would lose precision, the precise conversion (or differently
1950       imprecise conversion) is also performed and cached, to prevent
1951       requests for different numeric formats on the same SV causing
1952       lossy conversion chains. (lossless conversion chains are perfectly
1953       acceptable (still))
1954
1955
1956    flags are used:
1957    SvIOKp is true if the IV slot contains a valid value
1958    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1959    SvNOKp is true if the NV slot contains a valid value
1960    SvNOK  is true only if the NV value is accurate
1961
1962    so
1963    while converting from PV to NV, check to see if converting that NV to an
1964    IV(or UV) would lose accuracy over a direct conversion from PV to
1965    IV(or UV). If it would, cache both conversions, return NV, but mark
1966    SV as IOK NOKp (ie not NOK).
1967
1968    While converting from PV to IV, check to see if converting that IV to an
1969    NV would lose accuracy over a direct conversion from PV to NV. If it
1970    would, cache both conversions, flag similarly.
1971
1972    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1973    correctly because if IV & NV were set NV *always* overruled.
1974    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1975    changes - now IV and NV together means that the two are interchangeable:
1976    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1977
1978    The benefit of this is that operations such as pp_add know that if
1979    SvIOK is true for both left and right operands, then integer addition
1980    can be used instead of floating point (for cases where the result won't
1981    overflow). Before, floating point was always used, which could lead to
1982    loss of precision compared with integer addition.
1983
1984    * making IV and NV equal status should make maths accurate on 64 bit
1985      platforms
1986    * may speed up maths somewhat if pp_add and friends start to use
1987      integers when possible instead of fp. (Hopefully the overhead in
1988      looking for SvIOK and checking for overflow will not outweigh the
1989      fp to integer speedup)
1990    * will slow down integer operations (callers of SvIV) on "inaccurate"
1991      values, as the change from SvIOK to SvIOKp will cause a call into
1992      sv_2iv each time rather than a macro access direct to the IV slot
1993    * should speed up number->string conversion on integers as IV is
1994      favoured when IV and NV are equally accurate
1995
1996    ####################################################################
1997    You had better be using SvIOK_notUV if you want an IV for arithmetic:
1998    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1999    On the other hand, SvUOK is true iff UV.
2000    ####################################################################
2001
2002    Your mileage will vary depending your CPU's relative fp to integer
2003    performance ratio.
2004 */
2005
2006 #ifndef NV_PRESERVES_UV
2007 #  define IS_NUMBER_UNDERFLOW_IV 1
2008 #  define IS_NUMBER_UNDERFLOW_UV 2
2009 #  define IS_NUMBER_IV_AND_UV    2
2010 #  define IS_NUMBER_OVERFLOW_IV  4
2011 #  define IS_NUMBER_OVERFLOW_UV  5
2012
2013 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2014
2015 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
2016 STATIC int
2017 S_sv_2iuv_non_preserve(pTHX_ SV *const sv
2018 #  ifdef DEBUGGING
2019                        , I32 numtype
2020 #  endif
2021                        )
2022 {
2023     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
2024     PERL_UNUSED_CONTEXT;
2025
2026     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));
2027     if (SvNVX(sv) < (NV)IV_MIN) {
2028         (void)SvIOKp_on(sv);
2029         (void)SvNOK_on(sv);
2030         SvIV_set(sv, IV_MIN);
2031         return IS_NUMBER_UNDERFLOW_IV;
2032     }
2033     if (SvNVX(sv) > (NV)UV_MAX) {
2034         (void)SvIOKp_on(sv);
2035         (void)SvNOK_on(sv);
2036         SvIsUV_on(sv);
2037         SvUV_set(sv, UV_MAX);
2038         return IS_NUMBER_OVERFLOW_UV;
2039     }
2040     (void)SvIOKp_on(sv);
2041     (void)SvNOK_on(sv);
2042     /* Can't use strtol etc to convert this string.  (See truth table in
2043        sv_2iv  */
2044     if (SvNVX(sv) <= (UV)IV_MAX) {
2045         SvIV_set(sv, I_V(SvNVX(sv)));
2046         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2047             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2048         } else {
2049             /* Integer is imprecise. NOK, IOKp */
2050         }
2051         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2052     }
2053     SvIsUV_on(sv);
2054     SvUV_set(sv, U_V(SvNVX(sv)));
2055     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2056         if (SvUVX(sv) == UV_MAX) {
2057             /* As we know that NVs don't preserve UVs, UV_MAX cannot
2058                possibly be preserved by NV. Hence, it must be overflow.
2059                NOK, IOKp */
2060             return IS_NUMBER_OVERFLOW_UV;
2061         }
2062         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2063     } else {
2064         /* Integer is imprecise. NOK, IOKp */
2065     }
2066     return IS_NUMBER_OVERFLOW_IV;
2067 }
2068 #endif /* !NV_PRESERVES_UV*/
2069
2070 STATIC bool
2071 S_sv_2iuv_common(pTHX_ SV *const sv)
2072 {
2073     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2074
2075     if (SvNOKp(sv)) {
2076         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2077          * without also getting a cached IV/UV from it at the same time
2078          * (ie PV->NV conversion should detect loss of accuracy and cache
2079          * IV or UV at same time to avoid this. */
2080         /* IV-over-UV optimisation - choose to cache IV if possible */
2081
2082         if (SvTYPE(sv) == SVt_NV)
2083             sv_upgrade(sv, SVt_PVNV);
2084
2085         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2086         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2087            certainly cast into the IV range at IV_MAX, whereas the correct
2088            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2089            cases go to UV */
2090 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2091         if (Perl_isnan(SvNVX(sv))) {
2092             SvUV_set(sv, 0);
2093             SvIsUV_on(sv);
2094             return FALSE;
2095         }
2096 #endif
2097         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2098             SvIV_set(sv, I_V(SvNVX(sv)));
2099             if (SvNVX(sv) == (NV) SvIVX(sv)
2100 #ifndef NV_PRESERVES_UV
2101                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2102                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2103                 /* Don't flag it as "accurately an integer" if the number
2104                    came from a (by definition imprecise) NV operation, and
2105                    we're outside the range of NV integer precision */
2106 #endif
2107                 ) {
2108                 if (SvNOK(sv))
2109                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2110                 else {
2111                     /* scalar has trailing garbage, eg "42a" */
2112                 }
2113                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2114                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2115                                       PTR2UV(sv),
2116                                       SvNVX(sv),
2117                                       SvIVX(sv)));
2118
2119             } else {
2120                 /* IV not precise.  No need to convert from PV, as NV
2121                    conversion would already have cached IV if it detected
2122                    that PV->IV would be better than PV->NV->IV
2123                    flags already correct - don't set public IOK.  */
2124                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2125                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2126                                       PTR2UV(sv),
2127                                       SvNVX(sv),
2128                                       SvIVX(sv)));
2129             }
2130             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2131                but the cast (NV)IV_MIN rounds to a the value less (more
2132                negative) than IV_MIN which happens to be equal to SvNVX ??
2133                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2134                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2135                (NV)UVX == NVX are both true, but the values differ. :-(
2136                Hopefully for 2s complement IV_MIN is something like
2137                0x8000000000000000 which will be exact. NWC */
2138         }
2139         else {
2140             SvUV_set(sv, U_V(SvNVX(sv)));
2141             if (
2142                 (SvNVX(sv) == (NV) SvUVX(sv))
2143 #ifndef  NV_PRESERVES_UV
2144                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2145                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2146                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2147                 /* Don't flag it as "accurately an integer" if the number
2148                    came from a (by definition imprecise) NV operation, and
2149                    we're outside the range of NV integer precision */
2150 #endif
2151                 && SvNOK(sv)
2152                 )
2153                 SvIOK_on(sv);
2154             SvIsUV_on(sv);
2155             DEBUG_c(PerlIO_printf(Perl_debug_log,
2156                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2157                                   PTR2UV(sv),
2158                                   SvUVX(sv),
2159                                   SvUVX(sv)));
2160         }
2161     }
2162     else if (SvPOKp(sv)) {
2163         UV value;
2164         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2165         /* We want to avoid a possible problem when we cache an IV/ a UV which
2166            may be later translated to an NV, and the resulting NV is not
2167            the same as the direct translation of the initial string
2168            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2169            be careful to ensure that the value with the .456 is around if the
2170            NV value is requested in the future).
2171         
2172            This means that if we cache such an IV/a UV, we need to cache the
2173            NV as well.  Moreover, we trade speed for space, and do not
2174            cache the NV if we are sure it's not needed.
2175          */
2176
2177         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2178         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2179              == IS_NUMBER_IN_UV) {
2180             /* It's definitely an integer, only upgrade to PVIV */
2181             if (SvTYPE(sv) < SVt_PVIV)
2182                 sv_upgrade(sv, SVt_PVIV);
2183             (void)SvIOK_on(sv);
2184         } else if (SvTYPE(sv) < SVt_PVNV)
2185             sv_upgrade(sv, SVt_PVNV);
2186
2187         /* If NVs preserve UVs then we only use the UV value if we know that
2188            we aren't going to call atof() below. If NVs don't preserve UVs
2189            then the value returned may have more precision than atof() will
2190            return, even though value isn't perfectly accurate.  */
2191         if ((numtype & (IS_NUMBER_IN_UV
2192 #ifdef NV_PRESERVES_UV
2193                         | IS_NUMBER_NOT_INT
2194 #endif
2195             )) == IS_NUMBER_IN_UV) {
2196             /* This won't turn off the public IOK flag if it was set above  */
2197             (void)SvIOKp_on(sv);
2198
2199             if (!(numtype & IS_NUMBER_NEG)) {
2200                 /* positive */;
2201                 if (value <= (UV)IV_MAX) {
2202                     SvIV_set(sv, (IV)value);
2203                 } else {
2204                     /* it didn't overflow, and it was positive. */
2205                     SvUV_set(sv, value);
2206                     SvIsUV_on(sv);
2207                 }
2208             } else {
2209                 /* 2s complement assumption  */
2210                 if (value <= (UV)IV_MIN) {
2211                     SvIV_set(sv, -(IV)value);
2212                 } else {
2213                     /* Too negative for an IV.  This is a double upgrade, but
2214                        I'm assuming it will be rare.  */
2215                     if (SvTYPE(sv) < SVt_PVNV)
2216                         sv_upgrade(sv, SVt_PVNV);
2217                     SvNOK_on(sv);
2218                     SvIOK_off(sv);
2219                     SvIOKp_on(sv);
2220                     SvNV_set(sv, -(NV)value);
2221                     SvIV_set(sv, IV_MIN);
2222                 }
2223             }
2224         }
2225         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2226            will be in the previous block to set the IV slot, and the next
2227            block to set the NV slot.  So no else here.  */
2228         
2229         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2230             != IS_NUMBER_IN_UV) {
2231             /* It wasn't an (integer that doesn't overflow the UV). */
2232             SvNV_set(sv, Atof(SvPVX_const(sv)));
2233
2234             if (! numtype && ckWARN(WARN_NUMERIC))
2235                 not_a_number(sv);
2236
2237 #if defined(USE_LONG_DOUBLE)
2238             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2239                                   PTR2UV(sv), SvNVX(sv)));
2240 #else
2241             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2242                                   PTR2UV(sv), SvNVX(sv)));
2243 #endif
2244
2245 #ifdef NV_PRESERVES_UV
2246             (void)SvIOKp_on(sv);
2247             (void)SvNOK_on(sv);
2248             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2249                 SvIV_set(sv, I_V(SvNVX(sv)));
2250                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2251                     SvIOK_on(sv);
2252                 } else {
2253                     NOOP;  /* Integer is imprecise. NOK, IOKp */
2254                 }
2255                 /* UV will not work better than IV */
2256             } else {
2257                 if (SvNVX(sv) > (NV)UV_MAX) {
2258                     SvIsUV_on(sv);
2259                     /* Integer is inaccurate. NOK, IOKp, is UV */
2260                     SvUV_set(sv, UV_MAX);
2261                 } else {
2262                     SvUV_set(sv, U_V(SvNVX(sv)));
2263                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2264                        NV preservse UV so can do correct comparison.  */
2265                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2266                         SvIOK_on(sv);
2267                     } else {
2268                         NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
2269                     }
2270                 }
2271                 SvIsUV_on(sv);
2272             }
2273 #else /* NV_PRESERVES_UV */
2274             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2275                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2276                 /* The IV/UV slot will have been set from value returned by
2277                    grok_number above.  The NV slot has just been set using
2278                    Atof.  */
2279                 SvNOK_on(sv);
2280                 assert (SvIOKp(sv));
2281             } else {
2282                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2283                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2284                     /* Small enough to preserve all bits. */
2285                     (void)SvIOKp_on(sv);
2286                     SvNOK_on(sv);
2287                     SvIV_set(sv, I_V(SvNVX(sv)));
2288                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2289                         SvIOK_on(sv);
2290                     /* Assumption: first non-preserved integer is < IV_MAX,
2291                        this NV is in the preserved range, therefore: */
2292                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2293                           < (UV)IV_MAX)) {
2294                         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);
2295                     }
2296                 } else {
2297                     /* IN_UV NOT_INT
2298                          0      0       already failed to read UV.
2299                          0      1       already failed to read UV.
2300                          1      0       you won't get here in this case. IV/UV
2301                                         slot set, public IOK, Atof() unneeded.
2302                          1      1       already read UV.
2303                        so there's no point in sv_2iuv_non_preserve() attempting
2304                        to use atol, strtol, strtoul etc.  */
2305 #  ifdef DEBUGGING
2306                     sv_2iuv_non_preserve (sv, numtype);
2307 #  else
2308                     sv_2iuv_non_preserve (sv);
2309 #  endif
2310                 }
2311             }
2312 #endif /* NV_PRESERVES_UV */
2313         /* It might be more code efficient to go through the entire logic above
2314            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2315            gets complex and potentially buggy, so more programmer efficient
2316            to do it this way, by turning off the public flags:  */
2317         if (!numtype)
2318             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2319         }
2320     }
2321     else  {
2322         if (isGV_with_GP(sv))
2323             return glob_2number(MUTABLE_GV(sv));
2324
2325         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2326                 report_uninit(sv);
2327         if (SvTYPE(sv) < SVt_IV)
2328             /* Typically the caller expects that sv_any is not NULL now.  */
2329             sv_upgrade(sv, SVt_IV);
2330         /* Return 0 from the caller.  */
2331         return TRUE;
2332     }
2333     return FALSE;
2334 }
2335
2336 /*
2337 =for apidoc sv_2iv_flags
2338
2339 Return the integer value of an SV, doing any necessary string
2340 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2341 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2342
2343 =cut
2344 */
2345
2346 IV
2347 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2348 {
2349     PERL_ARGS_ASSERT_SV_2IV_FLAGS;
2350
2351     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2352          && SvTYPE(sv) != SVt_PVFM);
2353
2354     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2355         mg_get(sv);
2356
2357     if (SvROK(sv)) {
2358         if (SvAMAGIC(sv)) {
2359             SV * tmpstr;
2360             if (flags & SV_SKIP_OVERLOAD)
2361                 return 0;
2362             tmpstr = AMG_CALLunary(sv, numer_amg);
2363             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2364                 return SvIV(tmpstr);
2365             }
2366         }
2367         return PTR2IV(SvRV(sv));
2368     }
2369
2370     if (SvVALID(sv) || isREGEXP(sv)) {
2371         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2372            the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2373            In practice they are extremely unlikely to actually get anywhere
2374            accessible by user Perl code - the only way that I'm aware of is when
2375            a constant subroutine which is used as the second argument to index.
2376
2377            Regexps have no SvIVX and SvNVX fields.
2378         */
2379         assert(isREGEXP(sv) || SvPOKp(sv));
2380         {
2381             UV value;
2382             const char * const ptr =
2383                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2384             const int numtype
2385                 = grok_number(ptr, SvCUR(sv), &value);
2386
2387             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2388                 == IS_NUMBER_IN_UV) {
2389                 /* It's definitely an integer */
2390                 if (numtype & IS_NUMBER_NEG) {
2391                     if (value < (UV)IV_MIN)
2392                         return -(IV)value;
2393                 } else {
2394                     if (value < (UV)IV_MAX)
2395                         return (IV)value;
2396                 }
2397             }
2398             if (!numtype) {
2399                 if (ckWARN(WARN_NUMERIC))
2400                     not_a_number(sv);
2401             }
2402             return I_V(Atof(ptr));
2403         }
2404     }
2405
2406     if (SvTHINKFIRST(sv)) {
2407 #ifdef PERL_OLD_COPY_ON_WRITE
2408         if (SvIsCOW(sv)) {
2409             sv_force_normal_flags(sv, 0);
2410         }
2411 #endif
2412         if (SvREADONLY(sv) && !SvOK(sv)) {
2413             if (ckWARN(WARN_UNINITIALIZED))
2414                 report_uninit(sv);
2415             return 0;
2416         }
2417     }
2418
2419     if (!SvIOKp(sv)) {
2420         if (S_sv_2iuv_common(aTHX_ sv))
2421             return 0;
2422     }
2423
2424     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2425         PTR2UV(sv),SvIVX(sv)));
2426     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2427 }
2428
2429 /*
2430 =for apidoc sv_2uv_flags
2431
2432 Return the unsigned integer value of an SV, doing any necessary string
2433 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2434 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2435
2436 =cut
2437 */
2438
2439 UV
2440 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2441 {
2442     PERL_ARGS_ASSERT_SV_2UV_FLAGS;
2443
2444     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2445         mg_get(sv);
2446
2447     if (SvROK(sv)) {
2448         if (SvAMAGIC(sv)) {
2449             SV *tmpstr;
2450             if (flags & SV_SKIP_OVERLOAD)
2451                 return 0;
2452             tmpstr = AMG_CALLunary(sv, numer_amg);
2453             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2454                 return SvUV(tmpstr);
2455             }
2456         }
2457         return PTR2UV(SvRV(sv));
2458     }
2459
2460     if (SvVALID(sv) || isREGEXP(sv)) {
2461         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2462            the same flag bit as SVf_IVisUV, so must not let them cache IVs.  
2463            Regexps have no SvIVX and SvNVX fields. */
2464         assert(isREGEXP(sv) || SvPOKp(sv));
2465         {
2466             UV value;
2467             const char * const ptr =
2468                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2469             const int numtype
2470                 = grok_number(ptr, SvCUR(sv), &value);
2471
2472             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2473                 == IS_NUMBER_IN_UV) {
2474                 /* It's definitely an integer */
2475                 if (!(numtype & IS_NUMBER_NEG))
2476                     return value;
2477             }
2478             if (!numtype) {
2479                 if (ckWARN(WARN_NUMERIC))
2480                     not_a_number(sv);
2481             }
2482             return U_V(Atof(ptr));
2483         }
2484     }
2485
2486     if (SvTHINKFIRST(sv)) {
2487 #ifdef PERL_OLD_COPY_ON_WRITE
2488         if (SvIsCOW(sv)) {
2489             sv_force_normal_flags(sv, 0);
2490         }
2491 #endif
2492         if (SvREADONLY(sv) && !SvOK(sv)) {
2493             if (ckWARN(WARN_UNINITIALIZED))
2494                 report_uninit(sv);
2495             return 0;
2496         }
2497     }
2498
2499     if (!SvIOKp(sv)) {
2500         if (S_sv_2iuv_common(aTHX_ sv))
2501             return 0;
2502     }
2503
2504     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2505                           PTR2UV(sv),SvUVX(sv)));
2506     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2507 }
2508
2509 /*
2510 =for apidoc sv_2nv_flags
2511
2512 Return the num value of an SV, doing any necessary string or integer
2513 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2514 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2515
2516 =cut
2517 */
2518
2519 NV
2520 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2521 {
2522     PERL_ARGS_ASSERT_SV_2NV_FLAGS;
2523
2524     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2525          && SvTYPE(sv) != SVt_PVFM);
2526     if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
2527         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2528            the same flag bit as SVf_IVisUV, so must not let them cache NVs.
2529            Regexps have no SvIVX and SvNVX fields.  */
2530         const char *ptr;
2531         if (flags & SV_GMAGIC)
2532             mg_get(sv);
2533         if (SvNOKp(sv))
2534             return SvNVX(sv);
2535         if (SvPOKp(sv) && !SvIOKp(sv)) {
2536             ptr = SvPVX_const(sv);
2537           grokpv:
2538             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2539                 !grok_number(ptr, SvCUR(sv), NULL))
2540                 not_a_number(sv);
2541             return Atof(ptr);
2542         }
2543         if (SvIOKp(sv)) {
2544             if (SvIsUV(sv))
2545                 return (NV)SvUVX(sv);
2546             else
2547                 return (NV)SvIVX(sv);
2548         }
2549         if (SvROK(sv)) {
2550             goto return_rok;
2551         }
2552         if (isREGEXP(sv)) {
2553             ptr = RX_WRAPPED((REGEXP *)sv);
2554             goto grokpv;
2555         }
2556         assert(SvTYPE(sv) >= SVt_PVMG);
2557         /* This falls through to the report_uninit near the end of the
2558            function. */
2559     } else if (SvTHINKFIRST(sv)) {
2560         if (SvROK(sv)) {
2561         return_rok:
2562             if (SvAMAGIC(sv)) {
2563                 SV *tmpstr;
2564                 if (flags & SV_SKIP_OVERLOAD)
2565                     return 0;
2566                 tmpstr = AMG_CALLunary(sv, numer_amg);
2567                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2568                     return SvNV(tmpstr);
2569                 }
2570             }
2571             return PTR2NV(SvRV(sv));
2572         }
2573 #ifdef PERL_OLD_COPY_ON_WRITE
2574         if (SvIsCOW(sv)) {
2575             sv_force_normal_flags(sv, 0);
2576         }
2577 #endif
2578         if (SvREADONLY(sv) && !SvOK(sv)) {
2579             if (ckWARN(WARN_UNINITIALIZED))
2580                 report_uninit(sv);
2581             return 0.0;
2582         }
2583     }
2584     if (SvTYPE(sv) < SVt_NV) {
2585         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2586         sv_upgrade(sv, SVt_NV);
2587 #ifdef USE_LONG_DOUBLE
2588         DEBUG_c({
2589             STORE_NUMERIC_LOCAL_SET_STANDARD();
2590             PerlIO_printf(Perl_debug_log,
2591                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2592                           PTR2UV(sv), SvNVX(sv));
2593             RESTORE_NUMERIC_LOCAL();
2594         });
2595 #else
2596         DEBUG_c({
2597             STORE_NUMERIC_LOCAL_SET_STANDARD();
2598             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2599                           PTR2UV(sv), SvNVX(sv));
2600             RESTORE_NUMERIC_LOCAL();
2601         });
2602 #endif
2603     }
2604     else if (SvTYPE(sv) < SVt_PVNV)
2605         sv_upgrade(sv, SVt_PVNV);
2606     if (SvNOKp(sv)) {
2607         return SvNVX(sv);
2608     }
2609     if (SvIOKp(sv)) {
2610         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2611 #ifdef NV_PRESERVES_UV
2612         if (SvIOK(sv))
2613             SvNOK_on(sv);
2614         else
2615             SvNOKp_on(sv);
2616 #else
2617         /* Only set the public NV OK flag if this NV preserves the IV  */
2618         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2619         if (SvIOK(sv) &&
2620             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2621                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2622             SvNOK_on(sv);
2623         else
2624             SvNOKp_on(sv);
2625 #endif
2626     }
2627     else if (SvPOKp(sv)) {
2628         UV value;
2629         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2630         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2631             not_a_number(sv);
2632 #ifdef NV_PRESERVES_UV
2633         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2634             == IS_NUMBER_IN_UV) {
2635             /* It's definitely an integer */
2636             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2637         } else
2638             SvNV_set(sv, Atof(SvPVX_const(sv)));
2639         if (numtype)
2640             SvNOK_on(sv);
2641         else
2642             SvNOKp_on(sv);
2643 #else
2644         SvNV_set(sv, Atof(SvPVX_const(sv)));
2645         /* Only set the public NV OK flag if this NV preserves the value in
2646            the PV at least as well as an IV/UV would.
2647            Not sure how to do this 100% reliably. */
2648         /* if that shift count is out of range then Configure's test is
2649            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2650            UV_BITS */
2651         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2652             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2653             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2654         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2655             /* Can't use strtol etc to convert this string, so don't try.
2656                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2657             SvNOK_on(sv);
2658         } else {
2659             /* value has been set.  It may not be precise.  */
2660             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2661                 /* 2s complement assumption for (UV)IV_MIN  */
2662                 SvNOK_on(sv); /* Integer is too negative.  */
2663             } else {
2664                 SvNOKp_on(sv);
2665                 SvIOKp_on(sv);
2666
2667                 if (numtype & IS_NUMBER_NEG) {
2668                     SvIV_set(sv, -(IV)value);
2669                 } else if (value <= (UV)IV_MAX) {
2670                     SvIV_set(sv, (IV)value);
2671                 } else {
2672                     SvUV_set(sv, value);
2673                     SvIsUV_on(sv);
2674                 }
2675
2676                 if (numtype & IS_NUMBER_NOT_INT) {
2677                     /* I believe that even if the original PV had decimals,
2678                        they are lost beyond the limit of the FP precision.
2679                        However, neither is canonical, so both only get p
2680                        flags.  NWC, 2000/11/25 */
2681                     /* Both already have p flags, so do nothing */
2682                 } else {
2683                     const NV nv = SvNVX(sv);
2684                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2685                         if (SvIVX(sv) == I_V(nv)) {
2686                             SvNOK_on(sv);
2687                         } else {
2688                             /* It had no "." so it must be integer.  */
2689                         }
2690                         SvIOK_on(sv);
2691                     } else {
2692                         /* between IV_MAX and NV(UV_MAX).
2693                            Could be slightly > UV_MAX */
2694
2695                         if (numtype & IS_NUMBER_NOT_INT) {
2696                             /* UV and NV both imprecise.  */
2697                         } else {
2698                             const UV nv_as_uv = U_V(nv);
2699
2700                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2701                                 SvNOK_on(sv);
2702                             }
2703                             SvIOK_on(sv);
2704                         }
2705                     }
2706                 }
2707             }
2708         }
2709         /* It might be more code efficient to go through the entire logic above
2710            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2711            gets complex and potentially buggy, so more programmer efficient
2712            to do it this way, by turning off the public flags:  */
2713         if (!numtype)
2714             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2715 #endif /* NV_PRESERVES_UV */
2716     }
2717     else  {
2718         if (isGV_with_GP(sv)) {
2719             glob_2number(MUTABLE_GV(sv));
2720             return 0.0;
2721         }
2722
2723         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2724             report_uninit(sv);
2725         assert (SvTYPE(sv) >= SVt_NV);
2726         /* Typically the caller expects that sv_any is not NULL now.  */
2727         /* XXX Ilya implies that this is a bug in callers that assume this
2728            and ideally should be fixed.  */
2729         return 0.0;
2730     }
2731 #if defined(USE_LONG_DOUBLE)
2732     DEBUG_c({
2733         STORE_NUMERIC_LOCAL_SET_STANDARD();
2734         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2735                       PTR2UV(sv), SvNVX(sv));
2736         RESTORE_NUMERIC_LOCAL();
2737     });
2738 #else
2739     DEBUG_c({
2740         STORE_NUMERIC_LOCAL_SET_STANDARD();
2741         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2742                       PTR2UV(sv), SvNVX(sv));
2743         RESTORE_NUMERIC_LOCAL();
2744     });
2745 #endif
2746     return SvNVX(sv);
2747 }
2748
2749 /*
2750 =for apidoc sv_2num
2751
2752 Return an SV with the numeric value of the source SV, doing any necessary
2753 reference or overload conversion.  You must use the C<SvNUM(sv)> macro to
2754 access this function.
2755
2756 =cut
2757 */
2758
2759 SV *
2760 Perl_sv_2num(pTHX_ SV *const sv)
2761 {
2762     PERL_ARGS_ASSERT_SV_2NUM;
2763
2764     if (!SvROK(sv))
2765         return sv;
2766     if (SvAMAGIC(sv)) {
2767         SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2768         TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2769         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2770             return sv_2num(tmpsv);
2771     }
2772     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2773 }
2774
2775 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2776  * UV as a string towards the end of buf, and return pointers to start and
2777  * end of it.
2778  *
2779  * We assume that buf is at least TYPE_CHARS(UV) long.
2780  */
2781
2782 static char *
2783 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2784 {
2785     char *ptr = buf + TYPE_CHARS(UV);
2786     char * const ebuf = ptr;
2787     int sign;
2788
2789     PERL_ARGS_ASSERT_UIV_2BUF;
2790
2791     if (is_uv)
2792         sign = 0;
2793     else if (iv >= 0) {
2794         uv = iv;
2795         sign = 0;
2796     } else {
2797         uv = -iv;
2798         sign = 1;
2799     }
2800     do {
2801         *--ptr = '0' + (char)(uv % 10);
2802     } while (uv /= 10);
2803     if (sign)
2804         *--ptr = '-';
2805     *peob = ebuf;
2806     return ptr;
2807 }
2808
2809 /*
2810 =for apidoc sv_2pv_flags
2811
2812 Returns a pointer to the string value of an SV, and sets *lp to its length.
2813 If flags includes SV_GMAGIC, does an mg_get() first.  Coerces sv to a
2814 string if necessary.  Normally invoked via the C<SvPV_flags> macro.
2815 C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
2816
2817 =cut
2818 */
2819
2820 char *
2821 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
2822 {
2823     char *s;
2824
2825     PERL_ARGS_ASSERT_SV_2PV_FLAGS;
2826
2827     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2828          && SvTYPE(sv) != SVt_PVFM);
2829     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2830         mg_get(sv);
2831     if (SvROK(sv)) {
2832         if (SvAMAGIC(sv)) {
2833             SV *tmpstr;
2834             if (flags & SV_SKIP_OVERLOAD)
2835                 return NULL;
2836             tmpstr = AMG_CALLunary(sv, string_amg);
2837             TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2838             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2839                 /* Unwrap this:  */
2840                 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2841                  */
2842
2843                 char *pv;
2844                 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2845                     if (flags & SV_CONST_RETURN) {
2846                         pv = (char *) SvPVX_const(tmpstr);
2847                     } else {
2848                         pv = (flags & SV_MUTABLE_RETURN)
2849                             ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2850                     }
2851                     if (lp)
2852                         *lp = SvCUR(tmpstr);
2853                 } else {
2854                     pv = sv_2pv_flags(tmpstr, lp, flags);
2855                 }
2856                 if (SvUTF8(tmpstr))
2857                     SvUTF8_on(sv);
2858                 else
2859                     SvUTF8_off(sv);
2860                 return pv;
2861             }
2862         }
2863         {
2864             STRLEN len;
2865             char *retval;
2866             char *buffer;
2867             SV *const referent = SvRV(sv);
2868
2869             if (!referent) {
2870                 len = 7;
2871                 retval = buffer = savepvn("NULLREF", len);
2872             } else if (SvTYPE(referent) == SVt_REGEXP &&
2873                        (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
2874                         amagic_is_enabled(string_amg))) {
2875                 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2876
2877                 assert(re);
2878                         
2879                 /* If the regex is UTF-8 we want the containing scalar to
2880                    have an UTF-8 flag too */
2881                 if (RX_UTF8(re))
2882                     SvUTF8_on(sv);
2883                 else
2884                     SvUTF8_off(sv);     
2885
2886                 if (lp)
2887                     *lp = RX_WRAPLEN(re);
2888  
2889                 return RX_WRAPPED(re);
2890             } else {
2891                 const char *const typestr = sv_reftype(referent, 0);
2892                 const STRLEN typelen = strlen(typestr);
2893                 UV addr = PTR2UV(referent);
2894                 const char *stashname = NULL;
2895                 STRLEN stashnamelen = 0; /* hush, gcc */
2896                 const char *buffer_end;
2897
2898                 if (SvOBJECT(referent)) {
2899                     const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2900
2901                     if (name) {
2902                         stashname = HEK_KEY(name);
2903                         stashnamelen = HEK_LEN(name);
2904
2905                         if (HEK_UTF8(name)) {
2906                             SvUTF8_on(sv);
2907                         } else {
2908                             SvUTF8_off(sv);
2909                         }
2910                     } else {
2911                         stashname = "__ANON__";
2912                         stashnamelen = 8;
2913                     }
2914                     len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2915                         + 2 * sizeof(UV) + 2 /* )\0 */;
2916                 } else {
2917                     len = typelen + 3 /* (0x */
2918                         + 2 * sizeof(UV) + 2 /* )\0 */;
2919                 }
2920
2921                 Newx(buffer, len, char);
2922                 buffer_end = retval = buffer + len;
2923
2924                 /* Working backwards  */
2925                 *--retval = '\0';
2926                 *--retval = ')';
2927                 do {
2928                     *--retval = PL_hexdigit[addr & 15];
2929                 } while (addr >>= 4);
2930                 *--retval = 'x';
2931                 *--retval = '0';
2932                 *--retval = '(';
2933
2934                 retval -= typelen;
2935                 memcpy(retval, typestr, typelen);
2936
2937                 if (stashname) {
2938                     *--retval = '=';
2939                     retval -= stashnamelen;
2940                     memcpy(retval, stashname, stashnamelen);
2941                 }
2942                 /* retval may not necessarily have reached the start of the
2943                    buffer here.  */
2944                 assert (retval >= buffer);
2945
2946                 len = buffer_end - retval - 1; /* -1 for that \0  */
2947             }
2948             if (lp)
2949                 *lp = len;
2950             SAVEFREEPV(buffer);
2951             return retval;
2952         }
2953     }
2954
2955     if (SvPOKp(sv)) {
2956         if (lp)
2957             *lp = SvCUR(sv);
2958         if (flags & SV_MUTABLE_RETURN)
2959             return SvPVX_mutable(sv);
2960         if (flags & SV_CONST_RETURN)
2961             return (char *)SvPVX_const(sv);
2962         return SvPVX(sv);
2963     }
2964
2965     if (SvIOK(sv)) {
2966         /* I'm assuming that if both IV and NV are equally valid then
2967            converting the IV is going to be more efficient */
2968         const U32 isUIOK = SvIsUV(sv);
2969         char buf[TYPE_CHARS(UV)];
2970         char *ebuf, *ptr;
2971         STRLEN len;
2972
2973         if (SvTYPE(sv) < SVt_PVIV)
2974             sv_upgrade(sv, SVt_PVIV);
2975         ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2976         len = ebuf - ptr;
2977         /* inlined from sv_setpvn */
2978         s = SvGROW_mutable(sv, len + 1);
2979         Move(ptr, s, len, char);
2980         s += len;
2981         *s = '\0';
2982         SvPOK_on(sv);
2983     }
2984     else if (SvNOK(sv)) {
2985         if (SvTYPE(sv) < SVt_PVNV)
2986             sv_upgrade(sv, SVt_PVNV);
2987         if (SvNVX(sv) == 0.0) {
2988             s = SvGROW_mutable(sv, 2);
2989             *s++ = '0';
2990             *s = '\0';
2991         } else {
2992             dSAVE_ERRNO;
2993             /* The +20 is pure guesswork.  Configure test needed. --jhi */
2994             s = SvGROW_mutable(sv, NV_DIG + 20);
2995             /* some Xenix systems wipe out errno here */
2996
2997 #ifndef USE_LOCALE_NUMERIC
2998             PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
2999             SvPOK_on(sv);
3000 #else
3001             {
3002                 DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
3003                 PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
3004
3005                 /* If the radix character is UTF-8, and actually is in the
3006                  * output, turn on the UTF-8 flag for the scalar */
3007                 if (PL_numeric_local
3008                     && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
3009                     && instr(s, SvPVX_const(PL_numeric_radix_sv)))
3010                 {
3011                     SvUTF8_on(sv);
3012                 }
3013                 RESTORE_LC_NUMERIC();
3014             }
3015
3016             /* We don't call SvPOK_on(), because it may come to pass that the
3017              * locale changes so that the stringification we just did is no
3018              * longer correct.  We will have to re-stringify every time it is
3019              * needed */
3020 #endif
3021             RESTORE_ERRNO;
3022             while (*s) s++;
3023         }
3024     }
3025     else if (isGV_with_GP(sv)) {
3026         GV *const gv = MUTABLE_GV(sv);
3027         SV *const buffer = sv_newmortal();
3028
3029         gv_efullname3(buffer, gv, "*");
3030
3031         assert(SvPOK(buffer));
3032         if (SvUTF8(buffer))
3033             SvUTF8_on(sv);
3034         if (lp)
3035             *lp = SvCUR(buffer);
3036         return SvPVX(buffer);
3037     }
3038     else if (isREGEXP(sv)) {
3039         if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
3040         return RX_WRAPPED((REGEXP *)sv);
3041     }
3042     else {
3043         if (lp)
3044             *lp = 0;
3045         if (flags & SV_UNDEF_RETURNS_NULL)
3046             return NULL;
3047         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3048             report_uninit(sv);
3049         /* Typically the caller expects that sv_any is not NULL now.  */
3050         if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
3051             sv_upgrade(sv, SVt_PV);
3052         return (char *)"";
3053     }
3054
3055     {
3056         const STRLEN len = s - SvPVX_const(sv);
3057         if (lp) 
3058             *lp = len;
3059         SvCUR_set(sv, len);
3060     }
3061     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3062                           PTR2UV(sv),SvPVX_const(sv)));
3063     if (flags & SV_CONST_RETURN)
3064         return (char *)SvPVX_const(sv);
3065     if (flags & SV_MUTABLE_RETURN)
3066         return SvPVX_mutable(sv);
3067     return SvPVX(sv);
3068 }
3069
3070 /*
3071 =for apidoc sv_copypv
3072
3073 Copies a stringified representation of the source SV into the
3074 destination SV.  Automatically performs any necessary mg_get and
3075 coercion of numeric values into strings.  Guaranteed to preserve
3076 UTF8 flag even from overloaded objects.  Similar in nature to
3077 sv_2pv[_flags] but operates directly on an SV instead of just the
3078 string.  Mostly uses sv_2pv_flags to do its work, except when that
3079 would lose the UTF-8'ness of the PV.
3080
3081 =for apidoc sv_copypv_nomg
3082
3083 Like sv_copypv, but doesn't invoke get magic first.
3084
3085 =for apidoc sv_copypv_flags
3086
3087 Implementation of sv_copypv and sv_copypv_nomg.  Calls get magic iff flags
3088 include SV_GMAGIC.
3089
3090 =cut
3091 */
3092
3093 void
3094 Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
3095 {
3096     PERL_ARGS_ASSERT_SV_COPYPV;
3097
3098     sv_copypv_flags(dsv, ssv, 0);
3099 }
3100
3101 void
3102 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3103 {
3104     STRLEN len;
3105     const char *s;
3106
3107     PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3108
3109     if ((flags & SV_GMAGIC) && SvGMAGICAL(ssv))
3110         mg_get(ssv);
3111     s = SvPV_nomg_const(ssv,len);
3112     sv_setpvn(dsv,s,len);
3113     if (SvUTF8(ssv))
3114         SvUTF8_on(dsv);
3115     else
3116         SvUTF8_off(dsv);
3117 }
3118
3119 /*
3120 =for apidoc sv_2pvbyte
3121
3122 Return a pointer to the byte-encoded representation of the SV, and set *lp
3123 to its length.  May cause the SV to be downgraded from UTF-8 as a
3124 side-effect.
3125
3126 Usually accessed via the C<SvPVbyte> macro.
3127
3128 =cut
3129 */
3130
3131 char *
3132 Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
3133 {
3134     PERL_ARGS_ASSERT_SV_2PVBYTE;
3135
3136     SvGETMAGIC(sv);
3137     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3138      || isGV_with_GP(sv) || SvROK(sv)) {
3139         SV *sv2 = sv_newmortal();
3140         sv_copypv_nomg(sv2,sv);
3141         sv = sv2;
3142     }
3143     sv_utf8_downgrade(sv,0);
3144     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3145 }
3146
3147 /*
3148 =for apidoc sv_2pvutf8
3149
3150 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3151 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3152
3153 Usually accessed via the C<SvPVutf8> macro.
3154
3155 =cut
3156 */
3157
3158 char *
3159 Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
3160 {
3161     PERL_ARGS_ASSERT_SV_2PVUTF8;
3162
3163     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3164      || isGV_with_GP(sv) || SvROK(sv))
3165         sv = sv_mortalcopy(sv);
3166     else
3167         SvGETMAGIC(sv);
3168     sv_utf8_upgrade_nomg(sv);
3169     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3170 }
3171
3172
3173 /*
3174 =for apidoc sv_2bool
3175
3176 This macro is only used by sv_true() or its macro equivalent, and only if
3177 the latter's argument is neither SvPOK, SvIOK nor SvNOK.
3178 It calls sv_2bool_flags with the SV_GMAGIC flag.
3179
3180 =for apidoc sv_2bool_flags
3181
3182 This function is only used by sv_true() and friends,  and only if
3183 the latter's argument is neither SvPOK, SvIOK nor SvNOK.  If the flags
3184 contain SV_GMAGIC, then it does an mg_get() first.
3185
3186
3187 =cut
3188 */
3189
3190 bool
3191 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
3192 {
3193     PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3194
3195     restart:
3196     if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3197
3198     if (!SvOK(sv))
3199         return 0;
3200     if (SvROK(sv)) {
3201         if (SvAMAGIC(sv)) {
3202             SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3203             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
3204                 bool svb;
3205                 sv = tmpsv;
3206                 if(SvGMAGICAL(sv)) {
3207                     flags = SV_GMAGIC;
3208                     goto restart; /* call sv_2bool */
3209                 }
3210                 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
3211                 else if(!SvOK(sv)) {
3212                     svb = 0;
3213                 }
3214                 else if(SvPOK(sv)) {
3215                     svb = SvPVXtrue(sv);
3216                 }
3217                 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
3218                     svb = (SvIOK(sv) && SvIVX(sv) != 0)
3219                         || (SvNOK(sv) && SvNVX(sv) != 0.0);
3220                 }
3221                 else {
3222                     flags = 0;
3223                     goto restart; /* call sv_2bool_nomg */
3224                 }
3225                 return cBOOL(svb);
3226             }
3227         }
3228         return SvRV(sv) != 0;
3229     }
3230     if (isREGEXP(sv))
3231         return
3232           RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
3233     return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
3234 }
3235
3236 /*
3237 =for apidoc sv_utf8_upgrade
3238
3239 Converts the PV of an SV to its UTF-8-encoded form.
3240 Forces the SV to string form if it is not already.
3241 Will C<mg_get> on C<sv> if appropriate.
3242 Always sets the SvUTF8 flag to avoid future validity checks even
3243 if the whole string is the same in UTF-8 as not.
3244 Returns the number of bytes in the converted string
3245
3246 This is not a general purpose byte encoding to Unicode interface:
3247 use the Encode extension for that.
3248
3249 =for apidoc sv_utf8_upgrade_nomg
3250
3251 Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
3252
3253 =for apidoc sv_utf8_upgrade_flags
3254
3255 Converts the PV of an SV to its UTF-8-encoded form.
3256 Forces the SV to string form if it is not already.
3257 Always sets the SvUTF8 flag to avoid future validity checks even
3258 if all the bytes are invariant in UTF-8.
3259 If C<flags> has C<SV_GMAGIC> bit set,
3260 will C<mg_get> on C<sv> if appropriate, else not.
3261
3262 If C<flags> has SV_FORCE_UTF8_UPGRADE set, this function assumes that the PV
3263 will expand when converted to UTF-8, and skips the extra work of checking for
3264 that.  Typically this flag is used by a routine that has already parsed the
3265 string and found such characters, and passes this information on so that the
3266 work doesn't have to be repeated.
3267
3268 Returns the number of bytes in the converted string.
3269
3270 This is not a general purpose byte encoding to Unicode interface:
3271 use the Encode extension for that.
3272
3273 =for apidoc sv_utf8_upgrade_flags_grow
3274
3275 Like sv_utf8_upgrade_flags, but has an additional parameter C<extra>, which is
3276 the number of unused bytes the string of 'sv' is guaranteed to have free after
3277 it upon return.  This allows the caller to reserve extra space that it intends
3278 to fill, to avoid extra grows.
3279
3280 C<sv_utf8_upgrade>, C<sv_utf8_upgrade_nomg>, and C<sv_utf8_upgrade_flags>
3281 are implemented in terms of this function.
3282
3283 Returns the number of bytes in the converted string (not including the spares).
3284
3285 =cut
3286
3287 (One might think that the calling routine could pass in the position of the
3288 first variant character when it has set SV_FORCE_UTF8_UPGRADE, so it wouldn't
3289 have to be found again.  But that is not the case, because typically when the
3290 caller is likely to use this flag, it won't be calling this routine unless it
3291 finds something that won't fit into a byte.  Otherwise it tries to not upgrade
3292 and just use bytes.  But some things that do fit into a byte are variants in
3293 utf8, and the caller may not have been keeping track of these.)
3294
3295 If the routine itself changes the string, it adds a trailing C<NUL>.  Such a
3296 C<NUL> isn't guaranteed due to having other routines do the work in some input
3297 cases, or if the input is already flagged as being in utf8.
3298
3299 The speed of this could perhaps be improved for many cases if someone wanted to
3300 write a fast function that counts the number of variant characters in a string,
3301 especially if it could return the position of the first one.
3302
3303 */
3304
3305 STRLEN
3306 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3307 {
3308     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3309
3310     if (sv == &PL_sv_undef)
3311         return 0;
3312     if (!SvPOK_nog(sv)) {
3313         STRLEN len = 0;
3314         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3315             (void) sv_2pv_flags(sv,&len, flags);
3316             if (SvUTF8(sv)) {
3317                 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3318                 return len;
3319             }
3320         } else {
3321             (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3322         }
3323     }
3324
3325     if (SvUTF8(sv)) {
3326         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3327         return SvCUR(sv);
3328     }
3329
3330     if (SvIsCOW(sv)) {
3331         S_sv_uncow(aTHX_ sv, 0);
3332     }
3333
3334     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3335         sv_recode_to_utf8(sv, PL_encoding);
3336         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3337         return SvCUR(sv);
3338     }
3339
3340     if (SvCUR(sv) == 0) {
3341         if (extra) SvGROW(sv, extra);
3342     } else { /* Assume Latin-1/EBCDIC */
3343         /* This function could be much more efficient if we
3344          * had a FLAG in SVs to signal if there are any variant
3345          * chars in the PV.  Given that there isn't such a flag
3346          * make the loop as fast as possible (although there are certainly ways
3347          * to speed this up, eg. through vectorization) */
3348         U8 * s = (U8 *) SvPVX_const(sv);
3349         U8 * e = (U8 *) SvEND(sv);
3350         U8 *t = s;
3351         STRLEN two_byte_count = 0;
3352         
3353         if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3354
3355         /* See if really will need to convert to utf8.  We mustn't rely on our
3356          * incoming SV being well formed and having a trailing '\0', as certain
3357          * code in pp_formline can send us partially built SVs. */
3358
3359         while (t < e) {
3360             const U8 ch = *t++;
3361             if (NATIVE_BYTE_IS_INVARIANT(ch)) continue;
3362
3363             t--;    /* t already incremented; re-point to first variant */
3364             two_byte_count = 1;
3365             goto must_be_utf8;
3366         }
3367
3368         /* utf8 conversion not needed because all are invariants.  Mark as
3369          * UTF-8 even if no variant - saves scanning loop */
3370         SvUTF8_on(sv);
3371         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3372         return SvCUR(sv);
3373
3374 must_be_utf8:
3375
3376         /* Here, the string should be converted to utf8, either because of an
3377          * input flag (two_byte_count = 0), or because a character that
3378          * requires 2 bytes was found (two_byte_count = 1).  t points either to
3379          * the beginning of the string (if we didn't examine anything), or to
3380          * the first variant.  In either case, everything from s to t - 1 will
3381          * occupy only 1 byte each on output.
3382          *
3383          * There are two main ways to convert.  One is to create a new string
3384          * and go through the input starting from the beginning, appending each
3385          * converted value onto the new string as we go along.  It's probably
3386          * best to allocate enough space in the string for the worst possible
3387          * case rather than possibly running out of space and having to
3388          * reallocate and then copy what we've done so far.  Since everything
3389          * from s to t - 1 is invariant, the destination can be initialized
3390          * with these using a fast memory copy
3391          *
3392          * The other way is to figure out exactly how big the string should be
3393          * by parsing the entire input.  Then you don't have to make it big
3394          * enough to handle the worst possible case, and more importantly, if
3395          * the string you already have is large enough, you don't have to
3396          * allocate a new string, you can copy the last character in the input
3397          * string to the final position(s) that will be occupied by the
3398          * converted string and go backwards, stopping at t, since everything
3399          * before that is invariant.
3400          *
3401          * There are advantages and disadvantages to each method.
3402          *
3403          * In the first method, we can allocate a new string, do the memory
3404          * copy from the s to t - 1, and then proceed through the rest of the
3405          * string byte-by-byte.
3406          *
3407          * In the second method, we proceed through the rest of the input
3408          * string just calculating how big the converted string will be.  Then
3409          * there are two cases:
3410          *  1)  if the string has enough extra space to handle the converted
3411          *      value.  We go backwards through the string, converting until we
3412          *      get to the position we are at now, and then stop.  If this
3413          *      position is far enough along in the string, this method is
3414          *      faster than the other method.  If the memory copy were the same
3415          *      speed as the byte-by-byte loop, that position would be about
3416          *      half-way, as at the half-way mark, parsing to the end and back
3417          *      is one complete string's parse, the same amount as starting
3418          *      over and going all the way through.  Actually, it would be
3419          *      somewhat less than half-way, as it's faster to just count bytes
3420          *      than to also copy, and we don't have the overhead of allocating
3421          *      a new string, changing the scalar to use it, and freeing the
3422          *      existing one.  But if the memory copy is fast, the break-even
3423          *      point is somewhere after half way.  The counting loop could be
3424          *      sped up by vectorization, etc, to move the break-even point
3425          *      further towards the beginning.
3426          *  2)  if the string doesn't have enough space to handle the converted
3427          *      value.  A new string will have to be allocated, and one might
3428          *      as well, given that, start from the beginning doing the first
3429          *      method.  We've spent extra time parsing the string and in
3430          *      exchange all we've gotten is that we know precisely how big to
3431          *      make the new one.  Perl is more optimized for time than space,
3432          *      so this case is a loser.
3433          * So what I've decided to do is not use the 2nd method unless it is
3434          * guaranteed that a new string won't have to be allocated, assuming
3435          * the worst case.  I also decided not to put any more conditions on it
3436          * than this, for now.  It seems likely that, since the worst case is
3437          * twice as big as the unknown portion of the string (plus 1), we won't
3438          * be guaranteed enough space, causing us to go to the first method,
3439          * unless the string is short, or the first variant character is near
3440          * the end of it.  In either of these cases, it seems best to use the
3441          * 2nd method.  The only circumstance I can think of where this would
3442          * be really slower is if the string had once had much more data in it
3443          * than it does now, but there is still a substantial amount in it  */
3444
3445         {
3446             STRLEN invariant_head = t - s;
3447             STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3448             if (SvLEN(sv) < size) {
3449
3450                 /* Here, have decided to allocate a new string */
3451
3452                 U8 *dst;
3453                 U8 *d;
3454
3455                 Newx(dst, size, U8);
3456
3457                 /* If no known invariants at the beginning of the input string,
3458                  * set so starts from there.  Otherwise, can use memory copy to
3459                  * get up to where we are now, and then start from here */
3460
3461                 if (invariant_head <= 0) {
3462                     d = dst;
3463                 } else {
3464                     Copy(s, dst, invariant_head, char);
3465                     d = dst + invariant_head;
3466                 }
3467
3468                 while (t < e) {
3469                     append_utf8_from_native_byte(*t, &d);
3470                     t++;
3471                 }
3472                 *d = '\0';
3473                 SvPV_free(sv); /* No longer using pre-existing string */
3474                 SvPV_set(sv, (char*)dst);
3475                 SvCUR_set(sv, d - dst);
3476                 SvLEN_set(sv, size);
3477             } else {
3478
3479                 /* Here, have decided to get the exact size of the string.
3480                  * Currently this happens only when we know that there is
3481                  * guaranteed enough space to fit the converted string, so
3482                  * don't have to worry about growing.  If two_byte_count is 0,
3483                  * then t points to the first byte of the string which hasn't
3484                  * been examined yet.  Otherwise two_byte_count is 1, and t
3485                  * points to the first byte in the string that will expand to
3486                  * two.  Depending on this, start examining at t or 1 after t.
3487                  * */
3488
3489                 U8 *d = t + two_byte_count;
3490
3491
3492                 /* Count up the remaining bytes that expand to two */
3493
3494                 while (d < e) {
3495                     const U8 chr = *d++;
3496                     if (! NATIVE_BYTE_IS_INVARIANT(chr)) two_byte_count++;
3497                 }
3498
3499                 /* The string will expand by just the number of bytes that
3500                  * occupy two positions.  But we are one afterwards because of
3501                  * the increment just above.  This is the place to put the
3502                  * trailing NUL, and to set the length before we decrement */
3503
3504                 d += two_byte_count;
3505                 SvCUR_set(sv, d - s);
3506                 *d-- = '\0';
3507
3508
3509                 /* Having decremented d, it points to the position to put the
3510                  * very last byte of the expanded string.  Go backwards through
3511                  * the string, copying and expanding as we go, stopping when we
3512                  * get to the part that is invariant the rest of the way down */
3513
3514                 e--;
3515                 while (e >= t) {
3516                     if (NATIVE_BYTE_IS_INVARIANT(*e)) {
3517                         *d-- = *e;
3518                     } else {
3519                         *d-- = UTF8_EIGHT_BIT_LO(*e);
3520                         *d-- = UTF8_EIGHT_BIT_HI(*e);
3521                     }
3522                     e--;
3523                 }
3524             }
3525
3526             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3527                 /* Update pos. We do it at the end rather than during
3528                  * the upgrade, to avoid slowing down the common case
3529                  * (upgrade without pos).
3530                  * pos can be stored as either bytes or characters.  Since
3531                  * this was previously a byte string we can just turn off
3532                  * the bytes flag. */
3533                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3534                 if (mg) {
3535                     mg->mg_flags &= ~MGf_BYTES;
3536                 }
3537                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3538                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3539             }
3540         }
3541     }
3542
3543     /* Mark as UTF-8 even if no variant - saves scanning loop */
3544     SvUTF8_on(sv);
3545     return SvCUR(sv);
3546 }
3547
3548 /*
3549 =for apidoc sv_utf8_downgrade
3550
3551 Attempts to convert the PV of an SV from characters to bytes.
3552 If the PV contains a character that cannot fit
3553 in a byte, this conversion will fail;
3554 in this case, either returns false or, if C<fail_ok> is not
3555 true, croaks.
3556
3557 This is not a general purpose Unicode to byte encoding interface:
3558 use the Encode extension for that.
3559
3560 =cut
3561 */
3562
3563 bool
3564 Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
3565 {
3566     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3567
3568     if (SvPOKp(sv) && SvUTF8(sv)) {
3569         if (SvCUR(sv)) {
3570             U8 *s;
3571             STRLEN len;
3572             int mg_flags = SV_GMAGIC;
3573
3574             if (SvIsCOW(sv)) {
3575                 S_sv_uncow(aTHX_ sv, 0);
3576             }
3577             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3578                 /* update pos */
3579                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3580                 if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
3581                         mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
3582                                                 SV_GMAGIC|SV_CONST_RETURN);
3583                         mg_flags = 0; /* sv_pos_b2u does get magic */
3584                 }
3585                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3586                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3587
3588             }
3589             s = (U8 *) SvPV_flags(sv, len, mg_flags);
3590
3591             if (!utf8_to_bytes(s, &len)) {
3592                 if (fail_ok)
3593                     return FALSE;
3594                 else {
3595                     if (PL_op)
3596                         Perl_croak(aTHX_ "Wide character in %s",
3597                                    OP_DESC(PL_op));
3598                     else
3599                         Perl_croak(aTHX_ "Wide character");
3600                 }
3601             }
3602             SvCUR_set(sv, len);
3603         }
3604     }
3605     SvUTF8_off(sv);
3606     return TRUE;
3607 }
3608
3609 /*
3610 =for apidoc sv_utf8_encode
3611
3612 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3613 flag off so that it looks like octets again.
3614
3615 =cut
3616 */
3617
3618 void
3619 Perl_sv_utf8_encode(pTHX_ SV *const sv)
3620 {
3621     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3622
3623     if (SvREADONLY(sv)) {
3624         sv_force_normal_flags(sv, 0);
3625     }
3626     (void) sv_utf8_upgrade(sv);
3627     SvUTF8_off(sv);
3628 }
3629
3630 /*
3631 =for apidoc sv_utf8_decode
3632
3633 If the PV of the SV is an octet sequence in UTF-8
3634 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3635 so that it looks like a character.  If the PV contains only single-byte
3636 characters, the C<SvUTF8> flag stays off.
3637 Scans PV for validity and returns false if the PV is invalid UTF-8.
3638
3639 =cut
3640 */
3641
3642 bool
3643 Perl_sv_utf8_decode(pTHX_ SV *const sv)
3644 {
3645     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3646
3647     if (SvPOKp(sv)) {
3648         const U8 *start, *c;
3649         const U8 *e;
3650
3651         /* The octets may have got themselves encoded - get them back as
3652          * bytes
3653          */
3654         if (!sv_utf8_downgrade(sv, TRUE))
3655             return FALSE;
3656
3657         /* it is actually just a matter of turning the utf8 flag on, but
3658          * we want to make sure everything inside is valid utf8 first.
3659          */
3660         c = start = (const U8 *) SvPVX_const(sv);
3661         if (!is_utf8_string(c, SvCUR(sv)))
3662             return FALSE;
3663         e = (const U8 *) SvEND(sv);
3664         while (c < e) {
3665             const U8 ch = *c++;
3666             if (!UTF8_IS_INVARIANT(ch)) {
3667                 SvUTF8_on(sv);
3668                 break;
3669             }
3670         }
3671         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3672             /* XXX Is this dead code?  XS_utf8_decode calls SvSETMAGIC
3673                    after this, clearing pos.  Does anything on CPAN
3674                    need this? */
3675             /* adjust pos to the start of a UTF8 char sequence */
3676             MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3677             if (mg) {
3678                 I32 pos = mg->mg_len;
3679                 if (pos > 0) {
3680                     for (c = start + pos; c > start; c--) {
3681                         if (UTF8_IS_START(*c))
3682                             break;
3683                     }
3684                     mg->mg_len  = c - start;
3685                 }
3686             }
3687             if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3688                 magic_setutf8(sv,mg); /* clear UTF8 cache */
3689         }
3690     }
3691     return TRUE;
3692 }
3693
3694 /*
3695 =for apidoc sv_setsv
3696
3697 Copies the contents of the source SV C<ssv> into the destination SV
3698 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3699 function if the source SV needs to be reused.  Does not handle 'set' magic on
3700 destination SV.  Calls 'get' magic on source SV.  Loosely speaking, it
3701 performs a copy-by-value, obliterating any previous content of the
3702 destination.
3703
3704 You probably want to use one of the assortment of wrappers, such as
3705 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3706 C<SvSetMagicSV_nosteal>.
3707
3708 =for apidoc sv_setsv_flags
3709
3710 Copies the contents of the source SV C<ssv> into the destination SV
3711 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3712 function if the source SV needs to be reused.  Does not handle 'set' magic.
3713 Loosely speaking, it performs a copy-by-value, obliterating any previous
3714 content of the destination.
3715 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3716 C<ssv> if appropriate, else not.  If the C<flags>
3717 parameter has the C<SV_NOSTEAL> bit set then the
3718 buffers of temps will not be stolen.  <sv_setsv>
3719 and C<sv_setsv_nomg> are implemented in terms of this function.
3720
3721 You probably want to use one of the assortment of wrappers, such as
3722 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3723 C<SvSetMagicSV_nosteal>.
3724
3725 This is the primary function for copying scalars, and most other
3726 copy-ish functions and macros use this underneath.
3727
3728 =cut
3729 */
3730
3731 static void
3732 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3733 {
3734     I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3735     HV *old_stash = NULL;
3736
3737     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3738
3739     if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3740         const char * const name = GvNAME(sstr);
3741         const STRLEN len = GvNAMELEN(sstr);
3742         {
3743             if (dtype >= SVt_PV) {
3744                 SvPV_free(dstr);
3745                 SvPV_set(dstr, 0);
3746                 SvLEN_set(dstr, 0);
3747                 SvCUR_set(dstr, 0);
3748             }
3749             SvUPGRADE(dstr, SVt_PVGV);
3750             (void)SvOK_off(dstr);
3751             isGV_with_GP_on(dstr);
3752         }
3753         GvSTASH(dstr) = GvSTASH(sstr);
3754         if (GvSTASH(dstr))
3755             Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3756         gv_name_set(MUTABLE_GV(dstr), name, len,
3757                         GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
3758         SvFAKE_on(dstr);        /* can coerce to non-glob */
3759     }
3760
3761     if(GvGP(MUTABLE_GV(sstr))) {
3762         /* If source has method cache entry, clear it */
3763         if(GvCVGEN(sstr)) {
3764             SvREFCNT_dec(GvCV(sstr));
3765             GvCV_set(sstr, NULL);
3766             GvCVGEN(sstr) = 0;
3767         }
3768         /* If source has a real method, then a method is
3769            going to change */
3770         else if(
3771          GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3772         ) {
3773             mro_changes = 1;
3774         }
3775     }
3776
3777     /* If dest already had a real method, that's a change as well */
3778     if(
3779         !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3780      && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3781     ) {
3782         mro_changes = 1;
3783     }
3784
3785     /* We don't need to check the name of the destination if it was not a
3786        glob to begin with. */
3787     if(dtype == SVt_PVGV) {
3788         const char * const name = GvNAME((const GV *)dstr);
3789         if(
3790             strEQ(name,"ISA")
3791          /* The stash may have been detached from the symbol table, so
3792             check its name. */
3793          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3794         )
3795             mro_changes = 2;
3796         else {
3797             const STRLEN len = GvNAMELEN(dstr);
3798             if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3799              || (len == 1 && name[0] == ':')) {
3800                 mro_changes = 3;
3801
3802                 /* Set aside the old stash, so we can reset isa caches on
3803                    its subclasses. */
3804                 if((old_stash = GvHV(dstr)))
3805                     /* Make sure we do not lose it early. */
3806                     SvREFCNT_inc_simple_void_NN(
3807                      sv_2mortal((SV *)old_stash)
3808                     );
3809             }
3810         }
3811
3812         SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
3813     }
3814
3815     gp_free(MUTABLE_GV(dstr));
3816     GvINTRO_off(dstr);          /* one-shot flag */
3817     GvGP_set(dstr, gp_ref(GvGP(sstr)));
3818     if (SvTAINTED(sstr))
3819         SvTAINT(dstr);
3820     if (GvIMPORTED(dstr) != GVf_IMPORTED
3821         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3822         {
3823             GvIMPORTED_on(dstr);
3824         }
3825     GvMULTI_on(dstr);
3826     if(mro_changes == 2) {
3827       if (GvAV((const GV *)sstr)) {
3828         MAGIC *mg;
3829         SV * const sref = (SV *)GvAV((const GV *)dstr);
3830         if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3831             if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3832                 AV * const ary = newAV();
3833                 av_push(ary, mg->mg_obj); /* takes the refcount */
3834                 mg->mg_obj = (SV *)ary;
3835             }
3836             av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3837         }
3838         else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3839       }
3840       mro_isa_changed_in(GvSTASH(dstr));
3841     }
3842     else if(mro_changes == 3) {
3843         HV * const stash = GvHV(dstr);
3844         if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3845             mro_package_moved(
3846                 stash, old_stash,
3847                 (GV *)dstr, 0
3848             );
3849     }
3850     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3851     if (GvIO(dstr) && dtype == SVt_PVGV) {
3852         DEBUG_o(Perl_deb(aTHX_
3853                         "glob_assign_glob clearing PL_stashcache\n"));
3854         /* It's a cache. It will rebuild itself quite happily.
3855            It's a lot of effort to work out exactly which key (or keys)
3856            might be invalidated by the creation of the this file handle.
3857          */
3858         hv_clear(PL_stashcache);
3859     }
3860     return;
3861 }
3862
3863 static void
3864 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3865 {
3866     SV * const sref = SvRV(sstr);
3867     SV *dref;
3868     const int intro = GvINTRO(dstr);
3869     SV **location;
3870     U8 import_flag = 0;
3871     const U32 stype = SvTYPE(sref);
3872
3873     PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3874
3875     if (intro) {
3876         GvINTRO_off(dstr);      /* one-shot flag */
3877         GvLINE(dstr) = CopLINE(PL_curcop);
3878         GvEGV(dstr) = MUTABLE_GV(dstr);
3879     }
3880     GvMULTI_on(dstr);
3881     switch (stype) {
3882     case SVt_PVCV:
3883         location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
3884         import_flag = GVf_IMPORTED_CV;
3885         goto common;
3886     case SVt_PVHV:
3887         location = (SV **) &GvHV(dstr);
3888         import_flag = GVf_IMPORTED_HV;
3889         goto common;
3890     case SVt_PVAV:
3891         location = (SV **) &GvAV(dstr);
3892         import_flag = GVf_IMPORTED_AV;
3893         goto common;
3894     case SVt_PVIO:
3895         location = (SV **) &GvIOp(dstr);
3896         goto common;
3897     case SVt_PVFM:
3898         location = (SV **) &GvFORM(dstr);
3899         goto common;
3900     default:
3901         location = &GvSV(dstr);
3902         import_flag = GVf_IMPORTED_SV;
3903     common:
3904         if (intro) {
3905             if (stype == SVt_PVCV) {
3906                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3907                 if (GvCVGEN(dstr)) {
3908                     SvREFCNT_dec(GvCV(dstr));
3909                     GvCV_set(dstr, NULL);
3910                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3911                 }
3912             }
3913             /* SAVEt_GVSLOT takes more room on the savestack and has more
3914                overhead in leave_scope than SAVEt_GENERIC_SV.  But for CVs
3915                leave_scope needs access to the GV so it can reset method
3916                caches.  We must use SAVEt_GVSLOT whenever the type is
3917                SVt_PVCV, even if the stash is anonymous, as the stash may
3918                gain a name somehow before leave_scope. */
3919             if (stype == SVt_PVCV) {
3920                 /* There is no save_pushptrptrptr.  Creating it for this
3921                    one call site would be overkill.  So inline the ss add
3922                    routines here. */
3923                 dSS_ADD;
3924                 SS_ADD_PTR(dstr);
3925                 SS_ADD_PTR(location);
3926                 SS_ADD_PTR(SvREFCNT_inc(*location));
3927                 SS_ADD_UV(SAVEt_GVSLOT);
3928                 SS_ADD_END(4);
3929             }
3930             else SAVEGENERICSV(*location);
3931         }
3932         dref = *location;
3933         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3934             CV* const cv = MUTABLE_CV(*location);
3935             if (cv) {
3936                 if (!GvCVGEN((const GV *)dstr) &&
3937                     (CvROOT(cv) || CvXSUB(cv)) &&
3938                     /* redundant check that avoids creating the extra SV
3939                        most of the time: */
3940                     (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
3941                     {
3942                         SV * const new_const_sv =
3943                             CvCONST((const CV *)sref)
3944                                  ? cv_const_sv((const CV *)sref)
3945                                  : NULL;
3946                         report_redefined_cv(
3947                            sv_2mortal(Perl_newSVpvf(aTHX_
3948                                 "%"HEKf"::%"HEKf,
3949                                 HEKfARG(
3950                                  HvNAME_HEK(GvSTASH((const GV *)dstr))
3951                                 ),
3952                                 HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
3953                            )),
3954                            cv,
3955                            CvCONST((const CV *)sref) ? &new_const_sv : NULL
3956                         );
3957                     }
3958                 if (!intro)
3959                     cv_ckproto_len_flags(cv, (const GV *)dstr,
3960                                    SvPOK(sref) ? CvPROTO(sref) : NULL,
3961                                    SvPOK(sref) ? CvPROTOLEN(sref) : 0,
3962                                    SvPOK(sref) ? SvUTF8(sref) : 0);
3963             }
3964             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3965             GvASSUMECV_on(dstr);
3966             if(GvSTASH(dstr)) gv_method_changed(dstr); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3967         }
3968         *location = SvREFCNT_inc_simple_NN(sref);
3969         if (import_flag && !(GvFLAGS(dstr) & import_flag)
3970             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3971             GvFLAGS(dstr) |= import_flag;
3972         }
3973         if (stype == SVt_PVHV) {
3974             const char * const name = GvNAME((GV*)dstr);
3975             const STRLEN len = GvNAMELEN(dstr);
3976             if (
3977                 (
3978                    (len > 1 && name[len-2] == ':' && name[len-1] == ':')
3979                 || (len == 1 && name[0] == ':')
3980                 )
3981              && (!dref || HvENAME_get(dref))
3982             ) {
3983                 mro_package_moved(
3984                     (HV *)sref, (HV *)dref,
3985                     (GV *)dstr, 0
3986                 );
3987             }
3988         }
3989         else if (
3990             stype == SVt_PVAV && sref != dref
3991          && strEQ(GvNAME((GV*)dstr), "ISA")
3992          /* The stash may have been detached from the symbol table, so
3993             check its name before doing anything. */
3994          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3995         ) {
3996             MAGIC *mg;
3997             MAGIC * const omg = dref && SvSMAGICAL(dref)
3998                                  ? mg_find(dref, PERL_MAGIC_isa)
3999                                  : NULL;
4000             if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
4001                 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
4002                     AV * const ary = newAV();
4003                     av_push(ary, mg->mg_obj); /* takes the refcount */
4004                     mg->mg_obj = (SV *)ary;
4005                 }
4006                 if (omg) {
4007                     if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
4008                         SV **svp = AvARRAY((AV *)omg->mg_obj);
4009                         I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
4010                         while (items--)
4011                             av_push(
4012                              (AV *)mg->mg_obj,
4013                              SvREFCNT_inc_simple_NN(*svp++)
4014                             );
4015                     }
4016                     else
4017                         av_push(
4018                          (AV *)mg->mg_obj,
4019                          SvREFCNT_inc_simple_NN(omg->mg_obj)
4020                         );
4021                 }
4022                 else
4023                     av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
4024             }
4025             else
4026             {
4027                 sv_magic(
4028                  sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
4029                 );
4030                 mg = mg_find(sref, PERL_MAGIC_isa);
4031             }
4032             /* Since the *ISA assignment could have affected more than
4033                one stash, don't call mro_isa_changed_in directly, but let
4034                magic_clearisa do it for us, as it already has the logic for
4035                dealing with globs vs arrays of globs. */
4036             assert(mg);
4037             Perl_magic_clearisa(aTHX_ NULL, mg);
4038         }
4039         else if (stype == SVt_PVIO) {
4040             DEBUG_o(Perl_deb(aTHX_ "glob_assign_ref clearing PL_stashcache\n"));
4041             /* It's a cache. It will rebuild itself quite happily.
4042                It's a lot of effort to work out exactly which key (or keys)
4043                might be invalidated by the creation of the this file handle.
4044             */
4045             hv_clear(PL_stashcache);
4046         }
4047         break;
4048     }
4049     if (!intro) SvREFCNT_dec(dref);
4050     if (SvTAINTED(sstr))
4051         SvTAINT(dstr);
4052     return;
4053 }
4054
4055
4056
4057
4058 #ifdef PERL_DEBUG_READONLY_COW
4059 # include <sys/mman.h>
4060
4061 # ifndef PERL_MEMORY_DEBUG_HEADER_SIZE
4062 #  define PERL_MEMORY_DEBUG_HEADER_SIZE 0
4063 # endif
4064
4065 void
4066 Perl_sv_buf_to_ro(pTHX_ SV *sv)
4067 {
4068     struct perl_memory_debug_header * const header =
4069         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4070     const MEM_SIZE len = header->size;
4071     PERL_ARGS_ASSERT_SV_BUF_TO_RO;
4072 # ifdef PERL_TRACK_MEMPOOL
4073     if (!header->readonly) header->readonly = 1;
4074 # endif
4075     if (mprotect(header, len, PROT_READ))
4076         Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
4077                          header, len, errno);
4078 }
4079
4080 static void
4081 S_sv_buf_to_rw(pTHX_ SV *sv)
4082 {
4083     struct perl_memory_debug_header * const header =
4084         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4085     const MEM_SIZE len = header->size;
4086     PERL_ARGS_ASSERT_SV_BUF_TO_RW;
4087     if (mprotect(header, len, PROT_READ|PROT_WRITE))
4088         Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
4089                          header, len, errno);
4090 # ifdef PERL_TRACK_MEMPOOL
4091     header->readonly = 0;
4092 # endif
4093 }
4094
4095 #else
4096 # define sv_buf_to_ro(sv)       NOOP
4097 # define sv_buf_to_rw(sv)       NOOP
4098 #endif
4099
4100 void
4101 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
4102 {
4103     U32 sflags;
4104     int dtype;
4105     svtype stype;
4106
4107     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
4108
4109     if (sstr == dstr)
4110         return;
4111
4112     if (SvIS_FREED(dstr)) {
4113         Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
4114                    " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
4115     }
4116     SV_CHECK_THINKFIRST_COW_DROP(dstr);
4117     if (!sstr)
4118         sstr = &PL_sv_undef;
4119     if (SvIS_FREED(sstr)) {
4120         Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
4121                    (void*)sstr, (void*)dstr);
4122     }
4123     stype = SvTYPE(sstr);
4124     dtype = SvTYPE(dstr);
4125
4126     /* There's a lot of redundancy below but we're going for speed here */
4127
4128     switch (stype) {
4129     case SVt_NULL:
4130       undef_sstr:
4131         if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
4132             (void)SvOK_off(dstr);
4133             return;
4134         }
4135         break;
4136     case SVt_IV:
4137         if (SvIOK(sstr)) {
4138             switch (dtype) {
4139             case SVt_NULL:
4140                 sv_upgrade(dstr, SVt_IV);
4141                 break;
4142             case SVt_NV:
4143             case SVt_PV:
4144                 sv_upgrade(dstr, SVt_PVIV);
4145                 break;
4146             case SVt_PVGV:
4147             case SVt_PVLV:
4148                 goto end_of_first_switch;
4149             }
4150             (void)SvIOK_only(dstr);
4151             SvIV_set(dstr,  SvIVX(sstr));
4152             if (SvIsUV(sstr))
4153                 SvIsUV_on(dstr);
4154             /* SvTAINTED can only be true if the SV has taint magic, which in
4155                turn means that the SV type is PVMG (or greater). This is the
4156                case statement for SVt_IV, so this cannot be true (whatever gcov
4157                may say).  */
4158             assert(!SvTAINTED(sstr));
4159             return;
4160         }
4161         if (!SvROK(sstr))
4162             goto undef_sstr;
4163         if (dtype < SVt_PV && dtype != SVt_IV)
4164             sv_upgrade(dstr, SVt_IV);
4165         break;
4166
4167     case SVt_NV:
4168         if (SvNOK(sstr)) {
4169             switch (dtype) {
4170             case SVt_NULL:
4171             case SVt_IV:
4172                 sv_upgrade(dstr, SVt_NV);
4173                 break;
4174             case SVt_PV:
4175             case SVt_PVIV:
4176                 sv_upgrade(dstr, SVt_PVNV);
4177                 break;
4178             case SVt_PVGV:
4179             case SVt_PVLV:
4180                 goto end_of_first_switch;
4181             }
4182             SvNV_set(dstr, SvNVX(sstr));
4183             (void)SvNOK_only(dstr);
4184             /* SvTAINTED can only be true if the SV has taint magic, which in
4185                turn means that the SV type is PVMG (or greater). This is the
4186                case statement for SVt_NV, so this cannot be true (whatever gcov
4187                may say).  */
4188             assert(!SvTAINTED(sstr));
4189             return;
4190         }
4191         goto undef_sstr;
4192
4193     case SVt_PV:
4194         if (dtype < SVt_PV)
4195             sv_upgrade(dstr, SVt_PV);
4196         break;
4197     case SVt_PVIV:
4198         if (dtype < SVt_PVIV)
4199             sv_upgrade(dstr, SVt_PVIV);
4200         break;
4201     case SVt_PVNV:
4202         if (dtype < SVt_PVNV)
4203             sv_upgrade(dstr, SVt_PVNV);
4204         break;
4205     default:
4206         {
4207         const char * const type = sv_reftype(sstr,0);
4208         if (PL_op)
4209             /* diag_listed_as: Bizarre copy of %s */
4210             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4211         else
4212             Perl_croak(aTHX_ "Bizarre copy of %s", type);
4213         }
4214         NOT_REACHED; /* NOTREACHED */
4215
4216     case SVt_REGEXP:
4217       upgregexp:
4218         if (dtype < SVt_REGEXP)
4219         {
4220             if (dtype >= SVt_PV) {
4221                 SvPV_free(dstr);
4222                 SvPV_set(dstr, 0);
4223                 SvLEN_set(dstr, 0);
4224                 SvCUR_set(dstr, 0);
4225             }
4226             sv_upgrade(dstr, SVt_REGEXP);
4227         }
4228         break;
4229
4230         case SVt_INVLIST:
4231     case SVt_PVLV:
4232     case SVt_PVGV:
4233     case SVt_PVMG:
4234         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4235             mg_get(sstr);
4236             if (SvTYPE(sstr) != stype)
4237                 stype = SvTYPE(sstr);
4238         }
4239         if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4240                     glob_assign_glob(dstr, sstr, dtype);
4241                     return;
4242         }
4243         if (stype == SVt_PVLV)
4244         {
4245             if (isREGEXP(sstr)) goto upgregexp;
4246             SvUPGRADE(dstr, SVt_PVNV);
4247         }
4248         else
4249             SvUPGRADE(dstr, (svtype)stype);
4250     }
4251  end_of_first_switch:
4252
4253     /* dstr may have been upgraded.  */
4254     dtype = SvTYPE(dstr);
4255     sflags = SvFLAGS(sstr);
4256
4257     if (dtype == SVt_PVCV) {
4258         /* Assigning to a subroutine sets the prototype.  */
4259         if (SvOK(sstr)) {
4260             STRLEN len;
4261             const char *const ptr = SvPV_const(sstr, len);
4262
4263             SvGROW(dstr, len + 1);
4264             Copy(ptr, SvPVX(dstr), len + 1, char);
4265             SvCUR_set(dstr, len);
4266             SvPOK_only(dstr);
4267             SvFLAGS(dstr) |= sflags & SVf_UTF8;
4268             CvAUTOLOAD_off(dstr);
4269         } else {
4270             SvOK_off(dstr);
4271         }
4272     }
4273     else if (dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM) {
4274         const char * const type = sv_reftype(dstr,0);
4275         if (PL_op)
4276             /* diag_listed_as: Cannot copy to %s */
4277             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4278         else
4279             Perl_croak(aTHX_ "Cannot copy to %s", type);
4280     } else if (sflags & SVf_ROK) {
4281         if (isGV_with_GP(dstr)
4282             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4283             sstr = SvRV(sstr);
4284             if (sstr == dstr) {
4285                 if (GvIMPORTED(dstr) != GVf_IMPORTED
4286                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4287                 {
4288                     GvIMPORTED_on(dstr);
4289                 }
4290                 GvMULTI_on(dstr);
4291                 return;
4292             }
4293             glob_assign_glob(dstr, sstr, dtype);
4294             return;
4295         }
4296
4297         if (dtype >= SVt_PV) {
4298             if (isGV_with_GP(dstr)) {
4299                 glob_assign_ref(dstr, sstr);
4300                 return;
4301             }
4302             if (SvPVX_const(dstr)) {
4303                 SvPV_free(dstr);
4304                 SvLEN_set(dstr, 0);
4305                 SvCUR_set(dstr, 0);
4306             }
4307         }
4308         (void)SvOK_off(dstr);
4309         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4310         SvFLAGS(dstr) |= sflags & SVf_ROK;
4311         assert(!(sflags & SVp_NOK));
4312         assert(!(sflags & SVp_IOK));
4313         assert(!(sflags & SVf_NOK));
4314         assert(!(sflags & SVf_IOK));
4315     }
4316     else if (isGV_with_GP(dstr)) {
4317         if (!(sflags & SVf_OK)) {
4318             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4319                            "Undefined value assigned to typeglob");
4320         }
4321         else {
4322             GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
4323             if (dstr != (const SV *)gv) {
4324                 const char * const name = GvNAME((const GV *)dstr);
4325                 const STRLEN len = GvNAMELEN(dstr);
4326                 HV *old_stash = NULL;
4327                 bool reset_isa = FALSE;
4328                 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4329                  || (len == 1 && name[0] == ':')) {
4330                     /* Set aside the old stash, so we can reset isa caches
4331                        on its subclasses. */
4332                     if((old_stash = GvHV(dstr))) {
4333                         /* Make sure we do not lose it early. */
4334                         SvREFCNT_inc_simple_void_NN(
4335                          sv_2mortal((SV *)old_stash)
4336                         );
4337                     }
4338                     reset_isa = TRUE;
4339                 }
4340
4341                 if (GvGP(dstr)) {
4342                     SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
4343                     gp_free(MUTABLE_GV(dstr));
4344                 }
4345                 GvGP_set(dstr, gp_ref(GvGP(gv)));
4346
4347                 if (reset_isa) {
4348                     HV * const stash = GvHV(dstr);
4349                     if(
4350                         old_stash ? (HV *)HvENAME_get(old_stash) : stash
4351                     )
4352                         mro_package_moved(
4353                          stash, old_stash,
4354                          (GV *)dstr, 0
4355                         );
4356                 }
4357             }
4358         }
4359     }
4360     else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4361           && (stype == SVt_REGEXP || isREGEXP(sstr))) {
4362         reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4363     }
4364     else if (sflags & SVp_POK) {
4365         const STRLEN cur = SvCUR(sstr);
4366         const STRLEN len = SvLEN(sstr);
4367
4368         /*
4369          * We have three basic ways to copy the string:
4370          *
4371          *  1. Swipe
4372          *  2. Copy-on-write
4373          *  3. Actual copy
4374          * 
4375          * Which we choose is based on various factors.  The following
4376          * things are listed in order of speed, fastest to slowest:
4377          *  - Swipe
4378          *  - Copying a short string
4379          *  - Copy-on-write bookkeeping
4380          *  - malloc
4381          *  - Copying a long string
4382          * 
4383          * We swipe the string (steal the string buffer) if the SV on the
4384          * rhs is about to be freed anyway (TEMP and refcnt==1).  This is a
4385          * big win on long strings.  It should be a win on short strings if
4386          * SvPVX_const(dstr) has to be allocated.  If not, it should not 
4387          * slow things down, as SvPVX_const(sstr) would have been freed
4388          * soon anyway.
4389          * 
4390          * We also steal the buffer from a PADTMP (operator target) if it
4391          * is ‘long enough’.  For short strings, a swipe does not help
4392          * here, as it causes more malloc calls the next time the target
4393          * is used.  Benchmarks show that even if SvPVX_const(dstr) has to
4394          * be allocated it is still not worth swiping PADTMPs for short
4395          * strings, as the savings here are small.
4396          * 
4397          * If the rhs is already flagged as a copy-on-write string and COW
4398          * is possible here, we use copy-on-write and make both SVs share
4399          * the string buffer.
4400          * 
4401          * If the rhs is not flagged as copy-on-write, then we see whether
4402          * it is worth upgrading it to such.  If the lhs already has a buf-
4403          * fer big enough and the string is short, we skip it and fall back
4404          * to method 3, since memcpy is faster for short strings than the
4405          * later bookkeeping overhead that copy-on-write entails.
4406          * 
4407          * If there is no buffer on the left, or the buffer is too small,
4408          * then we use copy-on-write.
4409          */
4410
4411         /* Whichever path we take through the next code, we want this true,
4412            and doing it now facilitates the COW check.  */
4413         (void)SvPOK_only(dstr);
4414
4415         if (
4416                  (              /* Either ... */
4417                                 /* slated for free anyway (and not COW)? */
4418                     (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
4419                                 /* or a swipable TARG */
4420                  || ((sflags & (SVs_PADTMP|SVf_READONLY|SVf_IsCOW))
4421                        == SVs_PADTMP
4422                                 /* whose buffer is worth stealing */
4423                      && CHECK_COWBUF_THRESHOLD(cur,len)
4424                     )
4425                  ) &&
4426                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4427                  (!(flags & SV_NOSTEAL)) &&
4428                                         /* and we're allowed to steal temps */
4429                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4430                  len)             /* and really is a string */
4431         {       /* Passes the swipe test.  */
4432             if (SvPVX_const(dstr))      /* we know that dtype >= SVt_PV */
4433                 SvPV_free(dstr);
4434             SvPV_set(dstr, SvPVX_mutable(sstr));
4435             SvLEN_set(dstr, SvLEN(sstr));
4436             SvCUR_set(dstr, SvCUR(sstr));
4437
4438             SvTEMP_off(dstr);
4439             (void)SvOK_off(sstr);       /* NOTE: nukes most SvFLAGS on sstr */
4440             SvPV_set(sstr, NULL);
4441             SvLEN_set(sstr, 0);
4442             SvCUR_set(sstr, 0);
4443             SvTEMP_off(sstr);
4444         }
4445         else if (flags & SV_COW_SHARED_HASH_KEYS
4446               &&
4447 #ifdef PERL_OLD_COPY_ON_WRITE
4448                  (  sflags & SVf_IsCOW
4449                  || (   (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4450                      && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4451                      && SvTYPE(sstr) >= SVt_PVIV && len
4452                     )
4453                  )
4454 #elif defined(PERL_NEW_COPY_ON_WRITE)
4455                  (sflags & SVf_IsCOW
4456                    ? (!len ||
4457                        (  (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
4458                           /* If this is a regular (non-hek) COW, only so
4459                              many COW "copies" are possible. */
4460                        && CowREFCNT(sstr) != SV_COW_REFCNT_MAX  ))
4461                    : (  (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4462                      && !(SvFLAGS(dstr) & SVf_BREAK)
4463                      && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len
4464                      && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
4465                     ))
4466 #else
4467                  sflags & SVf_IsCOW
4468               && !(SvFLAGS(dstr) & SVf_BREAK)
4469 #endif
4470             ) {
4471             /* Either it's a shared hash key, or it's suitable for
4472                copy-on-write.  */
4473             if (DEBUG_C_TEST) {
4474                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4475                 sv_dump(sstr);
4476                 sv_dump(dstr);
4477             }
4478 #ifdef PERL_ANY_COW
4479             if (!(sflags & SVf_IsCOW)) {
4480                     SvIsCOW_on(sstr);
4481 # ifdef PERL_OLD_COPY_ON_WRITE
4482                     /* Make the source SV into a loop of 1.
4483                        (about to become 2) */
4484                     SV_COW_NEXT_SV_SET(sstr, sstr);
4485 # else
4486                     CowREFCNT(sstr) = 0;
4487 # endif
4488             }
4489 #endif
4490             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
4491                 SvPV_free(dstr);
4492             }
4493
4494 #ifdef PERL_ANY_COW
4495             if (len) {
4496 # ifdef PERL_OLD_COPY_ON_WRITE
4497                     assert (SvTYPE(dstr) >= SVt_PVIV);
4498                     /* SvIsCOW_normal */
4499                     /* splice us in between source and next-after-source.  */
4500                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4501                     SV_COW_NEXT_SV_SET(sstr, dstr);
4502 # else
4503                     if (sflags & SVf_IsCOW) {
4504                         sv_buf_to_rw(sstr);
4505                     }
4506                     CowREFCNT(sstr)++;
4507 # endif
4508                     SvPV_set(dstr, SvPVX_mutable(sstr));
4509                     sv_buf_to_ro(sstr);
4510             } else
4511 #endif
4512             {
4513                     /* SvIsCOW_shared_hash */
4514                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4515                                           "Copy on write: Sharing hash\n"));
4516
4517                     assert (SvTYPE(dstr) >= SVt_PV);
4518                     SvPV_set(dstr,
4519                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4520             }
4521             SvLEN_set(dstr, len);
4522             SvCUR_set(dstr, cur);
4523             SvIsCOW_on(dstr);
4524         } else {
4525             /* Failed the swipe test, and we cannot do copy-on-write either.
4526                Have to copy the string.  */
4527             SvGROW(dstr, cur + 1);      /* inlined from sv_setpvn */
4528             Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
4529             SvCUR_set(dstr, cur);
4530             *SvEND(dstr) = '\0';
4531         }
4532         if (sflags & SVp_NOK) {
4533             SvNV_set(dstr, SvNVX(sstr));
4534         }
4535         if (sflags & SVp_IOK) {
4536             SvIV_set(dstr, SvIVX(sstr));
4537             /* Must do this otherwise some other overloaded use of 0x80000000
4538                gets confused. I guess SVpbm_VALID */
4539             if (sflags & SVf_IVisUV)
4540                 SvIsUV_on(dstr);
4541         }
4542         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4543         {
4544             const MAGIC * const smg = SvVSTRING_mg(sstr);
4545             if (smg) {
4546                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4547                          smg->mg_ptr, smg->mg_len);
4548                 SvRMAGICAL_on(dstr);
4549             }
4550         }
4551     }
4552     else if (sflags & (SVp_IOK|SVp_NOK)) {
4553         (void)SvOK_off(dstr);
4554         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4555         if (sflags & SVp_IOK) {
4556             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4557             SvIV_set(dstr, SvIVX(sstr));
4558         }
4559         if (sflags & SVp_NOK) {
4560             SvNV_set(dstr, SvNVX(sstr));
4561         }
4562     }
4563     else {
4564         if (isGV_with_GP(sstr)) {
4565             gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4566         }
4567         else
4568             (void)SvOK_off(dstr);
4569     }
4570     if (SvTAINTED(sstr))
4571         SvTAINT(dstr);
4572 }
4573
4574 /*
4575 =for apidoc sv_setsv_mg
4576
4577 Like C<sv_setsv>, but also handles 'set' magic.
4578
4579 =cut
4580 */
4581
4582 void
4583 Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr)
4584 {
4585     PERL_ARGS_ASSERT_SV_SETSV_MG;
4586
4587     sv_setsv(dstr,sstr);
4588     SvSETMAGIC(dstr);
4589 }
4590
4591 #ifdef PERL_ANY_COW
4592 # ifdef PERL_OLD_COPY_ON_WRITE
4593 #  define SVt_COW SVt_PVIV
4594 # else
4595 #  define SVt_COW SVt_PV
4596 # endif
4597 SV *
4598 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4599 {
4600     STRLEN cur = SvCUR(sstr);
4601     STRLEN len = SvLEN(sstr);
4602     char *new_pv;
4603 #if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_NEW_COPY_ON_WRITE)
4604     const bool already = cBOOL(SvIsCOW(sstr));
4605 #endif
4606
4607     PERL_ARGS_ASSERT_SV_SETSV_COW;
4608
4609     if (DEBUG_C_TEST) {
4610         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4611                       (void*)sstr, (void*)dstr);
4612         sv_dump(sstr);
4613         if (dstr)
4614                     sv_dump(dstr);
4615     }
4616
4617     if (dstr) {
4618         if (SvTHINKFIRST(dstr))
4619             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4620         else if (SvPVX_const(dstr))
4621             Safefree(SvPVX_mutable(dstr));
4622     }
4623     else
4624         new_SV(dstr);
4625     SvUPGRADE(dstr, SVt_COW);
4626
4627     assert (SvPOK(sstr));
4628     assert (SvPOKp(sstr));
4629 # ifdef PERL_OLD_COPY_ON_WRITE
4630     assert (!SvIOK(sstr));
4631     assert (!SvIOKp(sstr));
4632     assert (!SvNOK(sstr));
4633     assert (!SvNOKp(sstr));
4634 # endif
4635
4636     if (SvIsCOW(sstr)) {
4637
4638         if (SvLEN(sstr) == 0) {
4639             /* source is a COW shared hash key.  */
4640             DEBUG_C(PerlIO_printf(Perl_debug_log,
4641                                   "Fast copy on write: Sharing hash\n"));
4642             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4643             goto common_exit;
4644         }
4645 # ifdef PERL_OLD_COPY_ON_WRITE
4646         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4647 # else
4648         assert(SvCUR(sstr)+1 < SvLEN(sstr));
4649         assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX);
4650 # endif
4651     } else {
4652         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4653         SvUPGRADE(sstr, SVt_COW);
4654         SvIsCOW_on(sstr);
4655         DEBUG_C(PerlIO_printf(Perl_debug_log,
4656                               "Fast copy on write: Converting sstr to COW\n"));
4657 # ifdef PERL_OLD_COPY_ON_WRITE
4658         SV_COW_NEXT_SV_SET(dstr, sstr);
4659 # else
4660         CowREFCNT(sstr) = 0;    
4661 # endif
4662     }
4663 # ifdef PERL_OLD_COPY_ON_WRITE
4664     SV_COW_NEXT_SV_SET(sstr, dstr);
4665 # else
4666 #  ifdef PERL_DEBUG_READONLY_COW
4667     if (already) sv_buf_to_rw(sstr);
4668 #  endif
4669     CowREFCNT(sstr)++;  
4670 # endif
4671     new_pv = SvPVX_mutable(sstr);
4672     sv_buf_to_ro(sstr);
4673
4674   common_exit:
4675     SvPV_set(dstr, new_pv);
4676     SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
4677     if (SvUTF8(sstr))
4678         SvUTF8_on(dstr);
4679     SvLEN_set(dstr, len);
4680     SvCUR_set(dstr, cur);
4681     if (DEBUG_C_TEST) {
4682         sv_dump(dstr);
4683     }
4684     return dstr;
4685 }
4686 #endif
4687
4688 /*
4689 =for apidoc sv_setpvn
4690
4691 Copies a string (possibly containing embedded C<NUL> characters) into an SV.
4692 The C<len> parameter indicates the number of
4693 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4694 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4695
4696 =cut
4697 */
4698
4699 void
4700 Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4701 {
4702     char *dptr;
4703
4704     PERL_ARGS_ASSERT_SV_SETPVN;
4705
4706     SV_CHECK_THINKFIRST_COW_DROP(sv);
4707     if (!ptr) {
4708         (void)SvOK_off(sv);
4709         return;
4710     }
4711     else {
4712         /* len is STRLEN which is unsigned, need to copy to signed */
4713         const IV iv = len;
4714         if (iv < 0)
4715             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
4716                        IVdf, iv);
4717     }
4718     SvUPGRADE(sv, SVt_PV);
4719
4720     dptr = SvGROW(sv, len + 1);
4721     Move(ptr,dptr,len,char);
4722     dptr[len] = '\0';
4723     SvCUR_set(sv, len);
4724     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4725     SvTAINT(sv);
4726     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4727 }
4728
4729 /*
4730 =for apidoc sv_setpvn_mg
4731
4732 Like C<sv_setpvn>, but also handles 'set' magic.
4733
4734 =cut
4735 */
4736
4737 void
4738 Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4739 {
4740     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4741
4742     sv_setpvn(sv,ptr,len);
4743     SvSETMAGIC(sv);
4744 }
4745
4746 /*
4747 =for apidoc sv_setpv
4748
4749 Copies a string into an SV.  The string must be terminated with a C<NUL>
4750 character.
4751 Does not handle 'set' magic.  See C<sv_setpv_mg>.
4752
4753 =cut
4754 */
4755
4756 void
4757 Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
4758 {
4759     STRLEN len;
4760
4761     PERL_ARGS_ASSERT_SV_SETPV;
4762
4763     SV_CHECK_THINKFIRST_COW_DROP(sv);
4764     if (!ptr) {
4765         (void)SvOK_off(sv);
4766         return;
4767     }
4768     len = strlen(ptr);
4769     SvUPGRADE(sv, SVt_PV);
4770
4771     SvGROW(sv, len + 1);
4772     Move(ptr,SvPVX(sv),len+1,char);
4773     SvCUR_set(sv, len);
4774     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4775     SvTAINT(sv);
4776     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4777 }
4778
4779 /*
4780 =for apidoc sv_setpv_mg
4781
4782 Like C<sv_setpv>, but also handles 'set' magic.
4783
4784 =cut
4785 */
4786
4787 void
4788 Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
4789 {
4790     PERL_ARGS_ASSERT_SV_SETPV_MG;
4791
4792     sv_setpv(sv,ptr);
4793     SvSETMAGIC(sv);
4794 }
4795
4796 void
4797 Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
4798 {
4799     PERL_ARGS_ASSERT_SV_SETHEK;
4800
4801     if (!hek) {
4802         return;
4803     }
4804
4805     if (HEK_LEN(hek) == HEf_SVKEY) {
4806         sv_setsv(sv, *(SV**)HEK_KEY(hek));
4807         return;
4808     } else {
4809         const int flags = HEK_FLAGS(hek);
4810         if (flags & HVhek_WASUTF8) {
4811             STRLEN utf8_len = HEK_LEN(hek);
4812             char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
4813             sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
4814             SvUTF8_on(sv);
4815             return;
4816         } else if (flags & HVhek_UNSHARED) {
4817             sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
4818             if (HEK_UTF8(hek))
4819                 SvUTF8_on(sv);
4820             else SvUTF8_off(sv);
4821             return;
4822         }
4823         {
4824             SV_CHECK_THINKFIRST_COW_DROP(sv);
4825             SvUPGRADE(sv, SVt_PV);
4826             SvPV_free(sv);
4827             SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
4828             SvCUR_set(sv, HEK_LEN(hek));
4829             SvLEN_set(sv, 0);
4830             SvIsCOW_on(sv);
4831             SvPOK_on(sv);
4832             if (HEK_UTF8(hek))
4833                 SvUTF8_on(sv);
4834             else SvUTF8_off(sv);
4835             return;
4836         }
4837     }
4838 }
4839
4840
4841 /*
4842 =for apidoc sv_usepvn_flags
4843
4844 Tells an SV to use C<ptr> to find its string value.  Normally the
4845 string is stored inside the SV, but sv_usepvn allows the SV to use an
4846 outside string.  The C<ptr> should point to memory that was allocated
4847 by L<Newx|perlclib/Memory Management and String Handling>. It must be
4848 the start of a Newx-ed block of memory, and not a pointer to the
4849 middle of it (beware of L<OOK|perlguts/Offsets> and copy-on-write),
4850 and not be from a non-Newx memory allocator like C<malloc>. The
4851 string length, C<len>, must be supplied.  By default this function
4852 will C<Renew> (i.e. realloc, move) the memory pointed to by C<ptr>,
4853 so that pointer should not be freed or used by the programmer after
4854 giving it to sv_usepvn, and neither should any pointers from "behind"
4855 that pointer (e.g. ptr + 1) be used.
4856
4857 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC.  If C<flags> &
4858 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be C<NUL>, and the realloc
4859 will be skipped (i.e. the buffer is actually at least 1 byte longer than
4860 C<len>, and already meets the requirements for storing in C<SvPVX>).
4861
4862 =cut
4863 */
4864
4865 void
4866 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4867 {
4868     STRLEN allocate;
4869
4870     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4871
4872     SV_CHECK_THINKFIRST_COW_DROP(sv);
4873     SvUPGRADE(sv, SVt_PV);
4874     if (!ptr) {
4875         (void)SvOK_off(sv);
4876         if (flags & SV_SMAGIC)
4877             SvSETMAGIC(sv);
4878         return;
4879     }
4880     if (SvPVX_const(sv))
4881         SvPV_free(sv);
4882
4883 #ifdef DEBUGGING
4884     if (flags & SV_HAS_TRAILING_NUL)
4885         assert(ptr[len] == '\0');
4886 #endif
4887
4888     allocate = (flags & SV_HAS_TRAILING_NUL)
4889         ? len + 1 :
4890 #ifdef Perl_safesysmalloc_size
4891         len + 1;
4892 #else 
4893         PERL_STRLEN_ROUNDUP(len + 1);
4894 #endif
4895     if (flags & SV_HAS_TRAILING_NUL) {
4896         /* It's long enough - do nothing.
4897            Specifically Perl_newCONSTSUB is relying on this.  */
4898     } else {
4899 #ifdef DEBUGGING
4900         /* Force a move to shake out bugs in callers.  */
4901         char *new_ptr = (char*)safemalloc(allocate);
4902         Copy(ptr, new_ptr, len, char);
4903         PoisonFree(ptr,len,char);
4904         Safefree(ptr);
4905         ptr = new_ptr;
4906 #else
4907         ptr = (char*) saferealloc (ptr, allocate);
4908 #endif
4909     }
4910 #ifdef Perl_safesysmalloc_size
4911     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4912 #else
4913     SvLEN_set(sv, allocate);
4914 #endif
4915     SvCUR_set(sv, len);
4916     SvPV_set(sv, ptr);
4917     if (!(flags & SV_HAS_TRAILING_NUL)) {
4918         ptr[len] = '\0';
4919     }
4920     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4921     SvTAINT(sv);
4922     if (flags & SV_SMAGIC)
4923         SvSETMAGIC(sv);
4924 }
4925
4926 #ifdef PERL_OLD_COPY_ON_WRITE
4927 /* Need to do this *after* making the SV normal, as we need the buffer
4928    pointer to remain valid until after we've copied it.  If we let go too early,
4929    another thread could invalidate it by unsharing last of the same hash key
4930    (which it can do by means other than releasing copy-on-write Svs)
4931    or by changing the other copy-on-write SVs in the loop.  */
4932 STATIC void
4933 S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after)
4934 {
4935     PERL_ARGS_ASSERT_SV_RELEASE_COW;
4936
4937     { /* this SV was SvIsCOW_normal(sv) */
4938          /* we need to find the SV pointing to us.  */
4939         SV *current = SV_COW_NEXT_SV(after);
4940
4941         if (current == sv) {
4942             /* The SV we point to points back to us (there were only two of us
4943                in the loop.)
4944                Hence other SV is no longer copy on write either.  */
4945             SvIsCOW_off(after);
4946             sv_buf_to_rw(after);
4947         } else {
4948             /* We need to follow the pointers around the loop.  */
4949             SV *next;
4950             while ((next = SV_COW_NEXT_SV(current)) != sv) {
4951                 assert (next);
4952                 current = next;
4953                  /* don't loop forever if the structure is bust, and we have
4954                     a pointer into a closed loop.  */
4955                 assert (current != after);
4956                 assert (SvPVX_const(current) == pvx);
4957             }
4958             /* Make the SV before us point to the SV after us.  */
4959             SV_COW_NEXT_SV_SET(current, after);
4960         }
4961     }
4962 }
4963 #endif
4964 /*
4965 =for apidoc sv_force_normal_flags
4966
4967 Undo various types of fakery on an SV, where fakery means
4968 "more than" a string: if the PV is a shared string, make
4969 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4970 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4971 we do the copy, and is also used locally; if this is a
4972 vstring, drop the vstring magic.  If C<SV_COW_DROP_PV> is set
4973 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4974 SvPOK_off rather than making a copy.  (Used where this
4975 scalar is about to be set to some other value.)  In addition,
4976 the C<flags> parameter gets passed to C<sv_unref_flags()>
4977 when unreffing.  C<sv_force_normal> calls this function
4978 with flags set to 0.
4979
4980 This function is expected to be used to signal to perl that this SV is
4981 about to be written to, and any extra book-keeping needs to be taken care
4982 of.  Hence, it croaks on read-only values.
4983
4984 =cut
4985 */
4986
4987 static void
4988 S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
4989 {
4990     assert(SvIsCOW(sv));
4991     {
4992 #ifdef PERL_ANY_COW
4993         const char * const pvx = SvPVX_const(sv);
4994         const STRLEN len = SvLEN(sv);
4995         const STRLEN cur = SvCUR(sv);
4996 # ifdef PERL_OLD_COPY_ON_WRITE
4997         /* next COW sv in the loop.  If len is 0 then this is a shared-hash
4998            key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4999            we'll fail an assertion.  */
5000         SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
5001 # endif
5002
5003         if (DEBUG_C_TEST) {
5004                 PerlIO_printf(Perl_debug_log,
5005                               "Copy on write: Force normal %ld\n",
5006                               (long) flags);
5007                 sv_dump(sv);
5008         }
5009         SvIsCOW_off(sv);
5010 # ifdef PERL_NEW_COPY_ON_WRITE
5011         if (len && CowREFCNT(sv) == 0)
5012             /* We own the buffer ourselves. */
5013             sv_buf_to_rw(sv);
5014         else
5015 # endif
5016         {
5017                 
5018             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
5019 # ifdef PERL_NEW_COPY_ON_WRITE
5020             /* Must do this first, since the macro uses SvPVX. */
5021             if (len) {
5022                 sv_buf_to_rw(sv);
5023                 CowREFCNT(sv)--;
5024                 sv_buf_to_ro(sv);
5025             }
5026 # endif
5027             SvPV_set(sv, NULL);
5028             SvCUR_set(sv, 0);
5029             SvLEN_set(sv, 0);
5030             if (flags & SV_COW_DROP_PV) {
5031                 /* OK, so we don't need to copy our buffer.  */
5032                 SvPOK_off(sv);
5033             } else {
5034                 SvGROW(sv, cur + 1);
5035                 Move(pvx,SvPVX(sv),cur,char);
5036                 SvCUR_set(sv, cur);
5037                 *SvEND(sv) = '\0';
5038             }
5039             if (len) {
5040 # ifdef PERL_OLD_COPY_ON_WRITE
5041                 sv_release_COW(sv, pvx, next);
5042 # endif
5043             } else {
5044                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5045             }
5046             if (DEBUG_C_TEST) {
5047                 sv_dump(sv);
5048             }
5049         }
5050 #else
5051             const char * const pvx = SvPVX_const(sv);
5052             const STRLEN len = SvCUR(sv);
5053             SvIsCOW_off(sv);
5054             SvPV_set(sv, NULL);
5055             SvLEN_set(sv, 0);
5056             if (flags & SV_COW_DROP_PV) {
5057                 /* OK, so we don't need to copy our buffer.  */
5058                 SvPOK_off(sv);
5059             } else {
5060                 SvGROW(sv, len + 1);
5061                 Move(pvx,SvPVX(sv),len,char);
5062                 *SvEND(sv) = '\0';
5063             }
5064             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5065 #endif
5066     }
5067 }
5068
5069 void
5070 Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
5071 {
5072     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
5073
5074     if (SvREADONLY(sv))
5075         Perl_croak_no_modify();
5076     else if (SvIsCOW(sv))
5077         S_sv_uncow(aTHX_ sv, flags);
5078     if (SvROK(sv))
5079         sv_unref_flags(sv, flags);
5080     else if (SvFAKE(sv) && isGV_with_GP(sv))
5081         sv_unglob(sv, flags);
5082     else if (SvFAKE(sv) && isREGEXP(sv)) {
5083         /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
5084            to sv_unglob. We only need it here, so inline it.  */
5085         const bool islv = SvTYPE(sv) == SVt_PVLV;
5086         const svtype new_type =
5087           islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
5088         SV *const temp = newSV_type(new_type);
5089         regexp *const temp_p = ReANY((REGEXP *)sv);
5090
5091         if (new_type == SVt_PVMG) {
5092             SvMAGIC_set(temp, SvMAGIC(sv));
5093             SvMAGIC_set(sv, NULL);
5094             SvSTASH_set(temp, SvSTASH(sv));
5095             SvSTASH_set(sv, NULL);
5096         }
5097         if (!islv) SvCUR_set(temp, SvCUR(sv));
5098         /* Remember that SvPVX is in the head, not the body.  But
5099            RX_WRAPPED is in the body. */
5100         assert(ReANY((REGEXP *)sv)->mother_re);
5101         /* Their buffer is already owned by someone else. */
5102         if (flags & SV_COW_DROP_PV) {
5103             /* SvLEN is already 0.  For SVt_REGEXP, we have a brand new
5104                zeroed body.  For SVt_PVLV, it should have been set to 0
5105                before turning into a regexp. */
5106             assert(!SvLEN(islv ? sv : temp));
5107             sv->sv_u.svu_pv = 0;
5108         }
5109         else {
5110             sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
5111             SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
5112             SvPOK_on(sv);
5113         }
5114
5115         /* Now swap the rest of the bodies. */
5116
5117         SvFAKE_off(sv);
5118         if (!islv) {
5119             SvFLAGS(sv) &= ~SVTYPEMASK;
5120             SvFLAGS(sv) |= new_type;
5121             SvANY(sv) = SvANY(temp);
5122         }
5123
5124         SvFLAGS(temp) &= ~(SVTYPEMASK);
5125         SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
5126         SvANY(temp) = temp_p;
5127         temp->sv_u.svu_rx = (regexp *)temp_p;
5128
5129         SvREFCNT_dec_NN(temp);
5130     }
5131     else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
5132 }
5133
5134 /*
5135 =for apidoc sv_chop
5136
5137 Efficient removal of characters from the beginning of the string buffer.
5138 SvPOK(sv), or at least SvPOKp(sv), must be true and the C<ptr> must be a
5139 pointer to somewhere inside the string buffer.  The C<ptr> becomes the first
5140 character of the adjusted string.  Uses the "OOK hack".  On return, only
5141 SvPOK(sv) and SvPOKp(sv) among the OK flags will be true.
5142
5143 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
5144 refer to the same chunk of data.
5145
5146 The unfortunate similarity of this function's name to that of Perl's C<chop>
5147 operator is strictly coincidental.  This function works from the left;
5148 C<chop> works from the right.
5149
5150 =cut
5151 */
5152
5153 void
5154 Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
5155 {
5156     STRLEN delta;
5157     STRLEN old_delta;
5158     U8 *p;
5159 #ifdef DEBUGGING
5160     const U8 *evacp;
5161     STRLEN evacn;
5162 #endif
5163     STRLEN max_delta;
5164
5165     PERL_ARGS_ASSERT_SV_CHOP;
5166
5167     if (!ptr || !SvPOKp(sv))
5168         return;
5169     delta = ptr - SvPVX_const(sv);
5170     if (!delta) {
5171         /* Nothing to do.  */
5172         return;
5173     }
5174     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
5175     if (delta > max_delta)
5176         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
5177                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
5178     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
5179     SV_CHECK_THINKFIRST(sv);
5180     SvPOK_only_UTF8(sv);
5181
5182     if (!SvOOK(sv)) {
5183         if (!SvLEN(sv)) { /* make copy of shared string */
5184             const char *pvx = SvPVX_const(sv);
5185             const STRLEN len = SvCUR(sv);
5186             SvGROW(sv, len + 1);
5187             Move(pvx,SvPVX(sv),len,char);
5188             *SvEND(sv) = '\0';
5189         }
5190         SvOOK_on(sv);
5191         old_delta = 0;
5192     } else {
5193         SvOOK_offset(sv, old_delta);
5194     }
5195     SvLEN_set(sv, SvLEN(sv) - delta);
5196     SvCUR_set(sv, SvCUR(sv) - delta);
5197     SvPV_set(sv, SvPVX(sv) + delta);
5198
5199     p = (U8 *)SvPVX_const(sv);
5200
5201 #ifdef DEBUGGING
5202     /* how many bytes were evacuated?  we will fill them with sentinel
5203        bytes, except for the part holding the new offset of course. */
5204     evacn = delta;
5205     if (old_delta)
5206         evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
5207     assert(evacn);
5208     assert(evacn <= delta + old_delta);
5209     evacp = p - evacn;
5210 #endif
5211
5212     /* This sets 'delta' to the accumulated value of all deltas so far */
5213     delta += old_delta;
5214     assert(delta);
5215
5216     /* If 'delta' fits in a byte, store it just prior to the new beginning of
5217      * the string; otherwise store a 0 byte there and store 'delta' just prior
5218      * to that, using as many bytes as a STRLEN occupies.  Thus it overwrites a
5219      * portion of the chopped part of the string */
5220     if (delta < 0x100) {
5221         *--p = (U8) delta;
5222     } else {
5223         *--p = 0;
5224         p -= sizeof(STRLEN);
5225         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
5226     }
5227
5228 #ifdef DEBUGGING
5229     /* Fill the preceding buffer with sentinals to verify that no-one is
5230        using it.  */
5231     while (p > evacp) {
5232         --p;
5233         *p = (U8)PTR2UV(p);
5234     }
5235 #endif
5236 }
5237
5238 /*
5239 =for apidoc sv_catpvn
5240
5241 Concatenates the string onto the end of the string which is in the SV.  The
5242 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
5243 status set, then the bytes appended should be valid UTF-8.
5244 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
5245
5246 =for apidoc sv_catpvn_flags
5247
5248 Concatenates the string onto the end of the string which is in the SV.  The
5249 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
5250 status set, then the bytes appended should be valid UTF-8.
5251 If C<flags> has the C<SV_SMAGIC> bit set, will
5252 C<mg_set> on C<dsv> afterwards if appropriate.
5253 C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5254 in terms of this function.
5255
5256 =cut
5257 */
5258
5259 void
5260 Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
5261 {
5262     STRLEN dlen;
5263     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5264
5265     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5266     assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5267
5268     if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
5269       if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
5270          sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5271          dlen = SvCUR(dsv);
5272       }
5273       else SvGROW(dsv, dlen + slen + 1);
5274       if (sstr == dstr)
5275         sstr = SvPVX_const(dsv);
5276       Move(sstr, SvPVX(dsv) + dlen, slen, char);
5277       SvCUR_set(dsv, SvCUR(dsv) + slen);
5278     }
5279     else {
5280         /* We inline bytes_to_utf8, to avoid an extra malloc. */
5281         const char * const send = sstr + slen;
5282         U8 *d;
5283
5284         /* Something this code does not account for, which I think is
5285            impossible; it would require the same pv to be treated as
5286            bytes *and* utf8, which would indicate a bug elsewhere. */
5287         assert(sstr != dstr);
5288
5289         SvGROW(dsv, dlen + slen * 2 + 1);
5290         d = (U8 *)SvPVX(dsv) + dlen;
5291
5292         while (sstr < send) {
5293             append_utf8_from_native_byte(*sstr, &d);
5294             sstr++;
5295         }
5296         SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5297     }
5298     *SvEND(dsv) = '\0';
5299     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
5300     SvTAINT(dsv);
5301     if (flags & SV_SMAGIC)
5302         SvSETMAGIC(dsv);
5303 }
5304
5305 /*
5306 =for apidoc sv_catsv
5307
5308 Concatenates the string from SV C<ssv> onto the end of the string in SV
5309 C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5310 Handles 'get' magic on both SVs, but no 'set' magic.  See C<sv_catsv_mg> and
5311 C<sv_catsv_nomg>.
5312
5313 =for apidoc sv_catsv_flags
5314
5315 Concatenates the string from SV C<ssv> onto the end of the string in SV
5316 C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5317 If C<flags> include C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if
5318 appropriate.  If C<flags> include C<SV_SMAGIC>, C<mg_set> will be called on
5319 the modified SV afterward, if appropriate.  C<sv_catsv>, C<sv_catsv_nomg>,
5320 and C<sv_catsv_mg> are implemented in terms of this function.
5321
5322 =cut */
5323
5324 void
5325 Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
5326 {
5327     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5328
5329     if (ssv) {
5330         STRLEN slen;
5331         const char *spv = SvPV_flags_const(ssv, slen, flags);
5332         if (spv) {
5333             if (flags & SV_GMAGIC)
5334                 SvGETMAGIC(dsv);
5335             sv_catpvn_flags(dsv, spv, slen,
5336                             DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
5337             if (flags & SV_SMAGIC)
5338                 SvSETMAGIC(dsv);
5339         }
5340     }
5341 }
5342
5343 /*
5344 =for apidoc sv_catpv
5345
5346 Concatenates the C<NUL>-terminated string onto the end of the string which is
5347 in the SV.
5348 If the SV has the UTF-8 status set, then the bytes appended should be
5349 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
5350
5351 =cut */
5352
5353 void
5354 Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
5355 {
5356     STRLEN len;
5357     STRLEN tlen;
5358     char *junk;
5359
5360     PERL_ARGS_ASSERT_SV_CATPV;
5361
5362     if (!ptr)
5363         return;
5364     junk = SvPV_force(sv, tlen);
5365     len = strlen(ptr);
5366     SvGROW(sv, tlen + len + 1);
5367     if (ptr == junk)
5368         ptr = SvPVX_const(sv);
5369     Move(ptr,SvPVX(sv)+tlen,len+1,char);
5370     SvCUR_set(sv, SvCUR(sv) + len);
5371     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5372     SvTAINT(sv);
5373 }
5374
5375 /*
5376 =for apidoc sv_catpv_flags
5377
5378 Concatenates the C<NUL>-terminated string onto the end of the string which is
5379 in the SV.
5380 If the SV has the UTF-8 status set, then the bytes appended should
5381 be valid UTF-8.  If C<flags> has the C<SV_SMAGIC> bit set, will C<mg_set>
5382 on the modified SV if appropriate.
5383
5384 =cut
5385 */
5386
5387 void
5388 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
5389 {
5390     PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5391     sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
5392 }
5393
5394 /*
5395 =for apidoc sv_catpv_mg
5396
5397 Like C<sv_catpv>, but also handles 'set' magic.
5398
5399 =cut
5400 */
5401
5402 void
5403 Perl_sv_catpv_mg(pTHX_ SV *const sv, const char *const ptr)
5404 {
5405     PERL_ARGS_ASSERT_SV_CATPV_MG;
5406
5407     sv_catpv(sv,ptr);
5408     SvSETMAGIC(sv);
5409 }
5410
5411 /*
5412 =for apidoc newSV
5413
5414 Creates a new SV.  A non-zero C<len> parameter indicates the number of
5415 bytes of preallocated string space the SV should have.  An extra byte for a
5416 trailing C<NUL> is also reserved.  (SvPOK is not set for the SV even if string
5417 space is allocated.)  The reference count for the new SV is set to 1.
5418
5419 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
5420 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5421 This aid has been superseded by a new build option, PERL_MEM_LOG (see
5422 L<perlhacktips/PERL_MEM_LOG>).  The older API is still there for use in XS
5423 modules supporting older perls.
5424
5425 =cut
5426 */
5427
5428 SV *
5429 Perl_newSV(pTHX_ const STRLEN len)
5430 {
5431     SV *sv;
5432
5433     new_SV(sv);
5434     if (len) {
5435         sv_upgrade(sv, SVt_PV);
5436         SvGROW(sv, len + 1);
5437     }
5438     return sv;
5439 }
5440 /*
5441 =for apidoc sv_magicext
5442
5443 Adds magic to an SV, upgrading it if necessary.  Applies the
5444 supplied vtable and returns a pointer to the magic added.
5445
5446 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5447 In particular, you can add magic to SvREADONLY SVs, and add more than
5448 one instance of the same 'how'.
5449
5450 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5451 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5452 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5453 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5454
5455 (This is now used as a subroutine by C<sv_magic>.)
5456
5457 =cut
5458 */
5459 MAGIC * 
5460 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, 
5461                 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5462 {
5463     MAGIC* mg;
5464
5465     PERL_ARGS_ASSERT_SV_MAGICEXT;
5466
5467     if (SvTYPE(sv)==SVt_PVAV) { assert (!AvPAD_NAMELIST(sv)); }
5468
5469     SvUPGRADE(sv, SVt_PVMG);
5470     Newxz(mg, 1, MAGIC);
5471     mg->mg_moremagic = SvMAGIC(sv);
5472     SvMAGIC_set(sv, mg);
5473
5474     /* Sometimes a magic contains a reference loop, where the sv and
5475        object refer to each other.  To prevent a reference loop that
5476        would prevent such objects being freed, we look for such loops
5477        and if we find one we avoid incrementing the object refcount.
5478
5479        Note we cannot do this to avoid self-tie loops as intervening RV must
5480        have its REFCNT incremented to keep it in existence.
5481
5482     */
5483     if (!obj || obj == sv ||
5484         how == PERL_MAGIC_arylen ||
5485         how == PERL_MAGIC_symtab ||
5486         (SvTYPE(obj) == SVt_PVGV &&
5487             (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5488              || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5489              || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5490     {
5491         mg->mg_obj = obj;
5492     }
5493     else {
5494         mg->mg_obj = SvREFCNT_inc_simple(obj);
5495         mg->mg_flags |= MGf_REFCOUNTED;
5496     }
5497
5498     /* Normal self-ties simply pass a null object, and instead of
5499        using mg_obj directly, use the SvTIED_obj macro to produce a
5500        new RV as needed.  For glob "self-ties", we are tieing the PVIO
5501        with an RV obj pointing to the glob containing the PVIO.  In
5502        this case, to avoid a reference loop, we need to weaken the
5503        reference.
5504     */
5505
5506     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5507         obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5508     {
5509       sv_rvweaken(obj);
5510     }
5511
5512     mg->mg_type = how;
5513     mg->mg_len = namlen;
5514     if (name) {
5515         if (namlen > 0)
5516             mg->mg_ptr = savepvn(name, namlen);
5517         else if (namlen == HEf_SVKEY) {
5518             /* Yes, this is casting away const. This is only for the case of
5519                HEf_SVKEY. I think we need to document this aberation of the
5520                constness of the API, rather than making name non-const, as
5521                that change propagating outwards a long way.  */
5522             mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5523         } else
5524             mg->mg_ptr = (char *) name;
5525     }
5526     mg->mg_virtual = (MGVTBL *) vtable;
5527
5528     mg_magical(sv);
5529     return mg;
5530 }
5531
5532 MAGIC *
5533 Perl_sv_magicext_mglob(pTHX_ SV *sv)
5534 {
5535     PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB;
5536     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
5537         /* This sv is only a delegate.  //g magic must be attached to
5538            its target. */
5539         vivify_defelem(sv);
5540         sv = LvTARG(sv);
5541     }
5542 #ifdef PERL_OLD_COPY_ON_WRITE
5543     if (SvIsCOW(sv))
5544         sv_force_normal_flags(sv, 0);
5545 #endif
5546     return sv_magicext(sv, NULL, PERL_MAGIC_regex_global,
5547                        &PL_vtbl_mglob, 0, 0);
5548 }
5549
5550 /*
5551 =for apidoc sv_magic
5552
5553 Adds magic to an SV.  First upgrades C<sv> to type C<SVt_PVMG> if
5554 necessary, then adds a new magic item of type C<how> to the head of the
5555 magic list.
5556
5557 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5558 handling of the C<name> and C<namlen> arguments.
5559
5560 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5561 to add more than one instance of the same 'how'.
5562
5563 =cut
5564 */
5565
5566 void
5567 Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
5568              const char *const name, const I32 namlen)
5569 {
5570     const MGVTBL *vtable;
5571     MAGIC* mg;
5572     unsigned int flags;
5573     unsigned int vtable_index;
5574
5575     PERL_ARGS_ASSERT_SV_MAGIC;
5576
5577     if (how < 0 || (unsigned)how >= C_ARRAY_LENGTH(PL_magic_data)
5578         || ((flags = PL_magic_data[how]),
5579             (vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
5580             > magic_vtable_max))
5581         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5582
5583     /* PERL_MAGIC_ext is reserved for use by extensions not perl internals.
5584        Useful for attaching extension internal data to perl vars.
5585        Note that multiple extensions may clash if magical scalars
5586        etc holding private data from one are passed to another. */
5587
5588     vtable = (vtable_index == magic_vtable_max)
5589         ? NULL : PL_magic_vtables + vtable_index;
5590
5591 #ifdef PERL_OLD_COPY_ON_WRITE
5592     if (SvIsCOW(sv))
5593         sv_force_normal_flags(sv, 0);
5594 #endif
5595     if (SvREADONLY(sv)) {
5596         if (
5597             !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
5598            )
5599         {
5600             Perl_croak_no_modify();
5601         }
5602     }
5603     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5604         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5605             /* sv_magic() refuses to add a magic of the same 'how' as an
5606                existing one
5607              */
5608             if (how == PERL_MAGIC_taint)
5609                 mg->mg_len |= 1;
5610             return;
5611         }
5612     }
5613
5614     /* Force pos to be stored as characters, not bytes. */
5615     if (SvMAGICAL(sv) && DO_UTF8(sv)
5616       && (mg = mg_find(sv, PERL_MAGIC_regex_global))
5617       && mg->mg_len != -1
5618       && mg->mg_flags & MGf_BYTES) {
5619         mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len,
5620                                                SV_CONST_RETURN);
5621         mg->mg_flags &= ~MGf_BYTES;
5622     }
5623
5624     /* Rest of work is done else where */
5625     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5626
5627     switch (how) {
5628     case PERL_MAGIC_taint:
5629         mg->mg_len = 1;
5630         break;
5631     case PERL_MAGIC_ext:
5632     case PERL_MAGIC_dbfile:
5633         SvRMAGICAL_on(sv);
5634         break;
5635     }
5636 }
5637
5638 static int
5639 S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
5640 {
5641     MAGIC* mg;
5642     MAGIC** mgp;
5643
5644     assert(flags <= 1);
5645
5646     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5647         return 0;
5648     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5649     for (mg = *mgp; mg; mg = *mgp) {
5650         const MGVTBL* const virt = mg->mg_virtual;
5651         if (mg->mg_type == type && (!flags || virt == vtbl)) {
5652             *mgp = mg->mg_moremagic;
5653             if (virt && virt->svt_free)
5654                 virt->svt_free(aTHX_ sv, mg);
5655             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5656                 if (mg->mg_len > 0)
5657                     Safefree(mg->mg_ptr);
5658                 else if (mg->mg_len == HEf_SVKEY)
5659                     SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5660                 else if (mg->mg_type == PERL_MAGIC_utf8)
5661                     Safefree(mg->mg_ptr);
5662             }
5663             if (mg->mg_flags & MGf_REFCOUNTED)
5664                 SvREFCNT_dec(mg->mg_obj);
5665             Safefree(mg);
5666         }
5667         else
5668             mgp = &mg->mg_moremagic;
5669     }
5670     if (SvMAGIC(sv)) {
5671         if (SvMAGICAL(sv))      /* if we're under save_magic, wait for restore_magic; */
5672             mg_magical(sv);     /*    else fix the flags now */
5673     }
5674     else {
5675         SvMAGICAL_off(sv);
5676         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5677     }
5678     return 0;
5679 }
5680
5681 /*
5682 =for apidoc sv_unmagic
5683
5684 Removes all magic of type C<type> from an SV.
5685
5686 =cut
5687 */
5688
5689 int
5690 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5691 {
5692     PERL_ARGS_ASSERT_SV_UNMAGIC;
5693     return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
5694 }
5695
5696 /*
5697 =for apidoc sv_unmagicext
5698
5699 Removes all magic of type C<type> with the specified C<vtbl> from an SV.
5700
5701 =cut
5702 */
5703
5704 int
5705 Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
5706 {
5707     PERL_ARGS_ASSERT_SV_UNMAGICEXT;
5708     return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
5709 }
5710
5711 /*
5712 =for apidoc sv_rvweaken
5713
5714 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5715 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5716 push a back-reference to this RV onto the array of backreferences
5717 associated with that magic.  If the RV is magical, set magic will be
5718 called after the RV is cleared.
5719
5720 =cut
5721 */
5722
5723 SV *
5724 Perl_sv_rvweaken(pTHX_ SV *const sv)
5725 {
5726     SV *tsv;
5727
5728     PERL_ARGS_ASSERT_SV_RVWEAKEN;
5729
5730     if (!SvOK(sv))  /* let undefs pass */
5731         return sv;
5732     if (!SvROK(sv))
5733         Perl_croak(aTHX_ "Can't weaken a nonreference");
5734     else if (SvWEAKREF(sv)) {
5735         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5736         return sv;
5737     }
5738     else if (SvREADONLY(sv)) croak_no_modify();
5739     tsv = SvRV(sv);
5740     Perl_sv_add_backref(aTHX_ tsv, sv);
5741     SvWEAKREF_on(sv);
5742     SvREFCNT_dec_NN(tsv);
5743     return sv;
5744 }
5745
5746 /* Give tsv backref magic if it hasn't already got it, then push a
5747  * back-reference to sv onto the array associated with the backref magic.
5748  *
5749  * As an optimisation, if there's only one backref and it's not an AV,
5750  * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5751  * allocate an AV. (Whether the slot holds an AV tells us whether this is
5752  * active.)
5753  */
5754
5755 /* A discussion about the backreferences array and its refcount:
5756  *
5757  * The AV holding the backreferences is pointed to either as the mg_obj of
5758  * PERL_MAGIC_backref, or in the specific case of a HV, from the
5759  * xhv_backreferences field. The array is created with a refcount
5760  * of 2. This means that if during global destruction the array gets
5761  * picked on before its parent to have its refcount decremented by the
5762  * random zapper, it won't actually be freed, meaning it's still there for
5763  * when its parent gets freed.
5764  *
5765  * When the parent SV is freed, the extra ref is killed by
5766  * Perl_sv_kill_backrefs.  The other ref is killed, in the case of magic,
5767  * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5768  *
5769  * When a single backref SV is stored directly, it is not reference
5770  * counted.
5771  */
5772
5773 void
5774 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5775 {
5776     SV **svp;
5777     AV *av = NULL;
5778     MAGIC *mg = NULL;
5779
5780     PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5781
5782     /* find slot to store array or singleton backref */
5783
5784     if (SvTYPE(tsv) == SVt_PVHV) {
5785         svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5786     } else {
5787         if (SvMAGICAL(tsv))
5788             mg = mg_find(tsv, PERL_MAGIC_backref);
5789         if (!mg)
5790             mg = sv_magicext(tsv, NULL, PERL_MAGIC_backref, &PL_vtbl_backref, NULL, 0);
5791         svp = &(mg->mg_obj);
5792     }
5793
5794     /* create or retrieve the array */
5795
5796     if (   (!*svp && SvTYPE(sv) == SVt_PVAV)
5797         || (*svp && SvTYPE(*svp) != SVt_PVAV)
5798     ) {
5799         /* create array */
5800         if (mg)
5801             mg->mg_flags |= MGf_REFCOUNTED;
5802         av = newAV();
5803         AvREAL_off(av);
5804         SvREFCNT_inc_simple_void_NN(av);
5805         /* av now has a refcnt of 2; see discussion above */
5806         av_extend(av, *svp ? 2 : 1);
5807         if (*svp) {
5808             /* move single existing backref to the array */
5809             AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5810         }
5811         *svp = (SV*)av;
5812     }
5813     else {
5814         av = MUTABLE_AV(*svp);
5815         if (!av) {
5816             /* optimisation: store single backref directly in HvAUX or mg_obj */
5817             *svp = sv;
5818             return;
5819         }
5820         assert(SvTYPE(av) == SVt_PVAV);
5821         if (AvFILLp(av) >= AvMAX(av)) {
5822             av_extend(av, AvFILLp(av)+1);
5823         }
5824     }
5825     /* push new backref */
5826     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5827 }
5828
5829 /* delete a back-reference to ourselves from the backref magic associated
5830  * with the SV we point to.
5831  */
5832
5833 void
5834 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5835 {
5836     SV **svp = NULL;
5837
5838     PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5839
5840     if (SvTYPE(tsv) == SVt_PVHV) {
5841         if (SvOOK(tsv))
5842             svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5843     }
5844     else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) {
5845         /* It's possible for the the last (strong) reference to tsv to have
5846            become freed *before* the last thing holding a weak reference.
5847            If both survive longer than the backreferences array, then when
5848            the referent's reference count drops to 0 and it is freed, it's
5849            not able to chase the backreferences, so they aren't NULLed.
5850
5851            For example, a CV holds a weak reference to its stash. If both the
5852            CV and the stash survive longer than the backreferences array,
5853            and the CV gets picked for the SvBREAK() treatment first,
5854            *and* it turns out that the stash is only being kept alive because
5855            of an our variable in the pad of the CV, then midway during CV
5856            destruction the stash gets freed, but CvSTASH() isn't set to NULL.
5857            It ends up pointing to the freed HV. Hence it's chased in here, and
5858            if this block wasn't here, it would hit the !svp panic just below.
5859
5860            I don't believe that "better" destruction ordering is going to help
5861            here - during global destruction there's always going to be the
5862            chance that something goes out of order. We've tried to make it
5863            foolproof before, and it only resulted in evolutionary pressure on
5864            fools. Which made us look foolish for our hubris. :-(
5865         */
5866         return;
5867     }
5868     else {
5869         MAGIC *const mg
5870             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5871         svp =  mg ? &(mg->mg_obj) : NULL;
5872     }
5873
5874     if (!svp)
5875         Perl_croak(aTHX_ "panic: del_backref, svp=0");
5876     if (!*svp) {
5877         /* It's possible that sv is being freed recursively part way through the
5878            freeing of tsv. If this happens, the backreferences array of tsv has
5879            already been freed, and so svp will be NULL. If this is the case,
5880            we should not panic. Instead, nothing needs doing, so return.  */
5881         if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
5882             return;
5883         Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
5884                    (void*)*svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
5885     }
5886
5887     if (SvTYPE(*svp) == SVt_PVAV) {
5888 #ifdef DEBUGGING
5889         int count = 1;
5890 #endif
5891         AV * const av = (AV*)*svp;
5892         SSize_t fill;
5893         assert(!SvIS_FREED(av));
5894         fill = AvFILLp(av);
5895         assert(fill > -1);
5896         svp = AvARRAY(av);
5897         /* for an SV with N weak references to it, if all those
5898          * weak refs are deleted, then sv_del_backref will be called
5899          * N times and O(N^2) compares will be done within the backref
5900          * array. To ameliorate this potential slowness, we:
5901          * 1) make sure this code is as tight as possible;
5902          * 2) when looking for SV, look for it at both the head and tail of the
5903          *    array first before searching the rest, since some create/destroy
5904          *    patterns will cause the backrefs to be freed in order.
5905          */
5906         if (*svp == sv) {
5907             AvARRAY(av)++;
5908             AvMAX(av)--;
5909         }
5910         else {
5911             SV **p = &svp[fill];
5912             SV *const topsv = *p;
5913             if (topsv != sv) {
5914 #ifdef DEBUGGING
5915                 count = 0;
5916 #endif
5917                 while (--p > svp) {
5918                     if (*p == sv) {
5919                         /* We weren't the last entry.
5920                            An unordered list has this property that you
5921                            can take the last element off the end to fill
5922                            the hole, and it's still an unordered list :-)
5923                         */
5924                         *p = topsv;
5925 #ifdef DEBUGGING
5926                         count++;
5927 #else
5928                         break; /* should only be one */
5929 #endif
5930                     }
5931                 }
5932             }
5933         }
5934         assert(count ==1);
5935         AvFILLp(av) = fill-1;
5936     }
5937     else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) {
5938         /* freed AV; skip */
5939     }
5940     else {
5941         /* optimisation: only a single backref, stored directly */
5942         if (*svp != sv)
5943             Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p",
5944                        (void*)*svp, (void*)sv);
5945         *svp = NULL;
5946     }
5947
5948 }
5949
5950 void
5951 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5952 {
5953     SV **svp;
5954     SV **last;
5955     bool is_array;
5956
5957     PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5958
5959     if (!av)
5960         return;
5961
5962     /* after multiple passes through Perl_sv_clean_all() for a thingy
5963      * that has badly leaked, the backref array may have gotten freed,
5964      * since we only protect it against 1 round of cleanup */
5965     if (SvIS_FREED(av)) {
5966         if (PL_in_clean_all) /* All is fair */
5967             return;
5968         Perl_croak(aTHX_
5969                    "panic: magic_killbackrefs (freed backref AV/SV)");
5970     }
5971
5972
5973     is_array = (SvTYPE(av) == SVt_PVAV);
5974     if (is_array) {
5975         assert(!SvIS_FREED(av));
5976         svp = AvARRAY(av);
5977         if (svp)
5978             last = svp + AvFILLp(av);
5979     }
5980     else {
5981         /* optimisation: only a single backref, stored directly */
5982         svp = (SV**)&av;
5983         last = svp;
5984     }
5985
5986     if (svp) {
5987         while (svp <= last) {
5988             if (*svp) {
5989                 SV *const referrer = *svp;
5990                 if (SvWEAKREF(referrer)) {
5991                     /* XXX Should we check that it hasn't changed? */
5992                     assert(SvROK(referrer));
5993                     SvRV_set(referrer, 0);
5994                     SvOK_off(referrer);
5995                     SvWEAKREF_off(referrer);
5996                     SvSETMAGIC(referrer);
5997                 } else if (SvTYPE(referrer) == SVt_PVGV ||
5998                            SvTYPE(referrer) == SVt_PVLV) {
5999                     assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
6000                     /* You lookin' at me?  */
6001                     assert(GvSTASH(referrer));
6002                     assert(GvSTASH(referrer) == (const HV *)sv);
6003                     GvSTASH(referrer) = 0;
6004                 } else if (SvTYPE(referrer) == SVt_PVCV ||
6005                            SvTYPE(referrer) == SVt_PVFM) {
6006                     if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
6007                         /* You lookin' at me?  */
6008                         assert(CvSTASH(referrer));
6009                         assert(CvSTASH(referrer) == (const HV *)sv);
6010                         SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
6011                     }
6012                     else {
6013                         assert(SvTYPE(sv) == SVt_PVGV);
6014                         /* You lookin' at me?  */
6015                         assert(CvGV(referrer));
6016                         assert(CvGV(referrer) == (const GV *)sv);
6017                         anonymise_cv_maybe(MUTABLE_GV(sv),
6018                                                 MUTABLE_CV(referrer));
6019                     }
6020
6021                 } else {
6022                     Perl_croak(aTHX_
6023                                "panic: magic_killbackrefs (flags=%"UVxf")",
6024                                (UV)SvFLAGS(referrer));
6025                 }
6026
6027                 if (is_array)
6028                     *svp = NULL;
6029             }
6030             svp++;
6031         }
6032     }
6033     if (is_array) {
6034         AvFILLp(av) = -1;
6035         SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */
6036     }
6037     return;
6038 }
6039
6040 /*
6041 =for apidoc sv_insert
6042
6043 Inserts a string at the specified offset/length within the SV.  Similar to
6044 the Perl substr() function.  Handles get magic.
6045
6046 =for apidoc sv_insert_flags
6047
6048 Same as C<sv_insert>, but the extra C<flags> are passed to the
6049 C<SvPV_force_flags> that applies to C<bigstr>.
6050
6051 =cut
6052 */
6053
6054 void
6055 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
6056 {
6057     char *big;
6058     char *mid;
6059     char *midend;
6060     char *bigend;
6061     SSize_t i;          /* better be sizeof(STRLEN) or bad things happen */
6062     STRLEN curlen;
6063
6064     PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
6065
6066     if (!bigstr)
6067         Perl_croak(aTHX_ "Can't modify nonexistent substring");
6068     SvPV_force_flags(bigstr, curlen, flags);
6069     (void)SvPOK_only_UTF8(bigstr);
6070     if (offset + len > curlen) {
6071         SvGROW(bigstr, offset+len+1);
6072         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
6073         SvCUR_set(bigstr, offset+len);
6074     }
6075
6076     SvTAINT(bigstr);
6077     i = littlelen - len;
6078     if (i > 0) {                        /* string might grow */
6079         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
6080         mid = big + offset + len;
6081         midend = bigend = big + SvCUR(bigstr);
6082         bigend += i;
6083         *bigend = '\0';
6084         while (midend > mid)            /* shove everything down */
6085             *--bigend = *--midend;
6086         Move(little,big+offset,littlelen,char);
6087         SvCUR_set(bigstr, SvCUR(bigstr) + i);
6088         SvSETMAGIC(bigstr);
6089         return;
6090     }
6091     else if (i == 0) {
6092         Move(little,SvPVX(bigstr)+offset,len,char);
6093         SvSETMAGIC(bigstr);
6094         return;
6095     }
6096
6097     big = SvPVX(bigstr);
6098     mid = big + offset;
6099     midend = mid + len;
6100     bigend = big + SvCUR(bigstr);
6101
6102     if (midend > bigend)
6103         Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p",
6104                    midend, bigend);
6105
6106     if (mid - big > bigend - midend) {  /* faster to shorten from end */
6107         if (littlelen) {
6108             Move(little, mid, littlelen,char);
6109             mid += littlelen;
6110         }
6111         i = bigend - midend;
6112         if (i > 0) {
6113             Move(midend, mid, i,char);
6114             mid += i;
6115         }
6116         *mid = '\0';
6117         SvCUR_set(bigstr, mid - big);
6118     }
6119     else if ((i = mid - big)) { /* faster from front */
6120         midend -= littlelen;
6121         mid = midend;
6122         Move(big, midend - i, i, char);
6123         sv_chop(bigstr,midend-i);
6124         if (littlelen)
6125             Move(little, mid, littlelen,char);
6126     }
6127     else if (littlelen) {
6128         midend -= littlelen;
6129         sv_chop(bigstr,midend);
6130         Move(little,midend,littlelen,char);
6131     }
6132     else {
6133         sv_chop(bigstr,midend);
6134     }
6135     SvSETMAGIC(bigstr);
6136 }
6137
6138 /*
6139 =for apidoc sv_replace
6140
6141 Make the first argument a copy of the second, then delete the original.
6142 The target SV physically takes over ownership of the body of the source SV
6143 and inherits its flags; however, the target keeps any magic it owns,
6144 and any magic in the source is discarded.
6145 Note that this is a rather specialist SV copying operation; most of the
6146 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
6147
6148 =cut
6149 */
6150
6151 void
6152 Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv)
6153 {
6154     const U32 refcnt = SvREFCNT(sv);
6155
6156     PERL_ARGS_ASSERT_SV_REPLACE;
6157
6158     SV_CHECK_THINKFIRST_COW_DROP(sv);
6159     if (SvREFCNT(nsv) != 1) {
6160         Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
6161                    " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
6162     }
6163     if (SvMAGICAL(sv)) {
6164         if (SvMAGICAL(nsv))
6165             mg_free(nsv);
6166         else
6167             sv_upgrade(nsv, SVt_PVMG);
6168         SvMAGIC_set(nsv, SvMAGIC(sv));
6169         SvFLAGS(nsv) |= SvMAGICAL(sv);
6170         SvMAGICAL_off(sv);
6171         SvMAGIC_set(sv, NULL);
6172     }
6173     SvREFCNT(sv) = 0;
6174     sv_clear(sv);
6175     assert(!SvREFCNT(sv));
6176 #ifdef DEBUG_LEAKING_SCALARS
6177     sv->sv_flags  = nsv->sv_flags;
6178     sv->sv_any    = nsv->sv_any;
6179     sv->sv_refcnt = nsv->sv_refcnt;
6180     sv->sv_u      = nsv->sv_u;
6181 #else
6182     StructCopy(nsv,sv,SV);
6183 #endif
6184     if(SvTYPE(sv) == SVt_IV) {
6185         SvANY(sv)
6186             = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
6187     }
6188         
6189
6190 #ifdef PERL_OLD_COPY_ON_WRITE
6191     if (SvIsCOW_normal(nsv)) {
6192         /* We need to follow the pointers around the loop to make the
6193            previous SV point to sv, rather than nsv.  */
6194         SV *next;
6195         SV *current = nsv;
6196         while ((next = SV_COW_NEXT_SV(current)) != nsv) {
6197             assert(next);
6198             current = next;
6199             assert(SvPVX_const(current) == SvPVX_const(nsv));
6200         }
6201         /* Make the SV before us point to the SV after us.  */
6202         if (DEBUG_C_TEST) {
6203             PerlIO_printf(Perl_debug_log, "previous is\n");
6204             sv_dump(current);
6205             PerlIO_printf(Perl_debug_log,
6206                           "move it from 0x%"UVxf" to 0x%"UVxf"\n",
6207                           (UV) SV_COW_NEXT_SV(current), (UV) sv);
6208         }
6209         SV_COW_NEXT_SV_SET(current, sv);
6210     }
6211 #endif
6212     SvREFCNT(sv) = refcnt;
6213     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
6214     SvREFCNT(nsv) = 0;
6215     del_SV(nsv);
6216 }
6217
6218 /* We're about to free a GV which has a CV that refers back to us.
6219  * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
6220  * field) */
6221
6222 STATIC void
6223 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
6224 {
6225     SV *gvname;
6226     GV *anongv;
6227
6228     PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
6229
6230     /* be assertive! */
6231     assert(SvREFCNT(gv) == 0);
6232     assert(isGV(gv) && isGV_with_GP(gv));
6233     assert(GvGP(gv));
6234     assert(!CvANON(cv));
6235     assert(CvGV(cv) == gv);
6236     assert(!CvNAMED(cv));
6237
6238     /* will the CV shortly be freed by gp_free() ? */
6239     if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
6240         SvANY(cv)->xcv_gv_u.xcv_gv = NULL;
6241         return;
6242     }
6243
6244     /* if not, anonymise: */
6245     gvname = (GvSTASH(gv) && HvNAME(GvSTASH(gv)) && HvENAME(GvSTASH(gv)))
6246                     ? newSVhek(HvENAME_HEK(GvSTASH(gv)))
6247                     : newSVpvn_flags( "__ANON__", 8, 0 );
6248     sv_catpvs(gvname, "::__ANON__");
6249     anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
6250     SvREFCNT_dec_NN(gvname);
6251
6252     CvANON_on(cv);
6253     CvCVGV_RC_on(cv);
6254     SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
6255 }
6256
6257
6258 /*
6259 =for apidoc sv_clear
6260
6261 Clear an SV: call any destructors, free up any memory used by the body,
6262 and free the body itself.  The SV's head is I<not> freed, although
6263 its type is set to all 1's so that it won't inadvertently be assumed
6264 to be live during global destruction etc.
6265 This function should only be called when REFCNT is zero.  Most of the time
6266 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
6267 instead.
6268
6269 =cut
6270 */
6271
6272 void
6273 Perl_sv_clear(pTHX_ SV *const orig_sv)
6274 {
6275     dVAR;
6276     HV *stash;
6277     U32 type;
6278     const struct body_details *sv_type_details;
6279     SV* iter_sv = NULL;
6280     SV* next_sv = NULL;
6281     SV *sv = orig_sv;
6282     STRLEN hash_index;
6283
6284     PERL_ARGS_ASSERT_SV_CLEAR;
6285
6286     /* within this loop, sv is the SV currently being freed, and
6287      * iter_sv is the most recent AV or whatever that's being iterated
6288      * over to provide more SVs */
6289
6290     while (sv) {
6291
6292         type = SvTYPE(sv);
6293
6294         assert(SvREFCNT(sv) == 0);
6295         assert(SvTYPE(sv) != (svtype)SVTYPEMASK);
6296
6297         if (type <= SVt_IV) {
6298             /* See the comment in sv.h about the collusion between this
6299              * early return and the overloading of the NULL slots in the
6300              * size table.  */
6301             if (SvROK(sv))
6302                 goto free_rv;
6303             SvFLAGS(sv) &= SVf_BREAK;
6304             SvFLAGS(sv) |= SVTYPEMASK;
6305             goto free_head;
6306         }
6307
6308         assert(!SvOBJECT(sv) || type >= SVt_PVMG); /* objs are always >= MG */
6309
6310         if (type >= SVt_PVMG) {
6311             if (SvOBJECT(sv)) {
6312                 if (!curse(sv, 1)) goto get_next_sv;
6313                 type = SvTYPE(sv); /* destructor may have changed it */
6314             }
6315             /* Free back-references before magic, in case the magic calls
6316              * Perl code that has weak references to sv. */
6317             if (type == SVt_PVHV) {
6318                 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
6319                 if (SvMAGIC(sv))
6320                     mg_free(sv);
6321             }
6322             else if (type == SVt_PVMG && SvPAD_OUR(sv)) {
6323                 SvREFCNT_dec(SvOURSTASH(sv));
6324             }
6325             else if (type == SVt_PVAV && AvPAD_NAMELIST(sv)) {
6326                 assert(!SvMAGICAL(sv));
6327             } else if (SvMAGIC(sv)) {
6328                 /* Free back-references before other types of magic. */
6329                 sv_unmagic(sv, PERL_MAGIC_backref);
6330                 mg_free(sv);
6331             }
6332             SvMAGICAL_off(sv);
6333             if (type == SVt_PVMG && SvPAD_TYPED(sv))
6334                 SvREFCNT_dec(SvSTASH(sv));
6335         }
6336         switch (type) {
6337             /* case SVt_INVLIST: */
6338         case SVt_PVIO:
6339             if (IoIFP(sv) &&
6340                 IoIFP(sv) != PerlIO_stdin() &&
6341                 IoIFP(sv) != PerlIO_stdout() &&
6342                 IoIFP(sv) != PerlIO_stderr() &&
6343                 !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6344             {
6345                 io_close(MUTABLE_IO(sv), FALSE);
6346             }
6347             if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6348                 PerlDir_close(IoDIRP(sv));
6349             IoDIRP(sv) = (DIR*)NULL;
6350             Safefree(IoTOP_NAME(sv));
6351             Safefree(IoFMT_NAME(sv));
6352             Safefree(IoBOTTOM_NAME(sv));
6353             if ((const GV *)sv == PL_statgv)
6354                 PL_statgv = NULL;
6355             goto freescalar;
6356         case SVt_REGEXP:
6357             /* FIXME for plugins */
6358           freeregexp:
6359             pregfree2((REGEXP*) sv);
6360             goto freescalar;
6361         case SVt_PVCV:
6362         case SVt_PVFM:
6363             cv_undef(MUTABLE_CV(sv));
6364             /* If we're in a stash, we don't own a reference to it.
6365              * However it does have a back reference to us, which needs to
6366              * be cleared.  */
6367             if ((stash = CvSTASH(sv)))
6368                 sv_del_backref(MUTABLE_SV(stash), sv);
6369             goto freescalar;
6370         case SVt_PVHV:
6371             if (PL_last_swash_hv == (const HV *)sv) {
6372                 PL_last_swash_hv = NULL;
6373             }
6374             if (HvTOTALKEYS((HV*)sv) > 0) {
6375                 const char *name;
6376                 /* this statement should match the one at the beginning of
6377                  * hv_undef_flags() */
6378                 if (   PL_phase != PERL_PHASE_DESTRUCT
6379                     && (name = HvNAME((HV*)sv)))
6380                 {
6381                     if (PL_stashcache) {
6382                     DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n",
6383                                      SVfARG(sv)));
6384                         (void)hv_deletehek(PL_stashcache,
6385                                            HvNAME_HEK((HV*)sv), G_DISCARD);
6386                     }
6387                     hv_name_set((HV*)sv, NULL, 0, 0);
6388                 }
6389
6390                 /* save old iter_sv in unused SvSTASH field */
6391                 assert(!SvOBJECT(sv));
6392                 SvSTASH(sv) = (HV*)iter_sv;
6393                 iter_sv = sv;
6394
6395                 /* save old hash_index in unused SvMAGIC field */
6396                 assert(!SvMAGICAL(sv));
6397                 assert(!SvMAGIC(sv));
6398                 ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index = hash_index;
6399                 hash_index = 0;
6400
6401                 next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index);
6402                 goto get_next_sv; /* process this new sv */
6403             }
6404             /* free empty hash */
6405             Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6406             assert(!HvARRAY((HV*)sv));
6407             break;
6408         case SVt_PVAV:
6409             {
6410                 AV* av = MUTABLE_AV(sv);
6411                 if (PL_comppad == av) {
6412                     PL_comppad = NULL;
6413                     PL_curpad = NULL;
6414                 }
6415                 if (AvREAL(av) && AvFILLp(av) > -1) {
6416                     next_sv = AvARRAY(av)[AvFILLp(av)--];
6417                     /* save old iter_sv in top-most slot of AV,
6418                      * and pray that it doesn't get wiped in the meantime */
6419                     AvARRAY(av)[AvMAX(av)] = iter_sv;
6420                     iter_sv = sv;
6421                     goto get_next_sv; /* process this new sv */
6422                 }
6423                 Safefree(AvALLOC(av));
6424             }
6425
6426             break;
6427         case SVt_PVLV:
6428             if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
6429                 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
6430                 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
6431                 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
6432             }
6433             else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
6434                 SvREFCNT_dec(LvTARG(sv));
6435             if (isREGEXP(sv)) goto freeregexp;
6436         case SVt_PVGV:
6437             if (isGV_with_GP(sv)) {
6438                 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
6439                    && HvENAME_get(stash))
6440                     mro_method_changed_in(stash);
6441                 gp_free(MUTABLE_GV(sv));
6442                 if (GvNAME_HEK(sv))
6443                     unshare_hek(GvNAME_HEK(sv));
6444                 /* If we're in a stash, we don't own a reference to it.
6445                  * However it does have a back reference to us, which
6446                  * needs to be cleared.  */
6447                 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
6448                         sv_del_backref(MUTABLE_SV(stash), sv);
6449             }
6450             /* FIXME. There are probably more unreferenced pointers to SVs
6451              * in the interpreter struct that we should check and tidy in
6452              * a similar fashion to this:  */
6453             /* See also S_sv_unglob, which does the same thing. */
6454             if ((const GV *)sv == PL_last_in_gv)
6455                 PL_last_in_gv = NULL;
6456             else if ((const GV *)sv == PL_statgv)
6457                 PL_statgv = NULL;
6458             else if ((const GV *)sv == PL_stderrgv)
6459                 PL_stderrgv = NULL;
6460         case SVt_PVMG:
6461         case SVt_PVNV:
6462         case SVt_PVIV:
6463         case SVt_INVLIST:
6464         case SVt_PV:
6465           freescalar:
6466             /* Don't bother with SvOOK_off(sv); as we're only going to
6467              * free it.  */
6468             if (SvOOK(sv)) {
6469                 STRLEN offset;
6470                 SvOOK_offset(sv, offset);
6471                 SvPV_set(sv, SvPVX_mutable(sv) - offset);
6472                 /* Don't even bother with turning off the OOK flag.  */
6473             }
6474             if (SvROK(sv)) {
6475             free_rv:
6476                 {
6477                     SV * const target = SvRV(sv);
6478                     if (SvWEAKREF(sv))
6479                         sv_del_backref(target, sv);
6480                     else
6481                         next_sv = target;
6482                 }
6483             }
6484 #ifdef PERL_ANY_COW
6485             else if (SvPVX_const(sv)
6486                      && !(SvTYPE(sv) == SVt_PVIO
6487                      && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6488             {
6489                 if (SvIsCOW(sv)) {
6490                     if (DEBUG_C_TEST) {
6491                         PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6492                         sv_dump(sv);
6493                     }
6494       &nb