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