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