This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix two minor bugs with local glob assignment
[perl5.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(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(obj);
509     }
510     if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
511         DEBUG_D((PerlIO_printf(Perl_debug_log,
512                 "Cleaning named glob AV object:\n "), sv_dump(obj)));
513         GvAV(sv) = NULL;
514         SvREFCNT_dec(obj);
515     }
516     if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
517         DEBUG_D((PerlIO_printf(Perl_debug_log,
518                 "Cleaning named glob HV object:\n "), sv_dump(obj)));
519         GvHV(sv) = NULL;
520         SvREFCNT_dec(obj);
521     }
522     if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
523         DEBUG_D((PerlIO_printf(Perl_debug_log,
524                 "Cleaning named glob CV object:\n "), sv_dump(obj)));
525         GvCV_set(sv, NULL);
526         SvREFCNT_dec(obj);
527     }
528     SvREFCNT_dec(sv); /* undo the inc above */
529 }
530
531 /* clear any IO slots in a GV which hold objects (except stderr, defout);
532  * called by sv_clean_objs() for each live GV */
533
534 static void
535 do_clean_named_io_objs(pTHX_ SV *const sv)
536 {
537     dVAR;
538     SV *obj;
539     assert(SvTYPE(sv) == SVt_PVGV);
540     assert(isGV_with_GP(sv));
541     if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
542         return;
543
544     SvREFCNT_inc(sv);
545     if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
546         DEBUG_D((PerlIO_printf(Perl_debug_log,
547                 "Cleaning named glob IO object:\n "), sv_dump(obj)));
548         GvIOp(sv) = NULL;
549         SvREFCNT_dec(obj);
550     }
551     SvREFCNT_dec(sv); /* undo the inc above */
552 }
553
554 /* Void wrapper to pass to visit() */
555 static void
556 do_curse(pTHX_ SV * const sv) {
557     if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
558      || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
559         return;
560     (void)curse(sv, 0);
561 }
562
563 /*
564 =for apidoc sv_clean_objs
565
566 Attempt to destroy all objects not yet freed.
567
568 =cut
569 */
570
571 void
572 Perl_sv_clean_objs(pTHX)
573 {
574     dVAR;
575     GV *olddef, *olderr;
576     PL_in_clean_objs = TRUE;
577     visit(do_clean_objs, SVf_ROK, SVf_ROK);
578     /* Some barnacles may yet remain, clinging to typeglobs.
579      * Run the non-IO destructors first: they may want to output
580      * error messages, close files etc */
581     visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
582     visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
583     /* And if there are some very tenacious barnacles clinging to arrays,
584        closures, or what have you.... */
585     visit(do_curse, SVs_OBJECT, SVs_OBJECT);
586     olddef = PL_defoutgv;
587     PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
588     if (olddef && isGV_with_GP(olddef))
589         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
590     olderr = PL_stderrgv;
591     PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
592     if (olderr && isGV_with_GP(olderr))
593         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
594     SvREFCNT_dec(olddef);
595     PL_in_clean_objs = FALSE;
596 }
597
598 /* called by sv_clean_all() for each live SV */
599
600 static void
601 do_clean_all(pTHX_ SV *const sv)
602 {
603     dVAR;
604     if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
605         /* don't clean pid table and strtab */
606         return;
607     }
608     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
609     SvFLAGS(sv) |= SVf_BREAK;
610     SvREFCNT_dec(sv);
611 }
612
613 /*
614 =for apidoc sv_clean_all
615
616 Decrement the refcnt of each remaining SV, possibly triggering a
617 cleanup.  This function may have to be called multiple times to free
618 SVs which are in complex self-referential hierarchies.
619
620 =cut
621 */
622
623 I32
624 Perl_sv_clean_all(pTHX)
625 {
626     dVAR;
627     I32 cleaned;
628     PL_in_clean_all = TRUE;
629     cleaned = visit(do_clean_all, 0,0);
630     return cleaned;
631 }
632
633 /*
634   ARENASETS: a meta-arena implementation which separates arena-info
635   into struct arena_set, which contains an array of struct
636   arena_descs, each holding info for a single arena.  By separating
637   the meta-info from the arena, we recover the 1st slot, formerly
638   borrowed for list management.  The arena_set is about the size of an
639   arena, avoiding the needless malloc overhead of a naive linked-list.
640
641   The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
642   memory in the last arena-set (1/2 on average).  In trade, we get
643   back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
644   smaller types).  The recovery of the wasted space allows use of
645   small arenas for large, rare body types, by changing array* fields
646   in body_details_by_type[] below.
647 */
648 struct arena_desc {
649     char       *arena;          /* the raw storage, allocated aligned */
650     size_t      size;           /* its size ~4k typ */
651     svtype      utype;          /* bodytype stored in arena */
652 };
653
654 struct arena_set;
655
656 /* Get the maximum number of elements in set[] such that struct arena_set
657    will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
658    therefore likely to be 1 aligned memory page.  */
659
660 #define ARENAS_PER_SET  ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
661                           - 2 * sizeof(int)) / sizeof (struct arena_desc))
662
663 struct arena_set {
664     struct arena_set* next;
665     unsigned int   set_size;    /* ie ARENAS_PER_SET */
666     unsigned int   curr;        /* index of next available arena-desc */
667     struct arena_desc set[ARENAS_PER_SET];
668 };
669
670 /*
671 =for apidoc sv_free_arenas
672
673 Deallocate the memory used by all arenas.  Note that all the individual SV
674 heads and bodies within the arenas must already have been freed.
675
676 =cut
677 */
678 void
679 Perl_sv_free_arenas(pTHX)
680 {
681     dVAR;
682     SV* sva;
683     SV* svanext;
684     unsigned int i;
685
686     /* Free arenas here, but be careful about fake ones.  (We assume
687        contiguity of the fake ones with the corresponding real ones.) */
688
689     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
690         svanext = MUTABLE_SV(SvANY(sva));
691         while (svanext && SvFAKE(svanext))
692             svanext = MUTABLE_SV(SvANY(svanext));
693
694         if (!SvFAKE(sva))
695             Safefree(sva);
696     }
697
698     {
699         struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
700
701         while (aroot) {
702             struct arena_set *current = aroot;
703             i = aroot->curr;
704             while (i--) {
705                 assert(aroot->set[i].arena);
706                 Safefree(aroot->set[i].arena);
707             }
708             aroot = aroot->next;
709             Safefree(current);
710         }
711     }
712     PL_body_arenas = 0;
713
714     i = PERL_ARENA_ROOTS_SIZE;
715     while (i--)
716         PL_body_roots[i] = 0;
717
718     PL_sv_arenaroot = 0;
719     PL_sv_root = 0;
720 }
721
722 /*
723   Here are mid-level routines that manage the allocation of bodies out
724   of the various arenas.  There are 5 kinds of arenas:
725
726   1. SV-head arenas, which are discussed and handled above
727   2. regular body arenas
728   3. arenas for reduced-size bodies
729   4. Hash-Entry arenas
730
731   Arena types 2 & 3 are chained by body-type off an array of
732   arena-root pointers, which is indexed by svtype.  Some of the
733   larger/less used body types are malloced singly, since a large
734   unused block of them is wasteful.  Also, several svtypes dont have
735   bodies; the data fits into the sv-head itself.  The arena-root
736   pointer thus has a few unused root-pointers (which may be hijacked
737   later for arena types 4,5)
738
739   3 differs from 2 as an optimization; some body types have several
740   unused fields in the front of the structure (which are kept in-place
741   for consistency).  These bodies can be allocated in smaller chunks,
742   because the leading fields arent accessed.  Pointers to such bodies
743   are decremented to point at the unused 'ghost' memory, knowing that
744   the pointers are used with offsets to the real memory.
745
746
747 =head1 SV-Body Allocation
748
749 Allocation of SV-bodies is similar to SV-heads, differing as follows;
750 the allocation mechanism is used for many body types, so is somewhat
751 more complicated, it uses arena-sets, and has no need for still-live
752 SV detection.
753
754 At the outermost level, (new|del)_X*V macros return bodies of the
755 appropriate type.  These macros call either (new|del)_body_type or
756 (new|del)_body_allocated macro pairs, depending on specifics of the
757 type.  Most body types use the former pair, the latter pair is used to
758 allocate body types with "ghost fields".
759
760 "ghost fields" are fields that are unused in certain types, and
761 consequently don't need to actually exist.  They are declared because
762 they're part of a "base type", which allows use of functions as
763 methods.  The simplest examples are AVs and HVs, 2 aggregate types
764 which don't use the fields which support SCALAR semantics.
765
766 For these types, the arenas are carved up into appropriately sized
767 chunks, we thus avoid wasted memory for those unaccessed members.
768 When bodies are allocated, we adjust the pointer back in memory by the
769 size of the part not allocated, so it's as if we allocated the full
770 structure.  (But things will all go boom if you write to the part that
771 is "not there", because you'll be overwriting the last members of the
772 preceding structure in memory.)
773
774 We calculate the correction using the STRUCT_OFFSET macro on the first
775 member present. If the allocated structure is smaller (no initial NV
776 actually allocated) then the net effect is to subtract the size of the NV
777 from the pointer, to return a new pointer as if an initial NV were actually
778 allocated. (We were using structures named *_allocated for this, but
779 this turned out to be a subtle bug, because a structure without an NV
780 could have a lower alignment constraint, but the compiler is allowed to
781 optimised accesses based on the alignment constraint of the actual pointer
782 to the full structure, for example, using a single 64 bit load instruction
783 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
784
785 This is the same trick as was used for NV and IV bodies. Ironically it
786 doesn't need to be used for NV bodies any more, because NV is now at
787 the start of the structure. IV bodies don't need it either, because
788 they are no longer allocated.
789
790 In turn, the new_body_* allocators call S_new_body(), which invokes
791 new_body_inline macro, which takes a lock, and takes a body off the
792 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
793 necessary to refresh an empty list.  Then the lock is released, and
794 the body is returned.
795
796 Perl_more_bodies allocates a new arena, and carves it up into an array of N
797 bodies, which it strings into a linked list.  It looks up arena-size
798 and body-size from the body_details table described below, thus
799 supporting the multiple body-types.
800
801 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
802 the (new|del)_X*V macros are mapped directly to malloc/free.
803
804 For each sv-type, struct body_details bodies_by_type[] carries
805 parameters which control these aspects of SV handling:
806
807 Arena_size determines whether arenas are used for this body type, and if
808 so, how big they are.  PURIFY or PERL_ARENA_SIZE=0 set this field to
809 zero, forcing individual mallocs and frees.
810
811 Body_size determines how big a body is, and therefore how many fit into
812 each arena.  Offset carries the body-pointer adjustment needed for
813 "ghost fields", and is used in *_allocated macros.
814
815 But its main purpose is to parameterize info needed in
816 Perl_sv_upgrade().  The info here dramatically simplifies the function
817 vs the implementation in 5.8.8, making it table-driven.  All fields
818 are used for this, except for arena_size.
819
820 For the sv-types that have no bodies, arenas are not used, so those
821 PL_body_roots[sv_type] are unused, and can be overloaded.  In
822 something of a special case, SVt_NULL is borrowed for HE arenas;
823 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
824 bodies_by_type[SVt_NULL] slot is not used, as the table is not
825 available in hv.c.
826
827 */
828
829 struct body_details {
830     U8 body_size;       /* Size to allocate  */
831     U8 copy;            /* Size of structure to copy (may be shorter)  */
832     U8 offset;
833     unsigned int type : 4;          /* We have space for a sanity check.  */
834     unsigned int cant_upgrade : 1;  /* Cannot upgrade this type */
835     unsigned int zero_nv : 1;       /* zero the NV when upgrading from this */
836     unsigned int arena : 1;         /* Allocated from an arena */
837     size_t arena_size;              /* Size of arena to allocate */
838 };
839
840 #define HADNV FALSE
841 #define NONV TRUE
842
843
844 #ifdef PURIFY
845 /* With -DPURFIY we allocate everything directly, and don't use arenas.
846    This seems a rather elegant way to simplify some of the code below.  */
847 #define HASARENA FALSE
848 #else
849 #define HASARENA TRUE
850 #endif
851 #define NOARENA FALSE
852
853 /* Size the arenas to exactly fit a given number of bodies.  A count
854    of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
855    simplifying the default.  If count > 0, the arena is sized to fit
856    only that many bodies, allowing arenas to be used for large, rare
857    bodies (XPVFM, XPVIO) without undue waste.  The arena size is
858    limited by PERL_ARENA_SIZE, so we can safely oversize the
859    declarations.
860  */
861 #define FIT_ARENA0(body_size)                           \
862     ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
863 #define FIT_ARENAn(count,body_size)                     \
864     ( count * body_size <= PERL_ARENA_SIZE)             \
865     ? count * body_size                                 \
866     : FIT_ARENA0 (body_size)
867 #define FIT_ARENA(count,body_size)                      \
868     count                                               \
869     ? FIT_ARENAn (count, body_size)                     \
870     : FIT_ARENA0 (body_size)
871
872 /* Calculate the length to copy. Specifically work out the length less any
873    final padding the compiler needed to add.  See the comment in sv_upgrade
874    for why copying the padding proved to be a bug.  */
875
876 #define copy_length(type, last_member) \
877         STRUCT_OFFSET(type, last_member) \
878         + sizeof (((type*)SvANY((const SV *)0))->last_member)
879
880 static const struct body_details bodies_by_type[] = {
881     /* HEs use this offset for their arena.  */
882     { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
883
884     /* The bind placeholder pretends to be an RV for now.
885        Also it's marked as "can't upgrade" to stop anyone using it before it's
886        implemented.  */
887     { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
888
889     /* IVs are in the head, so the allocation size is 0.  */
890     { 0,
891       sizeof(IV), /* This is used to copy out the IV body.  */
892       STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
893       NOARENA /* IVS don't need an arena  */, 0
894     },
895
896     { sizeof(NV), sizeof(NV),
897       STRUCT_OFFSET(XPVNV, xnv_u),
898       SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
899
900     { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
901       copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
902       + STRUCT_OFFSET(XPV, xpv_cur),
903       SVt_PV, FALSE, NONV, HASARENA,
904       FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
905
906     { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
907       copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
908       + STRUCT_OFFSET(XPV, xpv_cur),
909       SVt_PVIV, FALSE, NONV, HASARENA,
910       FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
911
912     { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
913       copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
914       + STRUCT_OFFSET(XPV, xpv_cur),
915       SVt_PVNV, FALSE, HADNV, HASARENA,
916       FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
917
918     { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
919       HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
920
921     { sizeof(regexp),
922       sizeof(regexp),
923       0,
924       SVt_REGEXP, FALSE, NONV, HASARENA,
925       FIT_ARENA(0, sizeof(regexp))
926     },
927
928     { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
929       HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
930     
931     { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
932       HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
933
934     { sizeof(XPVAV),
935       copy_length(XPVAV, xav_alloc),
936       0,
937       SVt_PVAV, TRUE, NONV, HASARENA,
938       FIT_ARENA(0, sizeof(XPVAV)) },
939
940     { sizeof(XPVHV),
941       copy_length(XPVHV, xhv_max),
942       0,
943       SVt_PVHV, TRUE, NONV, HASARENA,
944       FIT_ARENA(0, sizeof(XPVHV)) },
945
946     { sizeof(XPVCV),
947       sizeof(XPVCV),
948       0,
949       SVt_PVCV, TRUE, NONV, HASARENA,
950       FIT_ARENA(0, sizeof(XPVCV)) },
951
952     { sizeof(XPVFM),
953       sizeof(XPVFM),
954       0,
955       SVt_PVFM, TRUE, NONV, NOARENA,
956       FIT_ARENA(20, sizeof(XPVFM)) },
957
958     { sizeof(XPVIO),
959       sizeof(XPVIO),
960       0,
961       SVt_PVIO, TRUE, NONV, HASARENA,
962       FIT_ARENA(24, sizeof(XPVIO)) },
963 };
964
965 #define new_body_allocated(sv_type)             \
966     (void *)((char *)S_new_body(aTHX_ sv_type)  \
967              - bodies_by_type[sv_type].offset)
968
969 /* return a thing to the free list */
970
971 #define del_body(thing, root)                           \
972     STMT_START {                                        \
973         void ** const thing_copy = (void **)thing;      \
974         *thing_copy = *root;                            \
975         *root = (void*)thing_copy;                      \
976     } STMT_END
977
978 #ifdef PURIFY
979
980 #define new_XNV()       safemalloc(sizeof(XPVNV))
981 #define new_XPVNV()     safemalloc(sizeof(XPVNV))
982 #define new_XPVMG()     safemalloc(sizeof(XPVMG))
983
984 #define del_XPVGV(p)    safefree(p)
985
986 #else /* !PURIFY */
987
988 #define new_XNV()       new_body_allocated(SVt_NV)
989 #define new_XPVNV()     new_body_allocated(SVt_PVNV)
990 #define new_XPVMG()     new_body_allocated(SVt_PVMG)
991
992 #define del_XPVGV(p)    del_body(p + bodies_by_type[SVt_PVGV].offset,   \
993                                  &PL_body_roots[SVt_PVGV])
994
995 #endif /* PURIFY */
996
997 /* no arena for you! */
998
999 #define new_NOARENA(details) \
1000         safemalloc((details)->body_size + (details)->offset)
1001 #define new_NOARENAZ(details) \
1002         safecalloc((details)->body_size + (details)->offset, 1)
1003
1004 void *
1005 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
1006                   const size_t arena_size)
1007 {
1008     dVAR;
1009     void ** const root = &PL_body_roots[sv_type];
1010     struct arena_desc *adesc;
1011     struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1012     unsigned int curr;
1013     char *start;
1014     const char *end;
1015     const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1016 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1017     static bool done_sanity_check;
1018
1019     /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1020      * variables like done_sanity_check. */
1021     if (!done_sanity_check) {
1022         unsigned int i = SVt_LAST;
1023
1024         done_sanity_check = TRUE;
1025
1026         while (i--)
1027             assert (bodies_by_type[i].type == i);
1028     }
1029 #endif
1030
1031     assert(arena_size);
1032
1033     /* may need new arena-set to hold new arena */
1034     if (!aroot || aroot->curr >= aroot->set_size) {
1035         struct arena_set *newroot;
1036         Newxz(newroot, 1, struct arena_set);
1037         newroot->set_size = ARENAS_PER_SET;
1038         newroot->next = aroot;
1039         aroot = newroot;
1040         PL_body_arenas = (void *) newroot;
1041         DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1042     }
1043
1044     /* ok, now have arena-set with at least 1 empty/available arena-desc */
1045     curr = aroot->curr++;
1046     adesc = &(aroot->set[curr]);
1047     assert(!adesc->arena);
1048     
1049     Newx(adesc->arena, good_arena_size, char);
1050     adesc->size = good_arena_size;
1051     adesc->utype = sv_type;
1052     DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n", 
1053                           curr, (void*)adesc->arena, (UV)good_arena_size));
1054
1055     start = (char *) adesc->arena;
1056
1057     /* Get the address of the byte after the end of the last body we can fit.
1058        Remember, this is integer division:  */
1059     end = start + good_arena_size / body_size * body_size;
1060
1061     /* computed count doesn't reflect the 1st slot reservation */
1062 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1063     DEBUG_m(PerlIO_printf(Perl_debug_log,
1064                           "arena %p end %p arena-size %d (from %d) type %d "
1065                           "size %d ct %d\n",
1066                           (void*)start, (void*)end, (int)good_arena_size,
1067                           (int)arena_size, sv_type, (int)body_size,
1068                           (int)good_arena_size / (int)body_size));
1069 #else
1070     DEBUG_m(PerlIO_printf(Perl_debug_log,
1071                           "arena %p end %p arena-size %d type %d size %d ct %d\n",
1072                           (void*)start, (void*)end,
1073                           (int)arena_size, sv_type, (int)body_size,
1074                           (int)good_arena_size / (int)body_size));
1075 #endif
1076     *root = (void *)start;
1077
1078     while (1) {
1079         /* Where the next body would start:  */
1080         char * const next = start + body_size;
1081
1082         if (next >= end) {
1083             /* This is the last body:  */
1084             assert(next == end);
1085
1086             *(void **)start = 0;
1087             return *root;
1088         }
1089
1090         *(void**) start = (void *)next;
1091         start = next;
1092     }
1093 }
1094
1095 /* grab a new thing from the free list, allocating more if necessary.
1096    The inline version is used for speed in hot routines, and the
1097    function using it serves the rest (unless PURIFY).
1098 */
1099 #define new_body_inline(xpv, sv_type) \
1100     STMT_START { \
1101         void ** const r3wt = &PL_body_roots[sv_type]; \
1102         xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \
1103           ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1104                                              bodies_by_type[sv_type].body_size,\
1105                                              bodies_by_type[sv_type].arena_size)); \
1106         *(r3wt) = *(void**)(xpv); \
1107     } STMT_END
1108
1109 #ifndef PURIFY
1110
1111 STATIC void *
1112 S_new_body(pTHX_ const svtype sv_type)
1113 {
1114     dVAR;
1115     void *xpv;
1116     new_body_inline(xpv, sv_type);
1117     return xpv;
1118 }
1119
1120 #endif
1121
1122 static const struct body_details fake_rv =
1123     { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1124
1125 /*
1126 =for apidoc sv_upgrade
1127
1128 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1129 SV, then copies across as much information as possible from the old body.
1130 It croaks if the SV is already in a more complex form than requested.  You
1131 generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
1132 before calling C<sv_upgrade>, and hence does not croak.  See also
1133 C<svtype>.
1134
1135 =cut
1136 */
1137
1138 void
1139 Perl_sv_upgrade(pTHX_ 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             SAVEGENERICSV(*location);
3791         }
3792         dref = *location;
3793         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3794             CV* const cv = MUTABLE_CV(*location);
3795             if (cv) {
3796                 if (!GvCVGEN((const GV *)dstr) &&
3797                     (CvROOT(cv) || CvXSUB(cv)) &&
3798                     /* redundant check that avoids creating the extra SV
3799                        most of the time: */
3800                     (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
3801                     {
3802                         SV * const new_const_sv =
3803                             CvCONST((const CV *)sref)
3804                                  ? cv_const_sv((const CV *)sref)
3805                                  : NULL;
3806                         report_redefined_cv(
3807                            sv_2mortal(Perl_newSVpvf(aTHX_
3808                                 "%"HEKf"::%"HEKf,
3809                                 HEKfARG(
3810                                  HvNAME_HEK(GvSTASH((const GV *)dstr))
3811                                 ),
3812                                 HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
3813                            )),
3814                            cv,
3815                            CvCONST((const CV *)sref) ? &new_const_sv : NULL
3816                         );
3817                     }
3818                 if (!intro)
3819                     cv_ckproto_len_flags(cv, (const GV *)dstr,
3820                                    SvPOK(sref) ? CvPROTO(sref) : NULL,
3821                                    SvPOK(sref) ? CvPROTOLEN(sref) : 0,
3822                                    SvPOK(sref) ? SvUTF8(sref) : 0);
3823             }
3824             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3825             GvASSUMECV_on(dstr);
3826             if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3827         }
3828         *location = SvREFCNT_inc_simple_NN(sref);
3829         if (import_flag && !(GvFLAGS(dstr) & import_flag)
3830             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3831             GvFLAGS(dstr) |= import_flag;
3832         }
3833         if (stype == SVt_PVHV) {
3834             const char * const name = GvNAME((GV*)dstr);
3835             const STRLEN len = GvNAMELEN(dstr);
3836             if (
3837                 (
3838                    (len > 1 && name[len-2] == ':' && name[len-1] == ':')
3839                 || (len == 1 && name[0] == ':')
3840                 )
3841              && (!dref || HvENAME_get(dref))
3842             ) {
3843                 mro_package_moved(
3844                     (HV *)sref, (HV *)dref,
3845                     (GV *)dstr, 0
3846                 );
3847             }
3848         }
3849         else if (
3850             stype == SVt_PVAV && sref != dref
3851          && strEQ(GvNAME((GV*)dstr), "ISA")
3852          /* The stash may have been detached from the symbol table, so
3853             check its name before doing anything. */
3854          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3855         ) {
3856             MAGIC *mg;
3857             MAGIC * const omg = dref && SvSMAGICAL(dref)
3858                                  ? mg_find(dref, PERL_MAGIC_isa)
3859                                  : NULL;
3860             if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3861                 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3862                     AV * const ary = newAV();
3863                     av_push(ary, mg->mg_obj); /* takes the refcount */
3864                     mg->mg_obj = (SV *)ary;
3865                 }
3866                 if (omg) {
3867                     if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
3868                         SV **svp = AvARRAY((AV *)omg->mg_obj);
3869                         I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
3870                         while (items--)
3871                             av_push(
3872                              (AV *)mg->mg_obj,
3873                              SvREFCNT_inc_simple_NN(*svp++)
3874                             );
3875                     }
3876                     else
3877                         av_push(
3878                          (AV *)mg->mg_obj,
3879                          SvREFCNT_inc_simple_NN(omg->mg_obj)
3880                         );
3881                 }
3882                 else
3883                     av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
3884             }
3885             else
3886             {
3887                 sv_magic(
3888                  sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
3889                 );
3890                 mg = mg_find(sref, PERL_MAGIC_isa);
3891             }
3892             /* Since the *ISA assignment could have affected more than
3893                one stash, don't call mro_isa_changed_in directly, but let
3894                magic_clearisa do it for us, as it already has the logic for
3895                dealing with globs vs arrays of globs. */
3896             assert(mg);
3897             Perl_magic_clearisa(aTHX_ NULL, mg);
3898         }
3899         else if (stype == SVt_PVIO) {
3900             DEBUG_o(Perl_deb(aTHX_ "glob_assign_ref clearing PL_stashcache\n"));
3901             /* It's a cache. It will rebuild itself quite happily.
3902                It's a lot of effort to work out exactly which key (or keys)
3903                might be invalidated by the creation of the this file handle.
3904             */
3905             hv_clear(PL_stashcache);
3906         }
3907         break;
3908     }
3909     if (!intro) SvREFCNT_dec(dref);
3910     if (SvTAINTED(sstr))
3911         SvTAINT(dstr);
3912     return;
3913 }
3914
3915 /* Work around compiler warnings about unsigned >= THRESHOLD when thres-
3916    hold is 0. */
3917 #if SV_COW_THRESHOLD
3918 # define GE_COW_THRESHOLD(len)          ((len) >= SV_COW_THRESHOLD)
3919 #else
3920 # define GE_COW_THRESHOLD(len)          1
3921 #endif
3922 #if SV_COWBUF_THRESHOLD
3923 # define GE_COWBUF_THRESHOLD(len)       ((len) >= SV_COWBUF_THRESHOLD)
3924 #else
3925 # define GE_COWBUF_THRESHOLD(len)       1
3926 #endif
3927
3928 void
3929 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
3930 {
3931     dVAR;
3932     U32 sflags;
3933     int dtype;
3934     svtype stype;
3935
3936     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3937
3938     if (sstr == dstr)
3939         return;
3940
3941     if (SvIS_FREED(dstr)) {
3942         Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3943                    " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3944     }
3945     SV_CHECK_THINKFIRST_COW_DROP(dstr);
3946     if (!sstr)
3947         sstr = &PL_sv_undef;
3948     if (SvIS_FREED(sstr)) {
3949         Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3950                    (void*)sstr, (void*)dstr);
3951     }
3952     stype = SvTYPE(sstr);
3953     dtype = SvTYPE(dstr);
3954
3955     /* There's a lot of redundancy below but we're going for speed here */
3956
3957     switch (stype) {
3958     case SVt_NULL:
3959       undef_sstr:
3960         if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
3961             (void)SvOK_off(dstr);
3962             return;
3963         }
3964         break;
3965     case SVt_IV:
3966         if (SvIOK(sstr)) {
3967             switch (dtype) {
3968             case SVt_NULL:
3969                 sv_upgrade(dstr, SVt_IV);
3970                 break;
3971             case SVt_NV:
3972             case SVt_PV:
3973                 sv_upgrade(dstr, SVt_PVIV);
3974                 break;
3975             case SVt_PVGV:
3976             case SVt_PVLV:
3977                 goto end_of_first_switch;
3978             }
3979             (void)SvIOK_only(dstr);
3980             SvIV_set(dstr,  SvIVX(sstr));
3981             if (SvIsUV(sstr))
3982                 SvIsUV_on(dstr);
3983             /* SvTAINTED can only be true if the SV has taint magic, which in
3984                turn means that the SV type is PVMG (or greater). This is the
3985                case statement for SVt_IV, so this cannot be true (whatever gcov
3986                may say).  */
3987             assert(!SvTAINTED(sstr));
3988             return;
3989         }
3990         if (!SvROK(sstr))
3991             goto undef_sstr;
3992         if (dtype < SVt_PV && dtype != SVt_IV)
3993             sv_upgrade(dstr, SVt_IV);
3994         break;
3995
3996     case SVt_NV:
3997         if (SvNOK(sstr)) {
3998             switch (dtype) {
3999             case SVt_NULL:
4000             case SVt_IV:
4001                 sv_upgrade(dstr, SVt_NV);
4002                 break;
4003             case SVt_PV:
4004             case SVt_PVIV:
4005                 sv_upgrade(dstr, SVt_PVNV);
4006                 break;
4007             case SVt_PVGV:
4008             case SVt_PVLV:
4009                 goto end_of_first_switch;
4010             }
4011             SvNV_set(dstr, SvNVX(sstr));
4012             (void)SvNOK_only(dstr);
4013             /* SvTAINTED can only be true if the SV has taint magic, which in
4014                turn means that the SV type is PVMG (or greater). This is the
4015                case statement for SVt_NV, so this cannot be true (whatever gcov
4016                may say).  */
4017             assert(!SvTAINTED(sstr));
4018             return;
4019         }
4020         goto undef_sstr;
4021
4022     case SVt_PV:
4023         if (dtype < SVt_PV)
4024             sv_upgrade(dstr, SVt_PV);
4025         break;
4026     case SVt_PVIV:
4027         if (dtype < SVt_PVIV)
4028             sv_upgrade(dstr, SVt_PVIV);
4029         break;
4030     case SVt_PVNV:
4031         if (dtype < SVt_PVNV)
4032             sv_upgrade(dstr, SVt_PVNV);
4033         break;
4034     default:
4035         {
4036         const char * const type = sv_reftype(sstr,0);
4037         if (PL_op)
4038             /* diag_listed_as: Bizarre copy of %s */
4039             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4040         else
4041             Perl_croak(aTHX_ "Bizarre copy of %s", type);
4042         }
4043         break;
4044
4045     case SVt_REGEXP:
4046       upgregexp:
4047         if (dtype < SVt_REGEXP)
4048         {
4049             if (dtype >= SVt_PV) {
4050                 SvPV_free(dstr);
4051                 SvPV_set(dstr, 0);
4052                 SvLEN_set(dstr, 0);
4053                 SvCUR_set(dstr, 0);
4054             }
4055             sv_upgrade(dstr, SVt_REGEXP);
4056         }
4057         break;
4058
4059         /* case SVt_BIND: */
4060     case SVt_PVLV:
4061     case SVt_PVGV:
4062     case SVt_PVMG:
4063         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4064             mg_get(sstr);
4065             if (SvTYPE(sstr) != stype)
4066                 stype = SvTYPE(sstr);
4067         }
4068         if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4069                     glob_assign_glob(dstr, sstr, dtype);
4070                     return;
4071         }
4072         if (stype == SVt_PVLV)
4073         {
4074             if (isREGEXP(sstr)) goto upgregexp;
4075             SvUPGRADE(dstr, SVt_PVNV);
4076         }
4077         else
4078             SvUPGRADE(dstr, (svtype)stype);
4079     }
4080  end_of_first_switch:
4081
4082     /* dstr may have been upgraded.  */
4083     dtype = SvTYPE(dstr);
4084     sflags = SvFLAGS(sstr);
4085
4086     if (dtype == SVt_PVCV) {
4087         /* Assigning to a subroutine sets the prototype.  */
4088         if (SvOK(sstr)) {
4089             STRLEN len;
4090             const char *const ptr = SvPV_const(sstr, len);
4091
4092             SvGROW(dstr, len + 1);
4093             Copy(ptr, SvPVX(dstr), len + 1, char);
4094             SvCUR_set(dstr, len);
4095             SvPOK_only(dstr);
4096             SvFLAGS(dstr) |= sflags & SVf_UTF8;
4097             CvAUTOLOAD_off(dstr);
4098         } else {
4099             SvOK_off(dstr);
4100         }
4101     }
4102     else if (dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM) {
4103         const char * const type = sv_reftype(dstr,0);
4104         if (PL_op)
4105             /* diag_listed_as: Cannot copy to %s */
4106             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4107         else
4108             Perl_croak(aTHX_ "Cannot copy to %s", type);
4109     } else if (sflags & SVf_ROK) {
4110         if (isGV_with_GP(dstr)
4111             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4112             sstr = SvRV(sstr);
4113             if (sstr == dstr) {
4114                 if (GvIMPORTED(dstr) != GVf_IMPORTED
4115                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4116                 {
4117                     GvIMPORTED_on(dstr);
4118                 }
4119                 GvMULTI_on(dstr);
4120                 return;
4121             }
4122             glob_assign_glob(dstr, sstr, dtype);
4123             return;
4124         }
4125
4126         if (dtype >= SVt_PV) {
4127             if (isGV_with_GP(dstr)) {
4128                 glob_assign_ref(dstr, sstr);
4129                 return;
4130             }
4131             if (SvPVX_const(dstr)) {
4132                 SvPV_free(dstr);
4133                 SvLEN_set(dstr, 0);
4134                 SvCUR_set(dstr, 0);
4135             }
4136         }
4137         (void)SvOK_off(dstr);
4138         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4139         SvFLAGS(dstr) |= sflags & SVf_ROK;
4140         assert(!(sflags & SVp_NOK));
4141         assert(!(sflags & SVp_IOK));
4142         assert(!(sflags & SVf_NOK));
4143         assert(!(sflags & SVf_IOK));
4144     }
4145     else if (isGV_with_GP(dstr)) {
4146         if (!(sflags & SVf_OK)) {
4147             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4148                            "Undefined value assigned to typeglob");
4149         }
4150         else {
4151             GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
4152             if (dstr != (const SV *)gv) {
4153                 const char * const name = GvNAME((const GV *)dstr);
4154                 const STRLEN len = GvNAMELEN(dstr);
4155                 HV *old_stash = NULL;
4156                 bool reset_isa = FALSE;
4157                 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4158                  || (len == 1 && name[0] == ':')) {
4159                     /* Set aside the old stash, so we can reset isa caches
4160                        on its subclasses. */
4161                     if((old_stash = GvHV(dstr))) {
4162                         /* Make sure we do not lose it early. */
4163                         SvREFCNT_inc_simple_void_NN(
4164                          sv_2mortal((SV *)old_stash)
4165                         );
4166                     }
4167                     reset_isa = TRUE;
4168                 }
4169
4170                 if (GvGP(dstr))
4171                     gp_free(MUTABLE_GV(dstr));
4172                 GvGP_set(dstr, gp_ref(GvGP(gv)));
4173
4174                 if (reset_isa) {
4175                     HV * const stash = GvHV(dstr);
4176                     if(
4177                         old_stash ? (HV *)HvENAME_get(old_stash) : stash
4178                     )
4179                         mro_package_moved(
4180                          stash, old_stash,
4181                          (GV *)dstr, 0
4182                         );
4183                 }
4184             }
4185         }
4186     }
4187     else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4188           && (stype == SVt_REGEXP || isREGEXP(sstr))) {
4189         reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4190     }
4191     else if (sflags & SVp_POK) {
4192         bool isSwipe = 0;
4193         const STRLEN cur = SvCUR(sstr);
4194         const STRLEN len = SvLEN(sstr);
4195
4196         /*
4197          * Check to see if we can just swipe the string.  If so, it's a
4198          * possible small lose on short strings, but a big win on long ones.
4199          * It might even be a win on short strings if SvPVX_const(dstr)
4200          * has to be allocated and SvPVX_const(sstr) has to be freed.
4201          * Likewise if we can set up COW rather than doing an actual copy, we
4202          * drop to the else clause, as the swipe code and the COW setup code
4203          * have much in common.
4204          */
4205
4206         /* Whichever path we take through the next code, we want this true,
4207            and doing it now facilitates the COW check.  */
4208         (void)SvPOK_only(dstr);
4209
4210         if (
4211             /* If we're already COW then this clause is not true, and if COW
4212                is allowed then we drop down to the else and make dest COW 
4213                with us.  If caller hasn't said that we're allowed to COW
4214                shared hash keys then we don't do the COW setup, even if the
4215                source scalar is a shared hash key scalar.  */
4216             (((flags & SV_COW_SHARED_HASH_KEYS)
4217                ? !(sflags & SVf_IsCOW)
4218 #ifdef PERL_NEW_COPY_ON_WRITE
4219                 || (len &&
4220                     ((!GE_COWBUF_THRESHOLD(cur) && SvLEN(dstr) > cur)
4221                    /* If this is a regular (non-hek) COW, only so many COW
4222                       "copies" are possible. */
4223                     || CowREFCNT(sstr) == SV_COW_REFCNT_MAX))
4224 #endif
4225                : 1 /* If making a COW copy is forbidden then the behaviour we
4226                        desire is as if the source SV isn't actually already
4227                        COW, even if it is.  So we act as if the source flags
4228                        are not COW, rather than actually testing them.  */
4229               )
4230 #ifndef PERL_ANY_COW
4231              /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4232                 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4233                 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4234                 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4235                 but in turn, it's somewhat dead code, never expected to go
4236                 live, but more kept as a placeholder on how to do it better
4237                 in a newer implementation.  */
4238              /* If we are COW and dstr is a suitable target then we drop down
4239                 into the else and make dest a COW of us.  */
4240              || (SvFLAGS(dstr) & SVf_BREAK)
4241 #endif
4242              )
4243             &&
4244             !(isSwipe =
4245 #ifdef PERL_NEW_COPY_ON_WRITE
4246                                 /* slated for free anyway (and not COW)? */
4247                  (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP &&
4248 #else
4249                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
4250 #endif
4251                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4252                  (!(flags & SV_NOSTEAL)) &&
4253                                         /* and we're allowed to steal temps */
4254                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4255                  len)             /* and really is a string */
4256 #ifdef PERL_ANY_COW
4257             && ((flags & SV_COW_SHARED_HASH_KEYS)
4258                 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4259 # ifdef PERL_OLD_COPY_ON_WRITE
4260                      && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4261                      && SvTYPE(sstr) >= SVt_PVIV
4262 # else
4263                      && !(SvFLAGS(dstr) & SVf_BREAK)
4264                      && !(sflags & SVf_IsCOW)
4265                      && GE_COW_THRESHOLD(cur) && cur+1 < len
4266                      && (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1)
4267 # endif
4268                     ))
4269                 : 1)
4270 #endif
4271             ) {
4272             /* Failed the swipe test, and it's not a shared hash key either.
4273                Have to copy the string.  */
4274             SvGROW(dstr, cur + 1);      /* inlined from sv_setpvn */
4275             Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
4276             SvCUR_set(dstr, cur);
4277             *SvEND(dstr) = '\0';
4278         } else {
4279             /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4280                be true in here.  */
4281             /* Either it's a shared hash key, or it's suitable for
4282                copy-on-write or we can swipe the string.  */
4283             if (DEBUG_C_TEST) {
4284                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4285                 sv_dump(sstr);
4286                 sv_dump(dstr);
4287             }
4288 #ifdef PERL_ANY_COW
4289             if (!isSwipe) {
4290                 if (!(sflags & SVf_IsCOW)) {
4291                     SvIsCOW_on(sstr);
4292 # ifdef PERL_OLD_COPY_ON_WRITE
4293                     /* Make the source SV into a loop of 1.
4294                        (about to become 2) */
4295                     SV_COW_NEXT_SV_SET(sstr, sstr);
4296 # else
4297                     CowREFCNT(sstr) = 0;
4298 # endif
4299                 }
4300             }
4301 #endif
4302             /* Initial code is common.  */
4303             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
4304                 SvPV_free(dstr);
4305             }
4306
4307             if (!isSwipe) {
4308                 /* making another shared SV.  */
4309 #ifdef PERL_ANY_COW
4310                 if (len) {
4311 # ifdef PERL_OLD_COPY_ON_WRITE
4312                     assert (SvTYPE(dstr) >= SVt_PVIV);
4313                     /* SvIsCOW_normal */
4314                     /* splice us in between source and next-after-source.  */
4315                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4316                     SV_COW_NEXT_SV_SET(sstr, dstr);
4317 # else
4318                     CowREFCNT(sstr)++;
4319 # endif
4320                     SvPV_set(dstr, SvPVX_mutable(sstr));
4321                 } else
4322 #endif
4323                 {
4324                     /* SvIsCOW_shared_hash */
4325                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4326                                           "Copy on write: Sharing hash\n"));
4327
4328                     assert (SvTYPE(dstr) >= SVt_PV);
4329                     SvPV_set(dstr,
4330                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4331                 }
4332                 SvLEN_set(dstr, len);
4333                 SvCUR_set(dstr, cur);
4334                 SvIsCOW_on(dstr);
4335             }
4336             else
4337                 {       /* Passes the swipe test.  */
4338                 SvPV_set(dstr, SvPVX_mutable(sstr));
4339                 SvLEN_set(dstr, SvLEN(sstr));
4340                 SvCUR_set(dstr, SvCUR(sstr));
4341
4342                 SvTEMP_off(dstr);
4343                 (void)SvOK_off(sstr);   /* NOTE: nukes most SvFLAGS on sstr */
4344                 SvPV_set(sstr, NULL);
4345                 SvLEN_set(sstr, 0);
4346                 SvCUR_set(sstr, 0);
4347                 SvTEMP_off(sstr);
4348             }
4349         }
4350         if (sflags & SVp_NOK) {
4351             SvNV_set(dstr, SvNVX(sstr));
4352         }
4353         if (sflags & SVp_IOK) {
4354             SvIV_set(dstr, SvIVX(sstr));
4355             /* Must do this otherwise some other overloaded use of 0x80000000
4356                gets confused. I guess SVpbm_VALID */
4357             if (sflags & SVf_IVisUV)
4358                 SvIsUV_on(dstr);
4359         }
4360         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4361         {
4362             const MAGIC * const smg = SvVSTRING_mg(sstr);
4363             if (smg) {
4364                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4365                          smg->mg_ptr, smg->mg_len);
4366                 SvRMAGICAL_on(dstr);
4367             }
4368         }
4369     }
4370     else if (sflags & (SVp_IOK|SVp_NOK)) {
4371         (void)SvOK_off(dstr);
4372         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4373         if (sflags & SVp_IOK) {
4374             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4375             SvIV_set(dstr, SvIVX(sstr));
4376         }
4377         if (sflags & SVp_NOK) {
4378             SvNV_set(dstr, SvNVX(sstr));
4379         }
4380     }
4381     else {
4382         if (isGV_with_GP(sstr)) {
4383             gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4384         }
4385         else
4386             (void)SvOK_off(dstr);
4387     }
4388     if (SvTAINTED(sstr))
4389         SvTAINT(dstr);
4390 }
4391
4392 /*
4393 =for apidoc sv_setsv_mg
4394
4395 Like C<sv_setsv>, but also handles 'set' magic.
4396
4397 =cut
4398 */
4399
4400 void
4401 Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr)
4402 {
4403     PERL_ARGS_ASSERT_SV_SETSV_MG;
4404
4405     sv_setsv(dstr,sstr);
4406     SvSETMAGIC(dstr);
4407 }
4408
4409 #ifdef PERL_ANY_COW
4410 # ifdef PERL_OLD_COPY_ON_WRITE
4411 #  define SVt_COW SVt_PVIV
4412 # else
4413 #  define SVt_COW SVt_PV
4414 # endif
4415 SV *
4416 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4417 {
4418     STRLEN cur = SvCUR(sstr);
4419     STRLEN len = SvLEN(sstr);
4420     char *new_pv;
4421
4422     PERL_ARGS_ASSERT_SV_SETSV_COW;
4423
4424     if (DEBUG_C_TEST) {
4425         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4426                       (void*)sstr, (void*)dstr);
4427         sv_dump(sstr);
4428         if (dstr)
4429                     sv_dump(dstr);
4430     }
4431
4432     if (dstr) {
4433         if (SvTHINKFIRST(dstr))
4434             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4435         else if (SvPVX_const(dstr))
4436             Safefree(SvPVX_mutable(dstr));
4437     }
4438     else
4439         new_SV(dstr);
4440     SvUPGRADE(dstr, SVt_COW);
4441
4442     assert (SvPOK(sstr));
4443     assert (SvPOKp(sstr));
4444 # ifdef PERL_OLD_COPY_ON_WRITE
4445     assert (!SvIOK(sstr));
4446     assert (!SvIOKp(sstr));
4447     assert (!SvNOK(sstr));
4448     assert (!SvNOKp(sstr));
4449 # endif
4450
4451     if (SvIsCOW(sstr)) {
4452
4453         if (SvLEN(sstr) == 0) {
4454             /* source is a COW shared hash key.  */
4455             DEBUG_C(PerlIO_printf(Perl_debug_log,
4456                                   "Fast copy on write: Sharing hash\n"));
4457             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4458             goto common_exit;
4459         }
4460 # ifdef PERL_OLD_COPY_ON_WRITE
4461         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4462 # else
4463         assert(SvCUR(sstr)+1 < SvLEN(sstr));
4464         assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX);
4465 # endif
4466     } else {
4467         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4468         SvUPGRADE(sstr, SVt_COW);
4469         SvIsCOW_on(sstr);
4470         DEBUG_C(PerlIO_printf(Perl_debug_log,
4471                               "Fast copy on write: Converting sstr to COW\n"));
4472 # ifdef PERL_OLD_COPY_ON_WRITE
4473         SV_COW_NEXT_SV_SET(dstr, sstr);
4474 # else
4475         CowREFCNT(sstr) = 0;    
4476 # endif
4477     }
4478 # ifdef PERL_OLD_COPY_ON_WRITE
4479     SV_COW_NEXT_SV_SET(sstr, dstr);
4480 # else
4481     CowREFCNT(sstr)++;  
4482 # endif
4483     new_pv = SvPVX_mutable(sstr);
4484
4485   common_exit:
4486     SvPV_set(dstr, new_pv);
4487     SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
4488     if (SvUTF8(sstr))
4489         SvUTF8_on(dstr);
4490     SvLEN_set(dstr, len);
4491     SvCUR_set(dstr, cur);
4492     if (DEBUG_C_TEST) {
4493         sv_dump(dstr);
4494     }
4495     return dstr;
4496 }
4497 #endif
4498
4499 /*
4500 =for apidoc sv_setpvn
4501
4502 Copies a string into an SV.  The C<len> parameter indicates the number of
4503 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4504 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4505
4506 =cut
4507 */
4508
4509 void
4510 Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4511 {
4512     dVAR;
4513     char *dptr;
4514
4515     PERL_ARGS_ASSERT_SV_SETPVN;
4516
4517     SV_CHECK_THINKFIRST_COW_DROP(sv);
4518     if (!ptr) {
4519         (void)SvOK_off(sv);
4520         return;
4521     }
4522     else {
4523         /* len is STRLEN which is unsigned, need to copy to signed */
4524         const IV iv = len;
4525         if (iv < 0)
4526             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
4527                        IVdf, iv);
4528     }
4529     SvUPGRADE(sv, SVt_PV);
4530
4531     dptr = SvGROW(sv, len + 1);
4532     Move(ptr,dptr,len,char);
4533     dptr[len] = '\0';
4534     SvCUR_set(sv, len);
4535     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4536     SvTAINT(sv);
4537     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4538 }
4539
4540 /*
4541 =for apidoc sv_setpvn_mg
4542
4543 Like C<sv_setpvn>, but also handles 'set' magic.
4544
4545 =cut
4546 */
4547
4548 void
4549 Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4550 {
4551     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4552
4553     sv_setpvn(sv,ptr,len);
4554     SvSETMAGIC(sv);
4555 }
4556
4557 /*
4558 =for apidoc sv_setpv
4559
4560 Copies a string into an SV.  The string must be null-terminated.  Does not
4561 handle 'set' magic.  See C<sv_setpv_mg>.
4562
4563 =cut
4564 */
4565
4566 void
4567 Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
4568 {
4569     dVAR;
4570     STRLEN len;
4571
4572     PERL_ARGS_ASSERT_SV_SETPV;
4573
4574     SV_CHECK_THINKFIRST_COW_DROP(sv);
4575     if (!ptr) {
4576         (void)SvOK_off(sv);
4577         return;
4578     }
4579     len = strlen(ptr);
4580     SvUPGRADE(sv, SVt_PV);
4581
4582     SvGROW(sv, len + 1);
4583     Move(ptr,SvPVX(sv),len+1,char);
4584     SvCUR_set(sv, len);
4585     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4586     SvTAINT(sv);
4587     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4588 }
4589
4590 /*
4591 =for apidoc sv_setpv_mg
4592
4593 Like C<sv_setpv>, but also handles 'set' magic.
4594
4595 =cut
4596 */
4597
4598 void
4599 Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
4600 {
4601     PERL_ARGS_ASSERT_SV_SETPV_MG;
4602
4603     sv_setpv(sv,ptr);
4604     SvSETMAGIC(sv);
4605 }
4606
4607 void
4608 Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
4609 {
4610     dVAR;
4611
4612     PERL_ARGS_ASSERT_SV_SETHEK;
4613
4614     if (!hek) {
4615         return;
4616     }
4617
4618     if (HEK_LEN(hek) == HEf_SVKEY) {
4619         sv_setsv(sv, *(SV**)HEK_KEY(hek));
4620         return;
4621     } else {
4622         const int flags = HEK_FLAGS(hek);
4623         if (flags & HVhek_WASUTF8) {
4624             STRLEN utf8_len = HEK_LEN(hek);
4625             char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
4626             sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
4627             SvUTF8_on(sv);
4628             return;
4629         } else if (flags & HVhek_UNSHARED) {
4630             sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
4631             if (HEK_UTF8(hek))
4632                 SvUTF8_on(sv);
4633             else SvUTF8_off(sv);
4634             return;
4635         }
4636         {
4637             SV_CHECK_THINKFIRST_COW_DROP(sv);
4638             SvUPGRADE(sv, SVt_PV);
4639             Safefree(SvPVX(sv));
4640             SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
4641             SvCUR_set(sv, HEK_LEN(hek));
4642             SvLEN_set(sv, 0);
4643             SvIsCOW_on(sv);
4644             SvPOK_on(sv);
4645             if (HEK_UTF8(hek))
4646                 SvUTF8_on(sv);
4647             else SvUTF8_off(sv);
4648             return;
4649         }
4650     }
4651 }
4652
4653
4654 /*
4655 =for apidoc sv_usepvn_flags
4656
4657 Tells an SV to use C<ptr> to find its string value.  Normally the
4658 string is stored inside the SV but sv_usepvn allows the SV to use an
4659 outside string.  The C<ptr> should point to memory that was allocated
4660 by C<malloc>.  It must be the start of a mallocked block
4661 of memory, and not a pointer to the middle of it.  The
4662 string length, C<len>, must be supplied.  By default
4663 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4664 so that pointer should not be freed or used by the programmer after
4665 giving it to sv_usepvn, and neither should any pointers from "behind"
4666 that pointer (e.g. ptr + 1) be used.
4667
4668 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC.  If C<flags> &
4669 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4670 will be skipped (i.e. the buffer is actually at least 1 byte longer than
4671 C<len>, and already meets the requirements for storing in C<SvPVX>).
4672
4673 =cut
4674 */
4675
4676 void
4677 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4678 {
4679     dVAR;
4680     STRLEN allocate;
4681
4682     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4683
4684     SV_CHECK_THINKFIRST_COW_DROP(sv);
4685     SvUPGRADE(sv, SVt_PV);
4686     if (!ptr) {
4687         (void)SvOK_off(sv);
4688         if (flags & SV_SMAGIC)
4689             SvSETMAGIC(sv);
4690         return;
4691     }
4692     if (SvPVX_const(sv))
4693         SvPV_free(sv);
4694
4695 #ifdef DEBUGGING
4696     if (flags & SV_HAS_TRAILING_NUL)
4697         assert(ptr[len] == '\0');
4698 #endif
4699
4700     allocate = (flags & SV_HAS_TRAILING_NUL)
4701         ? len + 1 :
4702 #ifdef Perl_safesysmalloc_size
4703         len + 1;
4704 #else 
4705         PERL_STRLEN_ROUNDUP(len + 1);
4706 #endif
4707     if (flags & SV_HAS_TRAILING_NUL) {
4708         /* It's long enough - do nothing.
4709            Specifically Perl_newCONSTSUB is relying on this.  */
4710     } else {
4711 #ifdef DEBUGGING
4712         /* Force a move to shake out bugs in callers.  */
4713         char *new_ptr = (char*)safemalloc(allocate);
4714         Copy(ptr, new_ptr, len, char);
4715         PoisonFree(ptr,len,char);
4716         Safefree(ptr);
4717         ptr = new_ptr;
4718 #else
4719         ptr = (char*) saferealloc (ptr, allocate);
4720 #endif
4721     }
4722 #ifdef Perl_safesysmalloc_size
4723     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4724 #else
4725     SvLEN_set(sv, allocate);
4726 #endif
4727     SvCUR_set(sv, len);
4728     SvPV_set(sv, ptr);
4729     if (!(flags & SV_HAS_TRAILING_NUL)) {
4730         ptr[len] = '\0';
4731     }
4732     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4733     SvTAINT(sv);
4734     if (flags & SV_SMAGIC)
4735         SvSETMAGIC(sv);
4736 }
4737
4738 #ifdef PERL_OLD_COPY_ON_WRITE
4739 /* Need to do this *after* making the SV normal, as we need the buffer
4740    pointer to remain valid until after we've copied it.  If we let go too early,
4741    another thread could invalidate it by unsharing last of the same hash key
4742    (which it can do by means other than releasing copy-on-write Svs)
4743    or by changing the other copy-on-write SVs in the loop.  */
4744 STATIC void
4745 S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after)
4746 {
4747     PERL_ARGS_ASSERT_SV_RELEASE_COW;
4748
4749     { /* this SV was SvIsCOW_normal(sv) */
4750          /* we need to find the SV pointing to us.  */
4751         SV *current = SV_COW_NEXT_SV(after);
4752
4753         if (current == sv) {
4754             /* The SV we point to points back to us (there were only two of us
4755                in the loop.)
4756                Hence other SV is no longer copy on write either.  */
4757             SvIsCOW_off(after);
4758         } else {
4759             /* We need to follow the pointers around the loop.  */
4760             SV *next;
4761             while ((next = SV_COW_NEXT_SV(current)) != sv) {
4762                 assert (next);
4763                 current = next;
4764                  /* don't loop forever if the structure is bust, and we have
4765                     a pointer into a closed loop.  */
4766                 assert (current != after);
4767                 assert (SvPVX_const(current) == pvx);
4768             }
4769             /* Make the SV before us point to the SV after us.  */
4770             SV_COW_NEXT_SV_SET(current, after);
4771         }
4772     }
4773 }
4774 #endif
4775 /*
4776 =for apidoc sv_force_normal_flags
4777
4778 Undo various types of fakery on an SV, where fakery means
4779 "more than" a string: if the PV is a shared string, make
4780 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4781 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4782 we do the copy, and is also used locally; if this is a
4783 vstring, drop the vstring magic.  If C<SV_COW_DROP_PV> is set
4784 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4785 SvPOK_off rather than making a copy.  (Used where this
4786 scalar is about to be set to some other value.)  In addition,
4787 the C<flags> parameter gets passed to C<sv_unref_flags()>
4788 when unreffing.  C<sv_force_normal> calls this function
4789 with flags set to 0.
4790
4791 =cut
4792 */
4793
4794 void
4795 Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
4796 {
4797     dVAR;
4798
4799     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4800
4801 #ifdef PERL_ANY_COW
4802     if (SvREADONLY(sv)) {
4803         if (IN_PERL_RUNTIME)
4804             Perl_croak_no_modify();
4805     }
4806     else if (SvIsCOW(sv)) {
4807         const char * const pvx = SvPVX_const(sv);
4808         const STRLEN len = SvLEN(sv);
4809         const STRLEN cur = SvCUR(sv);
4810 # ifdef PERL_OLD_COPY_ON_WRITE
4811         /* next COW sv in the loop.  If len is 0 then this is a shared-hash
4812            key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4813            we'll fail an assertion.  */
4814         SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4815 # endif
4816
4817         if (DEBUG_C_TEST) {
4818                 PerlIO_printf(Perl_debug_log,
4819                               "Copy on write: Force normal %ld\n",
4820                               (long) flags);
4821                 sv_dump(sv);
4822         }
4823         SvIsCOW_off(sv);
4824 # ifdef PERL_NEW_COPY_ON_WRITE
4825         if (len && CowREFCNT(sv) == 0)
4826             /* We own the buffer ourselves. */
4827             NOOP;
4828         else
4829 # endif
4830         {
4831                 
4832             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
4833 # ifdef PERL_NEW_COPY_ON_WRITE
4834             /* Must do this first, since the macro uses SvPVX. */
4835             if (len) CowREFCNT(sv)--;
4836 # endif
4837             SvPV_set(sv, NULL);
4838             SvLEN_set(sv, 0);
4839             if (flags & SV_COW_DROP_PV) {
4840                 /* OK, so we don't need to copy our buffer.  */
4841                 SvPOK_off(sv);
4842             } else {
4843                 SvGROW(sv, cur + 1);
4844                 Move(pvx,SvPVX(sv),cur,char);
4845                 SvCUR_set(sv, cur);
4846                 *SvEND(sv) = '\0';
4847             }
4848             if (len) {
4849 # ifdef PERL_OLD_COPY_ON_WRITE
4850                 sv_release_COW(sv, pvx, next);
4851 # endif
4852             } else {
4853                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4854             }
4855             if (DEBUG_C_TEST) {
4856                 sv_dump(sv);
4857             }
4858         }
4859     }
4860 #else
4861     if (SvREADONLY(sv)) {
4862         if (IN_PERL_RUNTIME)
4863             Perl_croak_no_modify();
4864     }
4865     else
4866         if (SvIsCOW(sv)) {
4867             const char * const pvx = SvPVX_const(sv);
4868             const STRLEN len = SvCUR(sv);
4869             SvIsCOW_off(sv);
4870             SvPV_set(sv, NULL);
4871             SvLEN_set(sv, 0);
4872             if (flags & SV_COW_DROP_PV) {
4873                 /* OK, so we don't need to copy our buffer.  */
4874                 SvPOK_off(sv);
4875             } else {
4876                 SvGROW(sv, len + 1);
4877                 Move(pvx,SvPVX(sv),len,char);
4878                 *SvEND(sv) = '\0';
4879             }
4880             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4881         }
4882 #endif
4883     if (SvROK(sv))
4884         sv_unref_flags(sv, flags);
4885     else if (SvFAKE(sv) && isGV_with_GP(sv))
4886         sv_unglob(sv, flags);
4887     else if (SvFAKE(sv) && isREGEXP(sv)) {
4888         /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
4889            to sv_unglob. We only need it here, so inline it.  */
4890         const bool islv = SvTYPE(sv) == SVt_PVLV;
4891         const svtype new_type =
4892           islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
4893         SV *const temp = newSV_type(new_type);
4894         regexp *const temp_p = ReANY((REGEXP *)sv);
4895
4896         if (new_type == SVt_PVMG) {
4897             SvMAGIC_set(temp, SvMAGIC(sv));
4898             SvMAGIC_set(sv, NULL);
4899             SvSTASH_set(temp, SvSTASH(sv));
4900             SvSTASH_set(sv, NULL);
4901         }
4902         if (!islv) SvCUR_set(temp, SvCUR(sv));
4903         /* Remember that SvPVX is in the head, not the body.  But
4904            RX_WRAPPED is in the body. */
4905         assert(ReANY((REGEXP *)sv)->mother_re);
4906         /* Their buffer is already owned by someone else. */
4907         if (flags & SV_COW_DROP_PV) {
4908             /* SvLEN is already 0.  For SVt_REGEXP, we have a brand new
4909                zeroed body.  For SVt_PVLV, it should have been set to 0
4910                before turning into a regexp. */
4911             assert(!SvLEN(islv ? sv : temp));
4912             sv->sv_u.svu_pv = 0;
4913         }
4914         else {
4915             sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
4916             SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
4917             SvPOK_on(sv);
4918         }
4919
4920         /* Now swap the rest of the bodies. */
4921
4922         SvFAKE_off(sv);
4923         if (!islv) {
4924             SvFLAGS(sv) &= ~SVTYPEMASK;
4925             SvFLAGS(sv) |= new_type;
4926             SvANY(sv) = SvANY(temp);
4927         }
4928
4929         SvFLAGS(temp) &= ~(SVTYPEMASK);
4930         SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
4931         SvANY(temp) = temp_p;
4932         temp->sv_u.svu_rx = (regexp *)temp_p;
4933
4934         SvREFCNT_dec(temp);
4935     }
4936     else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
4937 }
4938
4939 /*
4940 =for apidoc sv_chop
4941
4942 Efficient removal of characters from the beginning of the string buffer.
4943 SvPOK(sv), or at least SvPOKp(sv), must be true and the C<ptr> must be a
4944 pointer to somewhere inside the string buffer.  The C<ptr> becomes the first
4945 character of the adjusted string.  Uses the "OOK hack".  On return, only
4946 SvPOK(sv) and SvPOKp(sv) among the OK flags will be true.
4947
4948 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4949 refer to the same chunk of data.
4950
4951 The unfortunate similarity of this function's name to that of Perl's C<chop>
4952 operator is strictly coincidental.  This function works from the left;
4953 C<chop> works from the right.
4954
4955 =cut
4956 */
4957
4958 void
4959 Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
4960 {
4961     STRLEN delta;
4962     STRLEN old_delta;
4963     U8 *p;
4964 #ifdef DEBUGGING
4965     const U8 *evacp;
4966     STRLEN evacn;
4967 #endif
4968     STRLEN max_delta;
4969
4970     PERL_ARGS_ASSERT_SV_CHOP;
4971
4972     if (!ptr || !SvPOKp(sv))
4973         return;
4974     delta = ptr - SvPVX_const(sv);
4975     if (!delta) {
4976         /* Nothing to do.  */
4977         return;
4978     }
4979     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4980     if (delta > max_delta)
4981         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4982                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4983     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
4984     SV_CHECK_THINKFIRST(sv);
4985     SvPOK_only_UTF8(sv);
4986
4987     if (!SvOOK(sv)) {
4988         if (!SvLEN(sv)) { /* make copy of shared string */
4989             const char *pvx = SvPVX_const(sv);
4990             const STRLEN len = SvCUR(sv);
4991             SvGROW(sv, len + 1);
4992             Move(pvx,SvPVX(sv),len,char);
4993             *SvEND(sv) = '\0';
4994         }
4995         SvOOK_on(sv);
4996         old_delta = 0;
4997     } else {
4998         SvOOK_offset(sv, old_delta);
4999     }
5000     SvLEN_set(sv, SvLEN(sv) - delta);
5001     SvCUR_set(sv, SvCUR(sv) - delta);
5002     SvPV_set(sv, SvPVX(sv) + delta);
5003
5004     p = (U8 *)SvPVX_const(sv);
5005
5006 #ifdef DEBUGGING
5007     /* how many bytes were evacuated?  we will fill them with sentinel
5008        bytes, except for the part holding the new offset of course. */
5009     evacn = delta;
5010     if (old_delta)
5011         evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
5012     assert(evacn);
5013     assert(evacn <= delta + old_delta);
5014     evacp = p - evacn;
5015 #endif
5016
5017     delta += old_delta;
5018     assert(delta);
5019     if (delta < 0x100) {
5020         *--p = (U8) delta;
5021     } else {
5022         *--p = 0;
5023         p -= sizeof(STRLEN);
5024         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
5025     }
5026
5027 #ifdef DEBUGGING
5028     /* Fill the preceding buffer with sentinals to verify that no-one is
5029        using it.  */
5030     while (p > evacp) {
5031         --p;
5032         *p = (U8)PTR2UV(p);
5033     }
5034 #endif
5035 }
5036
5037 /*
5038 =for apidoc sv_catpvn
5039
5040 Concatenates the string onto the end of the string which is in the SV.  The
5041 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
5042 status set, then the bytes appended should be valid UTF-8.
5043 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
5044
5045 =for apidoc sv_catpvn_flags
5046
5047 Concatenates the string onto the end of the string which is in the SV.  The
5048 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
5049 status set, then the bytes appended should be valid UTF-8.
5050 If C<flags> has the C<SV_SMAGIC> bit set, will
5051 C<mg_set> on C<dsv> afterwards if appropriate.
5052 C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5053 in terms of this function.
5054
5055 =cut
5056 */
5057
5058 void
5059 Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
5060 {
5061     dVAR;
5062     STRLEN dlen;
5063     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5064
5065     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5066     assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5067
5068     if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
5069       if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
5070          sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5071          dlen = SvCUR(dsv);
5072       }
5073       else SvGROW(dsv, dlen + slen + 1);
5074       if (sstr == dstr)
5075         sstr = SvPVX_const(dsv);
5076       Move(sstr, SvPVX(dsv) + dlen, slen, char);
5077       SvCUR_set(dsv, SvCUR(dsv) + slen);
5078     }
5079     else {
5080         /* We inline bytes_to_utf8, to avoid an extra malloc. */
5081         const char * const send = sstr + slen;
5082         U8 *d;
5083
5084         /* Something this code does not account for, which I think is
5085            impossible; it would require the same pv to be treated as
5086            bytes *and* utf8, which would indicate a bug elsewhere. */
5087         assert(sstr != dstr);
5088
5089         SvGROW(dsv, dlen + slen * 2 + 1);
5090         d = (U8 *)SvPVX(dsv) + dlen;
5091
5092         while (sstr < send) {
5093             const UV uv = NATIVE_TO_ASCII((U8)*sstr++);
5094             if (UNI_IS_INVARIANT(uv))
5095                 *d++ = (U8)UTF_TO_NATIVE(uv);
5096             else {
5097                 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
5098                 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
5099             }
5100         }
5101         SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5102     }
5103     *SvEND(dsv) = '\0';
5104     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
5105     SvTAINT(dsv);
5106     if (flags & SV_SMAGIC)
5107         SvSETMAGIC(dsv);
5108 }
5109
5110 /*
5111 =for apidoc sv_catsv
5112
5113 Concatenates the string from SV C<ssv> onto the end of the string in SV
5114 C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5115 Handles 'get' magic on both SVs, but no 'set' magic.  See C<sv_catsv_mg> and
5116 C<sv_catsv_nomg>.
5117
5118 =for apidoc sv_catsv_flags
5119
5120 Concatenates the string from SV C<ssv> onto the end of the string in SV
5121 C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5122 If C<flags> include C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if
5123 appropriate.  If C<flags> include C<SV_SMAGIC>, C<mg_set> will be called on
5124 the modified SV afterward, if appropriate.  C<sv_catsv>, C<sv_catsv_nomg>,
5125 and C<sv_catsv_mg> are implemented in terms of this function.
5126
5127 =cut */
5128
5129 void
5130 Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
5131 {
5132     dVAR;
5133  
5134     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5135
5136     if (ssv) {
5137         STRLEN slen;
5138         const char *spv = SvPV_flags_const(ssv, slen, flags);
5139         if (spv) {
5140             if (flags & SV_GMAGIC)
5141                 SvGETMAGIC(dsv);
5142             sv_catpvn_flags(dsv, spv, slen,
5143                             DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
5144             if (flags & SV_SMAGIC)
5145                 SvSETMAGIC(dsv);
5146         }
5147     }
5148 }
5149
5150 /*
5151 =for apidoc sv_catpv
5152
5153 Concatenates the string onto the end of the string which is in the SV.
5154 If the SV has the UTF-8 status set, then the bytes appended should be
5155 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
5156
5157 =cut */
5158
5159 void
5160 Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
5161 {
5162     dVAR;
5163     STRLEN len;
5164     STRLEN tlen;
5165     char *junk;
5166
5167     PERL_ARGS_ASSERT_SV_CATPV;
5168
5169     if (!ptr)
5170         return;
5171     junk = SvPV_force(sv, tlen);
5172     len = strlen(ptr);
5173     SvGROW(sv, tlen + len + 1);
5174     if (ptr == junk)
5175         ptr = SvPVX_const(sv);
5176     Move(ptr,SvPVX(sv)+tlen,len+1,char);
5177     SvCUR_set(sv, SvCUR(sv) + len);
5178     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5179     SvTAINT(sv);
5180 }
5181
5182 /*
5183 =for apidoc sv_catpv_flags
5184
5185 Concatenates the string onto the end of the string which is in the SV.
5186 If the SV has the UTF-8 status set, then the bytes appended should
5187 be valid UTF-8.  If C<flags> has the C<SV_SMAGIC> bit set, will C<mg_set>
5188 on the modified SV if appropriate.
5189
5190 =cut
5191 */
5192
5193 void
5194 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
5195 {
5196     PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5197     sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
5198 }
5199
5200 /*
5201 =for apidoc sv_catpv_mg
5202
5203 Like C<sv_catpv>, but also handles 'set' magic.
5204
5205 =cut
5206 */
5207
5208 void
5209 Perl_sv_catpv_mg(pTHX_ SV *const sv, const char *const ptr)
5210 {
5211     PERL_ARGS_ASSERT_SV_CATPV_MG;
5212
5213     sv_catpv(sv,ptr);
5214     SvSETMAGIC(sv);
5215 }
5216
5217 /*
5218 =for apidoc newSV
5219
5220 Creates a new SV.  A non-zero C<len> parameter indicates the number of
5221 bytes of preallocated string space the SV should have.  An extra byte for a
5222 trailing NUL is also reserved.  (SvPOK is not set for the SV even if string
5223 space is allocated.)  The reference count for the new SV is set to 1.
5224
5225 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
5226 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5227 This aid has been superseded by a new build option, PERL_MEM_LOG (see
5228 L<perlhacktips/PERL_MEM_LOG>).  The older API is still there for use in XS
5229 modules supporting older perls.
5230
5231 =cut
5232 */
5233
5234 SV *
5235 Perl_newSV(pTHX_ const STRLEN len)
5236 {
5237     dVAR;
5238     SV *sv;
5239
5240     new_SV(sv);
5241     if (len) {
5242         sv_upgrade(sv, SVt_PV);
5243         SvGROW(sv, len + 1);
5244     }
5245     return sv;
5246 }
5247 /*
5248 =for apidoc sv_magicext
5249
5250 Adds magic to an SV, upgrading it if necessary.  Applies the
5251 supplied vtable and returns a pointer to the magic added.
5252
5253 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5254 In particular, you can add magic to SvREADONLY SVs, and add more than
5255 one instance of the same 'how'.
5256
5257 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5258 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5259 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5260 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5261
5262 (This is now used as a subroutine by C<sv_magic>.)
5263
5264 =cut
5265 */
5266 MAGIC * 
5267 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, 
5268                 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5269 {
5270     dVAR;
5271     MAGIC* mg;
5272
5273     PERL_ARGS_ASSERT_SV_MAGICEXT;
5274
5275     SvUPGRADE(sv, SVt_PVMG);
5276     Newxz(mg, 1, MAGIC);
5277     mg->mg_moremagic = SvMAGIC(sv);
5278     SvMAGIC_set(sv, mg);
5279
5280     /* Sometimes a magic contains a reference loop, where the sv and
5281        object refer to each other.  To prevent a reference loop that
5282        would prevent such objects being freed, we look for such loops
5283        and if we find one we avoid incrementing the object refcount.
5284
5285        Note we cannot do this to avoid self-tie loops as intervening RV must
5286        have its REFCNT incremented to keep it in existence.
5287
5288     */
5289     if (!obj || obj == sv ||
5290         how == PERL_MAGIC_arylen ||
5291         how == PERL_MAGIC_symtab ||
5292         (SvTYPE(obj) == SVt_PVGV &&
5293             (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5294              || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5295              || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5296     {
5297         mg->mg_obj = obj;
5298     }
5299     else {
5300         mg->mg_obj = SvREFCNT_inc_simple(obj);
5301         mg->mg_flags |= MGf_REFCOUNTED;
5302     }
5303
5304     /* Normal self-ties simply pass a null object, and instead of
5305        using mg_obj directly, use the SvTIED_obj macro to produce a
5306        new RV as needed.  For glob "self-ties", we are tieing the PVIO
5307        with an RV obj pointing to the glob containing the PVIO.  In
5308        this case, to avoid a reference loop, we need to weaken the
5309        reference.
5310     */
5311
5312     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5313         obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5314     {
5315       sv_rvweaken(obj);
5316     }
5317
5318     mg->mg_type = how;
5319     mg->mg_len = namlen;
5320     if (name) {
5321         if (namlen > 0)
5322             mg->mg_ptr = savepvn(name, namlen);
5323         else if (namlen == HEf_SVKEY) {
5324             /* Yes, this is casting away const. This is only for the case of
5325                HEf_SVKEY. I think we need to document this aberation of the
5326                constness of the API, rather than making name non-const, as
5327                that change propagating outwards a long way.  */
5328             mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5329         } else
5330             mg->mg_ptr = (char *) name;
5331     }
5332     mg->mg_virtual = (MGVTBL *) vtable;
5333
5334     mg_magical(sv);
5335     return mg;
5336 }
5337
5338 /*
5339 =for apidoc sv_magic
5340
5341 Adds magic to an SV.  First upgrades C<sv> to type C<SVt_PVMG> if
5342 necessary, then adds a new magic item of type C<how> to the head of the
5343 magic list.
5344
5345 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5346 handling of the C<name> and C<namlen> arguments.
5347
5348 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5349 to add more than one instance of the same 'how'.
5350
5351 =cut
5352 */
5353
5354 void
5355 Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
5356              const char *const name, const I32 namlen)
5357 {
5358     dVAR;
5359     const MGVTBL *vtable;
5360     MAGIC* mg;
5361     unsigned int flags;
5362     unsigned int vtable_index;
5363
5364     PERL_ARGS_ASSERT_SV_MAGIC;
5365
5366     if (how < 0 || (unsigned)how > C_ARRAY_LENGTH(PL_magic_data)
5367         || ((flags = PL_magic_data[how]),
5368             (vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
5369             > magic_vtable_max))
5370         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5371
5372     /* PERL_MAGIC_ext is reserved for use by extensions not perl internals.
5373        Useful for attaching extension internal data to perl vars.
5374        Note that multiple extensions may clash if magical scalars
5375        etc holding private data from one are passed to another. */
5376
5377     vtable = (vtable_index == magic_vtable_max)
5378         ? NULL : PL_magic_vtables + vtable_index;
5379
5380 #ifdef PERL_ANY_COW
5381     if (SvIsCOW(sv))
5382         sv_force_normal_flags(sv, 0);
5383 #endif
5384     if (SvREADONLY(sv)) {
5385         if (
5386             /* its okay to attach magic to shared strings */
5387             !SvIsCOW(sv)
5388
5389             && IN_PERL_RUNTIME
5390             && !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
5391            )
5392         {
5393             Perl_croak_no_modify();
5394         }
5395     }
5396     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5397         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5398             /* sv_magic() refuses to add a magic of the same 'how' as an
5399                existing one
5400              */
5401             if (how == PERL_MAGIC_taint)
5402                 mg->mg_len |= 1;
5403             return;
5404         }
5405     }
5406
5407     /* Rest of work is done else where */
5408     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5409
5410     switch (how) {
5411     case PERL_MAGIC_taint:
5412         mg->mg_len = 1;
5413         break;
5414     case PERL_MAGIC_ext:
5415     case PERL_MAGIC_dbfile:
5416         SvRMAGICAL_on(sv);
5417         break;
5418     }
5419 }
5420
5421 static int
5422 S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
5423 {
5424     MAGIC* mg;
5425     MAGIC** mgp;
5426
5427     assert(flags <= 1);
5428
5429     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5430         return 0;
5431     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5432     for (mg = *mgp; mg; mg = *mgp) {
5433         const MGVTBL* const virt = mg->mg_virtual;
5434         if (mg->mg_type == type && (!flags || virt == vtbl)) {
5435             *mgp = mg->mg_moremagic;
5436             if (virt && virt->svt_free)
5437                 virt->svt_free(aTHX_ sv, mg);
5438             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5439                 if (mg->mg_len > 0)
5440                     Safefree(mg->mg_ptr);
5441                 else if (mg->mg_len == HEf_SVKEY)
5442                     SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5443                 else if (mg->mg_type == PERL_MAGIC_utf8)
5444                     Safefree(mg->mg_ptr);
5445             }
5446             if (mg->mg_flags & MGf_REFCOUNTED)
5447                 SvREFCNT_dec(mg->mg_obj);
5448             Safefree(mg);
5449         }
5450         else
5451             mgp = &mg->mg_moremagic;
5452     }
5453     if (SvMAGIC(sv)) {
5454         if (SvMAGICAL(sv))      /* if we're under save_magic, wait for restore_magic; */
5455             mg_magical(sv);     /*    else fix the flags now */
5456     }
5457     else {
5458         SvMAGICAL_off(sv);
5459         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5460     }
5461     return 0;
5462 }
5463
5464 /*
5465 =for apidoc sv_unmagic
5466
5467 Removes all magic of type C<type> from an SV.
5468
5469 =cut
5470 */
5471
5472 int
5473 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5474 {
5475     PERL_ARGS_ASSERT_SV_UNMAGIC;
5476     return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
5477 }
5478
5479 /*
5480 =for apidoc sv_unmagicext
5481
5482 Removes all magic of type C<type> with the specified C<vtbl> from an SV.
5483
5484 =cut
5485 */
5486
5487 int
5488 Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
5489 {
5490     PERL_ARGS_ASSERT_SV_UNMAGICEXT;
5491     return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
5492 }
5493
5494 /*
5495 =for apidoc sv_rvweaken
5496
5497 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5498 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5499 push a back-reference to this RV onto the array of backreferences
5500 associated with that magic.  If the RV is magical, set magic will be
5501 called after the RV is cleared.
5502
5503 =cut
5504 */
5505
5506 SV *
5507 Perl_sv_rvweaken(pTHX_ SV *const sv)
5508 {
5509     SV *tsv;
5510
5511     PERL_ARGS_ASSERT_SV_RVWEAKEN;
5512
5513     if (!SvOK(sv))  /* let undefs pass */
5514         return sv;
5515     if (!SvROK(sv))
5516         Perl_croak(aTHX_ "Can't weaken a nonreference");
5517     else if (SvWEAKREF(sv)) {
5518         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5519         return sv;
5520     }
5521     else if (SvREADONLY(sv)) croak_no_modify();
5522     tsv = SvRV(sv);