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