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