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