xref: /openbsd/gnu/usr.bin/perl/sv.c (revision e0680481)
1 /*    sv.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall
5  *    and others
6  *
7  *    You may distribute under the terms of either the GNU General Public
8  *    License or the Artistic License, as specified in the README file.
9  *
10  */
11 
12 /*
13  * 'I wonder what the Entish is for "yes" and "no",' he thought.
14  *                                                      --Pippin
15  *
16  *     [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
17  */
18 
19 /*
20  *
21  *
22  * This file contains the code that creates, manipulates and destroys
23  * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
24  * structure of an SV, so their creation and destruction is handled
25  * here; higher-level functions are in av.c, hv.c, and so on. Opcode
26  * level functions (eg. substr, split, join) for each of the types are
27  * in the pp*.c files.
28  */
29 
30 #include "EXTERN.h"
31 #define PERL_IN_SV_C
32 #include "perl.h"
33 #include "regcomp.h"
34 #ifdef __VMS
35 # include <rms.h>
36 #endif
37 
38 #ifdef __Lynx__
39 /* Missing proto on LynxOS */
40   char *gconvert(double, int, int,  char *);
41 #endif
42 
43 #ifdef USE_QUADMATH
44 #  define SNPRINTF_G(nv, buffer, size, ndig) \
45     quadmath_snprintf(buffer, size, "%.*Qg", (int)ndig, (NV)(nv))
46 #else
47 #  define SNPRINTF_G(nv, buffer, size, ndig) \
48     PERL_UNUSED_RESULT(Gconvert((NV)(nv), (int)ndig, 0, buffer))
49 #endif
50 
51 #ifndef SV_COW_THRESHOLD
52 #    define SV_COW_THRESHOLD                    0   /* COW iff len > K */
53 #endif
54 #ifndef SV_COWBUF_THRESHOLD
55 #    define SV_COWBUF_THRESHOLD                 1250 /* COW iff len > K */
56 #endif
57 #ifndef SV_COW_MAX_WASTE_THRESHOLD
58 #    define SV_COW_MAX_WASTE_THRESHOLD          80   /* COW iff (len - cur) < K */
59 #endif
60 #ifndef SV_COWBUF_WASTE_THRESHOLD
61 #    define SV_COWBUF_WASTE_THRESHOLD           80   /* COW iff (len - cur) < K */
62 #endif
63 #ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD
64 #    define SV_COW_MAX_WASTE_FACTOR_THRESHOLD   2    /* COW iff len < (cur * K) */
65 #endif
66 #ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD
67 #    define SV_COWBUF_WASTE_FACTOR_THRESHOLD    2    /* COW iff len < (cur * K) */
68 #endif
69 /* Work around compiler warnings about unsigned >= THRESHOLD when thres-
70    hold is 0. */
71 #if SV_COW_THRESHOLD
72 # define GE_COW_THRESHOLD(cur) ((cur) >= SV_COW_THRESHOLD)
73 #else
74 # define GE_COW_THRESHOLD(cur) 1
75 #endif
76 #if SV_COWBUF_THRESHOLD
77 # define GE_COWBUF_THRESHOLD(cur) ((cur) >= SV_COWBUF_THRESHOLD)
78 #else
79 # define GE_COWBUF_THRESHOLD(cur) 1
80 #endif
81 #if SV_COW_MAX_WASTE_THRESHOLD
82 # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COW_MAX_WASTE_THRESHOLD)
83 #else
84 # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) 1
85 #endif
86 #if SV_COWBUF_WASTE_THRESHOLD
87 # define GE_COWBUF_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COWBUF_WASTE_THRESHOLD)
88 #else
89 # define GE_COWBUF_WASTE_THRESHOLD(cur,len) 1
90 #endif
91 #if SV_COW_MAX_WASTE_FACTOR_THRESHOLD
92 # define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COW_MAX_WASTE_FACTOR_THRESHOLD * (cur))
93 #else
94 # define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) 1
95 #endif
96 #if SV_COWBUF_WASTE_FACTOR_THRESHOLD
97 # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COWBUF_WASTE_FACTOR_THRESHOLD * (cur))
98 #else
99 # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) 1
100 #endif
101 
102 #define CHECK_COW_THRESHOLD(cur,len) (\
103     GE_COW_THRESHOLD((cur)) && \
104     GE_COW_MAX_WASTE_THRESHOLD((cur),(len)) && \
105     GE_COW_MAX_WASTE_FACTOR_THRESHOLD((cur),(len)) \
106 )
107 #define CHECK_COWBUF_THRESHOLD(cur,len) (\
108     GE_COWBUF_THRESHOLD((cur)) && \
109     GE_COWBUF_WASTE_THRESHOLD((cur),(len)) && \
110     GE_COWBUF_WASTE_FACTOR_THRESHOLD((cur),(len)) \
111 )
112 
113 #ifdef PERL_UTF8_CACHE_ASSERT
114 /* if adding more checks watch out for the following tests:
115  *   t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
116  *   lib/utf8.t lib/Unicode/Collate/t/index.t
117  * --jhi
118  */
119 #   define ASSERT_UTF8_CACHE(cache) \
120     STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
121                               assert((cache)[2] <= (cache)[3]); \
122                               assert((cache)[3] <= (cache)[1]);} \
123                               } STMT_END
124 #else
125 #   define ASSERT_UTF8_CACHE(cache) NOOP
126 #endif
127 
128 static const char S_destroy[] = "DESTROY";
129 #define S_destroy_len (sizeof(S_destroy)-1)
130 
131 /* ============================================================================
132 
133 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
134 sv, av, hv...) contains type and reference count information, and for
135 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
136 contains fields specific to each type.  Some types store all they need
137 in the head, so don't have a body.
138 
139 In all but the most memory-paranoid configurations (ex: PURIFY), heads
140 and bodies are allocated out of arenas, which by default are
141 approximately 4K chunks of memory parcelled up into N heads or bodies.
142 Sv-bodies are allocated by their sv-type, guaranteeing size
143 consistency needed to allocate safely from arrays.
144 
145 For SV-heads, the first slot in each arena is reserved, and holds a
146 link to the next arena, some flags, and a note of the number of slots.
147 Snaked through each arena chain is a linked list of free items; when
148 this becomes empty, an extra arena is allocated and divided up into N
149 items which are threaded into the free list.
150 
151 SV-bodies are similar, but they use arena-sets by default, which
152 separate the link and info from the arena itself, and reclaim the 1st
153 slot in the arena.  SV-bodies are further described later.
154 
155 The following global variables are associated with arenas:
156 
157  PL_sv_arenaroot     pointer to list of SV arenas
158  PL_sv_root          pointer to list of free SV structures
159 
160  PL_body_arenas      head of linked-list of body arenas
161  PL_body_roots[]     array of pointers to list of free bodies of svtype
162                      arrays are indexed by the svtype needed
163 
164 A few special SV heads are not allocated from an arena, but are
165 instead directly created in the interpreter structure, eg PL_sv_undef.
166 The size of arenas can be changed from the default by setting
167 PERL_ARENA_SIZE appropriately at compile time.
168 
169 The SV arena serves the secondary purpose of allowing still-live SVs
170 to be located and destroyed during final cleanup.
171 
172 At the lowest level, the macros new_SV() and del_SV() grab and free
173 an SV head.  (If debugging with -DD, del_SV() calls the function S_del_sv()
174 to return the SV to the free list with error checking.) new_SV() calls
175 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
176 SVs in the free list have their SvTYPE field set to all ones.
177 
178 At the time of very final cleanup, sv_free_arenas() is called from
179 perl_destruct() to physically free all the arenas allocated since the
180 start of the interpreter.
181 
182 The internal function visit() scans the SV arenas list, and calls a specified
183 function for each SV it finds which is still live, I<i.e.> which has an SvTYPE
184 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
185 following functions (specified as [function that calls visit()] / [function
186 called by visit() for each SV]):
187 
188     sv_report_used() / do_report_used()
189                         dump all remaining SVs (debugging aid)
190 
191     sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
192                       do_clean_named_io_objs(),do_curse()
193                         Attempt to free all objects pointed to by RVs,
194                         try to do the same for all objects indir-
195                         ectly referenced by typeglobs too, and
196                         then do a final sweep, cursing any
197                         objects that remain.  Called once from
198                         perl_destruct(), prior to calling sv_clean_all()
199                         below.
200 
201     sv_clean_all() / do_clean_all()
202                         SvREFCNT_dec(sv) each remaining SV, possibly
203                         triggering an sv_free(). It also sets the
204                         SVf_BREAK flag on the SV to indicate that the
205                         refcnt has been artificially lowered, and thus
206                         stopping sv_free() from giving spurious warnings
207                         about SVs which unexpectedly have a refcnt
208                         of zero.  called repeatedly from perl_destruct()
209                         until there are no SVs left.
210 
211 =head2 Arena allocator API Summary
212 
213 Private API to rest of sv.c
214 
215     new_SV(),  del_SV(),
216 
217     new_XPVNV(), del_body()
218     etc
219 
220 Public API:
221 
222     sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
223 
224 =cut
225 
226  * ========================================================================= */
227 
228 /*
229  * "A time to plant, and a time to uproot what was planted..."
230  */
231 
232 #ifdef DEBUG_LEAKING_SCALARS
233 #  define FREE_SV_DEBUG_FILE(sv) STMT_START { \
234         if ((sv)->sv_debug_file) {                   \
235             PerlMemShared_free((sv)->sv_debug_file); \
236             sv->sv_debug_file = NULL;                \
237         }                                            \
238     } STMT_END
239 #  define DEBUG_SV_SERIAL(sv)						    \
240     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) del_SV\n",    \
241             PTR2UV(sv), (long)(sv)->sv_debug_serial))
242 #else
243 #  define FREE_SV_DEBUG_FILE(sv)
244 #  define DEBUG_SV_SERIAL(sv)	NOOP
245 #endif
246 
247 /* Mark an SV head as unused, and add to free list.
248  *
249  * If SVf_BREAK is set, skip adding it to the free list, as this SV had
250  * its refcount artificially decremented during global destruction, so
251  * there may be dangling pointers to it. The last thing we want in that
252  * case is for it to be reused. */
253 
254 #define plant_SV(p) \
255     STMT_START {					\
256         const U32 old_flags = SvFLAGS(p);			\
257         MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__);  \
258         DEBUG_SV_SERIAL(p);				\
259         FREE_SV_DEBUG_FILE(p);				\
260         POISON_SV_HEAD(p);				\
261         SvFLAGS(p) = SVTYPEMASK;			\
262         if (!(old_flags & SVf_BREAK)) {		\
263             SvARENA_CHAIN_SET(p, PL_sv_root);	\
264             PL_sv_root = (p);				\
265         }						\
266         --PL_sv_count;					\
267     } STMT_END
268 
269 
270 /* make some more SVs by adding another arena */
271 
272 SV*
Perl_more_sv(pTHX)273 Perl_more_sv(pTHX)
274 {
275     SV* sv;
276     char *chunk;                /* must use New here to match call to */
277     Newx(chunk,PERL_ARENA_SIZE,char);  /* Safefree() in sv_free_arenas() */
278     sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
279     uproot_SV(sv);
280     return sv;
281 }
282 
283 /* del_SV(): return an empty SV head to the free list */
284 
285 #ifdef DEBUGGING
286 
287 #define del_SV(p) \
288     STMT_START {					\
289         if (DEBUG_D_TEST)				\
290             del_sv(p);					\
291         else						\
292             plant_SV(p);				\
293     } STMT_END
294 
295 STATIC void
S_del_sv(pTHX_ SV * p)296 S_del_sv(pTHX_ SV *p)
297 {
298     PERL_ARGS_ASSERT_DEL_SV;
299 
300     if (DEBUG_D_TEST) {
301         SV* sva;
302         bool ok = 0;
303         for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
304             const SV * const sv = sva + 1;
305             const SV * const svend = &sva[SvREFCNT(sva)];
306             if (p >= sv && p < svend) {
307                 ok = 1;
308                 break;
309             }
310         }
311         if (!ok) {
312             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
313                              "Attempt to free non-arena SV: 0x%" UVxf
314                              pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
315             return;
316         }
317     }
318     plant_SV(p);
319 }
320 
321 #else /* ! DEBUGGING */
322 
323 #define del_SV(p)   plant_SV(p)
324 
325 #endif /* DEBUGGING */
326 
327 
328 /*
329 =for apidoc_section $SV
330 
331 =for apidoc sv_add_arena
332 
333 Given a chunk of memory, link it to the head of the list of arenas,
334 and split it into a list of free SVs.
335 
336 =cut
337 */
338 
339 static void
S_sv_add_arena(pTHX_ char * const ptr,const U32 size,const U32 flags)340 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
341 {
342     SV *const sva = MUTABLE_SV(ptr);
343     SV* sv;
344     SV* svend;
345 
346     PERL_ARGS_ASSERT_SV_ADD_ARENA;
347 
348     /* The first SV in an arena isn't an SV. */
349     SvANY(sva) = (void *) PL_sv_arenaroot;		/* ptr to next arena */
350     SvREFCNT(sva) = size / sizeof(SV);		/* number of SV slots */
351     SvFLAGS(sva) = flags;			/* FAKE if not to be freed */
352 
353     PL_sv_arenaroot = sva;
354     PL_sv_root = sva + 1;
355 
356     svend = &sva[SvREFCNT(sva) - 1];
357     sv = sva + 1;
358     while (sv < svend) {
359         SvARENA_CHAIN_SET(sv, (sv + 1));
360 #ifdef DEBUGGING
361         SvREFCNT(sv) = 0;
362 #endif
363         /* Must always set typemask because it's always checked in on cleanup
364            when the arenas are walked looking for objects.  */
365         SvFLAGS(sv) = SVTYPEMASK;
366         sv++;
367     }
368     SvARENA_CHAIN_SET(sv, 0);
369 #ifdef DEBUGGING
370     SvREFCNT(sv) = 0;
371 #endif
372     SvFLAGS(sv) = SVTYPEMASK;
373 }
374 
375 /* visit(): call the named function for each non-free SV in the arenas
376  * whose flags field matches the flags/mask args. */
377 
378 STATIC I32
S_visit(pTHX_ SVFUNC_t f,const U32 flags,const U32 mask)379 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
380 {
381     SV* sva;
382     I32 visited = 0;
383 
384     PERL_ARGS_ASSERT_VISIT;
385 
386     for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
387         const SV * const svend = &sva[SvREFCNT(sva)];
388         SV* sv;
389         for (sv = sva + 1; sv < svend; ++sv) {
390             if (!SvIS_FREED(sv)
391                     && (sv->sv_flags & mask) == flags
392                     && SvREFCNT(sv))
393             {
394                 (*f)(aTHX_ sv);
395                 ++visited;
396             }
397         }
398     }
399     return visited;
400 }
401 
402 #ifdef DEBUGGING
403 
404 /* called by sv_report_used() for each live SV */
405 
406 static void
do_report_used(pTHX_ SV * const sv)407 do_report_used(pTHX_ SV *const sv)
408 {
409     if (!SvIS_FREED(sv)) {
410         PerlIO_printf(Perl_debug_log, "****\n");
411         sv_dump(sv);
412     }
413 }
414 #endif
415 
416 /*
417 =for apidoc sv_report_used
418 
419 Dump the contents of all SVs not yet freed (debugging aid).
420 
421 =cut
422 */
423 
424 void
Perl_sv_report_used(pTHX)425 Perl_sv_report_used(pTHX)
426 {
427 #ifdef DEBUGGING
428     visit(do_report_used, 0, 0);
429 #else
430     PERL_UNUSED_CONTEXT;
431 #endif
432 }
433 
434 /* called by sv_clean_objs() for each live SV */
435 
436 static void
do_clean_objs(pTHX_ SV * const ref)437 do_clean_objs(pTHX_ SV *const ref)
438 {
439     assert (SvROK(ref));
440     {
441         SV * const target = SvRV(ref);
442         if (SvOBJECT(target)) {
443             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
444             if (SvWEAKREF(ref)) {
445                 sv_del_backref(target, ref);
446                 SvWEAKREF_off(ref);
447                 SvRV_set(ref, NULL);
448             } else {
449                 SvROK_off(ref);
450                 SvRV_set(ref, NULL);
451                 SvREFCNT_dec_NN(target);
452             }
453         }
454     }
455 }
456 
457 
458 /* clear any slots in a GV which hold objects - except IO;
459  * called by sv_clean_objs() for each live GV */
460 
461 static void
do_clean_named_objs(pTHX_ SV * const sv)462 do_clean_named_objs(pTHX_ SV *const sv)
463 {
464     SV *obj;
465     assert(SvTYPE(sv) == SVt_PVGV);
466     assert(isGV_with_GP(sv));
467     if (!GvGP(sv))
468         return;
469 
470     /* freeing GP entries may indirectly free the current GV;
471      * hold onto it while we mess with the GP slots */
472     SvREFCNT_inc(sv);
473 
474     if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
475         DEBUG_D((PerlIO_printf(Perl_debug_log,
476                 "Cleaning named glob SV object:\n "), sv_dump(obj)));
477         GvSV(sv) = NULL;
478         SvREFCNT_dec_NN(obj);
479     }
480     if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
481         DEBUG_D((PerlIO_printf(Perl_debug_log,
482                 "Cleaning named glob AV object:\n "), sv_dump(obj)));
483         GvAV(sv) = NULL;
484         SvREFCNT_dec_NN(obj);
485     }
486     if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
487         DEBUG_D((PerlIO_printf(Perl_debug_log,
488                 "Cleaning named glob HV object:\n "), sv_dump(obj)));
489         GvHV(sv) = NULL;
490         SvREFCNT_dec_NN(obj);
491     }
492     if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
493         DEBUG_D((PerlIO_printf(Perl_debug_log,
494                 "Cleaning named glob CV object:\n "), sv_dump(obj)));
495         GvCV_set(sv, NULL);
496         SvREFCNT_dec_NN(obj);
497     }
498     SvREFCNT_dec_NN(sv); /* undo the inc above */
499 }
500 
501 /* clear any IO slots in a GV which hold objects (except stderr, defout);
502  * called by sv_clean_objs() for each live GV */
503 
504 static void
do_clean_named_io_objs(pTHX_ SV * const sv)505 do_clean_named_io_objs(pTHX_ SV *const sv)
506 {
507     SV *obj;
508     assert(SvTYPE(sv) == SVt_PVGV);
509     assert(isGV_with_GP(sv));
510     if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
511         return;
512 
513     SvREFCNT_inc(sv);
514     if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
515         DEBUG_D((PerlIO_printf(Perl_debug_log,
516                 "Cleaning named glob IO object:\n "), sv_dump(obj)));
517         GvIOp(sv) = NULL;
518         SvREFCNT_dec_NN(obj);
519     }
520     SvREFCNT_dec_NN(sv); /* undo the inc above */
521 }
522 
523 /* Void wrapper to pass to visit() */
524 static void
do_curse(pTHX_ SV * const sv)525 do_curse(pTHX_ SV * const sv) {
526     if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
527      || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
528         return;
529     (void)curse(sv, 0);
530 }
531 
532 /*
533 =for apidoc sv_clean_objs
534 
535 Attempt to destroy all objects not yet freed.
536 
537 =cut
538 */
539 
540 void
Perl_sv_clean_objs(pTHX)541 Perl_sv_clean_objs(pTHX)
542 {
543     GV *olddef, *olderr;
544     PL_in_clean_objs = TRUE;
545     visit(do_clean_objs, SVf_ROK, SVf_ROK);
546     /* Some barnacles may yet remain, clinging to typeglobs.
547      * Run the non-IO destructors first: they may want to output
548      * error messages, close files etc */
549     visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
550     visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
551     /* And if there are some very tenacious barnacles clinging to arrays,
552        closures, or what have you.... */
553     visit(do_curse, SVs_OBJECT, SVs_OBJECT);
554     olddef = PL_defoutgv;
555     PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
556     if (olddef && isGV_with_GP(olddef))
557         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
558     olderr = PL_stderrgv;
559     PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
560     if (olderr && isGV_with_GP(olderr))
561         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
562     SvREFCNT_dec(olddef);
563     PL_in_clean_objs = FALSE;
564 }
565 
566 /* called by sv_clean_all() for each live SV */
567 
568 static void
do_clean_all(pTHX_ SV * const sv)569 do_clean_all(pTHX_ SV *const sv)
570 {
571     if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
572         /* don't clean pid table and strtab */
573         return;
574     }
575     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%" UVxf "\n", PTR2UV(sv)) ));
576     SvFLAGS(sv) |= SVf_BREAK;
577     SvREFCNT_dec_NN(sv);
578 }
579 
580 /*
581 =for apidoc sv_clean_all
582 
583 Decrement the refcnt of each remaining SV, possibly triggering a
584 cleanup.  This function may have to be called multiple times to free
585 SVs which are in complex self-referential hierarchies.
586 
587 =cut
588 */
589 
590 I32
Perl_sv_clean_all(pTHX)591 Perl_sv_clean_all(pTHX)
592 {
593     I32 cleaned;
594     PL_in_clean_all = TRUE;
595     cleaned = visit(do_clean_all, 0,0);
596     return cleaned;
597 }
598 
599 /*
600   ARENASETS: a meta-arena implementation which separates arena-info
601   into struct arena_set, which contains an array of struct
602   arena_descs, each holding info for a single arena.  By separating
603   the meta-info from the arena, we recover the 1st slot, formerly
604   borrowed for list management.  The arena_set is about the size of an
605   arena, avoiding the needless malloc overhead of a naive linked-list.
606 
607   The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
608   memory in the last arena-set (1/2 on average).  In trade, we get
609   back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
610   smaller types).  The recovery of the wasted space allows use of
611   small arenas for large, rare body types, by changing array* fields
612   in body_details_by_type[] below.
613 */
614 struct arena_desc {
615     char       *arena;		/* the raw storage, allocated aligned */
616     size_t      size;		/* its size ~4k typ */
617     svtype	utype;		/* bodytype stored in arena */
618 };
619 
620 struct arena_set;
621 
622 /* Get the maximum number of elements in set[] such that struct arena_set
623    will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
624    therefore likely to be 1 aligned memory page.  */
625 
626 #define ARENAS_PER_SET  ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
627                           - 2 * sizeof(int)) / sizeof (struct arena_desc))
628 
629 struct arena_set {
630     struct arena_set* next;
631     unsigned int   set_size;	/* ie ARENAS_PER_SET */
632     unsigned int   curr;	/* index of next available arena-desc */
633     struct arena_desc set[ARENAS_PER_SET];
634 };
635 
636 /*
637 =for apidoc sv_free_arenas
638 
639 Deallocate the memory used by all arenas.  Note that all the individual SV
640 heads and bodies within the arenas must already have been freed.
641 
642 =cut
643 
644 */
645 void
Perl_sv_free_arenas(pTHX)646 Perl_sv_free_arenas(pTHX)
647 {
648     SV* sva;
649     SV* svanext;
650     unsigned int i;
651 
652     /* Free arenas here, but be careful about fake ones.  (We assume
653        contiguity of the fake ones with the corresponding real ones.) */
654 
655     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
656         svanext = MUTABLE_SV(SvANY(sva));
657         while (svanext && SvFAKE(svanext))
658             svanext = MUTABLE_SV(SvANY(svanext));
659 
660         if (!SvFAKE(sva))
661             Safefree(sva);
662     }
663 
664     {
665         struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
666 
667         while (aroot) {
668             struct arena_set *current = aroot;
669             i = aroot->curr;
670             while (i--) {
671                 assert(aroot->set[i].arena);
672                 Safefree(aroot->set[i].arena);
673             }
674             aroot = aroot->next;
675             Safefree(current);
676         }
677     }
678     PL_body_arenas = 0;
679 
680     i = PERL_ARENA_ROOTS_SIZE;
681     while (i--)
682         PL_body_roots[i] = 0;
683 
684     PL_sv_arenaroot = 0;
685     PL_sv_root = 0;
686 }
687 
688 /*
689   Historically, here were mid-level routines that manage the
690   allocation of bodies out of the various arenas. Some of these
691   routines and related definitions remain here, but others were
692   moved into sv_inline.h to facilitate inlining of newSV_type().
693 
694   There are 4 kinds of arenas:
695 
696   1. SV-head arenas, which are discussed and handled above
697   2. regular body arenas
698   3. arenas for reduced-size bodies
699   4. Hash-Entry arenas
700 
701   Arena types 2 & 3 are chained by body-type off an array of
702   arena-root pointers, which is indexed by svtype.  Some of the
703   larger/less used body types are malloced singly, since a large
704   unused block of them is wasteful.  Also, several svtypes don't have
705   bodies; the data fits into the sv-head itself.  The arena-root
706   pointer thus has a few unused root-pointers (which may be hijacked
707   later for arena type 4)
708 
709   3 differs from 2 as an optimization; some body types have several
710   unused fields in the front of the structure (which are kept in-place
711   for consistency).  These bodies can be allocated in smaller chunks,
712   because the leading fields arent accessed.  Pointers to such bodies
713   are decremented to point at the unused 'ghost' memory, knowing that
714   the pointers are used with offsets to the real memory.
715 
716 Allocation of SV-bodies is similar to SV-heads, differing as follows;
717 the allocation mechanism is used for many body types, so is somewhat
718 more complicated, it uses arena-sets, and has no need for still-live
719 SV detection.
720 
721 At the outermost level, (new|del)_X*V macros return bodies of the
722 appropriate type.  These macros call either (new|del)_body_type or
723 (new|del)_body_allocated macro pairs, depending on specifics of the
724 type.  Most body types use the former pair, the latter pair is used to
725 allocate body types with "ghost fields".
726 
727 "ghost fields" are fields that are unused in certain types, and
728 consequently don't need to actually exist.  They are declared because
729 they're part of a "base type", which allows use of functions as
730 methods.  The simplest examples are AVs and HVs, 2 aggregate types
731 which don't use the fields which support SCALAR semantics.
732 
733 For these types, the arenas are carved up into appropriately sized
734 chunks, we thus avoid wasted memory for those unaccessed members.
735 When bodies are allocated, we adjust the pointer back in memory by the
736 size of the part not allocated, so it's as if we allocated the full
737 structure.  (But things will all go boom if you write to the part that
738 is "not there", because you'll be overwriting the last members of the
739 preceding structure in memory.)
740 
741 We calculate the correction using the STRUCT_OFFSET macro on the first
742 member present.  If the allocated structure is smaller (no initial NV
743 actually allocated) then the net effect is to subtract the size of the NV
744 from the pointer, to return a new pointer as if an initial NV were actually
745 allocated.  (We were using structures named *_allocated for this, but
746 this turned out to be a subtle bug, because a structure without an NV
747 could have a lower alignment constraint, but the compiler is allowed to
748 optimised accesses based on the alignment constraint of the actual pointer
749 to the full structure, for example, using a single 64 bit load instruction
750 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
751 
752 This is the same trick as was used for NV and IV bodies.  Ironically it
753 doesn't need to be used for NV bodies any more, because NV is now at
754 the start of the structure.  IV bodies, and also in some builds NV bodies,
755 don't need it either, because they are no longer allocated.
756 
757 In turn, the new_body_* allocators call S_new_body(), which invokes
758 new_body_from_arena macro, which takes a lock, and takes a body off the
759 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
760 necessary to refresh an empty list.  Then the lock is released, and
761 the body is returned.
762 
763 Perl_more_bodies allocates a new arena, and carves it up into an array of N
764 bodies, which it strings into a linked list.  It looks up arena-size
765 and body-size from the body_details table described below, thus
766 supporting the multiple body-types.
767 
768 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
769 the (new|del)_X*V macros are mapped directly to malloc/free.
770 
771 For each sv-type, struct body_details bodies_by_type[] carries
772 parameters which control these aspects of SV handling:
773 
774 Arena_size determines whether arenas are used for this body type, and if
775 so, how big they are.  PURIFY or PERL_ARENA_SIZE=0 set this field to
776 zero, forcing individual mallocs and frees.
777 
778 Body_size determines how big a body is, and therefore how many fit into
779 each arena.  Offset carries the body-pointer adjustment needed for
780 "ghost fields", and is used in *_allocated macros.
781 
782 But its main purpose is to parameterize info needed in
783 Perl_sv_upgrade().  The info here dramatically simplifies the function
784 vs the implementation in 5.8.8, making it table-driven.  All fields
785 are used for this, except for arena_size.
786 
787 For the sv-types that have no bodies, arenas are not used, so those
788 PL_body_roots[sv_type] are unused, and can be overloaded.  In
789 something of a special case, SVt_NULL is borrowed for HE arenas;
790 PL_body_roots[HE_ARENA_ROOT_IX=SVt_NULL] is filled by S_more_he, but the
791 bodies_by_type[SVt_NULL] slot is not used, as the table is not
792 available in hv.c. Similarly SVt_IV is re-used for HVAUX_ARENA_ROOT_IX.
793 
794 */
795 
796 /* return a thing to the free list */
797 
798 #define del_body(thing, root)				\
799     STMT_START {					\
800         void ** const thing_copy = (void **)thing;	\
801         *thing_copy = *root;				\
802         *root = (void*)thing_copy;			\
803     } STMT_END
804 
805 
806 void *
Perl_more_bodies(pTHX_ const svtype sv_type,const size_t body_size,const size_t arena_size)807 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
808                   const size_t arena_size)
809 {
810     void ** const root = &PL_body_roots[sv_type];
811     struct arena_desc *adesc;
812     struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
813     unsigned int curr;
814     char *start;
815     const char *end;
816     const size_t good_arena_size = Perl_malloc_good_size(arena_size);
817 #if defined(DEBUGGING)
818     static bool done_sanity_check;
819 
820     if (!done_sanity_check) {
821         unsigned int i = SVt_LAST;
822 
823         done_sanity_check = TRUE;
824 
825         while (i--)
826             assert (bodies_by_type[i].type == i);
827     }
828 #endif
829 
830     assert(arena_size);
831 
832     /* may need new arena-set to hold new arena */
833     if (!aroot || aroot->curr >= aroot->set_size) {
834         struct arena_set *newroot;
835         Newxz(newroot, 1, struct arena_set);
836         newroot->set_size = ARENAS_PER_SET;
837         newroot->next = aroot;
838         aroot = newroot;
839         PL_body_arenas = (void *) newroot;
840         DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
841     }
842 
843     /* ok, now have arena-set with at least 1 empty/available arena-desc */
844     curr = aroot->curr++;
845     adesc = &(aroot->set[curr]);
846     assert(!adesc->arena);
847 
848     Newx(adesc->arena, good_arena_size, char);
849     adesc->size = good_arena_size;
850     adesc->utype = sv_type;
851     DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %" UVuf "\n",
852                           curr, (void*)adesc->arena, (UV)good_arena_size));
853 
854     start = (char *) adesc->arena;
855 
856     /* Get the address of the byte after the end of the last body we can fit.
857        Remember, this is integer division:  */
858     end = start + good_arena_size / body_size * body_size;
859 
860     /* computed count doesn't reflect the 1st slot reservation */
861 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
862     DEBUG_m(PerlIO_printf(Perl_debug_log,
863                           "arena %p end %p arena-size %d (from %d) type %d "
864                           "size %d ct %d\n",
865                           (void*)start, (void*)end, (int)good_arena_size,
866                           (int)arena_size, sv_type, (int)body_size,
867                           (int)good_arena_size / (int)body_size));
868 #else
869     DEBUG_m(PerlIO_printf(Perl_debug_log,
870                           "arena %p end %p arena-size %d type %d size %d ct %d\n",
871                           (void*)start, (void*)end,
872                           (int)arena_size, sv_type, (int)body_size,
873                           (int)good_arena_size / (int)body_size));
874 #endif
875     *root = (void *)start;
876 
877     while (1) {
878         /* Where the next body would start:  */
879         char * const next = start + body_size;
880 
881         if (next >= end) {
882             /* This is the last body:  */
883             assert(next == end);
884 
885             *(void **)start = 0;
886             return *root;
887         }
888 
889         *(void**) start = (void *)next;
890         start = next;
891     }
892 }
893 
894 /*
895 =for apidoc sv_upgrade
896 
897 Upgrade an SV to a more complex form.  Generally adds a new body type to the
898 SV, then copies across as much information as possible from the old body.
899 It croaks if the SV is already in a more complex form than requested.  You
900 generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
901 before calling C<sv_upgrade>, and hence does not croak.  See also
902 C<L</svtype>>.
903 
904 =cut
905 */
906 
907 void
Perl_sv_upgrade(pTHX_ SV * const sv,svtype new_type)908 Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
909 {
910     void*	old_body;
911     void*	new_body;
912     const svtype old_type = SvTYPE(sv);
913     const struct body_details *new_type_details;
914     const struct body_details *old_type_details
915         = bodies_by_type + old_type;
916     SV *referent = NULL;
917 
918     PERL_ARGS_ASSERT_SV_UPGRADE;
919 
920     if (old_type == new_type)
921         return;
922 
923     /* This clause was purposefully added ahead of the early return above to
924        the shared string hackery for (sort {$a <=> $b} keys %hash), with the
925        inference by Nick I-S that it would fix other troublesome cases. See
926        changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
927 
928        Given that shared hash key scalars are no longer PVIV, but PV, there is
929        no longer need to unshare so as to free up the IVX slot for its proper
930        purpose. So it's safe to move the early return earlier.  */
931 
932     if (new_type > SVt_PVMG && SvIsCOW(sv)) {
933         sv_force_normal_flags(sv, 0);
934     }
935 
936     old_body = SvANY(sv);
937 
938     /* Copying structures onto other structures that have been neatly zeroed
939        has a subtle gotcha. Consider XPVMG
940 
941        +------+------+------+------+------+-------+-------+
942        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
943        +------+------+------+------+------+-------+-------+
944        0      4      8     12     16     20      24      28
945 
946        where NVs are aligned to 8 bytes, so that sizeof that structure is
947        actually 32 bytes long, with 4 bytes of padding at the end:
948 
949        +------+------+------+------+------+-------+-------+------+
950        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
951        +------+------+------+------+------+-------+-------+------+
952        0      4      8     12     16     20      24      28     32
953 
954        so what happens if you allocate memory for this structure:
955 
956        +------+------+------+------+------+-------+-------+------+------+...
957        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
958        +------+------+------+------+------+-------+-------+------+------+...
959        0      4      8     12     16     20      24      28     32     36
960 
961        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
962        expect, because you copy the area marked ??? onto GP. Now, ??? may have
963        started out as zero once, but it's quite possible that it isn't. So now,
964        rather than a nicely zeroed GP, you have it pointing somewhere random.
965        Bugs ensue.
966 
967        (In fact, GP ends up pointing at a previous GP structure, because the
968        principle cause of the padding in XPVMG getting garbage is a copy of
969        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
970        this happens to be moot because XPVGV has been re-ordered, with GP
971        no longer after STASH)
972 
973        So we are careful and work out the size of used parts of all the
974        structures.  */
975 
976     switch (old_type) {
977     case SVt_NULL:
978         break;
979     case SVt_IV:
980         if (SvROK(sv)) {
981             referent = SvRV(sv);
982             old_type_details = &fake_rv;
983             if (new_type == SVt_NV)
984                 new_type = SVt_PVNV;
985         } else {
986             if (new_type < SVt_PVIV) {
987                 new_type = (new_type == SVt_NV)
988                     ? SVt_PVNV : SVt_PVIV;
989             }
990         }
991         break;
992     case SVt_NV:
993         if (new_type < SVt_PVNV) {
994             new_type = SVt_PVNV;
995         }
996         break;
997     case SVt_PV:
998         assert(new_type > SVt_PV);
999         STATIC_ASSERT_STMT(SVt_IV < SVt_PV);
1000         STATIC_ASSERT_STMT(SVt_NV < SVt_PV);
1001         break;
1002     case SVt_PVIV:
1003         break;
1004     case SVt_PVNV:
1005         break;
1006     case SVt_PVMG:
1007         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1008            there's no way that it can be safely upgraded, because perl.c
1009            expects to Safefree(SvANY(PL_mess_sv))  */
1010         assert(sv != PL_mess_sv);
1011         break;
1012     default:
1013         if (UNLIKELY(old_type_details->cant_upgrade))
1014             Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1015                        sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1016     }
1017 
1018     if (UNLIKELY(old_type > new_type))
1019         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1020                 (int)old_type, (int)new_type);
1021 
1022     new_type_details = bodies_by_type + new_type;
1023 
1024     SvFLAGS(sv) &= ~SVTYPEMASK;
1025     SvFLAGS(sv) |= new_type;
1026 
1027     /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1028        the return statements above will have triggered.  */
1029     assert (new_type != SVt_NULL);
1030     switch (new_type) {
1031     case SVt_IV:
1032         assert(old_type == SVt_NULL);
1033         SET_SVANY_FOR_BODYLESS_IV(sv);
1034         SvIV_set(sv, 0);
1035         return;
1036     case SVt_NV:
1037         assert(old_type == SVt_NULL);
1038 #if NVSIZE <= IVSIZE
1039         SET_SVANY_FOR_BODYLESS_NV(sv);
1040 #else
1041         SvANY(sv) = new_XNV();
1042 #endif
1043         SvNV_set(sv, 0);
1044         return;
1045     case SVt_PVHV:
1046     case SVt_PVAV:
1047     case SVt_PVOBJ:
1048         assert(new_type_details->body_size);
1049 
1050 #ifndef PURIFY
1051         assert(new_type_details->arena);
1052         assert(new_type_details->arena_size);
1053         /* This points to the start of the allocated area.  */
1054         new_body = S_new_body(aTHX_ new_type);
1055         /* xpvav and xpvhv have no offset, so no need to adjust new_body */
1056         assert(!(new_type_details->offset));
1057 #else
1058         /* We always allocated the full length item with PURIFY. To do this
1059            we fake things so that arena is false for all 16 types..  */
1060         new_body = new_NOARENAZ(new_type_details);
1061 #endif
1062         SvANY(sv) = new_body;
1063         switch(new_type) {
1064         case SVt_PVAV:
1065             {
1066                 XPVAV pvav = {
1067                     .xmg_stash = NULL,
1068                     .xmg_u = {.xmg_magic = NULL},
1069                     .xav_fill = -1, .xav_max = -1, .xav_alloc = 0
1070                 };
1071                 *((XPVAV*) SvANY(sv)) = pvav;
1072             }
1073 
1074             AvREAL_only(sv);
1075             break;
1076         case SVt_PVHV:
1077             {
1078                 XPVHV pvhv = {
1079                     .xmg_stash = NULL,
1080                     .xmg_u = {.xmg_magic = NULL},
1081                     .xhv_keys = 0,
1082                     /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
1083                     .xhv_max = PERL_HASH_DEFAULT_HvMAX
1084                 };
1085                 *((XPVHV*) SvANY(sv)) = pvhv;
1086             }
1087 
1088             assert(!SvOK(sv));
1089             SvOK_off(sv);
1090 #ifndef NODEFAULT_SHAREKEYS
1091             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
1092 #endif
1093             break;
1094         case SVt_PVOBJ:
1095             {
1096                 XPVOBJ pvo = {
1097                     .xmg_stash = NULL, .xmg_u = {.xmg_magic = NULL},
1098                     .xobject_maxfield = -1,
1099                     .xobject_iter_sv_at = 0,
1100                     .xobject_fields = NULL,
1101                 };
1102                 *((XPVOBJ*) SvANY(sv)) = pvo;
1103             }
1104             break;
1105         default:
1106             NOT_REACHED;
1107         }
1108 
1109         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1110            The target created by newSVrv also is, and it can have magic.
1111            However, it never has SvPVX set.
1112         */
1113         if (old_type == SVt_IV) {
1114             assert(!SvROK(sv));
1115         } else if (old_type >= SVt_PV) {
1116             assert(SvPVX_const(sv) == 0);
1117         }
1118 
1119         if (old_type >= SVt_PVMG) {
1120             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1121             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1122         } else {
1123             sv->sv_u.svu_array = NULL; /* or svu_hash  */
1124         }
1125         break;
1126 
1127     case SVt_PVIV:
1128         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1129            no route from NV to PVIV, NOK can never be true  */
1130         assert(!SvNOKp(sv));
1131         assert(!SvNOK(sv));
1132         /* FALLTHROUGH */
1133     case SVt_PVIO:
1134     case SVt_PVFM:
1135     case SVt_PVGV:
1136     case SVt_PVCV:
1137     case SVt_PVLV:
1138     case SVt_INVLIST:
1139     case SVt_REGEXP:
1140     case SVt_PVMG:
1141     case SVt_PVNV:
1142     case SVt_PV:
1143 
1144         assert(new_type_details->body_size);
1145         /* We always allocated the full length item with PURIFY. To do this
1146            we fake things so that arena is false for all 16 types..  */
1147 #ifndef PURIFY
1148         if(new_type_details->arena) {
1149             /* This points to the start of the allocated area.  */
1150             new_body = S_new_body(aTHX_ new_type);
1151             Zero(new_body, new_type_details->body_size, char);
1152             new_body = ((char *)new_body) - new_type_details->offset;
1153         } else
1154 #endif
1155         {
1156             new_body = new_NOARENAZ(new_type_details);
1157         }
1158         SvANY(sv) = new_body;
1159 
1160         if (old_type_details->copy) {
1161             /* There is now the potential for an upgrade from something without
1162                an offset (PVNV or PVMG) to something with one (PVCV, PVFM)  */
1163             int offset = old_type_details->offset;
1164             int length = old_type_details->copy;
1165 
1166             if (new_type_details->offset > old_type_details->offset) {
1167                 const int difference
1168                     = new_type_details->offset - old_type_details->offset;
1169                 offset += difference;
1170                 length -= difference;
1171             }
1172             assert (length >= 0);
1173 
1174             Copy((char *)old_body + offset, (char *)new_body + offset, length,
1175                  char);
1176         }
1177 
1178 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1179         /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1180          * correct 0.0 for us.  Otherwise, if the old body didn't have an
1181          * NV slot, but the new one does, then we need to initialise the
1182          * freshly created NV slot with whatever the correct bit pattern is
1183          * for 0.0  */
1184         if (old_type_details->zero_nv && !new_type_details->zero_nv
1185             && !isGV_with_GP(sv))
1186             SvNV_set(sv, 0);
1187 #endif
1188 
1189         if (UNLIKELY(new_type == SVt_PVIO)) {
1190             IO * const io = MUTABLE_IO(sv);
1191             GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1192 
1193             SvOBJECT_on(io);
1194             /* Clear the stashcache because a new IO could overrule a package
1195                name */
1196             DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
1197             hv_clear(PL_stashcache);
1198 
1199             SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1200             IoPAGE_LEN(sv) = 60;
1201         }
1202         if (old_type < SVt_PV) {
1203             /* referent will be NULL unless the old type was SVt_IV emulating
1204                SVt_RV */
1205             sv->sv_u.svu_rv = referent;
1206         }
1207         break;
1208     default:
1209         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1210                    (unsigned long)new_type);
1211     }
1212 
1213     /* if this is zero, this is a body-less SVt_NULL, SVt_IV/SVt_RV,
1214        and sometimes SVt_NV */
1215     if (old_type_details->body_size) {
1216 #ifdef PURIFY
1217         safefree(old_body);
1218 #else
1219         /* Note that there is an assumption that all bodies of types that
1220            can be upgraded came from arenas. Only the more complex non-
1221            upgradable types are allowed to be directly malloc()ed.  */
1222         assert(old_type_details->arena);
1223         del_body((void*)((char*)old_body + old_type_details->offset),
1224                  &PL_body_roots[old_type]);
1225 #endif
1226     }
1227 }
1228 
1229 struct xpvhv_aux*
Perl_hv_auxalloc(pTHX_ HV * hv)1230 Perl_hv_auxalloc(pTHX_ HV *hv) {
1231     const struct body_details *old_type_details = bodies_by_type + SVt_PVHV;
1232     void *old_body;
1233     void *new_body;
1234 
1235     PERL_ARGS_ASSERT_HV_AUXALLOC;
1236     assert(SvTYPE(hv) == SVt_PVHV);
1237     assert(!HvHasAUX(hv));
1238 
1239 #ifdef PURIFY
1240     new_body = new_NOARENAZ(&fake_hv_with_aux);
1241 #else
1242     new_body_from_arena(new_body, HVAUX_ARENA_ROOT_IX, fake_hv_with_aux);
1243 #endif
1244 
1245     old_body = SvANY(hv);
1246 
1247     Copy((char *)old_body + old_type_details->offset,
1248          (char *)new_body + fake_hv_with_aux.offset,
1249          old_type_details->copy,
1250          char);
1251 
1252 #ifdef PURIFY
1253     safefree(old_body);
1254 #else
1255     assert(old_type_details->arena);
1256     del_body((void*)((char*)old_body + old_type_details->offset),
1257              &PL_body_roots[SVt_PVHV]);
1258 #endif
1259 
1260     SvANY(hv) = (XPVHV *) new_body;
1261     SvFLAGS(hv) |= SVphv_HasAUX;
1262     return HvAUX(hv);
1263 }
1264 
1265 /*
1266 =for apidoc sv_backoff
1267 
1268 Remove any string offset.  You should normally use the C<SvOOK_off> macro
1269 wrapper instead.
1270 
1271 =cut
1272 */
1273 
1274 /* prior to 5.000 stable, this function returned the new OOK-less SvFLAGS
1275    prior to 5.23.4 this function always returned 0
1276 */
1277 
1278 void
Perl_sv_backoff(SV * const sv)1279 Perl_sv_backoff(SV *const sv)
1280 {
1281     STRLEN delta;
1282     const char * const s = SvPVX_const(sv);
1283 
1284     PERL_ARGS_ASSERT_SV_BACKOFF;
1285 
1286     assert(SvOOK(sv));
1287     assert(SvTYPE(sv) != SVt_PVHV);
1288     assert(SvTYPE(sv) != SVt_PVAV);
1289 
1290     SvOOK_offset(sv, delta);
1291 
1292     SvLEN_set(sv, SvLEN(sv) + delta);
1293     SvPV_set(sv, SvPVX(sv) - delta);
1294     SvFLAGS(sv) &= ~SVf_OOK;
1295     Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1296     return;
1297 }
1298 
1299 
1300 /* forward declaration */
1301 static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
1302 
1303 
1304 /*
1305 =for apidoc sv_grow
1306 
1307 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1308 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1309 Use the C<SvGROW> wrapper instead.
1310 
1311 =cut
1312 */
1313 
1314 
1315 char *
Perl_sv_grow(pTHX_ SV * const sv,STRLEN newlen)1316 Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
1317 {
1318     char *s;
1319 
1320     PERL_ARGS_ASSERT_SV_GROW;
1321 
1322     if (SvROK(sv))
1323         sv_unref(sv);
1324     if (SvTYPE(sv) < SVt_PV) {
1325         sv_upgrade(sv, SVt_PV);
1326         s = SvPVX_mutable(sv);
1327     }
1328     else if (SvOOK(sv)) {	/* pv is offset? */
1329         sv_backoff(sv);
1330         s = SvPVX_mutable(sv);
1331         if (newlen > SvLEN(sv))
1332             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1333     }
1334     else
1335     {
1336         if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0);
1337         s = SvPVX_mutable(sv);
1338     }
1339 
1340 #ifdef PERL_COPY_ON_WRITE
1341     /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1342      * to store the COW count. So in general, allocate one more byte than
1343      * asked for, to make it likely this byte is always spare: and thus
1344      * make more strings COW-able.
1345      *
1346      * Only increment if the allocation isn't MEM_SIZE_MAX,
1347      * otherwise it will wrap to 0.
1348      */
1349     if ( newlen != MEM_SIZE_MAX )
1350         newlen++;
1351 #endif
1352 
1353 #if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size)
1354 #define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1355 #endif
1356 
1357     if (newlen > SvLEN(sv)) {		/* need more room? */
1358         STRLEN minlen = SvCUR(sv);
1359         minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + PERL_STRLEN_NEW_MIN;
1360         if (newlen < minlen)
1361             newlen = minlen;
1362 #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1363 
1364         /* Don't round up on the first allocation, as odds are pretty good that
1365          * the initial request is accurate as to what is really needed */
1366         if (SvLEN(sv)) {
1367             STRLEN rounded = PERL_STRLEN_ROUNDUP(newlen);
1368             if (rounded > newlen)
1369                 newlen = rounded;
1370         }
1371 #endif
1372         if (SvLEN(sv) && s) {
1373             s = (char*)saferealloc(s, newlen);
1374         }
1375         else {
1376             s = (char*)safemalloc(newlen);
1377             if (SvPVX_const(sv) && SvCUR(sv)) {
1378                 Move(SvPVX_const(sv), s, SvCUR(sv), char);
1379             }
1380         }
1381         SvPV_set(sv, s);
1382 #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1383         /* Do this here, do it once, do it right, and then we will never get
1384            called back into sv_grow() unless there really is some growing
1385            needed.  */
1386         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1387 #else
1388         SvLEN_set(sv, newlen);
1389 #endif
1390     }
1391     return s;
1392 }
1393 
1394 /*
1395 =for apidoc sv_grow_fresh
1396 
1397 A cut-down version of sv_grow intended only for when sv is a freshly-minted
1398 SVt_PV, SVt_PVIV, SVt_PVNV, or SVt_PVMG. i.e. sv has the default flags, has
1399 never been any other type, and does not have an existing string. Basically,
1400 just assigns a char buffer and returns a pointer to it.
1401 
1402 =cut
1403 */
1404 
1405 
1406 char *
Perl_sv_grow_fresh(pTHX_ SV * const sv,STRLEN newlen)1407 Perl_sv_grow_fresh(pTHX_ SV *const sv, STRLEN newlen)
1408 {
1409     char *s;
1410 
1411     PERL_ARGS_ASSERT_SV_GROW_FRESH;
1412 
1413     assert(SvTYPE(sv) >= SVt_PV && SvTYPE(sv) <= SVt_PVMG);
1414     assert(!SvROK(sv));
1415     assert(!SvOOK(sv));
1416     assert(!SvIsCOW(sv));
1417     assert(!SvLEN(sv));
1418     assert(!SvCUR(sv));
1419 
1420 #ifdef PERL_COPY_ON_WRITE
1421     /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1422      * to store the COW count. So in general, allocate one more byte than
1423      * asked for, to make it likely this byte is always spare: and thus
1424      * make more strings COW-able.
1425      *
1426      * Only increment if the allocation isn't MEM_SIZE_MAX,
1427      * otherwise it will wrap to 0.
1428      */
1429     if ( newlen != MEM_SIZE_MAX )
1430         newlen++;
1431 #endif
1432 
1433     if (newlen < PERL_STRLEN_NEW_MIN)
1434         newlen = PERL_STRLEN_NEW_MIN;
1435 
1436     s = (char*)safemalloc(newlen);
1437     SvPV_set(sv, s);
1438 
1439     /* No PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC here, since many strings */
1440     /* will never be grown once set. Let the real sv_grow worry about that. */
1441     SvLEN_set(sv, newlen);
1442     return s;
1443 }
1444 
1445 /*
1446 =for apidoc sv_setiv
1447 =for apidoc_item sv_setiv_mg
1448 
1449 These copy an integer into the given SV, upgrading first if necessary.
1450 
1451 They differ only in that C<sv_setiv_mg> handles 'set' magic; C<sv_setiv> does
1452 not.
1453 
1454 =cut
1455 */
1456 
1457 void
Perl_sv_setiv(pTHX_ SV * const sv,const IV i)1458 Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
1459 {
1460     PERL_ARGS_ASSERT_SV_SETIV;
1461 
1462     SV_CHECK_THINKFIRST_COW_DROP(sv);
1463     switch (SvTYPE(sv)) {
1464 #if NVSIZE <= IVSIZE
1465     case SVt_NULL:
1466     case SVt_NV:
1467         SET_SVANY_FOR_BODYLESS_IV(sv);
1468         SvFLAGS(sv) &= ~SVTYPEMASK;
1469         SvFLAGS(sv) |= SVt_IV;
1470         break;
1471 #else
1472     case SVt_NULL:
1473         SET_SVANY_FOR_BODYLESS_IV(sv);
1474         SvFLAGS(sv) &= ~SVTYPEMASK;
1475         SvFLAGS(sv) |= SVt_IV;
1476         break;
1477     case SVt_NV:
1478         sv_upgrade(sv, SVt_IV);
1479         break;
1480 #endif
1481     case SVt_PV:
1482         sv_upgrade(sv, SVt_PVIV);
1483         break;
1484 
1485     case SVt_PVGV:
1486         if (!isGV_with_GP(sv))
1487             break;
1488         /* FALLTHROUGH */
1489     case SVt_PVAV:
1490     case SVt_PVHV:
1491     case SVt_PVCV:
1492     case SVt_PVFM:
1493     case SVt_PVIO:
1494         /* diag_listed_as: Can't coerce %s to %s in %s */
1495         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1496                    OP_DESC(PL_op));
1497         NOT_REACHED; /* NOTREACHED */
1498         break;
1499     default: NOOP;
1500     }
1501     (void)SvIOK_only(sv);			/* validate number */
1502     SvIV_set(sv, i);
1503     SvTAINT(sv);
1504 }
1505 
1506 void
Perl_sv_setiv_mg(pTHX_ SV * const sv,const IV i)1507 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1508 {
1509     PERL_ARGS_ASSERT_SV_SETIV_MG;
1510 
1511     sv_setiv(sv,i);
1512     SvSETMAGIC(sv);
1513 }
1514 
1515 /*
1516 =for apidoc sv_setuv
1517 =for apidoc_item sv_setuv_mg
1518 
1519 These copy an unsigned integer into the given SV, upgrading first if necessary.
1520 
1521 
1522 They differ only in that C<sv_setuv_mg> handles 'set' magic; C<sv_setuv> does
1523 not.
1524 
1525 =cut
1526 */
1527 
1528 void
Perl_sv_setuv(pTHX_ SV * const sv,const UV u)1529 Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1530 {
1531     PERL_ARGS_ASSERT_SV_SETUV;
1532 
1533     /* With the if statement to ensure that integers are stored as IVs whenever
1534        possible:
1535        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1536 
1537        without
1538        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1539 
1540        If you wish to remove the following if statement, so that this routine
1541        (and its callers) always return UVs, please benchmark to see what the
1542        effect is. Modern CPUs may be different. Or may not :-)
1543     */
1544     if (u <= (UV)IV_MAX) {
1545        sv_setiv(sv, (IV)u);
1546        return;
1547     }
1548     sv_setiv(sv, 0);
1549     SvIsUV_on(sv);
1550     SvUV_set(sv, u);
1551 }
1552 
1553 void
Perl_sv_setuv_mg(pTHX_ SV * const sv,const UV u)1554 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1555 {
1556     PERL_ARGS_ASSERT_SV_SETUV_MG;
1557 
1558     sv_setuv(sv,u);
1559     SvSETMAGIC(sv);
1560 }
1561 
1562 /*
1563 =for apidoc sv_setnv
1564 =for apidoc_item sv_setnv_mg
1565 
1566 These copy a double into the given SV, upgrading first if necessary.
1567 
1568 They differ only in that C<sv_setnv_mg> handles 'set' magic; C<sv_setnv> does
1569 not.
1570 
1571 =cut
1572 */
1573 
1574 void
Perl_sv_setnv(pTHX_ SV * const sv,const NV num)1575 Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1576 {
1577     PERL_ARGS_ASSERT_SV_SETNV;
1578 
1579     SV_CHECK_THINKFIRST_COW_DROP(sv);
1580     switch (SvTYPE(sv)) {
1581     case SVt_NULL:
1582     case SVt_IV:
1583 #if NVSIZE <= IVSIZE
1584         SET_SVANY_FOR_BODYLESS_NV(sv);
1585         SvFLAGS(sv) &= ~SVTYPEMASK;
1586         SvFLAGS(sv) |= SVt_NV;
1587         break;
1588 #else
1589         sv_upgrade(sv, SVt_NV);
1590         break;
1591 #endif
1592     case SVt_PV:
1593     case SVt_PVIV:
1594         sv_upgrade(sv, SVt_PVNV);
1595         break;
1596 
1597     case SVt_PVGV:
1598         if (!isGV_with_GP(sv))
1599             break;
1600         /* FALLTHROUGH */
1601     case SVt_PVAV:
1602     case SVt_PVHV:
1603     case SVt_PVCV:
1604     case SVt_PVFM:
1605     case SVt_PVIO:
1606         /* diag_listed_as: Can't coerce %s to %s in %s */
1607         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1608                    OP_DESC(PL_op));
1609         NOT_REACHED; /* NOTREACHED */
1610         break;
1611     default: NOOP;
1612     }
1613     SvNV_set(sv, num);
1614     (void)SvNOK_only(sv);			/* validate number */
1615     SvTAINT(sv);
1616 }
1617 
1618 void
Perl_sv_setnv_mg(pTHX_ SV * const sv,const NV num)1619 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1620 {
1621     PERL_ARGS_ASSERT_SV_SETNV_MG;
1622 
1623     sv_setnv(sv,num);
1624     SvSETMAGIC(sv);
1625 }
1626 
1627 /*
1628 =for apidoc sv_setrv_noinc
1629 =for apidoc_item sv_setrv_noinc_mg
1630 
1631 Copies an SV pointer into the given SV as an SV reference, upgrading it if
1632 necessary. After this, C<SvRV(sv)> is equal to I<ref>. This does not adjust
1633 the reference count of I<ref>. The reference I<ref> must not be NULL.
1634 
1635 C<sv_setrv_noinc_mg> will invoke 'set' magic on the SV; C<sv_setrv_noinc> will
1636 not.
1637 
1638 =cut
1639 */
1640 
1641 void
Perl_sv_setrv_noinc(pTHX_ SV * const sv,SV * const ref)1642 Perl_sv_setrv_noinc(pTHX_ SV *const sv, SV *const ref)
1643 {
1644     PERL_ARGS_ASSERT_SV_SETRV_NOINC;
1645 
1646     SV_CHECK_THINKFIRST_COW_DROP(sv);
1647     prepare_SV_for_RV(sv);
1648 
1649     SvOK_off(sv);
1650     SvRV_set(sv, ref);
1651     SvROK_on(sv);
1652 }
1653 
1654 void
Perl_sv_setrv_noinc_mg(pTHX_ SV * const sv,SV * const ref)1655 Perl_sv_setrv_noinc_mg(pTHX_ SV *const sv, SV *const ref)
1656 {
1657     PERL_ARGS_ASSERT_SV_SETRV_NOINC_MG;
1658 
1659     sv_setrv_noinc(sv, ref);
1660     SvSETMAGIC(sv);
1661 }
1662 
1663 /*
1664 =for apidoc sv_setrv_inc
1665 =for apidoc_item sv_setrv_inc_mg
1666 
1667 As C<sv_setrv_noinc> but increments the reference count of I<ref>.
1668 
1669 C<sv_setrv_inc_mg> will invoke 'set' magic on the SV; C<sv_setrv_inc> will
1670 not.
1671 
1672 =cut
1673 */
1674 
1675 void
Perl_sv_setrv_inc(pTHX_ SV * const sv,SV * const ref)1676 Perl_sv_setrv_inc(pTHX_ SV *const sv, SV *const ref)
1677 {
1678     PERL_ARGS_ASSERT_SV_SETRV_INC;
1679 
1680     sv_setrv_noinc(sv, SvREFCNT_inc_simple_NN(ref));
1681 }
1682 
1683 void
Perl_sv_setrv_inc_mg(pTHX_ SV * const sv,SV * const ref)1684 Perl_sv_setrv_inc_mg(pTHX_ SV *const sv, SV *const ref)
1685 {
1686     PERL_ARGS_ASSERT_SV_SETRV_INC_MG;
1687 
1688     sv_setrv_noinc(sv, SvREFCNT_inc_simple_NN(ref));
1689     SvSETMAGIC(sv);
1690 }
1691 
1692 /* Return a cleaned-up, printable version of sv, for non-numeric, or
1693  * not incrementable warning display.
1694  * Originally part of S_not_a_number().
1695  * The return value may be != tmpbuf.
1696  */
1697 
1698 STATIC const char *
S_sv_display(pTHX_ SV * const sv,char * tmpbuf,STRLEN tmpbuf_size)1699 S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1700     const char *pv;
1701 
1702      PERL_ARGS_ASSERT_SV_DISPLAY;
1703 
1704      if (DO_UTF8(sv)) {
1705           SV *dsv = newSVpvs_flags("", SVs_TEMP);
1706           pv = sv_uni_display(dsv, sv, 32, UNI_DISPLAY_ISPRINT);
1707      } else {
1708           char *d = tmpbuf;
1709           const char * const limit = tmpbuf + tmpbuf_size - 8;
1710           /* each *s can expand to 4 chars + "...\0",
1711              i.e. need room for 8 chars */
1712 
1713           const char *s = SvPVX_const(sv);
1714           const char * const end = s + SvCUR(sv);
1715           for ( ; s < end && d < limit; s++ ) {
1716                int ch = (U8) *s;
1717                if (! isASCII(ch) && !isPRINT_LC(ch)) {
1718                     *d++ = 'M';
1719                     *d++ = '-';
1720 
1721                     /* Map to ASCII "equivalent" of Latin1 */
1722                     ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1723                }
1724                if (ch == '\n') {
1725                     *d++ = '\\';
1726                     *d++ = 'n';
1727                }
1728                else if (ch == '\r') {
1729                     *d++ = '\\';
1730                     *d++ = 'r';
1731                }
1732                else if (ch == '\f') {
1733                     *d++ = '\\';
1734                     *d++ = 'f';
1735                }
1736                else if (ch == '\\') {
1737                     *d++ = '\\';
1738                     *d++ = '\\';
1739                }
1740                else if (ch == '\0') {
1741                     *d++ = '\\';
1742                     *d++ = '0';
1743                }
1744                else if (isPRINT_LC(ch))
1745                     *d++ = ch;
1746                else {
1747                     *d++ = '^';
1748                     *d++ = toCTRL(ch);
1749                }
1750           }
1751           if (s < end) {
1752                *d++ = '.';
1753                *d++ = '.';
1754                *d++ = '.';
1755           }
1756           *d = '\0';
1757           pv = tmpbuf;
1758     }
1759 
1760     return pv;
1761 }
1762 
1763 /* Print an "isn't numeric" warning, using a cleaned-up,
1764  * printable version of the offending string
1765  */
1766 
1767 STATIC void
S_not_a_number(pTHX_ SV * const sv)1768 S_not_a_number(pTHX_ SV *const sv)
1769 {
1770      char tmpbuf[64];
1771      const char *pv;
1772 
1773      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1774 
1775      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1776 
1777     if (PL_op)
1778         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1779                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1780                     "Argument \"%s\" isn't numeric in %s", pv,
1781                     OP_DESC(PL_op));
1782     else
1783         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1784                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1785                     "Argument \"%s\" isn't numeric", pv);
1786 }
1787 
1788 STATIC void
S_not_incrementable(pTHX_ SV * const sv)1789 S_not_incrementable(pTHX_ SV *const sv) {
1790      char tmpbuf[64];
1791      const char *pv;
1792 
1793      PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1794 
1795      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1796 
1797      Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1798                  "Argument \"%s\" treated as 0 in increment (++)", pv);
1799 }
1800 
1801 /*
1802 =for apidoc looks_like_number
1803 
1804 Test if the content of an SV looks like a number (or is a number).
1805 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1806 non-numeric warning), even if your C<atof()> doesn't grok them.  Get-magic is
1807 ignored.
1808 
1809 =cut
1810 */
1811 
1812 I32
Perl_looks_like_number(pTHX_ SV * const sv)1813 Perl_looks_like_number(pTHX_ SV *const sv)
1814 {
1815     const char *sbegin;
1816     STRLEN len;
1817     int numtype;
1818 
1819     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1820 
1821     if (SvPOK(sv) || SvPOKp(sv)) {
1822         sbegin = SvPV_nomg_const(sv, len);
1823     }
1824     else
1825         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1826     numtype = grok_number(sbegin, len, NULL);
1827     return ((numtype & IS_NUMBER_TRAILING)) ? 0 : numtype;
1828 }
1829 
1830 STATIC bool
S_glob_2number(pTHX_ GV * const gv)1831 S_glob_2number(pTHX_ GV * const gv)
1832 {
1833     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1834 
1835     /* We know that all GVs stringify to something that is not-a-number,
1836         so no need to test that.  */
1837     if (ckWARN(WARN_NUMERIC))
1838     {
1839         SV *const buffer = sv_newmortal();
1840         gv_efullname3(buffer, gv, "*");
1841         not_a_number(buffer);
1842     }
1843     /* We just want something true to return, so that S_sv_2iuv_common
1844         can tail call us and return true.  */
1845     return TRUE;
1846 }
1847 
1848 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1849    until proven guilty, assume that things are not that bad... */
1850 
1851 /*
1852    NV_PRESERVES_UV:
1853 
1854    As 64 bit platforms often have an NV that doesn't preserve all bits of
1855    an IV (an assumption perl has been based on to date) it becomes necessary
1856    to remove the assumption that the NV always carries enough precision to
1857    recreate the IV whenever needed, and that the NV is the canonical form.
1858    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1859    precision as a side effect of conversion (which would lead to insanity
1860    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1861    1) to distinguish between IV/UV/NV slots that have a valid conversion cached
1862       where precision was lost, and IV/UV/NV slots that have a valid conversion
1863       which has lost no precision
1864    2) to ensure that if a numeric conversion to one form is requested that
1865       would lose precision, the precise conversion (or differently
1866       imprecise conversion) is also performed and cached, to prevent
1867       requests for different numeric formats on the same SV causing
1868       lossy conversion chains. (lossless conversion chains are perfectly
1869       acceptable (still))
1870 
1871 
1872    flags are used:
1873    SvIOKp is true if the IV slot contains a valid value
1874    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1875    SvNOKp is true if the NV slot contains a valid value
1876    SvNOK  is true only if the NV value is accurate
1877 
1878    so
1879    while converting from PV to NV, check to see if converting that NV to an
1880    IV(or UV) would lose accuracy over a direct conversion from PV to
1881    IV(or UV). If it would, cache both conversions, return NV, but mark
1882    SV as IOK NOKp (ie not NOK).
1883 
1884    While converting from PV to IV, check to see if converting that IV to an
1885    NV would lose accuracy over a direct conversion from PV to NV. If it
1886    would, cache both conversions, flag similarly.
1887 
1888    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1889    correctly because if IV & NV were set NV *always* overruled.
1890    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1891    changes - now IV and NV together means that the two are interchangeable:
1892    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1893 
1894    The benefit of this is that operations such as pp_add know that if
1895    SvIOK is true for both left and right operands, then integer addition
1896    can be used instead of floating point (for cases where the result won't
1897    overflow). Before, floating point was always used, which could lead to
1898    loss of precision compared with integer addition.
1899 
1900    * making IV and NV equal status should make maths accurate on 64 bit
1901      platforms
1902    * may speed up maths somewhat if pp_add and friends start to use
1903      integers when possible instead of fp. (Hopefully the overhead in
1904      looking for SvIOK and checking for overflow will not outweigh the
1905      fp to integer speedup)
1906    * will slow down integer operations (callers of SvIV) on "inaccurate"
1907      values, as the change from SvIOK to SvIOKp will cause a call into
1908      sv_2iv each time rather than a macro access direct to the IV slot
1909    * should speed up number->string conversion on integers as IV is
1910      favoured when IV and NV are equally accurate
1911 
1912    ####################################################################
1913    You had better be using SvIOK_notUV if you want an IV for arithmetic:
1914    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1915    On the other hand, SvUOK is true iff UV.
1916    ####################################################################
1917 
1918    Your mileage will vary depending your CPU's relative fp to integer
1919    performance ratio.
1920 */
1921 
1922 #ifndef NV_PRESERVES_UV
1923 #  define IS_NUMBER_UNDERFLOW_IV 1
1924 #  define IS_NUMBER_UNDERFLOW_UV 2
1925 #  define IS_NUMBER_IV_AND_UV    2
1926 #  define IS_NUMBER_OVERFLOW_IV  4
1927 #  define IS_NUMBER_OVERFLOW_UV  5
1928 
1929 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1930 
1931 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1932 STATIC int
S_sv_2iuv_non_preserve(pTHX_ SV * const sv,I32 numtype)1933 S_sv_2iuv_non_preserve(pTHX_ SV *const sv
1934 #  ifdef DEBUGGING
1935                        , I32 numtype
1936 #  endif
1937                        )
1938 {
1939     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1940     PERL_UNUSED_CONTEXT;
1941 
1942     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));
1943     if (SvNVX(sv) < (NV)IV_MIN) {
1944         (void)SvIOKp_on(sv);
1945         (void)SvNOK_on(sv);
1946         SvIV_set(sv, IV_MIN);
1947         return IS_NUMBER_UNDERFLOW_IV;
1948     }
1949     if (SvNVX(sv) > (NV)UV_MAX) {
1950         (void)SvIOKp_on(sv);
1951         (void)SvNOK_on(sv);
1952         SvIsUV_on(sv);
1953         SvUV_set(sv, UV_MAX);
1954         return IS_NUMBER_OVERFLOW_UV;
1955     }
1956     (void)SvIOKp_on(sv);
1957     (void)SvNOK_on(sv);
1958     /* Can't use strtol etc to convert this string.  (See truth table in
1959        sv_2iv  */
1960     if (SvNVX(sv) < IV_MAX_P1) {
1961         SvIV_set(sv, I_V(SvNVX(sv)));
1962         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1963             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1964         } else {
1965             /* Integer is imprecise. NOK, IOKp */
1966         }
1967         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1968     }
1969     SvIsUV_on(sv);
1970     SvUV_set(sv, U_V(SvNVX(sv)));
1971     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1972         if (SvUVX(sv) == UV_MAX) {
1973             /* As we know that NVs don't preserve UVs, UV_MAX cannot
1974                possibly be preserved by NV. Hence, it must be overflow.
1975                NOK, IOKp */
1976             return IS_NUMBER_OVERFLOW_UV;
1977         }
1978         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1979     } else {
1980         /* Integer is imprecise. NOK, IOKp */
1981     }
1982     return IS_NUMBER_OVERFLOW_IV;
1983 }
1984 #endif /* !NV_PRESERVES_UV*/
1985 
1986 /* If numtype is infnan, set the NV of the sv accordingly.
1987  * If numtype is anything else, try setting the NV using Atof(PV). */
1988 static void
S_sv_setnv(pTHX_ SV * sv,int numtype)1989 S_sv_setnv(pTHX_ SV* sv, int numtype)
1990 {
1991     bool pok = cBOOL(SvPOK(sv));
1992     bool nok = FALSE;
1993 #ifdef NV_INF
1994     if ((numtype & IS_NUMBER_INFINITY)) {
1995         SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
1996         nok = TRUE;
1997     } else
1998 #endif
1999 #ifdef NV_NAN
2000     if ((numtype & IS_NUMBER_NAN)) {
2001         SvNV_set(sv, NV_NAN);
2002         nok = TRUE;
2003     } else
2004 #endif
2005     if (pok) {
2006         SvNV_set(sv, Atof(SvPVX_const(sv)));
2007         /* Purposefully no true nok here, since we don't want to blow
2008          * away the possible IOK/UV of an existing sv. */
2009     }
2010     if (nok) {
2011         SvNOK_only(sv); /* No IV or UV please, this is pure infnan. */
2012         if (pok)
2013             SvPOK_on(sv); /* PV is okay, though. */
2014     }
2015 }
2016 
2017 STATIC bool
S_sv_2iuv_common(pTHX_ SV * const sv)2018 S_sv_2iuv_common(pTHX_ SV *const sv)
2019 {
2020     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2021 
2022     if (SvNOKp(sv)) {
2023         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2024          * without also getting a cached IV/UV from it at the same time
2025          * (ie PV->NV conversion should detect loss of accuracy and cache
2026          * IV or UV at same time to avoid this. */
2027         /* IV-over-UV optimisation - choose to cache IV if possible */
2028 
2029         if (SvTYPE(sv) == SVt_NV)
2030             sv_upgrade(sv, SVt_PVNV);
2031 
2032     got_nv:
2033         (void)SvIOKp_on(sv);	/* Must do this first, to clear any SvOOK */
2034         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2035            certainly cast into the IV range at IV_MAX, whereas the correct
2036            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2037            cases go to UV */
2038 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2039         if (Perl_isnan(SvNVX(sv))) {
2040             SvUV_set(sv, 0);
2041             SvIsUV_on(sv);
2042             return FALSE;
2043         }
2044 #endif
2045         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2046             SvIV_set(sv, I_V(SvNVX(sv)));
2047             if (SvNVX(sv) == (NV) SvIVX(sv)
2048 #ifndef NV_PRESERVES_UV
2049                 && SvIVX(sv) != IV_MIN /* avoid negating IV_MIN below */
2050                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2051                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2052                 /* Don't flag it as "accurately an integer" if the number
2053                    came from a (by definition imprecise) NV operation, and
2054                    we're outside the range of NV integer precision */
2055 #endif
2056                 ) {
2057                 if (SvNOK(sv))
2058                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2059                 else {
2060                     /* scalar has trailing garbage, eg "42a" */
2061                 }
2062                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2063                                       "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (precise)\n",
2064                                       PTR2UV(sv),
2065                                       SvNVX(sv),
2066                                       SvIVX(sv)));
2067 
2068             } else {
2069                 /* IV not precise.  No need to convert from PV, as NV
2070                    conversion would already have cached IV if it detected
2071                    that PV->IV would be better than PV->NV->IV
2072                    flags already correct - don't set public IOK.  */
2073                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2074                                       "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (imprecise)\n",
2075                                       PTR2UV(sv),
2076                                       SvNVX(sv),
2077                                       SvIVX(sv)));
2078             }
2079             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2080                but the cast (NV)IV_MIN rounds to a the value less (more
2081                negative) than IV_MIN which happens to be equal to SvNVX ??
2082                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2083                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2084                (NV)UVX == NVX are both true, but the values differ. :-(
2085                Hopefully for 2s complement IV_MIN is something like
2086                0x8000000000000000 which will be exact. NWC */
2087         }
2088         else {
2089             SvUV_set(sv, U_V(SvNVX(sv)));
2090             if (
2091                 (SvNVX(sv) == (NV) SvUVX(sv))
2092 #ifndef  NV_PRESERVES_UV
2093                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2094                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2095                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2096                 /* Don't flag it as "accurately an integer" if the number
2097                    came from a (by definition imprecise) NV operation, and
2098                    we're outside the range of NV integer precision */
2099 #endif
2100                 && SvNOK(sv)
2101                 )
2102                 SvIOK_on(sv);
2103             SvIsUV_on(sv);
2104             DEBUG_c(PerlIO_printf(Perl_debug_log,
2105                                   "0x%" UVxf " 2iv(%" UVuf " => %" IVdf ") (as unsigned)\n",
2106                                   PTR2UV(sv),
2107                                   SvUVX(sv),
2108                                   SvUVX(sv)));
2109         }
2110     }
2111     else if (SvPOKp(sv)) {
2112         UV value;
2113         int numtype;
2114         const char *s = SvPVX_const(sv);
2115         const STRLEN cur = SvCUR(sv);
2116 
2117         /* short-cut for a single digit string like "1" */
2118 
2119         if (cur == 1) {
2120             char c = *s;
2121             if (isDIGIT(c)) {
2122                 if (SvTYPE(sv) < SVt_PVIV)
2123                     sv_upgrade(sv, SVt_PVIV);
2124                 (void)SvIOK_on(sv);
2125                 SvIV_set(sv, (IV)(c - '0'));
2126                 return FALSE;
2127             }
2128         }
2129 
2130         numtype = grok_number(s, cur, &value);
2131         /* We want to avoid a possible problem when we cache an IV/ a UV which
2132            may be later translated to an NV, and the resulting NV is not
2133            the same as the direct translation of the initial string
2134            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2135            be careful to ensure that the value with the .456 is around if the
2136            NV value is requested in the future).
2137 
2138            This means that if we cache such an IV/a UV, we need to cache the
2139            NV as well.  Moreover, we trade speed for space, and do not
2140            cache the NV if we are sure it's not needed.
2141          */
2142 
2143         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2144         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2145              == IS_NUMBER_IN_UV) {
2146             /* It's definitely an integer, only upgrade to PVIV */
2147             if (SvTYPE(sv) < SVt_PVIV)
2148                 sv_upgrade(sv, SVt_PVIV);
2149             (void)SvIOK_on(sv);
2150         } else if (SvTYPE(sv) < SVt_PVNV)
2151             sv_upgrade(sv, SVt_PVNV);
2152 
2153         if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
2154             if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING)))
2155                 not_a_number(sv);
2156             S_sv_setnv(aTHX_ sv, numtype);
2157             goto got_nv;        /* Fill IV/UV slot and set IOKp */
2158         }
2159 
2160         /* If NVs preserve UVs then we only use the UV value if we know that
2161            we aren't going to call atof() below. If NVs don't preserve UVs
2162            then the value returned may have more precision than atof() will
2163            return, even though value isn't perfectly accurate.  */
2164         if ((numtype & (IS_NUMBER_IN_UV
2165 #ifdef NV_PRESERVES_UV
2166                         | IS_NUMBER_NOT_INT
2167 #endif
2168             )) == IS_NUMBER_IN_UV) {
2169             /* This won't turn off the public IOK flag if it was set above  */
2170             (void)SvIOKp_on(sv);
2171 
2172             if (!(numtype & IS_NUMBER_NEG)) {
2173                 /* positive */;
2174                 if (value <= (UV)IV_MAX) {
2175                     SvIV_set(sv, (IV)value);
2176                 } else {
2177                     /* it didn't overflow, and it was positive. */
2178                     SvUV_set(sv, value);
2179                     SvIsUV_on(sv);
2180                 }
2181             } else {
2182                 /* 2s complement assumption  */
2183                 if (value <= (UV)IV_MIN) {
2184                     SvIV_set(sv, value == (UV)IV_MIN
2185                                     ? IV_MIN : -(IV)value);
2186                 } else {
2187                     /* Too negative for an IV.  This is a double upgrade, but
2188                        I'm assuming it will be rare.  */
2189                     if (SvTYPE(sv) < SVt_PVNV)
2190                         sv_upgrade(sv, SVt_PVNV);
2191                     SvNOK_on(sv);
2192                     SvIOK_off(sv);
2193                     SvIOKp_on(sv);
2194                     SvNV_set(sv, -(NV)value);
2195                     SvIV_set(sv, IV_MIN);
2196                 }
2197             }
2198         }
2199         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2200            will be in the previous block to set the IV slot, and the next
2201            block to set the NV slot.  So no else here.  */
2202 
2203         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2204             != IS_NUMBER_IN_UV) {
2205             /* It wasn't an (integer that doesn't overflow the UV). */
2206             S_sv_setnv(aTHX_ sv, numtype);
2207 
2208             if (! numtype && ckWARN(WARN_NUMERIC))
2209                 not_a_number(sv);
2210 
2211             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" NVgf ")\n",
2212                                   PTR2UV(sv), SvNVX(sv)));
2213 
2214 #ifdef NV_PRESERVES_UV
2215             SvNOKp_on(sv);
2216             if (numtype)
2217                 SvNOK_on(sv);
2218             goto got_nv;        /* Fill IV/UV slot and set IOKp, maybe IOK */
2219 #else /* NV_PRESERVES_UV */
2220             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2221                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2222                 /* The IV/UV slot will have been set from value returned by
2223                    grok_number above.  The NV slot has just been set using
2224                    Atof.  */
2225                 SvNOK_on(sv);
2226                 assert (SvIOKp(sv));
2227             } else {
2228                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2229                     U_V(Perl_fabs(SvNVX(sv)))) {
2230                     /* Small enough to preserve all bits. */
2231                     (void)SvIOKp_on(sv);
2232                     SvNOK_on(sv);
2233                     SvIV_set(sv, I_V(SvNVX(sv)));
2234                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2235                         SvIOK_on(sv);
2236                     /* There had been runtime checking for
2237                        "U_V(Perl_fabs(SvNVX(sv))) < (UV)IV_MAX" here to ensure
2238                        that this NV is in the preserved range, but this should
2239                        be always true if the following assertion is true: */
2240                     STATIC_ASSERT_STMT(((UV)1 << NV_PRESERVES_UV_BITS) <=
2241                                        (UV)IV_MAX);
2242                 } else {
2243                     /* IN_UV NOT_INT
2244                          0      0	already failed to read UV.
2245                          0      1       already failed to read UV.
2246                          1      0       you won't get here in this case. IV/UV
2247                                         slot set, public IOK, Atof() unneeded.
2248                          1      1       already read UV.
2249                        so there's no point in sv_2iuv_non_preserve() attempting
2250                        to use atol, strtol, strtoul etc.  */
2251 #  ifdef DEBUGGING
2252                     sv_2iuv_non_preserve (sv, numtype);
2253 #  else
2254                     sv_2iuv_non_preserve (sv);
2255 #  endif
2256                 }
2257             }
2258         /* It might be more code efficient to go through the entire logic above
2259            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2260            gets complex and potentially buggy, so more programmer efficient
2261            to do it this way, by turning off the public flags:  */
2262         if (!numtype)
2263             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2264 #endif /* NV_PRESERVES_UV */
2265         }
2266     }
2267     else {
2268         if (isGV_with_GP(sv))
2269             return glob_2number(MUTABLE_GV(sv));
2270 
2271         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2272                 report_uninit(sv);
2273         if (SvTYPE(sv) < SVt_IV)
2274             /* Typically the caller expects that sv_any is not NULL now.  */
2275             sv_upgrade(sv, SVt_IV);
2276         /* Return 0 from the caller.  */
2277         return TRUE;
2278     }
2279     return FALSE;
2280 }
2281 
2282 /*
2283 =for apidoc sv_2iv_flags
2284 
2285 Return the integer value of an SV, doing any necessary string
2286 conversion.  If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2287 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2288 
2289 =cut
2290 */
2291 
2292 IV
Perl_sv_2iv_flags(pTHX_ SV * const sv,const I32 flags)2293 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2294 {
2295     PERL_ARGS_ASSERT_SV_2IV_FLAGS;
2296 
2297     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2298          && SvTYPE(sv) != SVt_PVFM);
2299 
2300     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2301         mg_get(sv);
2302 
2303     if (SvROK(sv)) {
2304         if (SvAMAGIC(sv)) {
2305             SV * tmpstr;
2306             if (flags & SV_SKIP_OVERLOAD)
2307                 return 0;
2308             tmpstr = AMG_CALLunary(sv, numer_amg);
2309             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2310                 return SvIV(tmpstr);
2311             }
2312         }
2313         return PTR2IV(SvRV(sv));
2314     }
2315 
2316     if (SvVALID(sv) || isREGEXP(sv)) {
2317         /* FBMs use the space for SvIVX and SvNVX for other purposes, so
2318            must not let them cache IVs.
2319            In practice they are extremely unlikely to actually get anywhere
2320            accessible by user Perl code - the only way that I'm aware of is when
2321            a constant subroutine which is used as the second argument to index.
2322 
2323            Regexps have no SvIVX and SvNVX fields.
2324         */
2325         assert(SvPOKp(sv));
2326         {
2327             UV value;
2328             const char * const ptr =
2329                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2330             const int numtype
2331                 = grok_number(ptr, SvCUR(sv), &value);
2332 
2333             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2334                 == IS_NUMBER_IN_UV) {
2335                 /* It's definitely an integer */
2336                 if (numtype & IS_NUMBER_NEG) {
2337                     if (value < (UV)IV_MIN)
2338                         return -(IV)value;
2339                 } else {
2340                     if (value < (UV)IV_MAX)
2341                         return (IV)value;
2342                 }
2343             }
2344 
2345             /* Quite wrong but no good choices. */
2346             if ((numtype & IS_NUMBER_INFINITY)) {
2347                 return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX;
2348             } else if ((numtype & IS_NUMBER_NAN)) {
2349                 return 0; /* So wrong. */
2350             }
2351 
2352             if (!numtype) {
2353                 if (ckWARN(WARN_NUMERIC))
2354                     not_a_number(sv);
2355             }
2356             return I_V(Atof(ptr));
2357         }
2358     }
2359 
2360     if (SvTHINKFIRST(sv)) {
2361         if (SvREADONLY(sv) && !SvOK(sv)) {
2362             if (ckWARN(WARN_UNINITIALIZED))
2363                 report_uninit(sv);
2364             return 0;
2365         }
2366     }
2367 
2368     if (!SvIOKp(sv)) {
2369         if (S_sv_2iuv_common(aTHX_ sv))
2370             return 0;
2371     }
2372 
2373     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" IVdf ")\n",
2374         PTR2UV(sv),SvIVX(sv)));
2375     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2376 }
2377 
2378 /*
2379 =for apidoc sv_2uv_flags
2380 
2381 Return the unsigned integer value of an SV, doing any necessary string
2382 conversion.  If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2383 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2384 
2385 =for apidoc Amnh||SV_GMAGIC
2386 
2387 =cut
2388 */
2389 
2390 UV
Perl_sv_2uv_flags(pTHX_ SV * const sv,const I32 flags)2391 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2392 {
2393     PERL_ARGS_ASSERT_SV_2UV_FLAGS;
2394 
2395     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2396         mg_get(sv);
2397 
2398     if (SvROK(sv)) {
2399         if (SvAMAGIC(sv)) {
2400             SV *tmpstr;
2401             if (flags & SV_SKIP_OVERLOAD)
2402                 return 0;
2403             tmpstr = AMG_CALLunary(sv, numer_amg);
2404             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2405                 return SvUV(tmpstr);
2406             }
2407         }
2408         return PTR2UV(SvRV(sv));
2409     }
2410 
2411     if (SvVALID(sv) || isREGEXP(sv)) {
2412         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2413            the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2414            Regexps have no SvIVX and SvNVX fields. */
2415         assert(SvPOKp(sv));
2416         {
2417             UV value;
2418             const char * const ptr =
2419                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2420             const int numtype
2421                 = grok_number(ptr, SvCUR(sv), &value);
2422 
2423             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2424                 == IS_NUMBER_IN_UV) {
2425                 /* It's definitely an integer */
2426                 if (!(numtype & IS_NUMBER_NEG))
2427                     return value;
2428             }
2429 
2430             /* Quite wrong but no good choices. */
2431             if ((numtype & IS_NUMBER_INFINITY)) {
2432                 return UV_MAX; /* So wrong. */
2433             } else if ((numtype & IS_NUMBER_NAN)) {
2434                 return 0; /* So wrong. */
2435             }
2436 
2437             if (!numtype) {
2438                 if (ckWARN(WARN_NUMERIC))
2439                     not_a_number(sv);
2440             }
2441             return U_V(Atof(ptr));
2442         }
2443     }
2444 
2445     if (SvTHINKFIRST(sv)) {
2446         if (SvREADONLY(sv) && !SvOK(sv)) {
2447             if (ckWARN(WARN_UNINITIALIZED))
2448                 report_uninit(sv);
2449             return 0;
2450         }
2451     }
2452 
2453     if (!SvIOKp(sv)) {
2454         if (S_sv_2iuv_common(aTHX_ sv))
2455             return 0;
2456     }
2457 
2458     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2uv(%" UVuf ")\n",
2459                           PTR2UV(sv),SvUVX(sv)));
2460     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2461 }
2462 
2463 /*
2464 =for apidoc sv_2nv_flags
2465 
2466 Return the num value of an SV, doing any necessary string or integer
2467 conversion.  If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first.
2468 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2469 
2470 =cut
2471 */
2472 
2473 NV
Perl_sv_2nv_flags(pTHX_ SV * const sv,const I32 flags)2474 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2475 {
2476     PERL_ARGS_ASSERT_SV_2NV_FLAGS;
2477 
2478     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2479          && SvTYPE(sv) != SVt_PVFM);
2480     if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
2481         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2482            the same flag bit as SVf_IVisUV, so must not let them cache NVs.
2483            Regexps have no SvIVX and SvNVX fields.  */
2484         const char *ptr;
2485         if (flags & SV_GMAGIC)
2486             mg_get(sv);
2487         if (SvNOKp(sv))
2488             return SvNVX(sv);
2489         if (SvPOKp(sv) && !SvIOKp(sv)) {
2490             ptr = SvPVX_const(sv);
2491             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2492                 !grok_number(ptr, SvCUR(sv), NULL))
2493                 not_a_number(sv);
2494             return Atof(ptr);
2495         }
2496         if (SvIOKp(sv)) {
2497             if (SvIsUV(sv))
2498                 return (NV)SvUVX(sv);
2499             else
2500                 return (NV)SvIVX(sv);
2501         }
2502         if (SvROK(sv)) {
2503             goto return_rok;
2504         }
2505         assert(SvTYPE(sv) >= SVt_PVMG);
2506         /* This falls through to the report_uninit near the end of the
2507            function. */
2508     } else if (SvTHINKFIRST(sv)) {
2509         if (SvROK(sv)) {
2510         return_rok:
2511             if (SvAMAGIC(sv)) {
2512                 SV *tmpstr;
2513                 if (flags & SV_SKIP_OVERLOAD)
2514                     return 0;
2515                 tmpstr = AMG_CALLunary(sv, numer_amg);
2516                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2517                     return SvNV(tmpstr);
2518                 }
2519             }
2520             return PTR2NV(SvRV(sv));
2521         }
2522         if (SvREADONLY(sv) && !SvOK(sv)) {
2523             if (ckWARN(WARN_UNINITIALIZED))
2524                 report_uninit(sv);
2525             return 0.0;
2526         }
2527     }
2528     if (SvTYPE(sv) < SVt_NV) {
2529         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2530         sv_upgrade(sv, SVt_NV);
2531         CLANG_DIAG_IGNORE_STMT(-Wthread-safety);
2532         DEBUG_c({
2533             DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2534             STORE_LC_NUMERIC_SET_STANDARD();
2535             PerlIO_printf(Perl_debug_log,
2536                           "0x%" UVxf " num(%" NVgf ")\n",
2537                           PTR2UV(sv), SvNVX(sv));
2538             RESTORE_LC_NUMERIC();
2539         });
2540         CLANG_DIAG_RESTORE_STMT;
2541 
2542     }
2543     else if (SvTYPE(sv) < SVt_PVNV)
2544         sv_upgrade(sv, SVt_PVNV);
2545     if (SvNOKp(sv)) {
2546         return SvNVX(sv);
2547     }
2548     if (SvIOKp(sv)) {
2549         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2550 #ifdef NV_PRESERVES_UV
2551         if (SvIOK(sv))
2552             SvNOK_on(sv);
2553         else
2554             SvNOKp_on(sv);
2555 #else
2556         /* Only set the public NV OK flag if this NV preserves the IV  */
2557         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2558         if (SvIOK(sv) &&
2559             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2560                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2561             SvNOK_on(sv);
2562         else
2563             SvNOKp_on(sv);
2564 #endif
2565     }
2566     else if (SvPOKp(sv)) {
2567         UV value;
2568         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2569         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2570             not_a_number(sv);
2571 #ifdef NV_PRESERVES_UV
2572         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2573             == IS_NUMBER_IN_UV) {
2574             /* It's definitely an integer */
2575             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2576         } else {
2577             S_sv_setnv(aTHX_ sv, numtype);
2578         }
2579         if (numtype)
2580             SvNOK_on(sv);
2581         else
2582             SvNOKp_on(sv);
2583 #else
2584         SvNV_set(sv, Atof(SvPVX_const(sv)));
2585         /* Only set the public NV OK flag if this NV preserves the value in
2586            the PV at least as well as an IV/UV would.
2587            Not sure how to do this 100% reliably. */
2588         /* if that shift count is out of range then Configure's test is
2589            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2590            UV_BITS */
2591         if (((UV)1 << NV_PRESERVES_UV_BITS) > U_V(Perl_fabs(SvNVX(sv)))) {
2592             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2593         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2594             /* Can't use strtol etc to convert this string, so don't try.
2595                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2596             SvNOK_on(sv);
2597         } else {
2598             /* value has been set.  It may not be precise.  */
2599             if ((numtype & IS_NUMBER_NEG) && (value >= (UV)IV_MIN)) {
2600                 /* 2s complement assumption for (UV)IV_MIN  */
2601                 SvNOK_on(sv); /* Integer is too negative.  */
2602             } else {
2603                 SvNOKp_on(sv);
2604                 SvIOKp_on(sv);
2605 
2606                 if (numtype & IS_NUMBER_NEG) {
2607                     /* -IV_MIN is undefined, but we should never reach
2608                      * this point with both IS_NUMBER_NEG and value ==
2609                      * (UV)IV_MIN */
2610                     assert(value != (UV)IV_MIN);
2611                     SvIV_set(sv, -(IV)value);
2612                 } else if (value <= (UV)IV_MAX) {
2613                     SvIV_set(sv, (IV)value);
2614                 } else {
2615                     SvUV_set(sv, value);
2616                     SvIsUV_on(sv);
2617                 }
2618 
2619                 if (numtype & IS_NUMBER_NOT_INT) {
2620                     /* I believe that even if the original PV had decimals,
2621                        they are lost beyond the limit of the FP precision.
2622                        However, neither is canonical, so both only get p
2623                        flags.  NWC, 2000/11/25 */
2624                     /* Both already have p flags, so do nothing */
2625                 } else {
2626                     const NV nv = SvNVX(sv);
2627                     /* XXX should this spot have NAN_COMPARE_BROKEN, too? */
2628                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2629                         if (SvIVX(sv) == I_V(nv)) {
2630                             SvNOK_on(sv);
2631                         } else {
2632                             /* It had no "." so it must be integer.  */
2633                         }
2634                         SvIOK_on(sv);
2635                     } else {
2636                         /* between IV_MAX and NV(UV_MAX).
2637                            Could be slightly > UV_MAX */
2638 
2639                         if (numtype & IS_NUMBER_NOT_INT) {
2640                             /* UV and NV both imprecise.  */
2641                         } else {
2642                             const UV nv_as_uv = U_V(nv);
2643 
2644                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2645                                 SvNOK_on(sv);
2646                             }
2647                             SvIOK_on(sv);
2648                         }
2649                     }
2650                 }
2651             }
2652         }
2653         /* It might be more code efficient to go through the entire logic above
2654            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2655            gets complex and potentially buggy, so more programmer efficient
2656            to do it this way, by turning off the public flags:  */
2657         if (!numtype)
2658             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2659 #endif /* NV_PRESERVES_UV */
2660     }
2661     else {
2662         if (isGV_with_GP(sv)) {
2663             glob_2number(MUTABLE_GV(sv));
2664             return 0.0;
2665         }
2666 
2667         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2668             report_uninit(sv);
2669         assert (SvTYPE(sv) >= SVt_NV);
2670         /* Typically the caller expects that sv_any is not NULL now.  */
2671         /* XXX Ilya implies that this is a bug in callers that assume this
2672            and ideally should be fixed.  */
2673         return 0.0;
2674     }
2675     CLANG_DIAG_IGNORE_STMT(-Wthread-safety);
2676     DEBUG_c({
2677         DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2678         STORE_LC_NUMERIC_SET_STANDARD();
2679         PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2nv(%" NVgf ")\n",
2680                       PTR2UV(sv), SvNVX(sv));
2681         RESTORE_LC_NUMERIC();
2682     });
2683     CLANG_DIAG_RESTORE_STMT;
2684     return SvNVX(sv);
2685 }
2686 
2687 /*
2688 =for apidoc sv_2num
2689 
2690 Return an SV with the numeric value of the source SV, doing any necessary
2691 reference or overload conversion.  The caller is expected to have handled
2692 get-magic already.
2693 
2694 =cut
2695 */
2696 
2697 SV *
Perl_sv_2num(pTHX_ SV * const sv)2698 Perl_sv_2num(pTHX_ SV *const sv)
2699 {
2700     PERL_ARGS_ASSERT_SV_2NUM;
2701 
2702     if (!SvROK(sv))
2703         return sv;
2704     if (SvAMAGIC(sv)) {
2705         SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2706         TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2707         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2708             return sv_2num(tmpsv);
2709     }
2710     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2711 }
2712 
2713 /* int2str_table: lookup table containing string representations of all
2714  * two digit numbers. For example, int2str_table.arr[0] is "00" and
2715  * int2str_table.arr[12*2] is "12".
2716  *
2717  * We are going to read two bytes at a time, so we have to ensure that
2718  * the array is aligned to a 2 byte boundary. That's why it was made a
2719  * union with a dummy U16 member. */
2720 static const union {
2721     char arr[200];
2722     U16 dummy;
2723 } int2str_table = {{
2724     '0', '0', '0', '1', '0', '2', '0', '3', '0', '4', '0', '5', '0', '6',
2725     '0', '7', '0', '8', '0', '9', '1', '0', '1', '1', '1', '2', '1', '3',
2726     '1', '4', '1', '5', '1', '6', '1', '7', '1', '8', '1', '9', '2', '0',
2727     '2', '1', '2', '2', '2', '3', '2', '4', '2', '5', '2', '6', '2', '7',
2728     '2', '8', '2', '9', '3', '0', '3', '1', '3', '2', '3', '3', '3', '4',
2729     '3', '5', '3', '6', '3', '7', '3', '8', '3', '9', '4', '0', '4', '1',
2730     '4', '2', '4', '3', '4', '4', '4', '5', '4', '6', '4', '7', '4', '8',
2731     '4', '9', '5', '0', '5', '1', '5', '2', '5', '3', '5', '4', '5', '5',
2732     '5', '6', '5', '7', '5', '8', '5', '9', '6', '0', '6', '1', '6', '2',
2733     '6', '3', '6', '4', '6', '5', '6', '6', '6', '7', '6', '8', '6', '9',
2734     '7', '0', '7', '1', '7', '2', '7', '3', '7', '4', '7', '5', '7', '6',
2735     '7', '7', '7', '8', '7', '9', '8', '0', '8', '1', '8', '2', '8', '3',
2736     '8', '4', '8', '5', '8', '6', '8', '7', '8', '8', '8', '9', '9', '0',
2737     '9', '1', '9', '2', '9', '3', '9', '4', '9', '5', '9', '6', '9', '7',
2738     '9', '8', '9', '9'
2739 }};
2740 
2741 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2742  * UV as a string towards the end of buf, and return pointers to start and
2743  * end of it.
2744  *
2745  * We assume that buf is at least TYPE_CHARS(UV) long.
2746  */
2747 
2748 PERL_STATIC_INLINE char *
S_uiv_2buf(char * const buf,const IV iv,UV uv,const int is_uv,char ** const peob)2749 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2750 {
2751     char *ptr = buf + TYPE_CHARS(UV);
2752     char * const ebuf = ptr;
2753     int sign;
2754     U16 *word_ptr, *word_table;
2755 
2756     PERL_ARGS_ASSERT_UIV_2BUF;
2757 
2758     /* ptr has to be properly aligned, because we will cast it to U16* */
2759     assert(PTR2nat(ptr) % 2 == 0);
2760     /* we are going to read/write two bytes at a time */
2761     word_ptr = (U16*)ptr;
2762     word_table = (U16*)int2str_table.arr;
2763 
2764     if (UNLIKELY(is_uv))
2765         sign = 0;
2766     else if (iv >= 0) {
2767         uv = iv;
2768         sign = 0;
2769     } else {
2770         /* Using 0- here to silence bogus warning from MS VC */
2771         uv = (UV) (0 - (UV) iv);
2772         sign = 1;
2773     }
2774 
2775     while (uv > 99) {
2776         *--word_ptr = word_table[uv % 100];
2777         uv /= 100;
2778     }
2779     ptr = (char*)word_ptr;
2780 
2781     if (uv < 10)
2782         *--ptr = (char)uv + '0';
2783     else {
2784         *--word_ptr = word_table[uv];
2785         ptr = (char*)word_ptr;
2786     }
2787 
2788     if (sign)
2789         *--ptr = '-';
2790 
2791     *peob = ebuf;
2792     return ptr;
2793 }
2794 
2795 /* Helper for sv_2pv_flags and sv_vcatpvfn_flags.  If the NV is an
2796  * infinity or a not-a-number, writes the appropriate strings to the
2797  * buffer, including a zero byte.  On success returns the written length,
2798  * excluding the zero byte, on failure (not an infinity, not a nan)
2799  * returns zero, assert-fails on maxlen being too short.
2800  *
2801  * XXX for "Inf", "-Inf", and "NaN", we could have three read-only
2802  * shared string constants we point to, instead of generating a new
2803  * string for each instance. */
2804 STATIC size_t
S_infnan_2pv(NV nv,char * buffer,size_t maxlen,char plus)2805 S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char plus) {
2806     char* s = buffer;
2807     assert(maxlen >= 4);
2808     if (Perl_isinf(nv)) {
2809         if (nv < 0) {
2810             if (maxlen < 5) /* "-Inf\0"  */
2811                 return 0;
2812             *s++ = '-';
2813         } else if (plus) {
2814             *s++ = '+';
2815         }
2816         *s++ = 'I';
2817         *s++ = 'n';
2818         *s++ = 'f';
2819     }
2820     else if (Perl_isnan(nv)) {
2821         *s++ = 'N';
2822         *s++ = 'a';
2823         *s++ = 'N';
2824         /* XXX optionally output the payload mantissa bits as
2825          * "(unsigned)" (to match the nan("...") C99 function,
2826          * or maybe as "(0xhhh...)"  would make more sense...
2827          * provide a format string so that the user can decide?
2828          * NOTE: would affect the maxlen and assert() logic.*/
2829     }
2830     else {
2831       return 0;
2832     }
2833     assert((s == buffer + 3) || (s == buffer + 4));
2834     *s = 0;
2835     return s - buffer;
2836 }
2837 
2838 /*
2839 =for apidoc      sv_2pv
2840 =for apidoc_item sv_2pv_flags
2841 
2842 These implement the various forms of the L<perlapi/C<SvPV>> macros.
2843 The macros are the preferred interface.
2844 
2845 These return a pointer to the string value of an SV (coercing it to a string if
2846 necessary), and set C<*lp> to its length in bytes.
2847 
2848 The forms differ in that plain C<sv_2pvbyte> always processes 'get' magic; and
2849 C<sv_2pvbyte_flags> processes 'get' magic if and only if C<flags> contains
2850 C<SV_GMAGIC>.
2851 
2852 =for apidoc Amnh||SV_GMAGIC
2853 
2854 =cut
2855 */
2856 
2857 char *
Perl_sv_2pv_flags(pTHX_ SV * const sv,STRLEN * const lp,const U32 flags)2858 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const U32 flags)
2859 {
2860     char *s;
2861     bool done_gmagic = FALSE;
2862 
2863     PERL_ARGS_ASSERT_SV_2PV_FLAGS;
2864 
2865     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2866          && SvTYPE(sv) != SVt_PVFM);
2867     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) {
2868         mg_get(sv);
2869         done_gmagic = TRUE;
2870     }
2871 
2872     if (SvROK(sv)) {
2873         if (SvAMAGIC(sv)) {
2874             SV *tmpstr;
2875             SV *nsv= (SV *)sv;
2876             if (flags & SV_SKIP_OVERLOAD)
2877                 return NULL;
2878             if (done_gmagic)
2879                 nsv = sv_mortalcopy_flags(sv,0);
2880             tmpstr = AMG_CALLunary(nsv, string_amg);
2881             TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2882             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(nsv)))) {
2883                 /* Unwrap this:  */
2884                 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2885                  */
2886 
2887                 char *pv;
2888                 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2889                     if (flags & SV_CONST_RETURN) {
2890                         pv = (char *) SvPVX_const(tmpstr);
2891                     } else {
2892                         pv = (flags & SV_MUTABLE_RETURN)
2893                             ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2894                     }
2895                     if (lp)
2896                         *lp = SvCUR(tmpstr);
2897                 } else {
2898                     pv = sv_2pv_flags(tmpstr, lp, flags);
2899                 }
2900                 if (SvUTF8(tmpstr))
2901                     SvUTF8_on(sv);
2902                 else
2903                     SvUTF8_off(sv);
2904                 return pv;
2905             }
2906         }
2907         {
2908             STRLEN len;
2909             char *retval;
2910             char *buffer;
2911             SV *const referent = SvRV(sv);
2912 
2913             if (!referent) {
2914                 len = 7;
2915                 retval = buffer = savepvn("NULLREF", len);
2916             } else if (SvTYPE(referent) == SVt_REGEXP &&
2917                        (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
2918                         amagic_is_enabled(string_amg))) {
2919                 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2920 
2921                 assert(re);
2922 
2923                 /* If the regex is UTF-8 we want the containing scalar to
2924                    have an UTF-8 flag too */
2925                 if (RX_UTF8(re))
2926                     SvUTF8_on(sv);
2927                 else
2928                     SvUTF8_off(sv);
2929 
2930                 if (lp)
2931                     *lp = RX_WRAPLEN(re);
2932 
2933                 return RX_WRAPPED(re);
2934             } else {
2935                 const char *const typestring = sv_reftype(referent, 0);
2936                 const STRLEN typelen = strlen(typestring);
2937                 UV addr = PTR2UV(referent);
2938                 const char *stashname = NULL;
2939                 STRLEN stashnamelen = 0; /* hush, gcc */
2940                 const char *buffer_end;
2941 
2942                 if (SvOBJECT(referent)) {
2943                     const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2944 
2945                     if (name) {
2946                         stashname = HEK_KEY(name);
2947                         stashnamelen = HEK_LEN(name);
2948 
2949                         if (HEK_UTF8(name)) {
2950                             SvUTF8_on(sv);
2951                         } else {
2952                             SvUTF8_off(sv);
2953                         }
2954                     } else {
2955                         stashname = "__ANON__";
2956                         stashnamelen = 8;
2957                     }
2958                     len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2959                         + 2 * sizeof(UV) + 2 /* )\0 */;
2960                 } else {
2961                     len = typelen + 3 /* (0x */
2962                         + 2 * sizeof(UV) + 2 /* )\0 */;
2963                 }
2964 
2965                 Newx(buffer, len, char);
2966                 buffer_end = retval = buffer + len;
2967 
2968                 /* Working backwards  */
2969                 *--retval = '\0';
2970                 *--retval = ')';
2971                 do {
2972                     *--retval = PL_hexdigit[addr & 15];
2973                 } while (addr >>= 4);
2974                 *--retval = 'x';
2975                 *--retval = '0';
2976                 *--retval = '(';
2977 
2978                 retval -= typelen;
2979                 memcpy(retval, typestring, typelen);
2980 
2981                 if (stashname) {
2982                     *--retval = '=';
2983                     retval -= stashnamelen;
2984                     memcpy(retval, stashname, stashnamelen);
2985                 }
2986                 /* retval may not necessarily have reached the start of the
2987                    buffer here.  */
2988                 assert (retval >= buffer);
2989 
2990                 len = buffer_end - retval - 1; /* -1 for that \0  */
2991             }
2992             if (lp)
2993                 *lp = len;
2994             SAVEFREEPV(buffer);
2995             return retval;
2996         }
2997     }
2998 
2999     if (SvPOKp(sv)) {
3000         if (lp)
3001             *lp = SvCUR(sv);
3002         if (flags & SV_MUTABLE_RETURN)
3003             return SvPVX_mutable(sv);
3004         if (flags & SV_CONST_RETURN)
3005             return (char *)SvPVX_const(sv);
3006         return SvPVX(sv);
3007     }
3008 
3009     if (SvIOK(sv)) {
3010         /* I'm assuming that if both IV and NV are equally valid then
3011            converting the IV is going to be more efficient */
3012         const U32 isUIOK = SvIsUV(sv);
3013         /* The purpose of this union is to ensure that arr is aligned on
3014            a 2 byte boundary, because that is what uiv_2buf() requires */
3015         union {
3016             char arr[TYPE_CHARS(UV)];
3017             U16 dummy;
3018         } buf;
3019         char *ebuf, *ptr;
3020         STRLEN len;
3021 
3022         if (SvTYPE(sv) < SVt_PVIV)
3023             sv_upgrade(sv, SVt_PVIV);
3024         ptr = uiv_2buf(buf.arr, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
3025         len = ebuf - ptr;
3026         /* inlined from sv_setpvn */
3027         s = SvGROW_mutable(sv, len + 1);
3028         Move(ptr, s, len, char);
3029         s += len;
3030         *s = '\0';
3031         /* We used to call SvPOK_on(). Whilst this is fine for (most) Perl code,
3032            it means that after this stringification is cached, there is no way
3033            to distinguish between values originally assigned as $a = 42; and
3034            $a = "42"; (or results of string operators vs numeric operators)
3035            where the value has subsequently been used in the other sense
3036            and had a value cached.
3037            This (somewhat) hack means that we retain the cached stringification,
3038            but don't set SVf_POK. Hence if a value is SVf_IOK|SVf_POK then it
3039            originated as "42", whereas if it's SVf_IOK then it originated as 42.
3040            (ignore SVp_IOK and SVp_POK)
3041            The SvPV macros are now updated to recognise this specific case
3042            (and that there isn't overloading or magic that could alter the
3043            cached value) and so return the cached value immediately without
3044            re-entering this function, getting back here to this block of code,
3045            and repeating the same conversion. */
3046         SvPOKp_on(sv);
3047     }
3048     else if (SvNOK(sv)) {
3049         if (SvTYPE(sv) < SVt_PVNV)
3050             sv_upgrade(sv, SVt_PVNV);
3051         if (SvNVX(sv) == 0.0
3052 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3053             && !Perl_isnan(SvNVX(sv))
3054 #endif
3055         ) {
3056             s = SvGROW_mutable(sv, 2);
3057             *s++ = '0';
3058             *s = '\0';
3059         } else {
3060             STRLEN len;
3061             STRLEN size = 5; /* "-Inf\0" */
3062 
3063             s = SvGROW_mutable(sv, size);
3064             len = S_infnan_2pv(SvNVX(sv), s, size, 0);
3065             if (len > 0) {
3066                 s += len;
3067                 SvPOKp_on(sv);
3068             }
3069             else {
3070                 /* some Xenix systems wipe out errno here */
3071                 dSAVE_ERRNO;
3072 
3073                 size =
3074                     1 + /* sign */
3075                     1 + /* "." */
3076                     NV_DIG +
3077                     1 + /* "e" */
3078                     1 + /* sign */
3079                     5 + /* exponent digits */
3080                     1 + /* \0 */
3081                     2; /* paranoia */
3082 
3083                 s = SvGROW_mutable(sv, size);
3084 #ifndef USE_LOCALE_NUMERIC
3085                 SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3086 
3087                 SvPOKp_on(sv);
3088 #else
3089                 {
3090                     bool local_radix;
3091                     DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3092                     STORE_LC_NUMERIC_SET_TO_NEEDED();
3093 
3094                     local_radix = NOT_IN_NUMERIC_STANDARD_;
3095                     if (local_radix && SvCUR(PL_numeric_radix_sv) > 1) {
3096                         size += SvCUR(PL_numeric_radix_sv) - 1;
3097                         s = SvGROW_mutable(sv, size);
3098                     }
3099 
3100                     SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG);
3101 
3102                     /* If the radix character is UTF-8, and actually is in the
3103                      * output, turn on the UTF-8 flag for the scalar */
3104                     if (   local_radix
3105                         && SvUTF8(PL_numeric_radix_sv)
3106                         && instr(s, SvPVX_const(PL_numeric_radix_sv)))
3107                     {
3108                         SvUTF8_on(sv);
3109                     }
3110 
3111                     RESTORE_LC_NUMERIC();
3112                 }
3113 
3114                 /* We don't call SvPOK_on(), because it may come to
3115                  * pass that the locale changes so that the
3116                  * stringification we just did is no longer correct.  We
3117                  * will have to re-stringify every time it is needed */
3118 #endif
3119                 RESTORE_ERRNO;
3120             }
3121             while (*s) s++;
3122         }
3123     }
3124     else if (isGV_with_GP(sv)) {
3125         GV *const gv = MUTABLE_GV(sv);
3126         SV *const buffer = sv_newmortal();
3127 
3128         gv_efullname3(buffer, gv, "*");
3129 
3130         assert(SvPOK(buffer));
3131         if (SvUTF8(buffer))
3132             SvUTF8_on(sv);
3133         else
3134             SvUTF8_off(sv);
3135         if (lp)
3136             *lp = SvCUR(buffer);
3137         return SvPVX(buffer);
3138     }
3139     else {
3140         if (lp)
3141             *lp = 0;
3142         if (flags & SV_UNDEF_RETURNS_NULL)
3143             return NULL;
3144         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3145             report_uninit(sv);
3146         /* Typically the caller expects that sv_any is not NULL now.  */
3147         if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
3148             sv_upgrade(sv, SVt_PV);
3149         return (char *)"";
3150     }
3151 
3152     {
3153         const STRLEN len = s - SvPVX_const(sv);
3154         if (lp)
3155             *lp = len;
3156         SvCUR_set(sv, len);
3157     }
3158     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2pv(%s)\n",
3159                           PTR2UV(sv),SvPVX_const(sv)));
3160     if (flags & SV_CONST_RETURN)
3161         return (char *)SvPVX_const(sv);
3162     if (flags & SV_MUTABLE_RETURN)
3163         return SvPVX_mutable(sv);
3164     return SvPVX(sv);
3165 }
3166 
3167 /*
3168 =for apidoc sv_copypv
3169 =for apidoc_item sv_copypv_flags
3170 =for apidoc_item sv_copypv_nomg
3171 
3172 These copy a stringified representation of the source SV into the
3173 destination SV.  They automatically perform coercion of numeric values into
3174 strings.  Guaranteed to preserve the C<UTF8> flag even from overloaded objects.
3175 Similar in nature to C<sv_2pv[_flags]> but they operate directly on an SV
3176 instead of just the string.  Mostly they use L</C<sv_2pv_flags>> to
3177 do the work, except when that would lose the UTF-8'ness of the PV.
3178 
3179 The three forms differ only in whether or not they perform 'get magic' on
3180 C<sv>.  C<sv_copypv_nomg> skips 'get magic'; C<sv_copypv> performs it; and
3181 C<sv_copypv_flags> either performs it (if the C<SV_GMAGIC> bit is set in
3182 C<flags>) or doesn't (if that bit is cleared).
3183 
3184 =cut
3185 */
3186 
3187 void
Perl_sv_copypv_flags(pTHX_ SV * const dsv,SV * const ssv,const I32 flags)3188 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3189 {
3190     STRLEN len;
3191     const char *s;
3192 
3193     PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3194 
3195     s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC));
3196     sv_setpvn(dsv,s,len);
3197     if (SvUTF8(ssv))
3198         SvUTF8_on(dsv);
3199     else
3200         SvUTF8_off(dsv);
3201 }
3202 
3203 /*
3204 =for apidoc      sv_2pvbyte
3205 =for apidoc_item sv_2pvbyte_flags
3206 
3207 These implement the various forms of the L<perlapi/C<SvPVbyte>> macros.
3208 The macros are the preferred interface.
3209 
3210 These return a pointer to the byte-encoded representation of the SV, and set
3211 C<*lp> to its length.  If the SV is marked as being encoded as UTF-8, it will
3212 be downgraded, if possible, to a byte string.  If the SV cannot be downgraded,
3213 they croak.
3214 
3215 The forms differ in that plain C<sv_2pvbyte> always processes 'get' magic; and
3216 C<sv_2pvbyte_flags> processes 'get' magic if and only if C<flags> contains
3217 C<SV_GMAGIC>.
3218 
3219 =for apidoc Amnh||SV_GMAGIC
3220 
3221 =cut
3222 */
3223 
3224 char *
Perl_sv_2pvbyte_flags(pTHX_ SV * sv,STRLEN * const lp,const U32 flags)3225 Perl_sv_2pvbyte_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags)
3226 {
3227     PERL_ARGS_ASSERT_SV_2PVBYTE_FLAGS;
3228 
3229     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
3230         mg_get(sv);
3231     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3232      || isGV_with_GP(sv) || SvROK(sv)) {
3233         SV *sv2 = sv_newmortal();
3234         sv_copypv_nomg(sv2,sv);
3235         sv = sv2;
3236     }
3237     sv_utf8_downgrade_nomg(sv,0);
3238     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3239 }
3240 
3241 /*
3242 =for apidoc      sv_2pvutf8
3243 =for apidoc_item sv_2pvutf8_flags
3244 
3245 These implement the various forms of the L<perlapi/C<SvPVutf8>> macros.
3246 The macros are the preferred interface.
3247 
3248 These return a pointer to the UTF-8-encoded representation of the SV, and set
3249 C<*lp> to its length in bytes.  They may cause the SV to be upgraded to UTF-8
3250 as a side-effect.
3251 
3252 The forms differ in that plain C<sv_2pvutf8> always processes 'get' magic; and
3253 C<sv_2pvutf8_flags> processes 'get' magic if and only if C<flags> contains
3254 C<SV_GMAGIC>.
3255 
3256 =cut
3257 */
3258 
3259 char *
Perl_sv_2pvutf8_flags(pTHX_ SV * sv,STRLEN * const lp,const U32 flags)3260 Perl_sv_2pvutf8_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags)
3261 {
3262     PERL_ARGS_ASSERT_SV_2PVUTF8_FLAGS;
3263 
3264     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
3265         mg_get(sv);
3266     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3267      || isGV_with_GP(sv) || SvROK(sv)) {
3268         SV *sv2 = sv_newmortal();
3269         sv_copypv_nomg(sv2,sv);
3270         sv = sv2;
3271     }
3272     sv_utf8_upgrade_nomg(sv);
3273     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3274 }
3275 
3276 
3277 /*
3278 =for apidoc sv_2bool
3279 
3280 This macro is only used by C<sv_true()> or its macro equivalent, and only if
3281 the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>.
3282 It calls C<sv_2bool_flags> with the C<SV_GMAGIC> flag.
3283 
3284 =for apidoc sv_2bool_flags
3285 
3286 This function is only used by C<sv_true()> and friends,  and only if
3287 the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>.  If the flags
3288 contain C<SV_GMAGIC>, then it does an C<mg_get()> first.
3289 
3290 
3291 =cut
3292 */
3293 
3294 bool
Perl_sv_2bool_flags(pTHX_ SV * sv,I32 flags)3295 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
3296 {
3297     PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3298 
3299     restart:
3300     if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3301 
3302     if (!SvOK(sv))
3303         return 0;
3304     if (SvROK(sv)) {
3305         if (SvAMAGIC(sv)) {
3306             SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3307             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
3308                 bool svb;
3309                 sv = tmpsv;
3310                 if(SvGMAGICAL(sv)) {
3311                     flags = SV_GMAGIC;
3312                     goto restart; /* call sv_2bool */
3313                 }
3314                 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
3315                 else if(!SvOK(sv)) {
3316                     svb = 0;
3317                 }
3318                 else if(SvPOK(sv)) {
3319                     svb = SvPVXtrue(sv);
3320                 }
3321                 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
3322                     svb = (SvIOK(sv) && SvIVX(sv) != 0)
3323                         || (SvNOK(sv) && SvNVX(sv) != 0.0);
3324                 }
3325                 else {
3326                     flags = 0;
3327                     goto restart; /* call sv_2bool_nomg */
3328                 }
3329                 return cBOOL(svb);
3330             }
3331         }
3332         assert(SvRV(sv));
3333         return TRUE;
3334     }
3335     if (isREGEXP(sv))
3336         return
3337           RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
3338 
3339     if (SvNOK(sv) && !SvPOK(sv))
3340         return SvNVX(sv) != 0.0;
3341 
3342     return SvTRUE_common(sv, 0);
3343 }
3344 
3345 /*
3346 =for apidoc sv_utf8_upgrade
3347 =for apidoc_item sv_utf8_upgrade_flags
3348 =for apidoc_item sv_utf8_upgrade_flags_grow
3349 =for apidoc_item sv_utf8_upgrade_nomg
3350 
3351 These convert the PV of an SV to its UTF-8-encoded form.
3352 The SV is forced to string form if it is not already.
3353 They always set the C<SvUTF8> flag to avoid future validity checks even if the
3354 whole string is the same in UTF-8 as not.
3355 They return the number of bytes in the converted string
3356 
3357 The forms differ in just two ways.  The main difference is whether or not they
3358 perform 'get magic' on C<sv>.  C<sv_utf8_upgrade_nomg> skips 'get magic';
3359 C<sv_utf8_upgrade> performs it; and C<sv_utf8_upgrade_flags> and
3360 C<sv_utf8_upgrade_flags_grow> either perform it (if the C<SV_GMAGIC> bit is set
3361 in C<flags>) or don't (if that bit is cleared).
3362 
3363 The other difference is that C<sv_utf8_upgrade_flags_grow> has an additional
3364 parameter, C<extra>, which allows the caller to specify an amount of space to
3365 be reserved as spare beyond what is needed for the actual conversion.  This is
3366 used when the caller knows it will soon be needing yet more space, and it is
3367 more efficient to request space from the system in a single call.
3368 This form is otherwise identical to C<sv_utf8_upgrade_flags>.
3369 
3370 These are not a general purpose byte encoding to Unicode interface: use the
3371 Encode extension for that.
3372 
3373 The C<SV_FORCE_UTF8_UPGRADE> flag is now ignored.
3374 
3375 =for apidoc Amnh||SV_GMAGIC|
3376 =for apidoc Amnh||SV_FORCE_UTF8_UPGRADE|
3377 
3378 =cut
3379 
3380 If the routine itself changes the string, it adds a trailing C<NUL>.  Such a
3381 C<NUL> isn't guaranteed due to having other routines do the work in some input
3382 cases, or if the input is already flagged as being in utf8.
3383 
3384 */
3385 
3386 STRLEN
Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV * const sv,const I32 flags,STRLEN extra)3387 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3388 {
3389     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3390 
3391     if (sv == &PL_sv_undef)
3392         return 0;
3393     if (!SvPOK_nog(sv)) {
3394         STRLEN len = 0;
3395         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3396             (void) sv_2pv_flags(sv,&len, flags);
3397             if (SvUTF8(sv)) {
3398                 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3399                 return len;
3400             }
3401         } else {
3402             (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3403         }
3404     }
3405 
3406     /* SVt_REGEXP's shouldn't be upgraded to UTF8 - they're already
3407      * compiled and individual nodes will remain non-utf8 even if the
3408      * stringified version of the pattern gets upgraded. Whether the
3409      * PVX of a REGEXP should be grown or we should just croak, I don't
3410      * know - DAPM */
3411     if (SvUTF8(sv) || isREGEXP(sv)) {
3412         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3413         return SvCUR(sv);
3414     }
3415 
3416     if (SvIsCOW(sv)) {
3417         S_sv_uncow(aTHX_ sv, 0);
3418     }
3419 
3420     if (SvCUR(sv) == 0) {
3421         if (extra) SvGROW(sv, extra + 1); /* Make sure is room for a trailing
3422                                              byte */
3423     } else { /* Assume Latin-1/EBCDIC */
3424         /* This function could be much more efficient if we
3425          * had a FLAG in SVs to signal if there are any variant
3426          * chars in the PV.  Given that there isn't such a flag
3427          * make the loop as fast as possible. */
3428         U8 * s = (U8 *) SvPVX_const(sv);
3429         U8 *t = s;
3430 
3431         if (is_utf8_invariant_string_loc(s, SvCUR(sv), (const U8 **) &t)) {
3432 
3433             /* utf8 conversion not needed because all are invariants.  Mark
3434              * as UTF-8 even if no variant - saves scanning loop */
3435             SvUTF8_on(sv);
3436             if (extra) SvGROW(sv, SvCUR(sv) + extra);
3437             return SvCUR(sv);
3438         }
3439 
3440         /* Here, there is at least one variant (t points to the first one), so
3441          * the string should be converted to utf8.  Everything from 's' to
3442          * 't - 1' will occupy only 1 byte each on output.
3443          *
3444          * Note that the incoming SV may not have a trailing '\0', as certain
3445          * code in pp_formline can send us partially built SVs.
3446          *
3447          * There are two main ways to convert.  One is to create a new string
3448          * and go through the input starting from the beginning, appending each
3449          * converted value onto the new string as we go along.  Going this
3450          * route, it's probably best to initially allocate enough space in the
3451          * string rather than possibly running out of space and having to
3452          * reallocate and then copy what we've done so far.  Since everything
3453          * from 's' to 't - 1' is invariant, the destination can be initialized
3454          * with these using a fast memory copy.  To be sure to allocate enough
3455          * space, one could use the worst case scenario, where every remaining
3456          * byte expands to two under UTF-8, or one could parse it and count
3457          * exactly how many do expand.
3458          *
3459          * The other way is to unconditionally parse the remainder of the
3460          * string to figure out exactly how big the expanded string will be,
3461          * growing if needed.  Then start at the end of the string and place
3462          * the character there at the end of the unfilled space in the expanded
3463          * one, working backwards until reaching 't'.
3464          *
3465          * The problem with assuming the worst case scenario is that for very
3466          * long strings, we could allocate much more memory than actually
3467          * needed, which can create performance problems.  If we have to parse
3468          * anyway, the second method is the winner as it may avoid an extra
3469          * copy.  The code used to use the first method under some
3470          * circumstances, but now that there is faster variant counting on
3471          * ASCII platforms, the second method is used exclusively, eliminating
3472          * some code that no longer has to be maintained. */
3473 
3474         {
3475             /* Count the total number of variants there are.  We can start
3476              * just beyond the first one, which is known to be at 't' */
3477             const Size_t invariant_length = t - s;
3478             U8 * e = (U8 *) SvEND(sv);
3479 
3480             /* The length of the left overs, plus 1. */
3481             const Size_t remaining_length_p1 = e - t;
3482 
3483             /* We expand by 1 for the variant at 't' and one for each remaining
3484              * variant (we start looking at 't+1') */
3485             Size_t expansion = 1 + variant_under_utf8_count(t + 1, e);
3486 
3487             /* +1 = trailing NUL */
3488             Size_t need = SvCUR(sv) + expansion + extra + 1;
3489             U8 * d;
3490 
3491             /* Grow if needed */
3492             if (SvLEN(sv) < need) {
3493                 t = invariant_length + (U8*) SvGROW(sv, need);
3494                 e = t + remaining_length_p1;
3495             }
3496             SvCUR_set(sv, invariant_length + remaining_length_p1 + expansion);
3497 
3498             /* Set the NUL at the end */
3499             d = (U8 *) SvEND(sv);
3500             *d-- = '\0';
3501 
3502             /* Having decremented d, it points to the position to put the
3503              * very last byte of the expanded string.  Go backwards through
3504              * the string, copying and expanding as we go, stopping when we
3505              * get to the part that is invariant the rest of the way down */
3506 
3507             e--;
3508             while (e >= t) {
3509                 if (NATIVE_BYTE_IS_INVARIANT(*e)) {
3510                     *d-- = *e;
3511                 } else {
3512                     *d-- = UTF8_EIGHT_BIT_LO(*e);
3513                     *d-- = UTF8_EIGHT_BIT_HI(*e);
3514                 }
3515                 e--;
3516             }
3517 
3518             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3519                 /* Update pos. We do it at the end rather than during
3520                  * the upgrade, to avoid slowing down the common case
3521                  * (upgrade without pos).
3522                  * pos can be stored as either bytes or characters.  Since
3523                  * this was previously a byte string we can just turn off
3524                  * the bytes flag. */
3525                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3526                 if (mg) {
3527                     mg->mg_flags &= ~MGf_BYTES;
3528                 }
3529                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3530                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3531             }
3532         }
3533     }
3534 
3535     SvUTF8_on(sv);
3536     return SvCUR(sv);
3537 }
3538 
3539 /*
3540 =for apidoc sv_utf8_downgrade
3541 =for apidoc_item sv_utf8_downgrade_flags
3542 =for apidoc_item sv_utf8_downgrade_nomg
3543 
3544 These attempt to convert the PV of an SV from characters to bytes.  If the PV
3545 contains a character that cannot fit in a byte, this conversion will fail; in
3546 this case, C<FALSE> is returned if C<fail_ok> is true; otherwise they croak.
3547 
3548 They are not a general purpose Unicode to byte encoding interface:
3549 use the C<Encode> extension for that.
3550 
3551 They differ only in that:
3552 
3553 C<sv_utf8_downgrade> processes 'get' magic on C<sv>.
3554 
3555 C<sv_utf8_downgrade_nomg> does not.
3556 
3557 C<sv_utf8_downgrade_flags> has an additional C<flags> parameter in which you can specify
3558 C<SV_GMAGIC> to process 'get' magic, or leave it cleared to not process 'get' magic.
3559 
3560 =cut
3561 */
3562 
3563 bool
Perl_sv_utf8_downgrade_flags(pTHX_ SV * const sv,const bool fail_ok,const U32 flags)3564 Perl_sv_utf8_downgrade_flags(pTHX_ SV *const sv, const bool fail_ok, const U32 flags)
3565 {
3566     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE_FLAGS;
3567 
3568     if (SvPOKp(sv) && SvUTF8(sv)) {
3569         if (SvCUR(sv)) {
3570             U8 *s;
3571             STRLEN len;
3572             U32 mg_flags = flags & SV_GMAGIC;
3573 
3574             if (SvIsCOW(sv)) {
3575                 S_sv_uncow(aTHX_ sv, 0);
3576             }
3577             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3578                 /* update pos */
3579                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3580                 if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
3581                         mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
3582                                                 mg_flags|SV_CONST_RETURN);
3583                         mg_flags = 0; /* sv_pos_b2u does get magic */
3584                 }
3585                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3586                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3587 
3588             }
3589             s = (U8 *) SvPV_flags(sv, len, mg_flags);
3590 
3591             if (!utf8_to_bytes(s, &len)) {
3592                 if (fail_ok)
3593                     return FALSE;
3594                 else {
3595                     if (PL_op)
3596                         Perl_croak(aTHX_ "Wide character in %s",
3597                                    OP_DESC(PL_op));
3598                     else
3599                         Perl_croak(aTHX_ "Wide character");
3600                 }
3601             }
3602             SvCUR_set(sv, len);
3603         }
3604     }
3605     SvUTF8_off(sv);
3606     return TRUE;
3607 }
3608 
3609 /*
3610 =for apidoc sv_utf8_encode
3611 
3612 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3613 flag off so that it looks like octets again.
3614 
3615 =cut
3616 */
3617 
3618 void
Perl_sv_utf8_encode(pTHX_ SV * const sv)3619 Perl_sv_utf8_encode(pTHX_ SV *const sv)
3620 {
3621     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3622 
3623     if (SvREADONLY(sv)) {
3624         sv_force_normal_flags(sv, 0);
3625     }
3626     (void) sv_utf8_upgrade(sv);
3627     SvUTF8_off(sv);
3628 }
3629 
3630 /*
3631 =for apidoc sv_utf8_decode
3632 
3633 If the PV of the SV is an octet sequence in Perl's extended UTF-8
3634 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3635 so that it looks like a character.  If the PV contains only single-byte
3636 characters, the C<SvUTF8> flag stays off.
3637 Scans PV for validity and returns FALSE if the PV is invalid UTF-8.
3638 
3639 =cut
3640 */
3641 
3642 bool
Perl_sv_utf8_decode(pTHX_ SV * const sv)3643 Perl_sv_utf8_decode(pTHX_ SV *const sv)
3644 {
3645     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3646 
3647     if (SvPOKp(sv)) {
3648         const U8 *start, *c, *first_variant;
3649 
3650         /* The octets may have got themselves encoded - get them back as
3651          * bytes
3652          */
3653         if (!sv_utf8_downgrade(sv, TRUE))
3654             return FALSE;
3655 
3656         /* it is actually just a matter of turning the utf8 flag on, but
3657          * we want to make sure everything inside is valid utf8 first.
3658          */
3659         c = start = (const U8 *) SvPVX_const(sv);
3660         if (! is_utf8_invariant_string_loc(c, SvCUR(sv), &first_variant)) {
3661             if (!is_utf8_string(first_variant, SvCUR(sv) - (first_variant -c)))
3662                 return FALSE;
3663             SvUTF8_on(sv);
3664         }
3665         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3666             /* XXX Is this dead code?  XS_utf8_decode calls SvSETMAGIC
3667                    after this, clearing pos.  Does anything on CPAN
3668                    need this? */
3669             /* adjust pos to the start of a UTF8 char sequence */
3670             MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3671             if (mg) {
3672                 I32 pos = mg->mg_len;
3673                 if (pos > 0) {
3674                     for (c = start + pos; c > start; c--) {
3675                         if (UTF8_IS_START(*c))
3676                             break;
3677                     }
3678                     mg->mg_len  = c - start;
3679                 }
3680             }
3681             if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3682                 magic_setutf8(sv,mg); /* clear UTF8 cache */
3683         }
3684     }
3685     return TRUE;
3686 }
3687 
3688 /*
3689 =for apidoc sv_setsv
3690 =for apidoc_item sv_setsv_flags
3691 =for apidoc_item sv_setsv_mg
3692 =for apidoc_item sv_setsv_nomg
3693 
3694 These copy the contents of the source SV C<ssv> into the destination SV C<dsv>.
3695 C<ssv> may be destroyed if it is mortal, so don't use these functions if
3696 the source SV needs to be reused.
3697 Loosely speaking, they perform a copy-by-value, obliterating any previous
3698 content of the destination.
3699 
3700 They differ only in that:
3701 
3702 C<sv_setsv> calls 'get' magic on C<ssv>, but skips 'set' magic on C<dsv>.
3703 
3704 C<sv_setsv_mg> calls both 'get' magic on C<ssv> and 'set' magic on C<dsv>.
3705 
3706 C<sv_setsv_nomg> skips all magic.
3707 
3708 C<sv_setsv_flags> has a C<flags> parameter which you can use to specify any
3709 combination of magic handling, and also you can specify C<SV_NOSTEAL> so that
3710 the buffers of temps will not be stolen.
3711 
3712 You probably want to instead use one of the assortment of wrappers, such as
3713 C<L</SvSetSV>>, C<L</SvSetSV_nosteal>>, C<L</SvSetMagicSV>> and
3714 C<L</SvSetMagicSV_nosteal>>.
3715 
3716 C<sv_setsv_flags> is the primary function for copying scalars, and most other
3717 copy-ish functions and macros use it underneath.
3718 
3719 =for apidoc Amnh||SV_NOSTEAL
3720 
3721 =cut
3722 */
3723 
3724 static void
S_glob_assign_glob(pTHX_ SV * const dsv,SV * const ssv,const int dtype)3725 S_glob_assign_glob(pTHX_ SV *const dsv, SV *const ssv, const int dtype)
3726 {
3727     I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3728     HV *old_stash = NULL;
3729 
3730     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3731 
3732     if (dtype != SVt_PVGV && !isGV_with_GP(dsv)) {
3733         const char * const name = GvNAME(ssv);
3734         const STRLEN len = GvNAMELEN(ssv);
3735         {
3736             if (dtype >= SVt_PV) {
3737                 SvPV_free(dsv);
3738                 SvPV_set(dsv, 0);
3739                 SvLEN_set(dsv, 0);
3740                 SvCUR_set(dsv, 0);
3741             }
3742             SvUPGRADE(dsv, SVt_PVGV);
3743             (void)SvOK_off(dsv);
3744             isGV_with_GP_on(dsv);
3745         }
3746         GvSTASH(dsv) = GvSTASH(ssv);
3747         if (GvSTASH(dsv))
3748             Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dsv)), dsv);
3749         gv_name_set(MUTABLE_GV(dsv), name, len,
3750                         GV_ADD | (GvNAMEUTF8(ssv) ? SVf_UTF8 : 0 ));
3751         SvFAKE_on(dsv);	/* can coerce to non-glob */
3752     }
3753 
3754     if(GvGP(MUTABLE_GV(ssv))) {
3755         /* If source has method cache entry, clear it */
3756         if(GvCVGEN(ssv)) {
3757             SvREFCNT_dec(GvCV(ssv));
3758             GvCV_set(ssv, NULL);
3759             GvCVGEN(ssv) = 0;
3760         }
3761         /* If source has a real method, then a method is
3762            going to change */
3763         else if(
3764          GvCV((const GV *)ssv) && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
3765         ) {
3766             mro_changes = 1;
3767         }
3768     }
3769 
3770     /* If dest already had a real method, that's a change as well */
3771     if(
3772         !mro_changes && GvGP(MUTABLE_GV(dsv)) && GvCVu((const GV *)dsv)
3773      && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
3774     ) {
3775         mro_changes = 1;
3776     }
3777 
3778     /* We don't need to check the name of the destination if it was not a
3779        glob to begin with. */
3780     if(dtype == SVt_PVGV) {
3781         const char * const name = GvNAME((const GV *)dsv);
3782         const STRLEN len = GvNAMELEN(dsv);
3783         if(memEQs(name, len, "ISA")
3784          /* The stash may have been detached from the symbol table, so
3785             check its name. */
3786          && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
3787         )
3788             mro_changes = 2;
3789         else {
3790             if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3791              || (len == 1 && name[0] == ':')) {
3792                 mro_changes = 3;
3793 
3794                 /* Set aside the old stash, so we can reset isa caches on
3795                    its subclasses. */
3796                 if((old_stash = GvHV(dsv)))
3797                     /* Make sure we do not lose it early. */
3798                     SvREFCNT_inc_simple_void_NN(
3799                      sv_2mortal((SV *)old_stash)
3800                     );
3801             }
3802         }
3803 
3804         SvREFCNT_inc_simple_void_NN(sv_2mortal(dsv));
3805     }
3806 
3807     /* freeing dsv's GP might free ssv (e.g. *x = $x),
3808      * so temporarily protect it */
3809     ENTER;
3810     SAVEFREESV(SvREFCNT_inc_simple_NN(ssv));
3811     gp_free(MUTABLE_GV(dsv));
3812     GvINTRO_off(dsv);		/* one-shot flag */
3813     GvGP_set(dsv, gp_ref(GvGP(ssv)));
3814     LEAVE;
3815 
3816     if (SvTAINTED(ssv))
3817         SvTAINT(dsv);
3818     if (GvIMPORTED(dsv) != GVf_IMPORTED
3819         && CopSTASH_ne(PL_curcop, GvSTASH(dsv)))
3820         {
3821             GvIMPORTED_on(dsv);
3822         }
3823     GvMULTI_on(dsv);
3824     if(mro_changes == 2) {
3825       if (GvAV((const GV *)ssv)) {
3826         MAGIC *mg;
3827         SV * const sref = (SV *)GvAV((const GV *)dsv);
3828         if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3829             if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3830                 AV * const ary = newAV_alloc_x(2);
3831                 av_push_simple(ary, mg->mg_obj); /* takes the refcount */
3832                 av_push_simple(ary, SvREFCNT_inc_simple_NN(dsv));
3833                 mg->mg_obj = (SV *)ary;
3834             } else {
3835                 av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dsv));
3836             }
3837         }
3838         else sv_magic(sref, dsv, PERL_MAGIC_isa, NULL, 0);
3839       }
3840       mro_isa_changed_in(GvSTASH(dsv));
3841     }
3842     else if(mro_changes == 3) {
3843         HV * const stash = GvHV(dsv);
3844         if(old_stash ? HvHasENAME(old_stash) : cBOOL(stash))
3845             mro_package_moved(
3846                 stash, old_stash,
3847                 (GV *)dsv, 0
3848             );
3849     }
3850     else if(mro_changes) mro_method_changed_in(GvSTASH(dsv));
3851     if (GvIO(dsv) && dtype == SVt_PVGV) {
3852         DEBUG_o(Perl_deb(aTHX_
3853                         "glob_assign_glob clearing PL_stashcache\n"));
3854         /* It's a cache. It will rebuild itself quite happily.
3855            It's a lot of effort to work out exactly which key (or keys)
3856            might be invalidated by the creation of the this file handle.
3857          */
3858         hv_clear(PL_stashcache);
3859     }
3860     return;
3861 }
3862 
3863 void
Perl_gv_setref(pTHX_ SV * const dsv,SV * const ssv)3864 Perl_gv_setref(pTHX_ SV *const dsv, SV *const ssv)
3865 {
3866     SV * const sref = SvRV(ssv);
3867     SV *dref;
3868     const int intro = GvINTRO(dsv);
3869     SV **location;
3870     U8 import_flag = 0;
3871     const U32 stype = SvTYPE(sref);
3872 
3873     PERL_ARGS_ASSERT_GV_SETREF;
3874 
3875     if (intro) {
3876         GvINTRO_off(dsv);	/* one-shot flag */
3877         GvLINE(dsv) = CopLINE(PL_curcop);
3878         GvEGV(dsv) = MUTABLE_GV(dsv);
3879     }
3880     GvMULTI_on(dsv);
3881     switch (stype) {
3882     case SVt_PVCV:
3883         location = (SV **) &(GvGP(dsv)->gp_cv); /* XXX bypassing GvCV_set */
3884         import_flag = GVf_IMPORTED_CV;
3885         goto common;
3886     case SVt_PVHV:
3887         location = (SV **) &GvHV(dsv);
3888         import_flag = GVf_IMPORTED_HV;
3889         goto common;
3890     case SVt_PVAV:
3891         location = (SV **) &GvAV(dsv);
3892         import_flag = GVf_IMPORTED_AV;
3893         goto common;
3894     case SVt_PVIO:
3895         location = (SV **) &GvIOp(dsv);
3896         goto common;
3897     case SVt_PVFM:
3898         location = (SV **) &GvFORM(dsv);
3899         goto common;
3900     default:
3901         location = &GvSV(dsv);
3902         import_flag = GVf_IMPORTED_SV;
3903     common:
3904         if (intro) {
3905             if (stype == SVt_PVCV) {
3906                 /*if (GvCVGEN(dsv) && (GvCV(dsv) != (const CV *)sref || GvCVGEN(dsv))) {*/
3907                 if (GvCVGEN(dsv)) {
3908                     SvREFCNT_dec(GvCV(dsv));
3909                     GvCV_set(dsv, NULL);
3910                     GvCVGEN(dsv) = 0; /* Switch off cacheness. */
3911                 }
3912             }
3913             /* SAVEt_GVSLOT takes more room on the savestack and has more
3914                overhead in leave_scope than SAVEt_GENERIC_SV.  But for CVs
3915                leave_scope needs access to the GV so it can reset method
3916                caches.  We must use SAVEt_GVSLOT whenever the type is
3917                SVt_PVCV, even if the stash is anonymous, as the stash may
3918                gain a name somehow before leave_scope. */
3919             if (stype == SVt_PVCV) {
3920                 /* There is no save_pushptrptrptr.  Creating it for this
3921                    one call site would be overkill.  So inline the ss add
3922                    routines here. */
3923                 dSS_ADD;
3924                 SS_ADD_PTR(dsv);
3925                 SS_ADD_PTR(location);
3926                 SS_ADD_PTR(SvREFCNT_inc(*location));
3927                 SS_ADD_UV(SAVEt_GVSLOT);
3928                 SS_ADD_END(4);
3929             }
3930             else SAVEGENERICSV(*location);
3931         }
3932         dref = *location;
3933         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dsv))) {
3934             CV* const cv = MUTABLE_CV(*location);
3935             if (cv) {
3936                 if (!GvCVGEN((const GV *)dsv) &&
3937                     (CvROOT(cv) || CvXSUB(cv)) &&
3938                     /* redundant check that avoids creating the extra SV
3939                        most of the time: */
3940                     (CvCONST(cv) || (ckWARN(WARN_REDEFINE) && !intro)))
3941                     {
3942                         SV * const new_const_sv =
3943                             CvCONST((const CV *)sref)
3944                                  ? cv_const_sv_or_av((const CV *)sref)
3945                                  : NULL;
3946                         HV * const stash = GvSTASH((const GV *)dsv);
3947                         report_redefined_cv(
3948                            sv_2mortal(
3949                              stash
3950                                ? Perl_newSVpvf(aTHX_
3951                                     "%" HEKf "::%" HEKf,
3952                                     HEKfARG(HvNAME_HEK(stash)),
3953                                     HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv))))
3954                                : Perl_newSVpvf(aTHX_
3955                                     "%" HEKf,
3956                                     HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv))))
3957                            ),
3958                            cv,
3959                            CvCONST((const CV *)sref) ? &new_const_sv : NULL
3960                         );
3961                     }
3962                 if (!intro)
3963                     cv_ckproto_len_flags(cv, (const GV *)dsv,
3964                                    SvPOK(sref) ? CvPROTO(sref) : NULL,
3965                                    SvPOK(sref) ? CvPROTOLEN(sref) : 0,
3966                                    SvPOK(sref) ? SvUTF8(sref) : 0);
3967             }
3968             GvCVGEN(dsv) = 0; /* Switch off cacheness. */
3969             GvASSUMECV_on(dsv);
3970             if(GvSTASH(dsv)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3971                 if (intro && GvREFCNT(dsv) > 1) {
3972                     /* temporary remove extra savestack's ref */
3973                     --GvREFCNT(dsv);
3974                     gv_method_changed(dsv);
3975                     ++GvREFCNT(dsv);
3976                 }
3977                 else gv_method_changed(dsv);
3978             }
3979         }
3980         *location = SvREFCNT_inc_simple_NN(sref);
3981         if (import_flag && !(GvFLAGS(dsv) & import_flag)
3982             && CopSTASH_ne(PL_curcop, GvSTASH(dsv))) {
3983             GvFLAGS(dsv) |= import_flag;
3984         }
3985 
3986         if (stype == SVt_PVHV) {
3987             const char * const name = GvNAME((GV*)dsv);
3988             const STRLEN len = GvNAMELEN(dsv);
3989             if (
3990                 (
3991                    (len > 1 && name[len-2] == ':' && name[len-1] == ':')
3992                 || (len == 1 && name[0] == ':')
3993                 )
3994              && (!dref || HvHasENAME(dref))
3995             ) {
3996                 mro_package_moved(
3997                     (HV *)sref, (HV *)dref,
3998                     (GV *)dsv, 0
3999                 );
4000             }
4001         }
4002         else if (
4003             stype == SVt_PVAV && sref != dref
4004          && memEQs(GvNAME((GV*)dsv), GvNAMELEN((GV*)dsv), "ISA")
4005          /* The stash may have been detached from the symbol table, so
4006             check its name before doing anything. */
4007          && GvSTASH(dsv) && HvHasENAME(GvSTASH(dsv))
4008         ) {
4009             MAGIC *mg;
4010             MAGIC * const omg = dref && SvSMAGICAL(dref)
4011                                  ? mg_find(dref, PERL_MAGIC_isa)
4012                                  : NULL;
4013             if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
4014                 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
4015                     AV * const ary = newAV_alloc_xz(4);
4016                     av_push_simple(ary, mg->mg_obj); /* takes the refcount */
4017                     mg->mg_obj = (SV *)ary;
4018                 }
4019                 if (omg) {
4020                     if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
4021                         SV **svp = AvARRAY((AV *)omg->mg_obj);
4022                         I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
4023                         while (items--)
4024                             av_push(
4025                              (AV *)mg->mg_obj,
4026                              SvREFCNT_inc_simple_NN(*svp++)
4027                             );
4028                     }
4029                     else
4030                         av_push(
4031                          (AV *)mg->mg_obj,
4032                          SvREFCNT_inc_simple_NN(omg->mg_obj)
4033                         );
4034                 }
4035                 else
4036                     av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dsv));
4037             }
4038             else
4039             {
4040                 SSize_t i;
4041                 sv_magic(
4042                  sref, omg ? omg->mg_obj : dsv, PERL_MAGIC_isa, NULL, 0
4043                 );
4044                 for (i = 0; i <= AvFILL(sref); ++i) {
4045                     SV **elem = av_fetch ((AV*)sref, i, 0);
4046                     if (elem) {
4047                         sv_magic(
4048                           *elem, sref, PERL_MAGIC_isaelem, NULL, i
4049                         );
4050                     }
4051                 }
4052                 mg = mg_find(sref, PERL_MAGIC_isa);
4053             }
4054             /* Since the *ISA assignment could have affected more than
4055                one stash, don't call mro_isa_changed_in directly, but let
4056                magic_clearisa do it for us, as it already has the logic for
4057                dealing with globs vs arrays of globs. */
4058             assert(mg);
4059             Perl_magic_clearisa(aTHX_ NULL, mg);
4060         }
4061         else if (stype == SVt_PVIO) {
4062             DEBUG_o(Perl_deb(aTHX_ "gv_setref clearing PL_stashcache\n"));
4063             /* It's a cache. It will rebuild itself quite happily.
4064                It's a lot of effort to work out exactly which key (or keys)
4065                might be invalidated by the creation of the this file handle.
4066             */
4067             hv_clear(PL_stashcache);
4068         }
4069         break;
4070     }
4071     if (!intro) SvREFCNT_dec(dref);
4072     if (SvTAINTED(ssv))
4073         SvTAINT(dsv);
4074     return;
4075 }
4076 
4077 
4078 
4079 
4080 #ifdef PERL_DEBUG_READONLY_COW
4081 # include <sys/mman.h>
4082 
4083 # ifndef PERL_MEMORY_DEBUG_HEADER_SIZE
4084 #  define PERL_MEMORY_DEBUG_HEADER_SIZE 0
4085 # endif
4086 
4087 void
Perl_sv_buf_to_ro(pTHX_ SV * sv)4088 Perl_sv_buf_to_ro(pTHX_ SV *sv)
4089 {
4090     struct perl_memory_debug_header * const header =
4091         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4092     const MEM_SIZE len = header->size;
4093     PERL_ARGS_ASSERT_SV_BUF_TO_RO;
4094 # ifdef PERL_TRACK_MEMPOOL
4095     if (!header->readonly) header->readonly = 1;
4096 # endif
4097     if (mprotect(header, len, PROT_READ))
4098         Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
4099                          header, len, errno);
4100 }
4101 
4102 static void
S_sv_buf_to_rw(pTHX_ SV * sv)4103 S_sv_buf_to_rw(pTHX_ SV *sv)
4104 {
4105     struct perl_memory_debug_header * const header =
4106         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4107     const MEM_SIZE len = header->size;
4108     PERL_ARGS_ASSERT_SV_BUF_TO_RW;
4109     if (mprotect(header, len, PROT_READ|PROT_WRITE))
4110         Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
4111                          header, len, errno);
4112 # ifdef PERL_TRACK_MEMPOOL
4113     header->readonly = 0;
4114 # endif
4115 }
4116 
4117 #else
4118 # define sv_buf_to_ro(sv)	NOOP
4119 # define sv_buf_to_rw(sv)	NOOP
4120 #endif
4121 
4122 void
Perl_sv_setsv_flags(pTHX_ SV * dsv,SV * ssv,const I32 flags)4123 Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags)
4124 {
4125     U32 sflags;
4126     int dtype;
4127     svtype stype;
4128     unsigned int both_type;
4129 
4130     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
4131 
4132     if (UNLIKELY( ssv == dsv ))
4133         return;
4134 
4135     if (UNLIKELY( !ssv ))
4136         ssv = &PL_sv_undef;
4137 
4138     stype = SvTYPE(ssv);
4139     dtype = SvTYPE(dsv);
4140     both_type = (stype | dtype);
4141 
4142     /* with these values, we can check that both SVs are NULL/IV (and not
4143      * freed) just by testing the or'ed types */
4144     STATIC_ASSERT_STMT(SVt_NULL == 0);
4145     STATIC_ASSERT_STMT(SVt_IV   == 1);
4146     STATIC_ASSERT_STMT(SVt_NV   == 2);
4147 #if NVSIZE <= IVSIZE
4148     if (both_type <= 2) {
4149 #else
4150     if (both_type <= 1) {
4151 #endif
4152         /* both src and dst are UNDEF/IV/RV - maybe NV depending on config,
4153          * so we can do a lot of special-casing */
4154         U32 sflags;
4155         U32 new_dflags;
4156         SV *old_rv = NULL;
4157 
4158         /* minimal subset of SV_CHECK_THINKFIRST_COW_DROP(dsv) */
4159         if (SvREADONLY(dsv))
4160             Perl_croak_no_modify();
4161         if (SvROK(dsv)) {
4162             if (SvWEAKREF(dsv))
4163                 sv_unref_flags(dsv, 0);
4164             else
4165                 old_rv = SvRV(dsv);
4166             SvROK_off(dsv);
4167         }
4168 
4169         assert(!SvGMAGICAL(ssv));
4170         assert(!SvGMAGICAL(dsv));
4171 
4172         sflags = SvFLAGS(ssv);
4173         if (sflags & (SVf_IOK|SVf_ROK)) {
4174             SET_SVANY_FOR_BODYLESS_IV(dsv);
4175             new_dflags = SVt_IV;
4176 
4177             if (sflags & SVf_ROK) {
4178                 dsv->sv_u.svu_rv = SvREFCNT_inc(SvRV(ssv));
4179                 new_dflags |= SVf_ROK;
4180             }
4181             else {
4182                 /* both src and dst are <= SVt_IV, so sv_any points to the
4183                  * head; so access the head directly
4184                  */
4185                 assert(    &(ssv->sv_u.svu_iv)
4186                         == &(((XPVIV*) SvANY(ssv))->xiv_iv));
4187                 assert(    &(dsv->sv_u.svu_iv)
4188                         == &(((XPVIV*) SvANY(dsv))->xiv_iv));
4189                 dsv->sv_u.svu_iv = ssv->sv_u.svu_iv;
4190                 new_dflags |= (SVf_IOK|SVp_IOK|(sflags & SVf_IVisUV));
4191             }
4192         }
4193 #if NVSIZE <= IVSIZE
4194         else if (sflags & SVf_NOK) {
4195             SET_SVANY_FOR_BODYLESS_NV(dsv);
4196             new_dflags = (SVt_NV|SVf_NOK|SVp_NOK);
4197 
4198             /* both src and dst are <= SVt_MV, so sv_any points to the
4199              * head; so access the head directly
4200              */
4201             assert(    &(ssv->sv_u.svu_nv)
4202                     == &(((XPVNV*) SvANY(ssv))->xnv_u.xnv_nv));
4203             assert(    &(dsv->sv_u.svu_nv)
4204                     == &(((XPVNV*) SvANY(dsv))->xnv_u.xnv_nv));
4205             dsv->sv_u.svu_nv = ssv->sv_u.svu_nv;
4206         }
4207 #endif
4208         else {
4209             new_dflags = dtype; /* turn off everything except the type */
4210         }
4211         /* Should preserve some dsv flags - at least SVs_TEMP, */
4212         /* so cannot just set SvFLAGS(dsv) = new_dflags        */
4213         /* First clear the flags that we do want to clobber    */
4214         (void)SvOK_off(dsv);
4215         SvFLAGS(dsv) &= ~SVTYPEMASK;
4216         /* Now set the new flags */
4217         SvFLAGS(dsv) |= new_dflags;
4218 
4219         SvREFCNT_dec(old_rv);
4220         return;
4221     }
4222 
4223     if (UNLIKELY(both_type == SVTYPEMASK)) {
4224         if (SvIS_FREED(dsv)) {
4225             Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
4226                        " to a freed scalar %p", SVfARG(ssv), (void *)dsv);
4227         }
4228         if (SvIS_FREED(ssv)) {
4229             Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
4230                        (void*)ssv, (void*)dsv);
4231         }
4232     }
4233 
4234 
4235 
4236     SV_CHECK_THINKFIRST_COW_DROP(dsv);
4237     dtype = SvTYPE(dsv); /* THINKFIRST may have changed type */
4238 
4239     /* There's a lot of redundancy below but we're going for speed here
4240      * Note: some of the cases below do return; rather than break; so the
4241      * if-elseif-else logic below this switch does not see all cases. */
4242 
4243     switch (stype) {
4244     case SVt_NULL:
4245       undef_sstr:
4246         if (LIKELY( dtype != SVt_PVGV && dtype != SVt_PVLV )) {
4247             (void)SvOK_off(dsv);
4248             return;
4249         }
4250         break;
4251     case SVt_IV:
4252         if (SvIOK(ssv)) {
4253             switch (dtype) {
4254             case SVt_NULL:
4255                 /* For performance, we inline promoting to type SVt_IV. */
4256                 /* We're starting from SVt_NULL, so provided that define is
4257                  * actual 0, we don't have to unset any SV type flags
4258                  * to promote to SVt_IV. */
4259                 STATIC_ASSERT_STMT(SVt_NULL == 0);
4260                 SET_SVANY_FOR_BODYLESS_IV(dsv);
4261                 SvFLAGS(dsv) |= SVt_IV;
4262                 break;
4263             case SVt_NV:
4264             case SVt_PV:
4265                 sv_upgrade(dsv, SVt_PVIV);
4266                 break;
4267             case SVt_PVGV:
4268             case SVt_PVLV:
4269                 goto end_of_first_switch;
4270             }
4271             (void)SvIOK_only(dsv);
4272             SvIV_set(dsv,  SvIVX(ssv));
4273             if (SvIsUV(ssv))
4274                 SvIsUV_on(dsv);
4275             /* SvTAINTED can only be true if the SV has taint magic, which in
4276                turn means that the SV type is PVMG (or greater). This is the
4277                case statement for SVt_IV, so this cannot be true (whatever gcov
4278                may say).  */
4279             assert(!SvTAINTED(ssv));
4280             return;
4281         }
4282         if (!SvROK(ssv))
4283             goto undef_sstr;
4284         if (dtype < SVt_PV && dtype != SVt_IV)
4285             sv_upgrade(dsv, SVt_IV);
4286         break;
4287 
4288     case SVt_NV:
4289         if (LIKELY( SvNOK(ssv) )) {
4290             switch (dtype) {
4291             case SVt_NULL:
4292             case SVt_IV:
4293                 sv_upgrade(dsv, SVt_NV);
4294                 break;
4295             case SVt_PV:
4296             case SVt_PVIV:
4297                 sv_upgrade(dsv, SVt_PVNV);
4298                 break;
4299             case SVt_PVGV:
4300             case SVt_PVLV:
4301                 goto end_of_first_switch;
4302             }
4303             SvNV_set(dsv, SvNVX(ssv));
4304             (void)SvNOK_only(dsv);
4305             /* SvTAINTED can only be true if the SV has taint magic, which in
4306                turn means that the SV type is PVMG (or greater). This is the
4307                case statement for SVt_NV, so this cannot be true (whatever gcov
4308                may say).  */
4309             assert(!SvTAINTED(ssv));
4310             return;
4311         }
4312         goto undef_sstr;
4313 
4314     case SVt_PV:
4315         if (dtype < SVt_PV)
4316             sv_upgrade(dsv, SVt_PV);
4317         break;
4318     case SVt_PVIV:
4319         if (dtype < SVt_PVIV)
4320             sv_upgrade(dsv, SVt_PVIV);
4321         break;
4322     case SVt_PVNV:
4323         if (dtype < SVt_PVNV)
4324             sv_upgrade(dsv, SVt_PVNV);
4325         break;
4326 
4327     case SVt_INVLIST:
4328         invlist_clone(ssv, dsv);
4329         return;
4330     default:
4331         {
4332         const char * const type = sv_reftype(ssv,0);
4333         if (PL_op)
4334             /* diag_listed_as: Bizarre copy of %s */
4335             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4336         else
4337             Perl_croak(aTHX_ "Bizarre copy of %s", type);
4338         }
4339         NOT_REACHED; /* NOTREACHED */
4340 
4341     case SVt_REGEXP:
4342       upgregexp:
4343         if (dtype < SVt_REGEXP)
4344             sv_upgrade(dsv, SVt_REGEXP);
4345         break;
4346 
4347     case SVt_PVLV:
4348     case SVt_PVGV:
4349     case SVt_PVMG:
4350         if (SvGMAGICAL(ssv) && (flags & SV_GMAGIC)) {
4351             mg_get(ssv);
4352             if (SvTYPE(ssv) != stype)
4353                 stype = SvTYPE(ssv);
4354         }
4355         if (isGV_with_GP(ssv) && dtype <= SVt_PVLV) {
4356                     glob_assign_glob(dsv, ssv, dtype);
4357                     return;
4358         }
4359         if (stype == SVt_PVLV)
4360         {
4361             if (isREGEXP(ssv)) goto upgregexp;
4362             SvUPGRADE(dsv, SVt_PVNV);
4363         }
4364         else
4365             SvUPGRADE(dsv, (svtype)stype);
4366     }
4367  end_of_first_switch:
4368 
4369     /* dsv may have been upgraded.  */
4370     dtype = SvTYPE(dsv);
4371     sflags = SvFLAGS(ssv);
4372 
4373     if (UNLIKELY( dtype == SVt_PVCV )) {
4374         /* Assigning to a subroutine sets the prototype.  */
4375         if (SvOK(ssv)) {
4376             STRLEN len;
4377             const char *const ptr = SvPV_const(ssv, len);
4378 
4379             SvGROW(dsv, len + 1);
4380             Copy(ptr, SvPVX(dsv), len + 1, char);
4381             SvCUR_set(dsv, len);
4382             SvPOK_only(dsv);
4383             SvFLAGS(dsv) |= sflags & SVf_UTF8;
4384             CvAUTOLOAD_off(dsv);
4385         } else {
4386             SvOK_off(dsv);
4387         }
4388     }
4389     else if (UNLIKELY(dtype == SVt_PVAV || dtype == SVt_PVHV
4390              || dtype == SVt_PVFM))
4391     {
4392         const char * const type = sv_reftype(dsv,0);
4393         if (PL_op)
4394             /* diag_listed_as: Cannot copy to %s */
4395             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4396         else
4397             Perl_croak(aTHX_ "Cannot copy to %s", type);
4398     } else if (sflags & SVf_ROK) {
4399         if (isGV_with_GP(dsv)
4400             && SvTYPE(SvRV(ssv)) == SVt_PVGV && isGV_with_GP(SvRV(ssv))) {
4401             ssv = SvRV(ssv);
4402             if (ssv == dsv) {
4403                 if (GvIMPORTED(dsv) != GVf_IMPORTED
4404                     && CopSTASH_ne(PL_curcop, GvSTASH(dsv)))
4405                 {
4406                     GvIMPORTED_on(dsv);
4407                 }
4408                 GvMULTI_on(dsv);
4409                 return;
4410             }
4411             glob_assign_glob(dsv, ssv, dtype);
4412             return;
4413         }
4414 
4415         if (dtype >= SVt_PV) {
4416             if (isGV_with_GP(dsv)) {
4417                 gv_setref(dsv, ssv);
4418                 return;
4419             }
4420             if (SvPVX_const(dsv)) {
4421                 SvPV_free(dsv);
4422                 SvLEN_set(dsv, 0);
4423                 SvCUR_set(dsv, 0);
4424             }
4425         }
4426         (void)SvOK_off(dsv);
4427         SvRV_set(dsv, SvREFCNT_inc(SvRV(ssv)));
4428         SvFLAGS(dsv) |= sflags & SVf_ROK;
4429         assert(!(sflags & SVp_NOK));
4430         assert(!(sflags & SVp_IOK));
4431         assert(!(sflags & SVf_NOK));
4432         assert(!(sflags & SVf_IOK));
4433     }
4434     else if (isGV_with_GP(dsv)) {
4435         if (!(sflags & SVf_OK)) {
4436             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4437                            "Undefined value assigned to typeglob");
4438         }
4439         else {
4440             GV *gv = gv_fetchsv_nomg(ssv, GV_ADD, SVt_PVGV);
4441             if (dsv != (const SV *)gv) {
4442                 const char * const name = GvNAME((const GV *)dsv);
4443                 const STRLEN len = GvNAMELEN(dsv);
4444                 HV *old_stash = NULL;
4445                 bool reset_isa = FALSE;
4446                 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4447                  || (len == 1 && name[0] == ':')) {
4448                     /* Set aside the old stash, so we can reset isa caches
4449                        on its subclasses. */
4450                     if((old_stash = GvHV(dsv))) {
4451                         /* Make sure we do not lose it early. */
4452                         SvREFCNT_inc_simple_void_NN(
4453                          sv_2mortal((SV *)old_stash)
4454                         );
4455                     }
4456                     reset_isa = TRUE;
4457                 }
4458 
4459                 if (GvGP(dsv)) {
4460                     SvREFCNT_inc_simple_void_NN(sv_2mortal(dsv));
4461                     gp_free(MUTABLE_GV(dsv));
4462                 }
4463                 GvGP_set(dsv, gp_ref(GvGP(gv)));
4464 
4465                 if (reset_isa) {
4466                     HV * const stash = GvHV(dsv);
4467                     if(
4468                         old_stash ? HvHasENAME(old_stash) : cBOOL(stash)
4469                     )
4470                         mro_package_moved(
4471                          stash, old_stash,
4472                          (GV *)dsv, 0
4473                         );
4474                 }
4475             }
4476         }
4477     }
4478     else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4479           && (stype == SVt_REGEXP || isREGEXP(ssv))) {
4480         reg_temp_copy((REGEXP*)dsv, (REGEXP*)ssv);
4481     }
4482     else if (sflags & SVp_POK) {
4483         const STRLEN cur = SvCUR(ssv);
4484         const STRLEN len = SvLEN(ssv);
4485 
4486         /*
4487          * We have three basic ways to copy the string:
4488          *
4489          *  1. Swipe
4490          *  2. Copy-on-write
4491          *  3. Actual copy
4492          *
4493          * Which we choose is based on various factors.  The following
4494          * things are listed in order of speed, fastest to slowest:
4495          *  - Swipe
4496          *  - Copying a short string
4497          *  - Copy-on-write bookkeeping
4498          *  - malloc
4499          *  - Copying a long string
4500          *
4501          * We swipe the string (steal the string buffer) if the SV on the
4502          * rhs is about to be freed anyway (TEMP and refcnt==1).  This is a
4503          * big win on long strings.  It should be a win on short strings if
4504          * SvPVX_const(dsv) has to be allocated.  If not, it should not
4505          * slow things down, as SvPVX_const(ssv) would have been freed
4506          * soon anyway.
4507          *
4508          * We also steal the buffer from a PADTMP (operator target) if it
4509          * is ‘long enough’.  For short strings, a swipe does not help
4510          * here, as it causes more malloc calls the next time the target
4511          * is used.  Benchmarks show that even if SvPVX_const(dsv) has to
4512          * be allocated it is still not worth swiping PADTMPs for short
4513          * strings, as the savings here are small.
4514          *
4515          * If swiping is not an option, then we see whether it is worth using
4516          * copy-on-write.  If the lhs already has a buffer big enough and the
4517          * string is short, we skip it and fall back to method 3, since memcpy
4518          * is faster for short strings than the later bookkeeping overhead that
4519          * copy-on-write entails.
4520 
4521          * If the rhs is not a copy-on-write string yet, then we also
4522          * consider whether the buffer is too large relative to the string
4523          * it holds.  Some operations such as readline allocate a large
4524          * buffer in the expectation of reusing it.  But turning such into
4525          * a COW buffer is counter-productive because it increases memory
4526          * usage by making readline allocate a new large buffer the sec-
4527          * ond time round.  So, if the buffer is too large, again, we use
4528          * method 3 (copy).
4529          *
4530          * Finally, if there is no buffer on the left, or the buffer is too
4531          * small, then we use copy-on-write and make both SVs share the
4532          * string buffer.
4533          *
4534          */
4535 
4536         /* Whichever path we take through the next code, we want this true,
4537            and doing it now facilitates the COW check.  */
4538         (void)SvPOK_only(dsv);
4539 
4540         if (
4541                  (              /* Either ... */
4542                                 /* slated for free anyway (and not COW)? */
4543                     (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
4544                                 /* or a swipable TARG */
4545                  || ((sflags &
4546                            (SVs_PADTMP|SVf_READONLY|SVf_PROTECT|SVf_IsCOW))
4547                        == SVs_PADTMP
4548                                 /* whose buffer is worth stealing */
4549                      && CHECK_COWBUF_THRESHOLD(cur,len)
4550                     )
4551                  ) &&
4552                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4553                  (!(flags & SV_NOSTEAL)) &&
4554                                         /* and we're allowed to steal temps */
4555                  SvREFCNT(ssv) == 1 &&   /* and no other references to it? */
4556                  len)             /* and really is a string */
4557         {	/* Passes the swipe test.  */
4558             if (SvPVX_const(dsv))	/* we know that dtype >= SVt_PV */
4559                 SvPV_free(dsv);
4560             SvPV_set(dsv, SvPVX_mutable(ssv));
4561             SvLEN_set(dsv, SvLEN(ssv));
4562             SvCUR_set(dsv, SvCUR(ssv));
4563 
4564             SvTEMP_off(dsv);
4565             (void)SvOK_off(ssv);	/* NOTE: nukes most SvFLAGS on ssv */
4566             SvPV_set(ssv, NULL);
4567             SvLEN_set(ssv, 0);
4568             SvCUR_set(ssv, 0);
4569             SvTEMP_off(ssv);
4570         }
4571         /* We must check for SvIsCOW_static() even without
4572          * SV_COW_SHARED_HASH_KEYS being set or else we'll break SvIsBOOL()
4573          */
4574         else if (SvIsCOW_static(ssv)) {
4575             if (SvPVX_const(dsv)) {     /* we know that dtype >= SVt_PV */
4576                 SvPV_free(dsv);
4577             }
4578             SvPV_set(dsv, SvPVX(ssv));
4579             SvLEN_set(dsv, 0);
4580             SvCUR_set(dsv, cur);
4581             SvFLAGS(dsv) |= (SVf_IsCOW|SVppv_STATIC);
4582         }
4583         else if (flags & SV_COW_SHARED_HASH_KEYS
4584               &&
4585 #ifdef PERL_COPY_ON_WRITE
4586                  (sflags & SVf_IsCOW
4587                    ? (!len ||
4588                        (  (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dsv) < cur+1)
4589                           /* If this is a regular (non-hek) COW, only so
4590                              many COW "copies" are possible. */
4591                        && CowREFCNT(ssv) != SV_COW_REFCNT_MAX  ))
4592                    : (  (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4593                      && !(SvFLAGS(dsv) & SVf_BREAK)
4594                      && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len
4595                      && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dsv) < cur+1)
4596                     ))
4597 #else
4598                  sflags & SVf_IsCOW
4599               && !(SvFLAGS(dsv) & SVf_BREAK)
4600 #endif
4601             ) {
4602             /* Either it's a shared hash key, or it's suitable for
4603                copy-on-write.  */
4604 #ifdef DEBUGGING
4605             if (DEBUG_C_TEST) {
4606                 PerlIO_printf(Perl_debug_log, "Copy on write: ssv --> dsv\n");
4607                 sv_dump(ssv);
4608                 sv_dump(dsv);
4609             }
4610 #endif
4611 #ifdef PERL_ANY_COW
4612             if (!(sflags & SVf_IsCOW)) {
4613                     SvIsCOW_on(ssv);
4614                     CowREFCNT(ssv) = 0;
4615             }
4616 #endif
4617             if (SvPVX_const(dsv)) {	/* we know that dtype >= SVt_PV */
4618                 SvPV_free(dsv);
4619             }
4620 
4621 #ifdef PERL_ANY_COW
4622             if (len) {
4623                     if (sflags & SVf_IsCOW) {
4624                         sv_buf_to_rw(ssv);
4625                     }
4626                     CowREFCNT(ssv)++;
4627                     SvPV_set(dsv, SvPVX_mutable(ssv));
4628                     sv_buf_to_ro(ssv);
4629             } else
4630 #endif
4631             {
4632                     /* SvIsCOW_shared_hash */
4633                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4634                                           "Copy on write: Sharing hash\n"));
4635 
4636                     assert (SvTYPE(dsv) >= SVt_PV);
4637                     SvPV_set(dsv,
4638                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv)))));
4639             }
4640             SvLEN_set(dsv, len);
4641             SvCUR_set(dsv, cur);
4642             SvIsCOW_on(dsv);
4643         } else {
4644             /* Failed the swipe test, and we cannot do copy-on-write either.
4645                Have to copy the string.  */
4646             SvGROW(dsv, cur + 1);	/* inlined from sv_setpvn */
4647             Move(SvPVX_const(ssv),SvPVX(dsv),cur,char);
4648             SvCUR_set(dsv, cur);
4649             *SvEND(dsv) = '\0';
4650         }
4651         if (sflags & SVp_NOK) {
4652             SvNV_set(dsv, SvNVX(ssv));
4653             if ((sflags & SVf_NOK) && !(sflags & SVf_POK)) {
4654                 /* Source was SVf_NOK|SVp_NOK|SVp_POK but not SVf_POK, meaning
4655                    a value set as floating point and later stringified, where
4656                   the value happens to be one of the few that we know aren't
4657                   affected by the numeric locale, hence we can cache the
4658                   stringification. Currently that's  +Inf, -Inf and NaN, but
4659                   conceivably we might extend this to -9 .. +9 (excluding -0).
4660                   So mark destination the same: */
4661                 SvFLAGS(dsv) &= ~SVf_POK;
4662             }
4663         }
4664         if (sflags & SVp_IOK) {
4665             SvIV_set(dsv, SvIVX(ssv));
4666             if (sflags & SVf_IVisUV)
4667                 SvIsUV_on(dsv);
4668             if ((sflags & SVf_IOK) && !(sflags & SVf_POK)) {
4669                 /* Source was SVf_IOK|SVp_IOK|SVp_POK but not SVf_POK, meaning
4670                    a value set as an integer and later stringified. So mark
4671                    destination the same: */
4672                 SvFLAGS(dsv) &= ~SVf_POK;
4673             }
4674         }
4675         SvFLAGS(dsv) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4676         {
4677             const MAGIC * const smg = SvVSTRING_mg(ssv);
4678             if (smg) {
4679                 sv_magic(dsv, NULL, PERL_MAGIC_vstring,
4680                          smg->mg_ptr, smg->mg_len);
4681                 SvRMAGICAL_on(dsv);
4682             }
4683         }
4684     }
4685     else if (sflags & (SVp_IOK|SVp_NOK)) {
4686         (void)SvOK_off(dsv);
4687         SvFLAGS(dsv) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4688         if (sflags & SVp_IOK) {
4689             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4690             SvIV_set(dsv, SvIVX(ssv));
4691         }
4692         if (sflags & SVp_NOK) {
4693             SvNV_set(dsv, SvNVX(ssv));
4694         }
4695     }
4696     else {
4697         if (isGV_with_GP(ssv)) {
4698             gv_efullname3(dsv, MUTABLE_GV(ssv), "*");
4699         }
4700         else
4701             (void)SvOK_off(dsv);
4702     }
4703     if (SvTAINTED(ssv))
4704         SvTAINT(dsv);
4705 }
4706 
4707 
4708 /*
4709 =for apidoc sv_set_undef
4710 
4711 Equivalent to C<sv_setsv(sv, &PL_sv_undef)>, but more efficient.
4712 Doesn't handle set magic.
4713 
4714 The perl equivalent is C<$sv = undef;>. Note that it doesn't free any string
4715 buffer, unlike C<undef $sv>.
4716 
4717 Introduced in perl 5.25.12.
4718 
4719 =cut
4720 */
4721 
4722 void
4723 Perl_sv_set_undef(pTHX_ SV *sv)
4724 {
4725     U32 type = SvTYPE(sv);
4726 
4727     PERL_ARGS_ASSERT_SV_SET_UNDEF;
4728 
4729     /* shortcut, NULL, IV, RV */
4730 
4731     if (type <= SVt_IV) {
4732         assert(!SvGMAGICAL(sv));
4733         if (SvREADONLY(sv)) {
4734             /* does undeffing PL_sv_undef count as modifying a read-only
4735              * variable? Some XS code does this */
4736             if (sv == &PL_sv_undef)
4737                 return;
4738             Perl_croak_no_modify();
4739         }
4740 
4741         if (SvROK(sv)) {
4742             if (SvWEAKREF(sv))
4743                 sv_unref_flags(sv, 0);
4744             else {
4745                 SV *rv = SvRV(sv);
4746                 SvFLAGS(sv) = type; /* quickly turn off all flags */
4747                 SvREFCNT_dec_NN(rv);
4748                 return;
4749             }
4750         }
4751         SvFLAGS(sv) = type; /* quickly turn off all flags */
4752         return;
4753     }
4754 
4755     if (SvIS_FREED(sv))
4756         Perl_croak(aTHX_ "panic: attempt to undefine a freed scalar %p",
4757             (void *)sv);
4758 
4759     SV_CHECK_THINKFIRST_COW_DROP(sv);
4760 
4761     if (isGV_with_GP(sv))
4762         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4763                        "Undefined value assigned to typeglob");
4764     else
4765         SvOK_off(sv);
4766 }
4767 
4768 /*
4769 =for apidoc sv_set_true
4770 
4771 Equivalent to C<sv_setsv(sv, &PL_sv_yes)>, but may be made more
4772 efficient in the future. Doesn't handle set magic.
4773 
4774 The perl equivalent is C<$sv = !0;>.
4775 
4776 Introduced in perl 5.35.11.
4777 
4778 =cut
4779 */
4780 
4781 void
4782 Perl_sv_set_true(pTHX_ SV *sv)
4783 {
4784     PERL_ARGS_ASSERT_SV_SET_TRUE;
4785     sv_setsv(sv, &PL_sv_yes);
4786 }
4787 
4788 /*
4789 =for apidoc sv_set_false
4790 
4791 Equivalent to C<sv_setsv(sv, &PL_sv_no)>, but may be made more
4792 efficient in the future. Doesn't handle set magic.
4793 
4794 The perl equivalent is C<$sv = !1;>.
4795 
4796 Introduced in perl 5.35.11.
4797 
4798 =cut
4799 */
4800 
4801 void
4802 Perl_sv_set_false(pTHX_ SV *sv)
4803 {
4804     PERL_ARGS_ASSERT_SV_SET_FALSE;
4805     sv_setsv(sv, &PL_sv_no);
4806 }
4807 
4808 /*
4809 =for apidoc sv_set_bool
4810 
4811 Equivalent to C<sv_setsv(sv, bool_val ? &Pl_sv_yes : &PL_sv_no)>, but
4812 may be made more efficient in the future. Doesn't handle set magic.
4813 
4814 The perl equivalent is C<$sv = !!$expr;>.
4815 
4816 Introduced in perl 5.35.11.
4817 
4818 =cut
4819 */
4820 
4821 void
4822 Perl_sv_set_bool(pTHX_ SV *sv, const bool bool_val)
4823 {
4824     PERL_ARGS_ASSERT_SV_SET_BOOL;
4825     sv_setsv(sv, bool_val ? &PL_sv_yes : &PL_sv_no);
4826 }
4827 
4828 
4829 void
4830 Perl_sv_setsv_mg(pTHX_ SV *const dsv, SV *const ssv)
4831 {
4832     PERL_ARGS_ASSERT_SV_SETSV_MG;
4833 
4834     sv_setsv(dsv,ssv);
4835     SvSETMAGIC(dsv);
4836 }
4837 
4838 #ifdef PERL_ANY_COW
4839 #  define SVt_COW SVt_PV
4840 SV *
4841 Perl_sv_setsv_cow(pTHX_ SV *dsv, SV *ssv)
4842 {
4843     STRLEN cur = SvCUR(ssv);
4844     STRLEN len = SvLEN(ssv);
4845     char *new_pv;
4846     U32 new_flags = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
4847 #if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_COPY_ON_WRITE)
4848     const bool already = cBOOL(SvIsCOW(ssv));
4849 #endif
4850 
4851     PERL_ARGS_ASSERT_SV_SETSV_COW;
4852 #ifdef DEBUGGING
4853     if (DEBUG_C_TEST) {
4854         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4855                       (void*)ssv, (void*)dsv);
4856         sv_dump(ssv);
4857         if (dsv)
4858                     sv_dump(dsv);
4859     }
4860 #endif
4861     if (dsv) {
4862         if (SvTHINKFIRST(dsv))
4863             sv_force_normal_flags(dsv, SV_COW_DROP_PV);
4864         else if (SvPVX_const(dsv))
4865             Safefree(SvPVX_mutable(dsv));
4866         SvUPGRADE(dsv, SVt_COW);
4867     }
4868     else
4869         dsv = newSV_type(SVt_COW);
4870 
4871     assert (SvPOK(ssv));
4872     assert (SvPOKp(ssv));
4873 
4874     if (SvIsCOW(ssv)) {
4875         if (SvIsCOW_shared_hash(ssv)) {
4876             /* source is a COW shared hash key.  */
4877             DEBUG_C(PerlIO_printf(Perl_debug_log,
4878                                   "Fast copy on write: Sharing hash\n"));
4879             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv))));
4880             goto common_exit;
4881         }
4882         else if (SvIsCOW_static(ssv)) {
4883             /* source is static constant; preserve this */
4884             new_pv = SvPVX(ssv);
4885             new_flags |= SVppv_STATIC;
4886             goto common_exit;
4887         }
4888         assert(SvCUR(ssv)+1 < SvLEN(ssv));
4889         assert(CowREFCNT(ssv) < SV_COW_REFCNT_MAX);
4890     } else {
4891         assert ((SvFLAGS(ssv) & CAN_COW_MASK) == CAN_COW_FLAGS);
4892         SvUPGRADE(ssv, SVt_COW);
4893         SvIsCOW_on(ssv);
4894         DEBUG_C(PerlIO_printf(Perl_debug_log,
4895                               "Fast copy on write: Converting ssv to COW\n"));
4896         CowREFCNT(ssv) = 0;
4897     }
4898 #  ifdef PERL_DEBUG_READONLY_COW
4899     if (already) sv_buf_to_rw(ssv);
4900 #  endif
4901     CowREFCNT(ssv)++;
4902     new_pv = SvPVX_mutable(ssv);
4903     sv_buf_to_ro(ssv);
4904 
4905   common_exit:
4906     SvPV_set(dsv, new_pv);
4907     SvFLAGS(dsv) = new_flags;
4908     if (SvUTF8(ssv))
4909         SvUTF8_on(dsv);
4910     SvLEN_set(dsv, len);
4911     SvCUR_set(dsv, cur);
4912 #ifdef DEBUGGING
4913     if (DEBUG_C_TEST)
4914                 sv_dump(dsv);
4915 #endif
4916     return dsv;
4917 }
4918 #endif
4919 
4920 /*
4921 =for apidoc sv_setpv_bufsize
4922 
4923 Sets the SV to be a string of cur bytes length, with at least
4924 len bytes available. Ensures that there is a null byte at SvEND.
4925 Returns a char * pointer to the SvPV buffer.
4926 
4927 =cut
4928 */
4929 
4930 char *
4931 Perl_sv_setpv_bufsize(pTHX_ SV *const sv, const STRLEN cur, const STRLEN len)
4932 {
4933     char *pv;
4934 
4935     PERL_ARGS_ASSERT_SV_SETPV_BUFSIZE;
4936 
4937     SV_CHECK_THINKFIRST_COW_DROP(sv);
4938     SvUPGRADE(sv, SVt_PV);
4939     pv = SvGROW(sv, len + 1);
4940     SvCUR_set(sv, cur);
4941     *(SvEND(sv))= '\0';
4942     (void)SvPOK_only_UTF8(sv);                /* validate pointer */
4943 
4944     SvTAINT(sv);
4945     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4946     return pv;
4947 }
4948 
4949 /*
4950 =for apidoc            sv_setpv
4951 =for apidoc_item       sv_setpv_mg
4952 =for apidoc_item       sv_setpvn
4953 =for apidoc_item       sv_setpvn_fresh
4954 =for apidoc_item       sv_setpvn_mg
4955 =for apidoc_item |void|sv_setpvs|SV* sv|"literal string"
4956 =for apidoc_item |void|sv_setpvs_mg|SV* sv|"literal string"
4957 
4958 These copy a string into the SV C<sv>, making sure it is C<L</SvPOK_only>>.
4959 
4960 In the C<pvs> forms, the string must be a C literal string, enclosed in double
4961 quotes.
4962 
4963 In the C<pvn> forms, the first byte of the string is pointed to by C<ptr>, and
4964 C<len> indicates the number of bytes to be copied, potentially including
4965 embedded C<NUL> characters.
4966 
4967 In the plain C<pv> forms, C<ptr> points to a NUL-terminated C string.  That is,
4968 it points to the first byte of the string, and the copy proceeds up through the
4969 first encountered C<NUL> byte.
4970 
4971 In the forms that take a C<ptr> argument, if it is NULL, the SV will become
4972 undefined.
4973 
4974 The UTF-8 flag is not changed by these functions.  A terminating NUL byte is
4975 guaranteed in the result.
4976 
4977 The C<_mg> forms handle 'set' magic; the other forms skip all magic.
4978 
4979 C<sv_setpvn_fresh> is a cut-down alternative to C<sv_setpvn>, intended ONLY
4980 to be used with a fresh sv that has been upgraded to a SVt_PV, SVt_PVIV,
4981 SVt_PVNV, or SVt_PVMG.
4982 
4983 =cut
4984 */
4985 
4986 void
4987 Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4988 {
4989     char *dptr;
4990 
4991     PERL_ARGS_ASSERT_SV_SETPVN;
4992 
4993     SV_CHECK_THINKFIRST_COW_DROP(sv);
4994     if (isGV_with_GP(sv))
4995         Perl_croak_no_modify();
4996     if (!ptr) {
4997         (void)SvOK_off(sv);
4998         return;
4999     }
5000     else {
5001         /* len is STRLEN which is unsigned, need to copy to signed */
5002         const IV iv = len;
5003         if (iv < 0)
5004             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
5005                        IVdf, iv);
5006     }
5007     SvUPGRADE(sv, SVt_PV);
5008 
5009     dptr = SvGROW(sv, len + 1);
5010     Move(ptr,dptr,len,char);
5011     dptr[len] = '\0';
5012     SvCUR_set(sv, len);
5013     (void)SvPOK_only_UTF8(sv);		/* validate pointer */
5014     SvTAINT(sv);
5015     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
5016 }
5017 
5018 void
5019 Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
5020 {
5021     PERL_ARGS_ASSERT_SV_SETPVN_MG;
5022 
5023     sv_setpvn(sv,ptr,len);
5024     SvSETMAGIC(sv);
5025 }
5026 
5027 void
5028 Perl_sv_setpvn_fresh(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
5029 {
5030     char *dptr;
5031 
5032     PERL_ARGS_ASSERT_SV_SETPVN_FRESH;
5033     assert(SvTYPE(sv) >= SVt_PV && SvTYPE(sv) <= SVt_PVMG);
5034     assert(!SvTHINKFIRST(sv));
5035     assert(!isGV_with_GP(sv));
5036 
5037     if (ptr) {
5038         const IV iv = len;
5039         /* len is STRLEN which is unsigned, need to copy to signed */
5040         if (iv < 0)
5041             Perl_croak(aTHX_ "panic: sv_setpvn_fresh called with negative strlen %"
5042                        IVdf, iv);
5043 
5044         dptr = sv_grow_fresh(sv, len + 1);
5045         Move(ptr,dptr,len,char);
5046         dptr[len] = '\0';
5047         SvCUR_set(sv, len);
5048         SvPOK_on(sv);
5049         SvTAINT(sv);
5050     }
5051 }
5052 
5053 void
5054 Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
5055 {
5056     STRLEN len;
5057 
5058     PERL_ARGS_ASSERT_SV_SETPV;
5059 
5060     SV_CHECK_THINKFIRST_COW_DROP(sv);
5061     if (!ptr) {
5062         (void)SvOK_off(sv);
5063         return;
5064     }
5065     len = strlen(ptr);
5066     SvUPGRADE(sv, SVt_PV);
5067 
5068     SvGROW(sv, len + 1);
5069     Move(ptr,SvPVX(sv),len+1,char);
5070     SvCUR_set(sv, len);
5071     (void)SvPOK_only_UTF8(sv);		/* validate pointer */
5072     SvTAINT(sv);
5073     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
5074 }
5075 
5076 void
5077 Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
5078 {
5079     PERL_ARGS_ASSERT_SV_SETPV_MG;
5080 
5081     sv_setpv(sv,ptr);
5082     SvSETMAGIC(sv);
5083 }
5084 
5085 void
5086 Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
5087 {
5088     PERL_ARGS_ASSERT_SV_SETHEK;
5089 
5090     if (!hek) {
5091         return;
5092     }
5093 
5094     if (HEK_LEN(hek) == HEf_SVKEY) {
5095         sv_setsv(sv, *(SV**)HEK_KEY(hek));
5096         return;
5097     } else {
5098         const int flags = HEK_FLAGS(hek);
5099         if (flags & HVhek_WASUTF8) {
5100             STRLEN utf8_len = HEK_LEN(hek);
5101             char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
5102             sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
5103             SvUTF8_on(sv);
5104             return;
5105         } else if (flags & HVhek_NOTSHARED) {
5106             sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
5107             if (HEK_UTF8(hek))
5108                 SvUTF8_on(sv);
5109             else SvUTF8_off(sv);
5110             return;
5111         }
5112         {
5113             SV_CHECK_THINKFIRST_COW_DROP(sv);
5114             SvUPGRADE(sv, SVt_PV);
5115             SvPV_free(sv);
5116             SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
5117             SvCUR_set(sv, HEK_LEN(hek));
5118             SvLEN_set(sv, 0);
5119             SvIsCOW_on(sv);
5120             SvPOK_on(sv);
5121             if (HEK_UTF8(hek))
5122                 SvUTF8_on(sv);
5123             else SvUTF8_off(sv);
5124             return;
5125         }
5126     }
5127 }
5128 
5129 
5130 /*
5131 =for apidoc      sv_usepvn
5132 =for apidoc_item sv_usepvn_flags
5133 =for apidoc_item sv_usepvn_mg
5134 
5135 These tell an SV to use C<ptr> for its string value.  Normally SVs have
5136 their string stored inside the SV, but these tell the SV to use an
5137 external string instead.
5138 
5139 C<ptr> should point to memory that was allocated
5140 by L</C<Newx>>.  It must be
5141 the start of a C<Newx>-ed block of memory, and not a pointer to the
5142 middle of it (beware of L<C<OOK>|perlguts/Offsets> and copy-on-write),
5143 and not be from a non-C<Newx> memory allocator like C<malloc>.  The
5144 string length, C<len>, must be supplied.  By default this function
5145 will L</C<Renew>> (i.e. realloc, move) the memory pointed to by C<ptr>,
5146 so that the pointer should not be freed or used by the programmer after giving
5147 it to C<sv_usepvn>, and neither should any pointers from "behind" that pointer
5148 (I<e.g.>, S<C<ptr> + 1>) be used.
5149 
5150 In the C<sv_usepvn_flags> form, if S<C<flags & SV_SMAGIC>> is true,
5151 C<SvSETMAGIC> is called before returning.
5152 And if S<C<flags & SV_HAS_TRAILING_NUL>> is true, then C<ptr[len]> must be
5153 C<NUL>, and the realloc will be skipped (I<i.e.>, the buffer is actually at
5154 least 1 byte longer than C<len>, and already meets the requirements for storing
5155 in C<SvPVX>).
5156 
5157 C<sv_usepvn> is merely C<sv_usepvn_flags> with C<flags> set to 0, so 'set'
5158 magic is skipped.
5159 
5160 C<sv_usepvn_mg> is merely C<sv_usepvn_flags> with C<flags> set to C<SV_SMAGIC>,
5161 so 'set' magic is performed.
5162 
5163 =for apidoc Amnh||SV_SMAGIC
5164 =for apidoc Amnh||SV_HAS_TRAILING_NUL
5165 
5166 =cut
5167 */
5168 
5169 void
5170 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
5171 {
5172     STRLEN allocate;
5173 
5174     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
5175 
5176     SV_CHECK_THINKFIRST_COW_DROP(sv);
5177     SvUPGRADE(sv, SVt_PV);
5178     if (!ptr) {
5179         (void)SvOK_off(sv);
5180         if (flags & SV_SMAGIC)
5181             SvSETMAGIC(sv);
5182         return;
5183     }
5184     if (SvPVX_const(sv))
5185         SvPV_free(sv);
5186 
5187 #ifdef DEBUGGING
5188     if (flags & SV_HAS_TRAILING_NUL)
5189         assert(ptr[len] == '\0');
5190 #endif
5191 
5192     allocate = (flags & SV_HAS_TRAILING_NUL)
5193         ? len + 1 :
5194 #ifdef Perl_safesysmalloc_size
5195         len + 1;
5196 #else
5197         PERL_STRLEN_ROUNDUP(len + 1);
5198 #endif
5199     if (flags & SV_HAS_TRAILING_NUL) {
5200         /* It's long enough - do nothing.
5201            Specifically Perl_newCONSTSUB is relying on this.  */
5202     } else {
5203 #ifdef DEBUGGING
5204         /* Force a move to shake out bugs in callers.  */
5205         char *new_ptr = (char*)safemalloc(allocate);
5206         Copy(ptr, new_ptr, len, char);
5207         PoisonFree(ptr,len,char);
5208         Safefree(ptr);
5209         ptr = new_ptr;
5210 #else
5211         ptr = (char*) saferealloc (ptr, allocate);
5212 #endif
5213     }
5214 #ifdef Perl_safesysmalloc_size
5215     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
5216 #else
5217     SvLEN_set(sv, allocate);
5218 #endif
5219     SvCUR_set(sv, len);
5220     SvPV_set(sv, ptr);
5221     if (!(flags & SV_HAS_TRAILING_NUL)) {
5222         ptr[len] = '\0';
5223     }
5224     (void)SvPOK_only_UTF8(sv);		/* validate pointer */
5225     SvTAINT(sv);
5226     if (flags & SV_SMAGIC)
5227         SvSETMAGIC(sv);
5228 }
5229 
5230 
5231 static void
5232 S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
5233 {
5234     assert(SvIsCOW(sv));
5235     {
5236 #ifdef PERL_ANY_COW
5237         const char * const pvx = SvPVX_const(sv);
5238         const STRLEN len = SvLEN(sv);
5239         const STRLEN cur = SvCUR(sv);
5240         const bool was_shared_hek = SvIsCOW_shared_hash(sv);
5241 
5242 #ifdef DEBUGGING
5243         if (DEBUG_C_TEST) {
5244                 PerlIO_printf(Perl_debug_log,
5245                               "Copy on write: Force normal %ld\n",
5246                               (long) flags);
5247                 sv_dump(sv);
5248         }
5249 #endif
5250         SvIsCOW_off(sv);
5251 # ifdef PERL_COPY_ON_WRITE
5252         if (len) {
5253             /* Must do this first, since the CowREFCNT uses SvPVX and
5254             we need to write to CowREFCNT, or de-RO the whole buffer if we are
5255             the only owner left of the buffer. */
5256             sv_buf_to_rw(sv); /* NOOP if RO-ing not supported */
5257             {
5258                 U8 cowrefcnt = CowREFCNT(sv);
5259                 if(cowrefcnt != 0) {
5260                     cowrefcnt--;
5261                     CowREFCNT(sv) = cowrefcnt;
5262                     sv_buf_to_ro(sv);
5263                     goto copy_over;
5264                 }
5265             }
5266             /* Else we are the only owner of the buffer. */
5267         }
5268         else
5269 # endif
5270         {
5271             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
5272             copy_over:
5273             SvPV_set(sv, NULL);
5274             SvCUR_set(sv, 0);
5275             SvLEN_set(sv, 0);
5276             if (flags & SV_COW_DROP_PV) {
5277                 /* OK, so we don't need to copy our buffer.  */
5278                 SvPOK_off(sv);
5279             } else {
5280                 SvGROW(sv, cur + 1);
5281                 Move(pvx,SvPVX(sv),cur,char);
5282                 SvCUR_set(sv, cur);
5283                 *SvEND(sv) = '\0';
5284             }
5285             if (was_shared_hek) {
5286                         unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5287             }
5288 #ifdef DEBUGGING
5289             if (DEBUG_C_TEST)
5290                 sv_dump(sv);
5291 #endif
5292         }
5293 #else
5294             const char * const pvx = SvPVX_const(sv);
5295             const STRLEN len = SvCUR(sv);
5296             SvIsCOW_off(sv);
5297             SvPV_set(sv, NULL);
5298             SvLEN_set(sv, 0);
5299             if (flags & SV_COW_DROP_PV) {
5300                 /* OK, so we don't need to copy our buffer.  */
5301                 SvPOK_off(sv);
5302             } else {
5303                 SvGROW(sv, len + 1);
5304                 Move(pvx,SvPVX(sv),len,char);
5305                 *SvEND(sv) = '\0';
5306             }
5307             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5308 #endif
5309     }
5310 }
5311 
5312 
5313 /*
5314 =for apidoc sv_force_normal_flags
5315 
5316 Undo various types of fakery on an SV, where fakery means
5317 "more than" a string: if the PV is a shared string, make
5318 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5319 an C<xpvmg>; if we're a copy-on-write scalar, this is the on-write time when
5320 we do the copy, and is also used locally; if this is a
5321 vstring, drop the vstring magic.  If C<SV_COW_DROP_PV> is set
5322 then a copy-on-write scalar drops its PV buffer (if any) and becomes
5323 C<SvPOK_off> rather than making a copy.  (Used where this
5324 scalar is about to be set to some other value.)  In addition,
5325 the C<flags> parameter gets passed to C<sv_unref_flags()>
5326 when unreffing.  C<sv_force_normal> calls this function
5327 with flags set to 0.
5328 
5329 This function is expected to be used to signal to perl that this SV is
5330 about to be written to, and any extra book-keeping needs to be taken care
5331 of.  Hence, it croaks on read-only values.
5332 
5333 =for apidoc Amnh||SV_COW_DROP_PV
5334 
5335 =cut
5336 */
5337 
5338 void
5339 Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
5340 {
5341     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
5342 
5343     if (SvREADONLY(sv))
5344         Perl_croak_no_modify();
5345     else if (SvIsCOW(sv) && LIKELY(SvTYPE(sv) != SVt_PVHV))
5346         S_sv_uncow(aTHX_ sv, flags);
5347     if (SvROK(sv))
5348         sv_unref_flags(sv, flags);
5349     else if (SvFAKE(sv) && isGV_with_GP(sv))
5350         sv_unglob(sv, flags);
5351     else if (SvFAKE(sv) && isREGEXP(sv)) {
5352         /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
5353            to sv_unglob. We only need it here, so inline it.  */
5354         const bool islv = SvTYPE(sv) == SVt_PVLV;
5355         const svtype new_type =
5356           islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
5357         SV *const temp = newSV_type(new_type);
5358         regexp *old_rx_body;
5359 
5360         if (new_type == SVt_PVMG) {
5361             SvMAGIC_set(temp, SvMAGIC(sv));
5362             SvMAGIC_set(sv, NULL);
5363             SvSTASH_set(temp, SvSTASH(sv));
5364             SvSTASH_set(sv, NULL);
5365         }
5366         if (!islv)
5367             SvCUR_set(temp, SvCUR(sv));
5368         /* Remember that SvPVX is in the head, not the body. */
5369         assert(ReANY((REGEXP *)sv)->mother_re);
5370 
5371         if (islv) {
5372             /* LV-as-regex has sv->sv_any pointing to an XPVLV body,
5373              * whose xpvlenu_rx field points to the regex body */
5374             XPV *xpv = (XPV*)(SvANY(sv));
5375             old_rx_body = xpv->xpv_len_u.xpvlenu_rx;
5376             xpv->xpv_len_u.xpvlenu_rx = NULL;
5377         }
5378         else
5379             old_rx_body = ReANY((REGEXP *)sv);
5380 
5381         /* Their buffer is already owned by someone else. */
5382         if (flags & SV_COW_DROP_PV) {
5383             /* SvLEN is already 0.  For SVt_REGEXP, we have a brand new
5384                zeroed body.  For SVt_PVLV, we zeroed it above (len field
5385                a union with xpvlenu_rx) */
5386             assert(!SvLEN(islv ? sv : temp));
5387             sv->sv_u.svu_pv = 0;
5388         }
5389         else {
5390             sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
5391             SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
5392             SvPOK_on(sv);
5393         }
5394 
5395         /* Now swap the rest of the bodies. */
5396 
5397         SvFAKE_off(sv);
5398         if (!islv) {
5399             SvFLAGS(sv) &= ~SVTYPEMASK;
5400             SvFLAGS(sv) |= new_type;
5401             SvANY(sv) = SvANY(temp);
5402         }
5403 
5404         SvFLAGS(temp) &= ~(SVTYPEMASK);
5405         SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
5406         SvANY(temp) = old_rx_body;
5407 
5408         /* temp is now rebuilt as a correctly structured SVt_REGEXP, so this
5409          * will trigger a call to sv_clear() which will correctly free the
5410          * body. */
5411         SvREFCNT_dec_NN(temp);
5412     }
5413     else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
5414 }
5415 
5416 /*
5417 =for apidoc sv_chop
5418 
5419 Efficient removal of characters from the beginning of the string buffer.
5420 C<SvPOK(sv)>, or at least C<SvPOKp(sv)>, must be true and C<ptr> must be a
5421 pointer to somewhere inside the string buffer.  C<ptr> becomes the first
5422 character of the adjusted string.  Uses the C<OOK> hack.  On return, only
5423 C<SvPOK(sv)> and C<SvPOKp(sv)> among the C<OK> flags will be true.
5424 
5425 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
5426 refer to the same chunk of data.
5427 
5428 The unfortunate similarity of this function's name to that of Perl's C<chop>
5429 operator is strictly coincidental.  This function works from the left;
5430 C<chop> works from the right.
5431 
5432 =cut
5433 */
5434 
5435 void
5436 Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
5437 {
5438     STRLEN delta;
5439     STRLEN old_delta;
5440     U8 *p;
5441 #ifdef DEBUGGING
5442     const U8 *evacp;
5443     STRLEN evacn;
5444 #endif
5445     STRLEN max_delta;
5446 
5447     PERL_ARGS_ASSERT_SV_CHOP;
5448 
5449     if (!ptr || !SvPOKp(sv))
5450         return;
5451     delta = ptr - SvPVX_const(sv);
5452     if (!delta) {
5453         /* Nothing to do.  */
5454         return;
5455     }
5456     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
5457     if (delta > max_delta)
5458         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
5459                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
5460     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
5461     SV_CHECK_THINKFIRST(sv);
5462     SvPOK_only_UTF8(sv);
5463 
5464     if (!SvOOK(sv)) {
5465         if (!SvLEN(sv)) { /* make copy of shared string */
5466             const char *pvx = SvPVX_const(sv);
5467             const STRLEN len = SvCUR(sv);
5468             SvGROW(sv, len + 1);
5469             Move(pvx,SvPVX(sv),len,char);
5470             *SvEND(sv) = '\0';
5471         }
5472         SvOOK_on(sv);
5473         old_delta = 0;
5474     } else {
5475         SvOOK_offset(sv, old_delta);
5476     }
5477     SvLEN_set(sv, SvLEN(sv) - delta);
5478     SvCUR_set(sv, SvCUR(sv) - delta);
5479     SvPV_set(sv, SvPVX(sv) + delta);
5480 
5481     p = (U8 *)SvPVX_const(sv);
5482 
5483 #ifdef DEBUGGING
5484     /* how many bytes were evacuated?  we will fill them with sentinel
5485        bytes, except for the part holding the new offset of course. */
5486     evacn = delta;
5487     if (old_delta)
5488         evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
5489     assert(evacn);
5490     assert(evacn <= delta + old_delta);
5491     evacp = p - evacn;
5492 #endif
5493 
5494     /* This sets 'delta' to the accumulated value of all deltas so far */
5495     delta += old_delta;
5496     assert(delta);
5497 
5498     /* If 'delta' fits in a byte, store it just prior to the new beginning of
5499      * the string; otherwise store a 0 byte there and store 'delta' just prior
5500      * to that, using as many bytes as a STRLEN occupies.  Thus it overwrites a
5501      * portion of the chopped part of the string */
5502     if (delta < 0x100) {
5503         *--p = (U8) delta;
5504     } else {
5505         *--p = 0;
5506         p -= sizeof(STRLEN);
5507         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
5508     }
5509 
5510 #ifdef DEBUGGING
5511     /* Fill the preceding buffer with sentinals to verify that no-one is
5512        using it.  */
5513     while (p > evacp) {
5514         --p;
5515         *p = (U8)PTR2UV(p);
5516     }
5517 #endif
5518 }
5519 
5520 /*
5521 =for apidoc sv_catpvn
5522 =for apidoc_item sv_catpvn_flags
5523 =for apidoc_item sv_catpvn_mg
5524 =for apidoc_item sv_catpvn_nomg
5525 
5526 These concatenate the C<len> bytes of the string beginning at C<ptr> onto the
5527 end of the string which is in C<dsv>.  The caller must make sure C<ptr>
5528 contains at least C<len> bytes.
5529 
5530 For all but C<sv_catpvn_flags>, the string appended is assumed to be valid
5531 UTF-8 if the SV has the UTF-8 status set, and a string of bytes otherwise.
5532 
5533 They differ in that:
5534 
5535 C<sv_catpvn_mg> performs both 'get' and 'set' magic on C<dsv>.
5536 
5537 C<sv_catpvn> performs only 'get' magic.
5538 
5539 C<sv_catpvn_nomg> skips all magic.
5540 
5541 C<sv_catpvn_flags> has an extra C<flags> parameter which allows you to specify
5542 any combination of magic handling (using C<SV_GMAGIC> and/or C<SV_SMAGIC>) and
5543 to also override the UTF-8 handling.  By supplying the C<SV_CATBYTES> flag, the
5544 appended string is interpreted as plain bytes; by supplying instead the
5545 C<SV_CATUTF8> flag, it will be interpreted as UTF-8, and the C<dsv> will be
5546 upgraded to UTF-8 if necessary.
5547 
5548 C<sv_catpvn>, C<sv_catpvn_mg>, and C<sv_catpvn_nomg> are implemented
5549 in terms of C<sv_catpvn_flags>.
5550 
5551 =for apidoc Amnh||SV_CATUTF8
5552 =for apidoc Amnh||SV_CATBYTES
5553 
5554 =cut
5555 */
5556 
5557 void
5558 Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
5559 {
5560     STRLEN dlen;
5561     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5562 
5563     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5564     assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5565 
5566     if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
5567       if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
5568          sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5569          dlen = SvCUR(dsv);
5570       }
5571       else SvGROW(dsv, dlen + slen + 3);
5572       if (sstr == dstr)
5573         sstr = SvPVX_const(dsv);
5574       Move(sstr, SvPVX(dsv) + dlen, slen, char);
5575       SvCUR_set(dsv, SvCUR(dsv) + slen);
5576     }
5577     else {
5578         /* We inline bytes_to_utf8, to avoid an extra malloc. */
5579         const char * const send = sstr + slen;
5580         U8 *d;
5581 
5582         /* Something this code does not account for, which I think is
5583            impossible; it would require the same pv to be treated as
5584            bytes *and* utf8, which would indicate a bug elsewhere. */
5585         assert(sstr != dstr);
5586 
5587         SvGROW(dsv, dlen + slen * 2 + 3);
5588         d = (U8 *)SvPVX(dsv) + dlen;
5589 
5590         while (sstr < send) {
5591             append_utf8_from_native_byte(*sstr, &d);
5592             sstr++;
5593         }
5594         SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5595     }
5596     *SvEND(dsv) = '\0';
5597     (void)SvPOK_only_UTF8(dsv);		/* validate pointer */
5598     SvTAINT(dsv);
5599     if (flags & SV_SMAGIC)
5600         SvSETMAGIC(dsv);
5601 }
5602 
5603 /*
5604 =for apidoc sv_catsv
5605 =for apidoc_item sv_catsv_flags
5606 =for apidoc_item sv_catsv_mg
5607 =for apidoc_item sv_catsv_nomg
5608 
5609 These concatenate the string from SV C<sstr> onto the end of the string in SV
5610 C<dsv>.  If C<sstr> is null, these are no-ops; otherwise only C<dsv> is
5611 modified.
5612 
5613 They differ only in what magic they perform:
5614 
5615 C<sv_catsv_mg> performs 'get' magic on both SVs before the copy, and 'set' magic
5616 on C<dsv> afterwards.
5617 
5618 C<sv_catsv> performs just 'get' magic, on both SVs.
5619 
5620 C<sv_catsv_nomg> skips all magic.
5621 
5622 C<sv_catsv_flags> has an extra C<flags> parameter which allows you to use
5623 C<SV_GMAGIC> and/or C<SV_SMAGIC> to specify any combination of magic handling
5624 (although either both or neither SV will have 'get' magic applied to it.)
5625 
5626 C<sv_catsv>, C<sv_catsv_mg>, and C<sv_catsv_nomg> are implemented
5627 in terms of C<sv_catsv_flags>.
5628 
5629 =cut */
5630 
5631 void
5632 Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const sstr, const I32 flags)
5633 {
5634     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5635 
5636     if (sstr) {
5637         STRLEN slen;
5638         const char *spv = SvPV_flags_const(sstr, slen, flags);
5639         if (flags & SV_GMAGIC)
5640                 SvGETMAGIC(dsv);
5641         sv_catpvn_flags(dsv, spv, slen,
5642                             DO_UTF8(sstr) ? SV_CATUTF8 : SV_CATBYTES);
5643         if (flags & SV_SMAGIC)
5644                 SvSETMAGIC(dsv);
5645     }
5646 }
5647 
5648 /*
5649 =for apidoc sv_catpv
5650 =for apidoc_item sv_catpv_flags
5651 =for apidoc_item sv_catpv_mg
5652 =for apidoc_item sv_catpv_nomg
5653 
5654 These concatenate the C<NUL>-terminated string C<sstr> onto the end of the
5655 string which is in the SV.
5656 If the SV has the UTF-8 status set, then the bytes appended should be
5657 valid UTF-8.
5658 
5659 They differ only in how they handle magic:
5660 
5661 C<sv_catpv_mg> performs both 'get' and 'set' magic.
5662 
5663 C<sv_catpv> performs only 'get' magic.
5664 
5665 C<sv_catpv_nomg> skips all magic.
5666 
5667 C<sv_catpv_flags> has an extra C<flags> parameter which allows you to specify
5668 any combination of magic handling (using C<SV_GMAGIC> and/or C<SV_SMAGIC>), and
5669 to also override the UTF-8 handling.  By supplying the C<SV_CATUTF8> flag, the
5670 appended string is forced to be interpreted as UTF-8; by supplying instead the
5671 C<SV_CATBYTES> flag, it will be interpreted as just bytes.  Either the SV or
5672 the string appended will be upgraded to UTF-8 if necessary.
5673 
5674 =cut
5675 */
5676 
5677 void
5678 Perl_sv_catpv(pTHX_ SV *const dsv, const char *sstr)
5679 {
5680     STRLEN len;
5681     STRLEN tlen;
5682     char *junk;
5683 
5684     PERL_ARGS_ASSERT_SV_CATPV;
5685 
5686     if (!sstr)
5687         return;
5688     junk = SvPV_force(dsv, tlen);
5689     len = strlen(sstr);
5690     SvGROW(dsv, tlen + len + 1);
5691     if (sstr == junk)
5692         sstr = SvPVX_const(dsv);
5693     Move(sstr,SvPVX(dsv)+tlen,len+1,char);
5694     SvCUR_set(dsv, SvCUR(dsv) + len);
5695     (void)SvPOK_only_UTF8(dsv);		/* validate pointer */
5696     SvTAINT(dsv);
5697 }
5698 
5699 void
5700 Perl_sv_catpv_flags(pTHX_ SV *dsv, const char *sstr, const I32 flags)
5701 {
5702     PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5703     sv_catpvn_flags(dsv, sstr, strlen(sstr), flags);
5704 }
5705 
5706 void
5707 Perl_sv_catpv_mg(pTHX_ SV *const dsv, const char *const sstr)
5708 {
5709     PERL_ARGS_ASSERT_SV_CATPV_MG;
5710 
5711     sv_catpv(dsv,sstr);
5712     SvSETMAGIC(dsv);
5713 }
5714 
5715 /*
5716 =for apidoc newSV
5717 
5718 Creates a new SV.  A non-zero C<len> parameter indicates the number of
5719 bytes of preallocated string space the SV should have.  An extra byte for a
5720 trailing C<NUL> is also reserved.  (C<SvPOK> is not set for the SV even if string
5721 space is allocated.)  The reference count for the new SV is set to 1.
5722 
5723 In 5.9.3, C<newSV()> replaces the older C<NEWSV()> API, and drops the first
5724 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5725 This aid has been superseded by a new build option, C<PERL_MEM_LOG> (see
5726 L<perlhacktips/PERL_MEM_LOG>).  The older API is still there for use in XS
5727 modules supporting older perls.
5728 
5729 =cut
5730 */
5731 
5732 SV *
5733 Perl_newSV(pTHX_ const STRLEN len)
5734 {
5735     SV *sv;
5736 
5737     if (!len)
5738         new_SV(sv);
5739     else {
5740         sv = newSV_type(SVt_PV);
5741         sv_grow_fresh(sv, len + 1);
5742     }
5743     return sv;
5744 }
5745 /*
5746 =for apidoc sv_magicext
5747 
5748 Adds magic to an SV, upgrading it if necessary.  Applies the
5749 supplied C<vtable> and returns a pointer to the magic added.
5750 
5751 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5752 In particular, you can add magic to C<SvREADONLY> SVs, and add more than
5753 one instance of the same C<how>.
5754 
5755 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5756 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5757 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5758 to contain an SV* and is stored as-is with its C<REFCNT> incremented.
5759 
5760 (This is now used as a subroutine by C<sv_magic>.)
5761 
5762 =cut
5763 */
5764 MAGIC *
5765 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
5766                 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5767 {
5768     MAGIC* mg;
5769 
5770     PERL_ARGS_ASSERT_SV_MAGICEXT;
5771 
5772     SvUPGRADE(sv, SVt_PVMG);
5773     Newxz(mg, 1, MAGIC);
5774     mg->mg_moremagic = SvMAGIC(sv);
5775     SvMAGIC_set(sv, mg);
5776 
5777     /* Sometimes a magic contains a reference loop, where the sv and
5778        object refer to each other.  To prevent a reference loop that
5779        would prevent such objects being freed, we look for such loops
5780        and if we find one we avoid incrementing the object refcount.
5781 
5782        Note we cannot do this to avoid self-tie loops as intervening RV must
5783        have its REFCNT incremented to keep it in existence.
5784 
5785     */
5786     if (!obj || obj == sv ||
5787         how == PERL_MAGIC_arylen ||
5788         how == PERL_MAGIC_regdata ||
5789         how == PERL_MAGIC_regdatum ||
5790         how == PERL_MAGIC_symtab ||
5791         (SvTYPE(obj) == SVt_PVGV &&
5792             (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5793              || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5794              || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5795     {
5796         mg->mg_obj = obj;
5797     }
5798     else {
5799         mg->mg_obj = SvREFCNT_inc_simple(obj);
5800         mg->mg_flags |= MGf_REFCOUNTED;
5801     }
5802 
5803     /* Normal self-ties simply pass a null object, and instead of
5804        using mg_obj directly, use the SvTIED_obj macro to produce a
5805        new RV as needed.  For glob "self-ties", we are tieing the PVIO
5806        with an RV obj pointing to the glob containing the PVIO.  In
5807        this case, to avoid a reference loop, we need to weaken the
5808        reference.
5809     */
5810 
5811     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5812         obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5813     {
5814       sv_rvweaken(obj);
5815     }
5816 
5817     mg->mg_type = how;
5818     mg->mg_len = namlen;
5819     if (name) {
5820         if (namlen > 0)
5821             mg->mg_ptr = savepvn(name, namlen);
5822         else if (namlen == HEf_SVKEY) {
5823             /* Yes, this is casting away const. This is only for the case of
5824                HEf_SVKEY. I think we need to document this aberration of the
5825                constness of the API, rather than making name non-const, as
5826                that change propagating outwards a long way.  */
5827             mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5828         } else
5829             mg->mg_ptr = (char *) name;
5830     }
5831     mg->mg_virtual = (MGVTBL *) vtable;
5832 
5833     mg_magical(sv);
5834     return mg;
5835 }
5836 
5837 MAGIC *
5838 Perl_sv_magicext_mglob(pTHX_ SV *sv)
5839 {
5840     PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB;
5841     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
5842         /* This sv is only a delegate.  //g magic must be attached to
5843            its target. */
5844         vivify_defelem(sv);
5845         sv = LvTARG(sv);
5846     }
5847     return sv_magicext(sv, NULL, PERL_MAGIC_regex_global,
5848                        &PL_vtbl_mglob, 0, 0);
5849 }
5850 
5851 /*
5852 =for apidoc sv_magic
5853 
5854 Adds magic to an SV.  First upgrades C<sv> to type C<SVt_PVMG> if
5855 necessary, then adds a new magic item of type C<how> to the head of the
5856 magic list.
5857 
5858 See C<L</sv_magicext>> (which C<sv_magic> now calls) for a description of the
5859 handling of the C<name> and C<namlen> arguments.
5860 
5861 You need to use C<sv_magicext> to add magic to C<SvREADONLY> SVs and also
5862 to add more than one instance of the same C<how>.
5863 
5864 =cut
5865 */
5866 
5867 void
5868 Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
5869              const char *const name, const I32 namlen)
5870 {
5871     const MGVTBL *vtable;
5872     MAGIC* mg;
5873     unsigned int flags;
5874     unsigned int vtable_index;
5875 
5876     PERL_ARGS_ASSERT_SV_MAGIC;
5877 
5878     if (how < 0 || (unsigned)how >= C_ARRAY_LENGTH(PL_magic_data)
5879         || ((flags = PL_magic_data[how]),
5880             (vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
5881             > magic_vtable_max))
5882         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5883 
5884     /* PERL_MAGIC_ext is reserved for use by extensions not perl internals.
5885        Useful for attaching extension internal data to perl vars.
5886        Note that multiple extensions may clash if magical scalars
5887        etc holding private data from one are passed to another. */
5888 
5889     vtable = (vtable_index == magic_vtable_max)
5890         ? NULL : PL_magic_vtables + vtable_index;
5891 
5892     if (SvREADONLY(sv)) {
5893         if (
5894             !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
5895            )
5896         {
5897             Perl_croak_no_modify();
5898         }
5899     }
5900     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5901         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5902             /* sv_magic() refuses to add a magic of the same 'how' as an
5903                existing one
5904              */
5905             if (how == PERL_MAGIC_taint)
5906                 mg->mg_len |= 1;
5907             return;
5908         }
5909     }
5910 
5911     /* Rest of work is done else where */
5912     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5913 
5914     switch (how) {
5915     case PERL_MAGIC_taint:
5916         mg->mg_len = 1;
5917         break;
5918     case PERL_MAGIC_ext:
5919     case PERL_MAGIC_dbfile:
5920         SvRMAGICAL_on(sv);
5921         break;
5922     }
5923 }
5924 
5925 static int
5926 S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, const MGVTBL *vtbl, const U32 flags)
5927 {
5928     MAGIC* mg;
5929     MAGIC** mgp;
5930 
5931     assert(flags <= 1);
5932 
5933     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5934         return 0;
5935     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5936     for (mg = *mgp; mg; mg = *mgp) {
5937         const MGVTBL* const virt = mg->mg_virtual;
5938         if (mg->mg_type == type && (!flags || virt == vtbl)) {
5939             *mgp = mg->mg_moremagic;
5940             if (virt && virt->svt_free)
5941                 virt->svt_free(aTHX_ sv, mg);
5942             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5943                 if (mg->mg_len > 0)
5944                     Safefree(mg->mg_ptr);
5945                 else if (mg->mg_len == HEf_SVKEY)
5946                     SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5947                 else if (mg->mg_type == PERL_MAGIC_utf8)
5948                     Safefree(mg->mg_ptr);
5949             }
5950             if (mg->mg_flags & MGf_REFCOUNTED)
5951                 SvREFCNT_dec(mg->mg_obj);
5952             Safefree(mg);
5953         }
5954         else
5955             mgp = &mg->mg_moremagic;
5956     }
5957     if (SvMAGIC(sv)) {
5958         if (SvMAGICAL(sv))	/* if we're under save_magic, wait for restore_magic; */
5959             mg_magical(sv);	/*    else fix the flags now */
5960     }
5961     else
5962         SvMAGICAL_off(sv);
5963 
5964     return 0;
5965 }
5966 
5967 /*
5968 =for apidoc sv_unmagic
5969 
5970 Removes all magic of type C<type> from an SV.
5971 
5972 =cut
5973 */
5974 
5975 int
5976 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5977 {
5978     PERL_ARGS_ASSERT_SV_UNMAGIC;
5979     return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
5980 }
5981 
5982 /*
5983 =for apidoc sv_unmagicext
5984 
5985 Removes all magic of type C<type> with the specified C<vtbl> from an SV.
5986 
5987 =cut
5988 */
5989 
5990 int
5991 Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, const MGVTBL *vtbl)
5992 {
5993     PERL_ARGS_ASSERT_SV_UNMAGICEXT;
5994     return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
5995 }
5996 
5997 /*
5998 =for apidoc sv_rvweaken
5999 
6000 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
6001 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
6002 push a back-reference to this RV onto the array of backreferences
6003 associated with that magic.  If the RV is magical, set magic will be
6004 called after the RV is cleared.  Silently ignores C<undef> and warns
6005 on already-weak references.
6006 
6007 =cut
6008 */
6009 
6010 SV *
6011 Perl_sv_rvweaken(pTHX_ SV *const sv)
6012 {
6013     SV *tsv;
6014 
6015     PERL_ARGS_ASSERT_SV_RVWEAKEN;
6016 
6017     if (!SvOK(sv))  /* let undefs pass */
6018         return sv;
6019     if (!SvROK(sv))
6020         Perl_croak(aTHX_ "Can't weaken a nonreference");
6021     else if (SvWEAKREF(sv)) {
6022         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
6023         return sv;
6024     }
6025     else if (SvREADONLY(sv)) croak_no_modify();
6026     tsv = SvRV(sv);
6027     Perl_sv_add_backref(aTHX_ tsv, sv);
6028     SvWEAKREF_on(sv);
6029     SvREFCNT_dec_NN(tsv);
6030     return sv;
6031 }
6032 
6033 /*
6034 =for apidoc sv_rvunweaken
6035 
6036 Unweaken a reference: Clear the C<SvWEAKREF> flag on this RV; remove
6037 the backreference to this RV from the array of backreferences
6038 associated with the target SV, increment the refcount of the target.
6039 Silently ignores C<undef> and warns on non-weak references.
6040 
6041 =cut
6042 */
6043 
6044 SV *
6045 Perl_sv_rvunweaken(pTHX_ SV *const sv)
6046 {
6047     SV *tsv;
6048 
6049     PERL_ARGS_ASSERT_SV_RVUNWEAKEN;
6050 
6051     if (!SvOK(sv)) /* let undefs pass */
6052         return sv;
6053     if (!SvROK(sv))
6054         Perl_croak(aTHX_ "Can't unweaken a nonreference");
6055     else if (!SvWEAKREF(sv)) {
6056         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is not weak");
6057         return sv;
6058     }
6059     else if (SvREADONLY(sv)) croak_no_modify();
6060 
6061     tsv = SvRV(sv);
6062     SvWEAKREF_off(sv);
6063     SvROK_on(sv);
6064     SvREFCNT_inc_NN(tsv);
6065     Perl_sv_del_backref(aTHX_ tsv, sv);
6066     return sv;
6067 }
6068 
6069 /*
6070 =for apidoc sv_get_backrefs
6071 
6072 If C<sv> is the target of a weak reference then it returns the back
6073 references structure associated with the sv; otherwise return C<NULL>.
6074 
6075 When returning a non-null result the type of the return is relevant. If it
6076 is an AV then the elements of the AV are the weak reference RVs which
6077 point at this item. If it is any other type then the item itself is the
6078 weak reference.
6079 
6080 See also C<Perl_sv_add_backref()>, C<Perl_sv_del_backref()>,
6081 C<Perl_sv_kill_backrefs()>
6082 
6083 =cut
6084 */
6085 
6086 SV *
6087 Perl_sv_get_backrefs(SV *const sv)
6088 {
6089     SV *backrefs= NULL;
6090 
6091     PERL_ARGS_ASSERT_SV_GET_BACKREFS;
6092 
6093     /* find slot to store array or singleton backref */
6094 
6095     if (SvTYPE(sv) == SVt_PVHV) {
6096         if (HvHasAUX(sv)) {
6097             struct xpvhv_aux * const iter = HvAUX((HV *)sv);
6098             backrefs = (SV *)iter->xhv_backreferences;
6099         }
6100     } else if (SvMAGICAL(sv)) {
6101         MAGIC *mg = mg_find(sv, PERL_MAGIC_backref);
6102         if (mg)
6103             backrefs = mg->mg_obj;
6104     }
6105     return backrefs;
6106 }
6107 
6108 /* Give tsv backref magic if it hasn't already got it, then push a
6109  * back-reference to sv onto the array associated with the backref magic.
6110  *
6111  * As an optimisation, if there's only one backref and it's not an AV,
6112  * store it directly in the HvAUX or mg_obj slot, avoiding the need to
6113  * allocate an AV. (Whether the slot holds an AV tells us whether this is
6114  * active.)
6115  */
6116 
6117 /* A discussion about the backreferences array and its refcount:
6118  *
6119  * The AV holding the backreferences is pointed to either as the mg_obj of
6120  * PERL_MAGIC_backref, or in the specific case of a HV, from the
6121  * xhv_backreferences field. The array is created with a refcount
6122  * of 2. This means that if during global destruction the array gets
6123  * picked on before its parent to have its refcount decremented by the
6124  * random zapper, it won't actually be freed, meaning it's still there for
6125  * when its parent gets freed.
6126  *
6127  * When the parent SV is freed, the extra ref is killed by
6128  * Perl_sv_kill_backrefs.  The other ref is killed, in the case of magic,
6129  * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
6130  *
6131  * When a single backref SV is stored directly, it is not reference
6132  * counted.
6133  */
6134 
6135 void
6136 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
6137 {
6138     SV **svp;
6139     AV *av = NULL;
6140     MAGIC *mg = NULL;
6141 
6142     PERL_ARGS_ASSERT_SV_ADD_BACKREF;
6143 
6144     /* find slot to store array or singleton backref */
6145 
6146     if (SvTYPE(tsv) == SVt_PVHV) {
6147         svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
6148     } else {
6149         if (SvMAGICAL(tsv))
6150             mg = mg_find(tsv, PERL_MAGIC_backref);
6151         if (!mg)
6152             mg = sv_magicext(tsv, NULL, PERL_MAGIC_backref, &PL_vtbl_backref, NULL, 0);
6153         svp = &(mg->mg_obj);
6154     }
6155 
6156     /* create or retrieve the array */
6157 
6158     if (   (!*svp && SvTYPE(sv) == SVt_PVAV)
6159         || (*svp && SvTYPE(*svp) != SVt_PVAV)
6160     ) {
6161         /* create array */
6162         if (mg)
6163             mg->mg_flags |= MGf_REFCOUNTED;
6164         av = newAV();
6165         AvREAL_off(av);
6166         SvREFCNT_inc_simple_void_NN(av);
6167         /* av now has a refcnt of 2; see discussion above */
6168         av_extend(av, *svp ? 2 : 1);
6169         if (*svp) {
6170             /* move single existing backref to the array */
6171             AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
6172         }
6173         *svp = (SV*)av;
6174     }
6175     else {
6176         av = MUTABLE_AV(*svp);
6177         if (!av) {
6178             /* optimisation: store single backref directly in HvAUX or mg_obj */
6179             *svp = sv;
6180             return;
6181         }
6182         assert(SvTYPE(av) == SVt_PVAV);
6183         if (AvFILLp(av) >= AvMAX(av)) {
6184             av_extend(av, AvFILLp(av)+1);
6185         }
6186     }
6187     /* push new backref */
6188     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
6189 }
6190 
6191 /* delete a back-reference to ourselves from the backref magic associated
6192  * with the SV we point to.
6193  */
6194 
6195 void
6196 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
6197 {
6198     SV **svp = NULL;
6199 
6200     PERL_ARGS_ASSERT_SV_DEL_BACKREF;
6201 
6202     if (SvTYPE(tsv) == SVt_PVHV) {
6203         if (HvHasAUX(tsv))
6204             svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
6205     }
6206     else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) {
6207         /* It's possible for the last (strong) reference to tsv to have
6208            become freed *before* the last thing holding a weak reference.
6209            If both survive longer than the backreferences array, then when
6210            the referent's reference count drops to 0 and it is freed, it's
6211            not able to chase the backreferences, so they aren't NULLed.
6212 
6213            For example, a CV holds a weak reference to its stash. If both the
6214            CV and the stash survive longer than the backreferences array,
6215            and the CV gets picked for the SvBREAK() treatment first,
6216            *and* it turns out that the stash is only being kept alive because
6217            of an our variable in the pad of the CV, then midway during CV
6218            destruction the stash gets freed, but CvSTASH() isn't set to NULL.
6219            It ends up pointing to the freed HV. Hence it's chased in here, and
6220            if this block wasn't here, it would hit the !svp panic just below.
6221 
6222            I don't believe that "better" destruction ordering is going to help
6223            here - during global destruction there's always going to be the
6224            chance that something goes out of order. We've tried to make it
6225            foolproof before, and it only resulted in evolutionary pressure on
6226            fools. Which made us look foolish for our hubris. :-(
6227         */
6228         return;
6229     }
6230     else {
6231         MAGIC *const mg
6232             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
6233         svp =  mg ? &(mg->mg_obj) : NULL;
6234     }
6235 
6236     if (!svp)
6237         Perl_croak(aTHX_ "panic: del_backref, svp=0");
6238     if (!*svp) {
6239         /* It's possible that sv is being freed recursively part way through the
6240            freeing of tsv. If this happens, the backreferences array of tsv has
6241            already been freed, and so svp will be NULL. If this is the case,
6242            we should not panic. Instead, nothing needs doing, so return.  */
6243         if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
6244             return;
6245         Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
6246                    (void*)*svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
6247     }
6248 
6249     if (SvTYPE(*svp) == SVt_PVAV) {
6250 #ifdef DEBUGGING
6251         int count = 1;
6252 #endif
6253         AV * const av = (AV*)*svp;
6254         SSize_t fill;
6255         assert(!SvIS_FREED(av));
6256         fill = AvFILLp(av);
6257         assert(fill > -1);
6258         svp = AvARRAY(av);
6259         /* for an SV with N weak references to it, if all those
6260          * weak refs are deleted, then sv_del_backref will be called
6261          * N times and O(N^2) compares will be done within the backref
6262          * array. To ameliorate this potential slowness, we:
6263          * 1) make sure this code is as tight as possible;
6264          * 2) when looking for SV, look for it at both the head and tail of the
6265          *    array first before searching the rest, since some create/destroy
6266          *    patterns will cause the backrefs to be freed in order.
6267          */
6268         if (*svp == sv) {
6269             AvARRAY(av)++;
6270             AvMAX(av)--;
6271         }
6272         else {
6273             SV **p = &svp[fill];
6274             SV *const topsv = *p;
6275             if (topsv != sv) {
6276 #ifdef DEBUGGING
6277                 count = 0;
6278 #endif
6279                 while (--p > svp) {
6280                     if (*p == sv) {
6281                         /* We weren't the last entry.
6282                            An unordered list has this property that you
6283                            can take the last element off the end to fill
6284                            the hole, and it's still an unordered list :-)
6285                         */
6286                         *p = topsv;
6287 #ifdef DEBUGGING
6288                         count++;
6289 #else
6290                         break; /* should only be one */
6291 #endif
6292                     }
6293                 }
6294             }
6295         }
6296         assert(count ==1);
6297         AvFILLp(av) = fill-1;
6298     }
6299     else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) {
6300         /* freed AV; skip */
6301     }
6302     else {
6303         /* optimisation: only a single backref, stored directly */
6304         if (*svp != sv)
6305             Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p",
6306                        (void*)*svp, (void*)sv);
6307         *svp = NULL;
6308     }
6309 
6310 }
6311 
6312 void
6313 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
6314 {
6315     SV **svp;
6316     SV **last;
6317     bool is_array;
6318 
6319     PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
6320 
6321     if (!av)
6322         return;
6323 
6324     /* after multiple passes through Perl_sv_clean_all() for a thingy
6325      * that has badly leaked, the backref array may have gotten freed,
6326      * since we only protect it against 1 round of cleanup */
6327     if (SvIS_FREED(av)) {
6328         if (PL_in_clean_all) /* All is fair */
6329             return;
6330         Perl_croak(aTHX_
6331                    "panic: magic_killbackrefs (freed backref AV/SV)");
6332     }
6333 
6334 
6335     is_array = (SvTYPE(av) == SVt_PVAV);
6336     if (is_array) {
6337         assert(!SvIS_FREED(av));
6338         svp = AvARRAY(av);
6339         if (svp)
6340             last = svp + AvFILLp(av);
6341     }
6342     else {
6343         /* optimisation: only a single backref, stored directly */
6344         svp = (SV**)&av;
6345         last = svp;
6346     }
6347 
6348     if (svp) {
6349         while (svp <= last) {
6350             if (*svp) {
6351                 SV *const referrer = *svp;
6352                 if (SvWEAKREF(referrer)) {
6353                     /* XXX Should we check that it hasn't changed? */
6354                     assert(SvROK(referrer));
6355                     SvRV_set(referrer, 0);
6356                     SvOK_off(referrer);
6357                     SvWEAKREF_off(referrer);
6358                     SvSETMAGIC(referrer);
6359                 } else if (SvTYPE(referrer) == SVt_PVGV ||
6360                            SvTYPE(referrer) == SVt_PVLV) {
6361                     assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
6362                     /* You lookin' at me?  */
6363                     assert(GvSTASH(referrer));
6364                     assert(GvSTASH(referrer) == (const HV *)sv);
6365                     GvSTASH(referrer) = 0;
6366                 } else if (SvTYPE(referrer) == SVt_PVCV ||
6367                            SvTYPE(referrer) == SVt_PVFM) {
6368                     if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
6369                         /* You lookin' at me?  */
6370                         assert(CvSTASH(referrer));
6371                         assert(CvSTASH(referrer) == (const HV *)sv);
6372                         SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
6373                     }
6374                     else {
6375                         assert(SvTYPE(sv) == SVt_PVGV);
6376                         /* You lookin' at me?  */
6377                         assert(CvGV(referrer));
6378                         assert(CvGV(referrer) == (const GV *)sv);
6379                         anonymise_cv_maybe(MUTABLE_GV(sv),
6380                                                 MUTABLE_CV(referrer));
6381                     }
6382 
6383                 } else {
6384                     Perl_croak(aTHX_
6385                                "panic: magic_killbackrefs (flags=%" UVxf ")",
6386                                (UV)SvFLAGS(referrer));
6387                 }
6388 
6389                 if (is_array)
6390                     *svp = NULL;
6391             }
6392             svp++;
6393         }
6394     }
6395     if (is_array) {
6396         AvFILLp(av) = -1;
6397         SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */
6398     }
6399     return;
6400 }
6401 
6402 /*
6403 =for apidoc sv_insert
6404 
6405 Inserts and/or replaces a string at the specified offset/length within the SV.
6406 Similar to the Perl C<substr()> function, with C<littlelen> bytes starting at
6407 C<little> replacing C<len> bytes of the string in C<bigstr> starting at
6408 C<offset>.  Handles get magic.
6409 
6410 =for apidoc sv_insert_flags
6411 
6412 Same as C<sv_insert>, but the extra C<flags> are passed to the
6413 C<SvPV_force_flags> that applies to C<bigstr>.
6414 
6415 =cut
6416 */
6417 
6418 void
6419 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *little, const STRLEN littlelen, const U32 flags)
6420 {
6421     char *big;
6422     char *mid;
6423     char *midend;
6424     char *bigend;
6425     SSize_t i;		/* better be sizeof(STRLEN) or bad things happen */
6426     STRLEN curlen;
6427 
6428     PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
6429 
6430     SvPV_force_flags(bigstr, curlen, flags);
6431     (void)SvPOK_only_UTF8(bigstr);
6432 
6433     if (little >= SvPVX(bigstr) &&
6434         little < SvPVX(bigstr) + (SvLEN(bigstr) ? SvLEN(bigstr) : SvCUR(bigstr))) {
6435         /* little is a pointer to within bigstr, since we can reallocate bigstr,
6436            or little...little+littlelen might overlap offset...offset+len we make a copy
6437         */
6438         little = savepvn(little, littlelen);
6439         SAVEFREEPV(little);
6440     }
6441 
6442     if (offset + len > curlen) {
6443         SvGROW(bigstr, offset+len+1);
6444         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
6445         SvCUR_set(bigstr, offset+len);
6446     }
6447 
6448     SvTAINT(bigstr);
6449     i = littlelen - len;
6450     if (i > 0) {			/* string might grow */
6451         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
6452         mid = big + offset + len;
6453         midend = bigend = big + SvCUR(bigstr);
6454         bigend += i;
6455         *bigend = '\0';
6456         while (midend > mid)		/* shove everything down */
6457             *--bigend = *--midend;
6458         Move(little,big+offset,littlelen,char);
6459         SvCUR_set(bigstr, SvCUR(bigstr) + i);
6460         SvSETMAGIC(bigstr);
6461         return;
6462     }
6463     else if (i == 0) {
6464         Move(little,SvPVX(bigstr)+offset,len,char);
6465         SvSETMAGIC(bigstr);
6466         return;
6467     }
6468 
6469     big = SvPVX(bigstr);
6470     mid = big + offset;
6471     midend = mid + len;
6472     bigend = big + SvCUR(bigstr);
6473 
6474     if (midend > bigend)
6475         Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p",
6476                    midend, bigend);
6477 
6478     if (mid - big > bigend - midend) {	/* faster to shorten from end */
6479         if (littlelen) {
6480             Move(little, mid, littlelen,char);
6481             mid += littlelen;
6482         }
6483         i = bigend - midend;
6484         if (i > 0) {
6485             Move(midend, mid, i,char);
6486             mid += i;
6487         }
6488         *mid = '\0';
6489         SvCUR_set(bigstr, mid - big);
6490     }
6491     else if ((i = mid - big)) {	/* faster from front */
6492         midend -= littlelen;
6493         mid = midend;
6494         Move(big, midend - i, i, char);
6495         sv_chop(bigstr,midend-i);
6496         if (littlelen)
6497             Move(little, mid, littlelen,char);
6498     }
6499     else if (littlelen) {
6500         midend -= littlelen;
6501         sv_chop(bigstr,midend);
6502         Move(little,midend,littlelen,char);
6503     }
6504     else {
6505         sv_chop(bigstr,midend);
6506     }
6507     SvSETMAGIC(bigstr);
6508 }
6509 
6510 /*
6511 =for apidoc sv_replace
6512 
6513 Make the first argument a copy of the second, then delete the original.
6514 The target SV physically takes over ownership of the body of the source SV
6515 and inherits its flags; however, the target keeps any magic it owns,
6516 and any magic in the source is discarded.
6517 Note that this is a rather specialist SV copying operation; most of the
6518 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
6519 
6520 =cut
6521 */
6522 
6523 void
6524 Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv)
6525 {
6526     const U32 refcnt = SvREFCNT(sv);
6527 
6528     PERL_ARGS_ASSERT_SV_REPLACE;
6529 
6530     SV_CHECK_THINKFIRST_COW_DROP(sv);
6531     if (SvREFCNT(nsv) != 1) {
6532         Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
6533                    " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
6534     }
6535     if (SvMAGICAL(sv)) {
6536         if (SvMAGICAL(nsv))
6537             mg_free(nsv);
6538         else
6539             sv_upgrade(nsv, SVt_PVMG);
6540         SvMAGIC_set(nsv, SvMAGIC(sv));
6541         SvFLAGS(nsv) |= SvMAGICAL(sv);
6542         SvMAGICAL_off(sv);
6543         SvMAGIC_set(sv, NULL);
6544     }
6545     SvREFCNT(sv) = 0;
6546     sv_clear(sv);
6547     assert(!SvREFCNT(sv));
6548 #ifdef DEBUG_LEAKING_SCALARS
6549     sv->sv_flags  = nsv->sv_flags;
6550     sv->sv_any    = nsv->sv_any;
6551     sv->sv_refcnt = nsv->sv_refcnt;
6552     sv->sv_u      = nsv->sv_u;
6553 #else
6554     StructCopy(nsv,sv,SV);
6555 #endif
6556     if(SvTYPE(sv) == SVt_IV) {
6557         SET_SVANY_FOR_BODYLESS_IV(sv);
6558     }
6559 
6560 
6561     SvREFCNT(sv) = refcnt;
6562     SvFLAGS(nsv) |= SVTYPEMASK;		/* Mark as freed */
6563     SvREFCNT(nsv) = 0;
6564     del_SV(nsv);
6565 }
6566 
6567 /* We're about to free a GV which has a CV that refers back to us.
6568  * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
6569  * field) */
6570 
6571 STATIC void
6572 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
6573 {
6574     SV *gvname;
6575     GV *anongv;
6576 
6577     PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
6578 
6579     /* be assertive! */
6580     assert(SvREFCNT(gv) == 0);
6581     assert(isGV(gv) && isGV_with_GP(gv));
6582     assert(GvGP(gv));
6583     assert(!CvANON(cv));
6584     assert(CvGV(cv) == gv);
6585     assert(!CvNAMED(cv));
6586 
6587     /* will the CV shortly be freed by gp_free() ? */
6588     if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
6589         SvANY(cv)->xcv_gv_u.xcv_gv = NULL;
6590         return;
6591     }
6592 
6593     /* if not, anonymise: */
6594     gvname = (GvSTASH(gv) && HvHasNAME(GvSTASH(gv)) && HvHasENAME(GvSTASH(gv)))
6595                     ? newSVhek(HvENAME_HEK(GvSTASH(gv)))
6596                     : newSVpvn_flags( "__ANON__", 8, 0 );
6597     sv_catpvs(gvname, "::__ANON__");
6598     anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
6599     SvREFCNT_dec_NN(gvname);
6600 
6601     CvANON_on(cv);
6602     CvCVGV_RC_on(cv);
6603     SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
6604 }
6605 
6606 
6607 /*
6608 =for apidoc sv_clear
6609 
6610 Clear an SV: call any destructors, free up any memory used by the body,
6611 and free the body itself.  The SV's head is I<not> freed, although
6612 its type is set to all 1's so that it won't inadvertently be assumed
6613 to be live during global destruction etc.
6614 This function should only be called when C<REFCNT> is zero.  Most of the time
6615 you'll want to call C<SvREFCNT_dec> instead.
6616 
6617 =cut
6618 */
6619 
6620 void
6621 Perl_sv_clear(pTHX_ SV *const orig_sv)
6622 {
6623     SV* iter_sv = NULL;
6624     SV* next_sv = NULL;
6625     SV *sv = orig_sv;
6626     STRLEN hash_index = 0; /* initialise to make Coverity et al happy.
6627                               Not strictly necessary */
6628 
6629     PERL_ARGS_ASSERT_SV_CLEAR;
6630 
6631     /* within this loop, sv is the SV currently being freed, and
6632      * iter_sv is the most recent AV or whatever that's being iterated
6633      * over to provide more SVs */
6634 
6635     while (sv) {
6636         U32 type = SvTYPE(sv);
6637         HV *stash;
6638 
6639         assert(SvREFCNT(sv) == 0);
6640         assert(!SvIS_FREED(sv));
6641 #if NVSIZE <= IVSIZE
6642         if (type <= SVt_NV) {
6643 #else
6644         if (type <= SVt_IV) {
6645 #endif
6646             /* Historically this check on type was needed so that the code to
6647              * free bodies wasn't reached for these types, because the arena
6648              * slots were re-used for HEs and pointer table entries. The
6649              * metadata table `bodies_by_type` had the information for the sizes
6650              * for HEs and PTEs, hence the code here had to have a special-case
6651              * check to ensure that the "regular" body freeing code wasn't
6652              * reached, and get confused by the "lies" in `bodies_by_type`.
6653              *
6654              * However, it hasn't actually been needed for that reason since
6655              * Aug 2010 (commit 829cd18aa7f45221), because `bodies_by_type` was
6656              * changed to always hold the accurate metadata for the SV types.
6657              * This was possible because PTEs were no longer allocated from the
6658              * "SVt_IV" arena, and the code to allocate HEs from the "SVt_NULL"
6659              * arena is entirely in hv.c, so doesn't access the table.
6660              *
6661              * Some sort of check is still needed to handle SVt_IVs - pure RVs
6662              * need to take one code path which is common with RVs stored in
6663              * SVt_PV (or larger), but pure IVs mustn't take the "PV but not RV"
6664              * path, as SvPVX() doesn't point to valid memory.
6665              *
6666              * Hence this code is still the most efficient way to handle this.
6667              *
6668              * Additionally, for bodyless NVs, riding this branch is more
6669              * efficient than stepping through the general logic.
6670              */
6671 
6672             if (SvROK(sv))
6673                 goto free_rv;
6674             SvFLAGS(sv) &= SVf_BREAK;
6675             SvFLAGS(sv) |= SVTYPEMASK;
6676             goto free_head;
6677         }
6678 
6679         /* objs are always >= MG, but pad names use the SVs_OBJECT flag
6680            for another purpose  */
6681         assert(!SvOBJECT(sv) || type >= SVt_PVMG);
6682 
6683         if (type >= SVt_PVMG) {
6684             if (SvOBJECT(sv)) {
6685                 if (!curse(sv, 1)) goto get_next_sv;
6686                 type = SvTYPE(sv); /* destructor may have changed it */
6687             }
6688             /* Free back-references before magic, in case the magic calls
6689              * Perl code that has weak references to sv. */
6690             if (type == SVt_PVHV) {
6691                 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
6692                 if (SvMAGIC(sv))
6693                     mg_free(sv);
6694             }
6695             else if (SvMAGIC(sv)) {
6696                 /* Free back-references before other types of magic. */
6697                 sv_unmagic(sv, PERL_MAGIC_backref);
6698                 mg_free(sv);
6699             }
6700             SvMAGICAL_off(sv);
6701         }
6702         switch (type) {
6703             /* case SVt_INVLIST: */
6704         case SVt_PVIO:
6705             if (IoIFP(sv) &&
6706                 IoIFP(sv) != PerlIO_stdin() &&
6707                 IoIFP(sv) != PerlIO_stdout() &&
6708                 IoIFP(sv) != PerlIO_stderr() &&
6709                 !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6710             {
6711                 io_close(MUTABLE_IO(sv), NULL, FALSE,
6712                          (IoTYPE(sv) == IoTYPE_WRONLY ||
6713                           IoTYPE(sv) == IoTYPE_RDWR   ||
6714                           IoTYPE(sv) == IoTYPE_APPEND));
6715             }
6716             if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6717                 PerlDir_close(IoDIRP(sv));
6718             IoDIRP(sv) = (DIR*)NULL;
6719             Safefree(IoTOP_NAME(sv));
6720             Safefree(IoFMT_NAME(sv));
6721             Safefree(IoBOTTOM_NAME(sv));
6722             if ((const GV *)sv == PL_statgv)
6723                 PL_statgv = NULL;
6724             goto freescalar;
6725         case SVt_REGEXP:
6726             /* FIXME for plugins */
6727             pregfree2((REGEXP*) sv);
6728             goto freescalar;
6729         case SVt_PVCV:
6730         case SVt_PVFM:
6731             cv_undef(MUTABLE_CV(sv));
6732             /* If we're in a stash, we don't own a reference to it.
6733              * However it does have a back reference to us, which needs to
6734              * be cleared.  */
6735             if ((stash = CvSTASH(sv)))
6736                 sv_del_backref(MUTABLE_SV(stash), sv);
6737             goto freescalar;
6738         case SVt_PVHV:
6739             if (HvTOTALKEYS((HV*)sv) > 0) {
6740                 const HEK *hek;
6741                 /* this statement should match the one at the beginning of
6742                  * hv_undef_flags() */
6743                 if (   PL_phase != PERL_PHASE_DESTRUCT
6744                     && (hek = HvNAME_HEK((HV*)sv)))
6745                 {
6746                     if (PL_stashcache) {
6747                         DEBUG_o(Perl_deb(aTHX_
6748                             "sv_clear clearing PL_stashcache for '%" HEKf
6749                             "'\n",
6750                              HEKfARG(hek)));
6751                         (void)hv_deletehek(PL_stashcache,
6752                                            hek, G_DISCARD);
6753                     }
6754                     hv_name_set((HV*)sv, NULL, 0, 0);
6755                 }
6756 
6757                 /* save old iter_sv in unused SvSTASH field */
6758                 assert(!SvOBJECT(sv));
6759                 SvSTASH(sv) = (HV*)iter_sv;
6760                 iter_sv = sv;
6761 
6762                 /* save old hash_index in unused SvMAGIC field */
6763                 assert(!SvMAGICAL(sv));
6764                 assert(!SvMAGIC(sv));
6765                 ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index = hash_index;
6766                 hash_index = 0;
6767 
6768                 next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index);
6769                 goto get_next_sv; /* process this new sv */
6770             }
6771             /* free empty hash */
6772             Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6773             assert(!HvARRAY((HV*)sv));
6774             break;
6775         case SVt_PVAV:
6776             {
6777                 AV* av = MUTABLE_AV(sv);
6778                 if (PL_comppad == av) {
6779                     PL_comppad = NULL;
6780                     PL_curpad = NULL;
6781                 }
6782                 if (AvREAL(av) && AvFILLp(av) > -1) {
6783                     next_sv = AvARRAY(av)[AvFILLp(av)--];
6784                     /* save old iter_sv in top-most slot of AV,
6785                      * and pray that it doesn't get wiped in the meantime */
6786                     AvARRAY(av)[AvMAX(av)] = iter_sv;
6787                     iter_sv = sv;
6788                     goto get_next_sv; /* process this new sv */
6789                 }
6790                 Safefree(AvALLOC(av));
6791             }
6792 
6793             break;
6794         case SVt_PVOBJ:
6795             if(ObjectMAXFIELD(sv) > -1) {
6796                 next_sv = ObjectFIELDS(sv)[ObjectMAXFIELD(sv)--];
6797                 /* save old iter_sv in top-most field, and pray that it
6798                  * doesn't get wiped in the meantime */
6799                 ObjectFIELDS(sv)[(ObjectITERSVAT(sv) = ObjectMAXFIELD(sv) + 1)] = iter_sv;
6800                 iter_sv = sv;
6801                 goto get_next_sv;
6802             }
6803             Safefree(ObjectFIELDS(sv));
6804             break;
6805         case SVt_PVLV:
6806             if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
6807                 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
6808                 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
6809                 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
6810             }
6811             else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
6812                 SvREFCNT_dec(LvTARG(sv));
6813             if (isREGEXP(sv)) {
6814                 /* This PVLV has had a REGEXP assigned to it - the memory
6815                  * normally used to store SvLEN instead points to a regex body.
6816                  * Retrieving the pointer to the regex body from the correct
6817                  * location is normally abstracted by ReANY(), which handles
6818                  * both SVt_PVLV and SVt_REGEXP
6819                  *
6820                  * This code is unwinding the storage specific to SVt_PVLV.
6821                  * We get the body pointer directly from the union, free it,
6822                  * then set SvLEN to whatever value was in the now-freed regex
6823                  * body. The PVX buffer is shared by multiple re's and only
6824                  * freed once, by the re whose SvLEN is non-null.
6825                  *
6826                  * Perl_sv_force_normal_flags() also has code to free this
6827                  * hidden body - it swaps the body into a temporary SV it has
6828                  * just allocated, then frees that SV. That causes execution
6829                  * to reach the SVt_REGEXP: case about 60 lines earlier in this
6830                  * function.
6831                  *
6832                  * See Perl_reg_temp_copy() for the code that sets up this
6833                  * REGEXP body referenced by the PVLV. */
6834                 struct regexp *r = ((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx;
6835                 STRLEN len = r->xpv_len;
6836                 pregfree2((REGEXP*) sv);
6837                 del_body_by_type(r, SVt_REGEXP);
6838                 SvLEN_set((sv), len);
6839                 goto freescalar;
6840             }
6841             /* FALLTHROUGH */
6842         case SVt_PVGV:
6843             if (isGV_with_GP(sv)) {
6844                 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
6845                    && HvHasENAME(stash))
6846                     mro_method_changed_in(stash);
6847                 gp_free(MUTABLE_GV(sv));
6848                 if (GvNAME_HEK(sv))
6849                     unshare_hek(GvNAME_HEK(sv));
6850                 /* If we're in a stash, we don't own a reference to it.
6851                  * However it does have a back reference to us, which
6852                  * needs to be cleared.  */
6853                 if ((stash = GvSTASH(sv)))
6854                         sv_del_backref(MUTABLE_SV(stash), sv);
6855             }
6856             /* FIXME. There are probably more unreferenced pointers to SVs
6857              * in the interpreter struct that we should check and tidy in
6858              * a similar fashion to this:  */
6859             /* See also S_sv_unglob, which does the same thing. */
6860             if ((const GV *)sv == PL_last_in_gv)
6861                 PL_last_in_gv = NULL;
6862             else if ((const GV *)sv == PL_statgv)
6863                 PL_statgv = NULL;
6864             else if ((const GV *)sv == PL_stderrgv)
6865                 PL_stderrgv = NULL;
6866             /* FALLTHROUGH */
6867         case SVt_PVMG:
6868         case SVt_PVNV:
6869         case SVt_PVIV:
6870         case SVt_INVLIST:
6871         case SVt_PV:
6872           freescalar:
6873             /* Don't bother with SvOOK_off(sv); as we're only going to
6874              * free it.  */
6875             if (SvOOK(sv)) {
6876                 STRLEN offset;
6877                 SvOOK_offset(sv, offset);
6878                 SvPV_set(sv, SvPVX_mutable(sv) - offset);
6879                 /* Don't even bother with turning off the OOK flag.  */
6880             }
6881             if (SvROK(sv)) {
6882             free_rv:
6883                 {
6884                     SV * const target = SvRV(sv);
6885                     if (SvWEAKREF(sv))
6886                         sv_del_backref(target, sv);
6887                     else
6888                         next_sv = target;
6889                 }
6890             }
6891 #ifdef PERL_ANY_COW
6892             else if (SvPVX_const(sv)
6893                      && !(SvTYPE(sv) == SVt_PVIO
6894                      && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6895             {
6896                 if (SvIsCOW(sv)) {
6897 #ifdef DEBUGGING
6898                     if (DEBUG_C_TEST) {
6899                         PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6900                         sv_dump(sv);
6901                     }
6902 #endif
6903                     if (SvIsCOW_static(sv)) {
6904                         SvLEN_set(sv, 0);
6905                     }
6906                     else if (SvIsCOW_shared_hash(sv)) {
6907                         unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6908                     }
6909                     else {
6910                         if (CowREFCNT(sv)) {
6911                             sv_buf_to_rw(sv);
6912                             CowREFCNT(sv)--;
6913                             sv_buf_to_ro(sv);
6914                             SvLEN_set(sv, 0);
6915                         }
6916                     }
6917                 }
6918                 if (SvLEN(sv)) {
6919                     Safefree(SvPVX_mutable(sv));
6920                 }
6921             }
6922 #else
6923             else if (SvPVX_const(sv) && SvLEN(sv)
6924                      && !(SvTYPE(sv) == SVt_PVIO
6925                      && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6926                 Safefree(SvPVX_mutable(sv));
6927             else if (SvPVX_const(sv) && SvIsCOW(sv)) {
6928                 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6929             }
6930 #endif
6931             break;
6932         case SVt_NV:
6933             break;
6934         }
6935 
6936       free_body:
6937 
6938         {
6939             U32 arena_index;
6940             const struct body_details *sv_type_details;
6941 
6942             if (type == SVt_PVHV && HvHasAUX(sv)) {
6943                 arena_index = HVAUX_ARENA_ROOT_IX;
6944                 sv_type_details = &fake_hv_with_aux;
6945             }
6946             else {
6947                 arena_index = type;
6948                 sv_type_details = bodies_by_type + arena_index;
6949             }
6950 
6951             SvFLAGS(sv) &= SVf_BREAK;
6952             SvFLAGS(sv) |= SVTYPEMASK;
6953 
6954             if (sv_type_details->arena) {
6955                 del_body(((char *)SvANY(sv) + sv_type_details->offset),
6956                          &PL_body_roots[arena_index]);
6957             }
6958             else if (sv_type_details->body_size) {
6959                 safefree(SvANY(sv));
6960             }
6961         }
6962 
6963       free_head:
6964         /* caller is responsible for freeing the head of the original sv */
6965         if (sv != orig_sv && !SvREFCNT(sv))
6966             del_SV(sv);
6967 
6968         /* grab and free next sv, if any */
6969       get_next_sv:
6970         while (1) {
6971             sv = NULL;
6972             if (next_sv) {
6973                 sv = next_sv;
6974                 next_sv = NULL;
6975             }
6976             else if (!iter_sv) {
6977                 break;
6978             } else if (SvTYPE(iter_sv) == SVt_PVAV) {
6979                 AV *const av = (AV*)iter_sv;
6980                 if (AvFILLp(av) > -1) {
6981                     sv = AvARRAY(av)[AvFILLp(av)--];
6982                 }
6983                 else { /* no more elements of current AV to free */
6984                     sv = iter_sv;
6985                     type = SvTYPE(sv);
6986                     /* restore previous value, squirrelled away */
6987                     iter_sv = AvARRAY(av)[AvMAX(av)];
6988                     Safefree(AvALLOC(av));
6989                     goto free_body;
6990                 }
6991             } else if (SvTYPE(iter_sv) == SVt_PVOBJ) {
6992                 if (ObjectMAXFIELD(iter_sv) > -1) {
6993                     sv = ObjectFIELDS(iter_sv)[ObjectMAXFIELD(iter_sv)--];
6994                 }
6995                 else { /* no more fields in the current SV to free */
6996                     sv = iter_sv;
6997                     type = SvTYPE(sv);
6998                     iter_sv = ObjectFIELDS(sv)[ObjectITERSVAT(sv)];
6999                     Safefree(ObjectFIELDS(sv));
7000                     goto free_body;
7001                 }
7002             } else if (SvTYPE(iter_sv) == SVt_PVHV) {
7003                 sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index);
7004                 if (!sv && !HvTOTALKEYS((HV *)iter_sv)) {
7005                     /* no more elements of current HV to free */
7006                     sv = iter_sv;
7007                     type = SvTYPE(sv);
7008                     /* Restore previous values of iter_sv and hash_index,
7009                      * squirrelled away */
7010                     assert(!SvOBJECT(sv));
7011                     iter_sv = (SV*)SvSTASH(sv);
7012                     assert(!SvMAGICAL(sv));
7013                     hash_index = ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index;
7014 #ifdef DEBUGGING
7015                     /* perl -DA does not like rubbish in SvMAGIC. */
7016                     SvMAGIC_set(sv, 0);
7017 #endif
7018 
7019                     /* free any remaining detritus from the hash struct */
7020                     Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
7021                     assert(!HvARRAY((HV*)sv));
7022                     goto free_body;
7023                 }
7024             }
7025 
7026             /* unrolled SvREFCNT_dec and sv_free2 follows: */
7027 
7028             if (!sv)
7029                 continue;
7030             if (!SvREFCNT(sv)) {
7031                 sv_free(sv);
7032                 continue;
7033             }
7034             if (--(SvREFCNT(sv)))
7035                 continue;
7036 #ifdef DEBUGGING
7037             if (SvTEMP(sv)) {
7038                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
7039                          "Attempt to free temp prematurely: SV 0x%" UVxf
7040                          pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
7041                 continue;
7042             }
7043 #endif
7044             if (SvIMMORTAL(sv)) {
7045                 /* make sure SvREFCNT(sv)==0 happens very seldom */
7046                 SvREFCNT(sv) = SvREFCNT_IMMORTAL;
7047                 continue;
7048             }
7049             break;
7050         } /* while 1 */
7051 
7052     } /* while sv */
7053 }
7054 
7055 /* This routine curses the sv itself, not the object referenced by sv. So
7056    sv does not have to be ROK. */
7057 
7058 static bool
7059 S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
7060     PERL_ARGS_ASSERT_CURSE;
7061     assert(SvOBJECT(sv));
7062 
7063     if (PL_defstash &&	/* Still have a symbol table? */
7064         SvDESTROYABLE(sv))
7065     {
7066         dSP;
7067         HV* stash;
7068         do {
7069           stash = SvSTASH(sv);
7070           assert(SvTYPE(stash) == SVt_PVHV);
7071           if (HvNAME(stash)) {
7072             CV* destructor = NULL;
7073             struct mro_meta *meta;
7074 
7075             assert (HvHasAUX(stash));
7076 
7077             DEBUG_o( Perl_deb(aTHX_ "Looking for DESTROY method for %s\n",
7078                          HvNAME(stash)) );
7079 
7080             /* don't make this an initialization above the assert, since it needs
7081                an AUX structure */
7082             meta = HvMROMETA(stash);
7083             if (meta->destroy_gen && meta->destroy_gen == PL_sub_generation) {
7084                 destructor = meta->destroy;
7085                 DEBUG_o( Perl_deb(aTHX_ "Using cached DESTROY method %p for %s\n",
7086                              (void *)destructor, HvNAME(stash)) );
7087             }
7088             else {
7089                 bool autoload = FALSE;
7090                 GV *gv =
7091                     gv_fetchmeth_pvn(stash, S_destroy, S_destroy_len, -1, 0);
7092                 if (gv)
7093                     destructor = GvCV(gv);
7094                 if (!destructor) {
7095                     gv = gv_autoload_pvn(stash, S_destroy, S_destroy_len,
7096                                          GV_AUTOLOAD_ISMETHOD);
7097                     if (gv)
7098                         destructor = GvCV(gv);
7099                     if (destructor)
7100                         autoload = TRUE;
7101                 }
7102                 /* we don't cache AUTOLOAD for DESTROY, since this code
7103                    would then need to set $__PACKAGE__::AUTOLOAD, or the
7104                    equivalent for XS AUTOLOADs */
7105                 if (!autoload) {
7106                     meta->destroy_gen = PL_sub_generation;
7107                     meta->destroy = destructor;
7108 
7109                     DEBUG_o( Perl_deb(aTHX_ "Set cached DESTROY method %p for %s\n",
7110                                       (void *)destructor, HvNAME(stash)) );
7111                 }
7112                 else {
7113                     DEBUG_o( Perl_deb(aTHX_ "Not caching AUTOLOAD for DESTROY method for %s\n",
7114                                       HvNAME(stash)) );
7115                 }
7116             }
7117             assert(!destructor || SvTYPE(destructor) == SVt_PVCV);
7118             if (destructor
7119                 /* A constant subroutine can have no side effects, so
7120                    don't bother calling it.  */
7121                 && !CvCONST(destructor)
7122                 /* Don't bother calling an empty destructor or one that
7123                    returns immediately. */
7124                 && (CvISXSUB(destructor)
7125                 || (CvSTART(destructor)
7126                     && (CvSTART(destructor)->op_next->op_type
7127                                         != OP_LEAVESUB)
7128                     && (CvSTART(destructor)->op_next->op_type
7129                                         != OP_PUSHMARK
7130                         || CvSTART(destructor)->op_next->op_next->op_type
7131                                         != OP_RETURN
7132                        )
7133                    ))
7134                )
7135             {
7136                 SV* const tmpref = newRV(sv);
7137                 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
7138                 ENTER;
7139                 PUSHSTACKi(PERLSI_DESTROY);
7140                 EXTEND(SP, 2);
7141                 PUSHMARK(SP);
7142                 PUSHs(tmpref);
7143                 PUTBACK;
7144                 call_sv(MUTABLE_SV(destructor),
7145                             G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
7146                 POPSTACK;
7147                 SPAGAIN;
7148                 LEAVE;
7149                 if(SvREFCNT(tmpref) < 2) {
7150                     /* tmpref is not kept alive! */
7151                     SvREFCNT(sv)--;
7152                     SvRV_set(tmpref, NULL);
7153                     SvROK_off(tmpref);
7154                 }
7155                 SvREFCNT_dec_NN(tmpref);
7156             }
7157           }
7158         } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
7159 
7160 
7161         if (check_refcnt && SvREFCNT(sv)) {
7162             if (PL_in_clean_objs)
7163                 Perl_croak(aTHX_
7164                   "DESTROY created new reference to dead object '%" HEKf "'",
7165                    HEKfARG(HvNAME_HEK(stash)));
7166             /* DESTROY gave object new lease on life */
7167             return FALSE;
7168         }
7169     }
7170 
7171     if (SvOBJECT(sv)) {
7172         HV * const stash = SvSTASH(sv);
7173         /* Curse before freeing the stash, as freeing the stash could cause
7174            a recursive call into S_curse. */
7175         SvOBJECT_off(sv);	/* Curse the object. */
7176         SvSTASH_set(sv,0);	/* SvREFCNT_dec may try to read this */
7177         SvREFCNT_dec(stash); /* possibly of changed persuasion */
7178     }
7179     return TRUE;
7180 }
7181 
7182 /*
7183 =for apidoc sv_newref
7184 
7185 Increment an SV's reference count.  Use the C<SvREFCNT_inc()> wrapper
7186 instead.
7187 
7188 =cut
7189 */
7190 
7191 SV *
7192 Perl_sv_newref(pTHX_ SV *const sv)
7193 {
7194     PERL_UNUSED_CONTEXT;
7195     if (sv)
7196         (SvREFCNT(sv))++;
7197     return sv;
7198 }
7199 
7200 /*
7201 =for apidoc sv_free
7202 
7203 Decrement an SV's reference count, and if it drops to zero, call
7204 C<sv_clear> to invoke destructors and free up any memory used by
7205 the body; finally, deallocating the SV's head itself.
7206 Normally called via a wrapper macro C<SvREFCNT_dec>.
7207 
7208 =cut
7209 */
7210 
7211 void
7212 Perl_sv_free(pTHX_ SV *const sv)
7213 {
7214     SvREFCNT_dec(sv);
7215 }
7216 
7217 
7218 /* Private helper function for SvREFCNT_dec().
7219  * Called with rc set to original SvREFCNT(sv), where rc == 0 or 1 */
7220 
7221 void
7222 Perl_sv_free2(pTHX_ SV *const sv, const U32 rc)
7223 {
7224 
7225     PERL_ARGS_ASSERT_SV_FREE2;
7226 
7227     if (LIKELY( rc == 1 )) {
7228         /* normal case */
7229         SvREFCNT(sv) = 0;
7230 
7231 #ifdef DEBUGGING
7232         if (SvTEMP(sv)) {
7233             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
7234                              "Attempt to free temp prematurely: SV 0x%" UVxf
7235                              pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
7236             return;
7237         }
7238 #endif
7239         if (SvIMMORTAL(sv)) {
7240             /* make sure SvREFCNT(sv)==0 happens very seldom */
7241             SvREFCNT(sv) = SvREFCNT_IMMORTAL;
7242             return;
7243         }
7244         sv_clear(sv);
7245         if (! SvREFCNT(sv)) /* may have have been resurrected */
7246             del_SV(sv);
7247         return;
7248     }
7249 
7250     /* handle exceptional cases */
7251 
7252     assert(rc == 0);
7253 
7254     if (SvFLAGS(sv) & SVf_BREAK)
7255         /* this SV's refcnt has been artificially decremented to
7256          * trigger cleanup */
7257         return;
7258     if (PL_in_clean_all) /* All is fair */
7259         return;
7260     if (SvIMMORTAL(sv)) {
7261         /* make sure SvREFCNT(sv)==0 happens very seldom */
7262         SvREFCNT(sv) = SvREFCNT_IMMORTAL;
7263         return;
7264     }
7265     if (ckWARN_d(WARN_INTERNAL)) {
7266 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
7267         Perl_dump_sv_child(aTHX_ sv);
7268 #else
7269     #ifdef DEBUG_LEAKING_SCALARS
7270         sv_dump(sv);
7271     #endif
7272 #ifdef DEBUG_LEAKING_SCALARS_ABORT
7273         if (PL_warnhook == PERL_WARNHOOK_FATAL
7274             || ckDEAD(packWARN(WARN_INTERNAL))) {
7275             /* Don't let Perl_warner cause us to escape our fate:  */
7276             abort();
7277         }
7278 #endif
7279         /* This may not return:  */
7280         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
7281                     "Attempt to free unreferenced scalar: SV 0x%" UVxf
7282                     pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
7283 #endif
7284     }
7285 #ifdef DEBUG_LEAKING_SCALARS_ABORT
7286     abort();
7287 #endif
7288 
7289 }
7290 
7291 
7292 /*
7293 =for apidoc sv_len
7294 
7295 Returns the length of the string in the SV.  Handles magic and type
7296 coercion and sets the UTF8 flag appropriately.  See also C<L</SvCUR>>, which
7297 gives raw access to the C<xpv_cur> slot.
7298 
7299 =cut
7300 */
7301 
7302 STRLEN
7303 Perl_sv_len(pTHX_ SV *const sv)
7304 {
7305     STRLEN len;
7306 
7307     if (!sv)
7308         return 0;
7309 
7310     (void)SvPV_const(sv, len);
7311     return len;
7312 }
7313 
7314 /*
7315 =for apidoc sv_len_utf8
7316 =for apidoc_item sv_len_utf8_nomg
7317 
7318 These return the number of characters in the string in an SV, counting wide
7319 UTF-8 bytes as a single character.  Both handle type coercion.
7320 They differ only in that C<sv_len_utf8> performs 'get' magic;
7321 C<sv_len_utf8_nomg> skips any magic.
7322 
7323 =cut
7324 */
7325 
7326 /*
7327  * The length is cached in PERL_MAGIC_utf8, in the mg_len field.  Also the
7328  * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
7329  * (Note that the mg_len is not the length of the mg_ptr field.
7330  * This allows the cache to store the character length of the string without
7331  * needing to malloc() extra storage to attach to the mg_ptr.)
7332  *
7333  */
7334 
7335 STRLEN
7336 Perl_sv_len_utf8(pTHX_ SV *const sv)
7337 {
7338     if (!sv)
7339         return 0;
7340 
7341     SvGETMAGIC(sv);
7342     return sv_len_utf8_nomg(sv);
7343 }
7344 
7345 STRLEN
7346 Perl_sv_len_utf8_nomg(pTHX_ SV * const sv)
7347 {
7348     STRLEN len;
7349     const U8 *s = (U8*)SvPV_nomg_const(sv, len);
7350 
7351     PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG;
7352 
7353     if (PL_utf8cache && SvUTF8(sv)) {
7354             STRLEN ulen;
7355             MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
7356 
7357             if (mg && (mg->mg_len != -1 || mg->mg_ptr)) {
7358                 if (mg->mg_len != -1)
7359                     ulen = mg->mg_len;
7360                 else {
7361                     /* We can use the offset cache for a headstart.
7362                        The longer value is stored in the first pair.  */
7363                     STRLEN *cache = (STRLEN *) mg->mg_ptr;
7364 
7365                     ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1],
7366                                                        s + len);
7367                 }
7368 
7369                 if (PL_utf8cache < 0) {
7370                     const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
7371                     assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv);
7372                 }
7373             }
7374             else {
7375                 ulen = Perl_utf8_length(aTHX_ s, s + len);
7376                 utf8_mg_len_cache_update(sv, &mg, ulen);
7377             }
7378             return ulen;
7379     }
7380     return SvUTF8(sv) ? Perl_utf8_length(aTHX_ s, s + len) : len;
7381 }
7382 
7383 /* Walk forwards to find the byte corresponding to the passed in UTF-8
7384    offset.  */
7385 static STRLEN
7386 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
7387                       STRLEN *const uoffset_p, bool *const at_end,
7388                       bool* canonical_position)
7389 {
7390     const U8 *s = start;
7391     STRLEN uoffset = *uoffset_p;
7392 
7393     PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
7394 
7395     while (s < send && uoffset) {
7396         --uoffset;
7397         s += UTF8SKIP(s);
7398     }
7399     if (s == send) {
7400         *at_end = TRUE;
7401     }
7402     else if (s > send) {
7403         *at_end = TRUE;
7404         /* This is the existing behaviour. Possibly it should be a croak, as
7405            it's actually a bounds error  */
7406         s = send;
7407     }
7408     /* If the unicode position is beyond the end, we return the end but
7409        shouldn't cache that position */
7410     *canonical_position = (uoffset == 0);
7411     *uoffset_p -= uoffset;
7412     return s - start;
7413 }
7414 
7415 /* Given the length of the string in both bytes and UTF-8 characters, decide
7416    whether to walk forwards or backwards to find the byte corresponding to
7417    the passed in UTF-8 offset.  */
7418 static STRLEN
7419 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
7420                     STRLEN uoffset, const STRLEN uend)
7421 {
7422     STRLEN backw = uend - uoffset;
7423 
7424     PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
7425 
7426     if (uoffset < 2 * backw) {
7427         /* The assumption is that going forwards is twice the speed of going
7428            forward (that's where the 2 * backw comes from).
7429            (The real figure of course depends on the UTF-8 data.)  */
7430         const U8 *s = start;
7431 
7432         while (s < send && uoffset--)
7433             s += UTF8SKIP(s);
7434         assert (s <= send);
7435         if (s > send)
7436             s = send;
7437         return s - start;
7438     }
7439 
7440     while (backw--) {
7441         send--;
7442         while (UTF8_IS_CONTINUATION(*send))
7443             send--;
7444     }
7445     return send - start;
7446 }
7447 
7448 /* For the string representation of the given scalar, find the byte
7449    corresponding to the passed in UTF-8 offset.  uoffset0 and boffset0
7450    give another position in the string, *before* the sought offset, which
7451    (which is always true, as 0, 0 is a valid pair of positions), which should
7452    help reduce the amount of linear searching.
7453    If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
7454    will be used to reduce the amount of linear searching. The cache will be
7455    created if necessary, and the found value offered to it for update.  */
7456 static STRLEN
7457 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
7458                     const U8 *const send, STRLEN uoffset,
7459                     STRLEN uoffset0, STRLEN boffset0)
7460 {
7461     STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy.  */
7462     bool found = FALSE;
7463     bool at_end = FALSE;
7464     bool canonical_position = FALSE;
7465 
7466     PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
7467 
7468     assert (uoffset >= uoffset0);
7469 
7470     if (!uoffset)
7471         return 0;
7472 
7473     if (!SvREADONLY(sv) && !SvGMAGICAL(sv) && SvPOK(sv)
7474         && PL_utf8cache
7475         && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
7476                      (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
7477         if ((*mgp)->mg_ptr) {
7478             STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
7479             if (cache[0] == uoffset) {
7480                 /* An exact match. */
7481                 return cache[1];
7482             }
7483             if (cache[2] == uoffset) {
7484                 /* An exact match. */
7485                 return cache[3];
7486             }
7487 
7488             if (cache[0] < uoffset) {
7489                 /* The cache already knows part of the way.   */
7490                 if (cache[0] > uoffset0) {
7491                     /* The cache knows more than the passed in pair  */
7492                     uoffset0 = cache[0];
7493                     boffset0 = cache[1];
7494                 }
7495                 if ((*mgp)->mg_len != -1) {
7496                     /* And we know the end too.  */
7497                     boffset = boffset0
7498                         + sv_pos_u2b_midway(start + boffset0, send,
7499                                               uoffset - uoffset0,
7500                                               (*mgp)->mg_len - uoffset0);
7501                 } else {
7502                     uoffset -= uoffset0;
7503                     boffset = boffset0
7504                         + sv_pos_u2b_forwards(start + boffset0,
7505                                               send, &uoffset, &at_end,
7506                                               &canonical_position);
7507                     uoffset += uoffset0;
7508                 }
7509             }
7510             else if (cache[2] < uoffset) {
7511                 /* We're between the two cache entries.  */
7512                 if (cache[2] > uoffset0) {
7513                     /* and the cache knows more than the passed in pair  */
7514                     uoffset0 = cache[2];
7515                     boffset0 = cache[3];
7516                 }
7517 
7518                 boffset = boffset0
7519                     + sv_pos_u2b_midway(start + boffset0,
7520                                           start + cache[1],
7521                                           uoffset - uoffset0,
7522                                           cache[0] - uoffset0);
7523             } else {
7524                 boffset = boffset0
7525                     + sv_pos_u2b_midway(start + boffset0,
7526                                           start + cache[3],
7527                                           uoffset - uoffset0,
7528                                           cache[2] - uoffset0);
7529             }
7530             found = TRUE;
7531         }
7532         else if ((*mgp)->mg_len != -1) {
7533             /* If we can take advantage of a passed in offset, do so.  */
7534             /* In fact, offset0 is either 0, or less than offset, so don't
7535                need to worry about the other possibility.  */
7536             boffset = boffset0
7537                 + sv_pos_u2b_midway(start + boffset0, send,
7538                                       uoffset - uoffset0,
7539                                       (*mgp)->mg_len - uoffset0);
7540             found = TRUE;
7541         }
7542     }
7543 
7544     if (!found || PL_utf8cache < 0) {
7545         STRLEN real_boffset;
7546         uoffset -= uoffset0;
7547         real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0,
7548                                                       send, &uoffset, &at_end,
7549                                                       &canonical_position);
7550         uoffset += uoffset0;
7551 
7552         if (found && PL_utf8cache < 0)
7553             assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset,
7554                                        real_boffset, sv);
7555         boffset = real_boffset;
7556     }
7557 
7558     if (PL_utf8cache && canonical_position && !SvGMAGICAL(sv) && SvPOK(sv)) {
7559         if (at_end)
7560             utf8_mg_len_cache_update(sv, mgp, uoffset);
7561         else
7562             utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
7563     }
7564     return boffset;
7565 }
7566 
7567 
7568 /*
7569 =for apidoc sv_pos_u2b_flags
7570 
7571 Converts the offset from a count of UTF-8 chars from
7572 the start of the string, to a count of the equivalent number of bytes; if
7573 C<lenp> is non-zero, it does the same to C<lenp>, but this time starting from
7574 C<offset>, rather than from the start
7575 of the string.  Handles type coercion.
7576 C<flags> is passed to C<SvPV_flags>, and usually should be
7577 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
7578 
7579 =cut
7580 */
7581 
7582 /*
7583  * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
7584  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
7585  * byte offsets.  See also the comments of S_utf8_mg_pos_cache_update().
7586  *
7587  */
7588 
7589 STRLEN
7590 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
7591                       U32 flags)
7592 {
7593     const U8 *start;
7594     STRLEN len;
7595     STRLEN boffset;
7596 
7597     PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
7598 
7599     start = (U8*)SvPV_flags(sv, len, flags);
7600     if (len) {
7601         const U8 * const send = start + len;
7602         MAGIC *mg = NULL;
7603         boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
7604 
7605         if (lenp
7606             && *lenp /* don't bother doing work for 0, as its bytes equivalent
7607                         is 0, and *lenp is already set to that.  */) {
7608             /* Convert the relative offset to absolute.  */
7609             const STRLEN uoffset2 = uoffset + *lenp;
7610             const STRLEN boffset2
7611                 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
7612                                       uoffset, boffset) - boffset;
7613 
7614             *lenp = boffset2;
7615         }
7616     } else {
7617         if (lenp)
7618             *lenp = 0;
7619         boffset = 0;
7620     }
7621 
7622     return boffset;
7623 }
7624 
7625 /*
7626 =for apidoc sv_pos_u2b
7627 
7628 Converts the value pointed to by C<offsetp> from a count of UTF-8 chars from
7629 the start of the string, to a count of the equivalent number of bytes; if
7630 C<lenp> is non-zero, it does the same to C<lenp>, but this time starting from
7631 the offset, rather than from the start of the string.  Handles magic and
7632 type coercion.
7633 
7634 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
7635 than 2Gb.
7636 
7637 =cut
7638 */
7639 
7640 /*
7641  * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
7642  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
7643  * byte offsets.  See also the comments of S_utf8_mg_pos_cache_update().
7644  *
7645  */
7646 
7647 /* This function is subject to size and sign problems */
7648 
7649 void
7650 Perl_sv_pos_u2b(pTHX_ SV *const sv, I32 *const offsetp, I32 *const lenp)
7651 {
7652     PERL_ARGS_ASSERT_SV_POS_U2B;
7653 
7654     if (lenp) {
7655         STRLEN ulen = (STRLEN)*lenp;
7656         *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
7657                                          SV_GMAGIC|SV_CONST_RETURN);
7658         *lenp = (I32)ulen;
7659     } else {
7660         *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
7661                                          SV_GMAGIC|SV_CONST_RETURN);
7662     }
7663 }
7664 
7665 static void
7666 S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp,
7667                            const STRLEN ulen)
7668 {
7669     PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
7670     if (SvREADONLY(sv) || SvGMAGICAL(sv) || !SvPOK(sv))
7671         return;
7672 
7673     if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
7674                   !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
7675         *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
7676     }
7677     assert(*mgp);
7678 
7679     (*mgp)->mg_len = ulen;
7680 }
7681 
7682 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
7683    byte length pairing. The (byte) length of the total SV is passed in too,
7684    as blen, because for some (more esoteric) SVs, the call to SvPV_const()
7685    may not have updated SvCUR, so we can't rely on reading it directly.
7686 
7687    The proffered utf8/byte length pairing isn't used if the cache already has
7688    two pairs, and swapping either for the proffered pair would increase the
7689    RMS of the intervals between known byte offsets.
7690 
7691    The cache itself consists of 4 STRLEN values
7692    0: larger UTF-8 offset
7693    1: corresponding byte offset
7694    2: smaller UTF-8 offset
7695    3: corresponding byte offset
7696 
7697    Unused cache pairs have the value 0, 0.
7698    Keeping the cache "backwards" means that the invariant of
7699    cache[0] >= cache[2] is maintained even with empty slots, which means that
7700    the code that uses it doesn't need to worry if only 1 entry has actually
7701    been set to non-zero.  It also makes the "position beyond the end of the
7702    cache" logic much simpler, as the first slot is always the one to start
7703    from.
7704 */
7705 static void
7706 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
7707                            const STRLEN utf8, const STRLEN blen)
7708 {
7709     STRLEN *cache;
7710 
7711     PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
7712 
7713     if (SvREADONLY(sv))
7714         return;
7715 
7716     if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
7717                   !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
7718         *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
7719                            0);
7720         (*mgp)->mg_len = -1;
7721     }
7722     assert(*mgp);
7723 
7724     if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
7725         Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
7726         (*mgp)->mg_ptr = (char *) cache;
7727     }
7728     assert(cache);
7729 
7730     if (PL_utf8cache < 0 && SvPOKp(sv)) {
7731         /* SvPOKp() because, if sv is a reference, then SvPVX() is actually
7732            a pointer.  Note that we no longer cache utf8 offsets on refer-
7733            ences, but this check is still a good idea, for robustness.  */
7734         const U8 *start = (const U8 *) SvPVX_const(sv);
7735         const STRLEN realutf8 = utf8_length(start, start + byte);
7736 
7737         assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8,
7738                                    sv);
7739     }
7740 
7741     /* Cache is held with the later position first, to simplify the code
7742        that deals with unbounded ends.  */
7743 
7744     ASSERT_UTF8_CACHE(cache);
7745     if (cache[1] == 0) {
7746         /* Cache is totally empty  */
7747         cache[0] = utf8;
7748         cache[1] = byte;
7749     } else if (cache[3] == 0) {
7750         if (byte > cache[1]) {
7751             /* New one is larger, so goes first.  */
7752             cache[2] = cache[0];
7753             cache[3] = cache[1];
7754             cache[0] = utf8;
7755             cache[1] = byte;
7756         } else {
7757             cache[2] = utf8;
7758             cache[3] = byte;
7759         }
7760     } else {
7761 /* float casts necessary? XXX */
7762 #define THREEWAY_SQUARE(a,b,c,d) \
7763             ((float)((d) - (c))) * ((float)((d) - (c))) \
7764             + ((float)((c) - (b))) * ((float)((c) - (b))) \
7765                + ((float)((b) - (a))) * ((float)((b) - (a)))
7766 
7767         /* Cache has 2 slots in use, and we know three potential pairs.
7768            Keep the two that give the lowest RMS distance. Do the
7769            calculation in bytes simply because we always know the byte
7770            length.  squareroot has the same ordering as the positive value,
7771            so don't bother with the actual square root.  */
7772         if (byte > cache[1]) {
7773             /* New position is after the existing pair of pairs.  */
7774             const float keep_earlier
7775                 = THREEWAY_SQUARE(0, cache[3], byte, blen);
7776             const float keep_later
7777                 = THREEWAY_SQUARE(0, cache[1], byte, blen);
7778 
7779             if (keep_later < keep_earlier) {
7780                 cache[2] = cache[0];
7781                 cache[3] = cache[1];
7782             }
7783             cache[0] = utf8;
7784             cache[1] = byte;
7785         }
7786         else {
7787             const float keep_later = THREEWAY_SQUARE(0, byte, cache[1], blen);
7788             float b, c, keep_earlier;
7789             if (byte > cache[3]) {
7790                 /* New position is between the existing pair of pairs.  */
7791                 b = (float)cache[3];
7792                 c = (float)byte;
7793             } else {
7794                 /* New position is before the existing pair of pairs.  */
7795                 b = (float)byte;
7796                 c = (float)cache[3];
7797             }
7798             keep_earlier = THREEWAY_SQUARE(0, b, c, blen);
7799             if (byte > cache[3]) {
7800                 if (keep_later < keep_earlier) {
7801                     cache[2] = utf8;
7802                     cache[3] = byte;
7803                 }
7804                 else {
7805                     cache[0] = utf8;
7806                     cache[1] = byte;
7807                 }
7808             }
7809             else {
7810                 if (! (keep_later < keep_earlier)) {
7811                     cache[0] = cache[2];
7812                     cache[1] = cache[3];
7813                 }
7814                 cache[2] = utf8;
7815                 cache[3] = byte;
7816             }
7817         }
7818     }
7819     ASSERT_UTF8_CACHE(cache);
7820 }
7821 
7822 /* We already know all of the way, now we may be able to walk back.  The same
7823    assumption is made as in S_sv_pos_u2b_midway(), namely that walking
7824    backward is half the speed of walking forward. */
7825 static STRLEN
7826 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
7827                     const U8 *end, STRLEN endu)
7828 {
7829     const STRLEN forw = target - s;
7830     STRLEN backw = end - target;
7831 
7832     PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
7833 
7834     if (forw < 2 * backw) {
7835         return utf8_length(s, target);
7836     }
7837 
7838     while (end > target) {
7839         end--;
7840         while (UTF8_IS_CONTINUATION(*end)) {
7841             end--;
7842         }
7843         endu--;
7844     }
7845     return endu;
7846 }
7847 
7848 /*
7849 =for apidoc sv_pos_b2u_flags
7850 
7851 Converts C<offset> from a count of bytes from the start of the string, to
7852 a count of the equivalent number of UTF-8 chars.  Handles type coercion.
7853 C<flags> is passed to C<SvPV_flags>, and usually should be
7854 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
7855 
7856 =cut
7857 */
7858 
7859 /*
7860  * sv_pos_b2u_flags() uses, like sv_pos_u2b_flags(), the mg_ptr of the
7861  * potential PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8
7862  * and byte offsets.
7863  *
7864  */
7865 STRLEN
7866 Perl_sv_pos_b2u_flags(pTHX_ SV *const sv, STRLEN const offset, U32 flags)
7867 {
7868     const U8* s;
7869     STRLEN len = 0; /* Actually always set, but let's keep gcc happy.  */
7870     STRLEN blen;
7871     MAGIC* mg = NULL;
7872     const U8* send;
7873     bool found = FALSE;
7874 
7875     PERL_ARGS_ASSERT_SV_POS_B2U_FLAGS;
7876 
7877     s = (const U8*)SvPV_flags(sv, blen, flags);
7878 
7879     if (blen < offset)
7880         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%" UVuf
7881                    ", byte=%" UVuf, (UV)blen, (UV)offset);
7882 
7883     send = s + offset;
7884 
7885     if (!SvREADONLY(sv)
7886         && PL_utf8cache
7887         && SvTYPE(sv) >= SVt_PVMG
7888         && (mg = mg_find(sv, PERL_MAGIC_utf8)))
7889     {
7890         if (mg->mg_ptr) {
7891             STRLEN * const cache = (STRLEN *) mg->mg_ptr;
7892             if (cache[1] == offset) {
7893                 /* An exact match. */
7894                 return cache[0];
7895             }
7896             if (cache[3] == offset) {
7897                 /* An exact match. */
7898                 return cache[2];
7899             }
7900 
7901             if (cache[1] < offset) {
7902                 /* We already know part of the way. */
7903                 if (mg->mg_len != -1) {
7904                     /* Actually, we know the end too.  */
7905                     len = cache[0]
7906                         + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
7907                                               s + blen, mg->mg_len - cache[0]);
7908                 } else {
7909                     len = cache[0] + utf8_length(s + cache[1], send);
7910                 }
7911             }
7912             else if (cache[3] < offset) {
7913                 /* We're between the two cached pairs, so we do the calculation
7914                    offset by the byte/utf-8 positions for the earlier pair,
7915                    then add the utf-8 characters from the string start to
7916                    there.  */
7917                 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
7918                                           s + cache[1], cache[0] - cache[2])
7919                     + cache[2];
7920 
7921             }
7922             else { /* cache[3] > offset */
7923                 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
7924                                           cache[2]);
7925 
7926             }
7927             ASSERT_UTF8_CACHE(cache);
7928             found = TRUE;
7929         } else if (mg->mg_len != -1) {
7930             len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
7931             found = TRUE;
7932         }
7933     }
7934     if (!found || PL_utf8cache < 0) {
7935         const STRLEN real_len = utf8_length(s, send);
7936 
7937         if (found && PL_utf8cache < 0)
7938             assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv);
7939         len = real_len;
7940     }
7941 
7942     if (PL_utf8cache) {
7943         if (blen == offset)
7944             utf8_mg_len_cache_update(sv, &mg, len);
7945         else
7946             utf8_mg_pos_cache_update(sv, &mg, offset, len, blen);
7947     }
7948 
7949     return len;
7950 }
7951 
7952 /*
7953 =for apidoc sv_pos_b2u
7954 
7955 Converts the value pointed to by C<offsetp> from a count of bytes from the
7956 start of the string, to a count of the equivalent number of UTF-8 chars.
7957 Handles magic and type coercion.
7958 
7959 Use C<sv_pos_b2u_flags> in preference, which correctly handles strings
7960 longer than 2Gb.
7961 
7962 =cut
7963 */
7964 
7965 /*
7966  * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
7967  * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
7968  * byte offsets.
7969  *
7970  */
7971 void
7972 Perl_sv_pos_b2u(pTHX_ SV *const sv, I32 *const offsetp)
7973 {
7974     PERL_ARGS_ASSERT_SV_POS_B2U;
7975 
7976     if (!sv)
7977         return;
7978 
7979     *offsetp = (I32)sv_pos_b2u_flags(sv, (STRLEN)*offsetp,
7980                                      SV_GMAGIC|SV_CONST_RETURN);
7981 }
7982 
7983 static void
7984 S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache,
7985                              STRLEN real, SV *const sv)
7986 {
7987     PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT;
7988 
7989     /* As this is debugging only code, save space by keeping this test here,
7990        rather than inlining it in all the callers.  */
7991     if (from_cache == real)
7992         return;
7993 
7994     /* Need to turn the assertions off otherwise we may recurse infinitely
7995        while printing error messages.  */
7996     SAVEI8(PL_utf8cache);
7997     PL_utf8cache = 0;
7998     Perl_croak(aTHX_ "panic: %s cache %" UVuf " real %" UVuf " for %" SVf,
7999                func, (UV) from_cache, (UV) real, SVfARG(sv));
8000 }
8001 
8002 /*
8003 =for apidoc sv_eq
8004 
8005 Returns a boolean indicating whether the strings in the two SVs are
8006 identical.  Is UTF-8 and S<C<'use bytes'>> aware, handles get magic, and will
8007 coerce its args to strings if necessary.
8008 
8009 This function does not handle operator overloading. For a version that does,
8010 see instead C<sv_streq>.
8011 
8012 =for apidoc sv_eq_flags
8013 
8014 Returns a boolean indicating whether the strings in the two SVs are
8015 identical.  Is UTF-8 and S<C<'use bytes'>> aware and coerces its args to strings
8016 if necessary.  If the flags has the C<SV_GMAGIC> bit set, it handles get-magic, too.
8017 
8018 This function does not handle operator overloading. For a version that does,
8019 see instead C<sv_streq_flags>.
8020 
8021 =cut
8022 */
8023 
8024 I32
8025 Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
8026 {
8027     const char *pv1;
8028     STRLEN cur1;
8029     const char *pv2;
8030     STRLEN cur2;
8031 
8032     if (!sv1) {
8033         pv1 = "";
8034         cur1 = 0;
8035     }
8036     else {
8037         /* if pv1 and pv2 are the same, second SvPV_const call may
8038          * invalidate pv1 (if we are handling magic), so we may need to
8039          * make a copy */
8040         if (sv1 == sv2 && flags & SV_GMAGIC
8041          && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
8042             pv1 = SvPV_const(sv1, cur1);
8043             sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
8044         }
8045         pv1 = SvPV_flags_const(sv1, cur1, flags);
8046     }
8047 
8048     if (!sv2){
8049         pv2 = "";
8050         cur2 = 0;
8051     }
8052     else
8053         pv2 = SvPV_flags_const(sv2, cur2, flags);
8054 
8055     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
8056         /* Differing utf8ness.  */
8057         if (SvUTF8(sv1)) {
8058                   /* sv1 is the UTF-8 one  */
8059                   return bytes_cmp_utf8((const U8*)pv2, cur2,
8060                                         (const U8*)pv1, cur1) == 0;
8061         }
8062         else {
8063                   /* sv2 is the UTF-8 one  */
8064                   return bytes_cmp_utf8((const U8*)pv1, cur1,
8065                                         (const U8*)pv2, cur2) == 0;
8066         }
8067     }
8068 
8069     if (cur1 == cur2)
8070         return (pv1 == pv2) || memEQ(pv1, pv2, cur1);
8071     else
8072         return 0;
8073 }
8074 
8075 /*
8076 =for apidoc sv_streq_flags
8077 
8078 Returns a boolean indicating whether the strings in the two SVs are
8079 identical. If the flags argument has the C<SV_GMAGIC> bit set, it handles
8080 get-magic too. Will coerce its args to strings if necessary. Treats
8081 C<NULL> as undef. Correctly handles the UTF8 flag.
8082 
8083 If flags does not have the C<SV_SKIP_OVERLOAD> bit set, an attempt to use
8084 C<eq> overloading will be made. If such overloading does not exist or the
8085 flag is set, then regular string comparison will be used instead.
8086 
8087 =for apidoc sv_streq
8088 
8089 A convenient shortcut for calling C<sv_streq_flags> with the C<SV_GMAGIC>
8090 flag. This function basically behaves like the Perl code C<$sv1 eq $sv2>.
8091 
8092 =cut
8093 */
8094 
8095 bool
8096 Perl_sv_streq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
8097 {
8098     PERL_ARGS_ASSERT_SV_STREQ_FLAGS;
8099 
8100     if(flags & SV_GMAGIC) {
8101         if(sv1)
8102             SvGETMAGIC(sv1);
8103         if(sv2)
8104             SvGETMAGIC(sv2);
8105     }
8106 
8107     /* Treat NULL as undef */
8108     if(!sv1)
8109         sv1 = &PL_sv_undef;
8110     if(!sv2)
8111         sv2 = &PL_sv_undef;
8112 
8113     if(!(flags & SV_SKIP_OVERLOAD) &&
8114             (SvAMAGIC(sv1) || SvAMAGIC(sv2))) {
8115         SV *ret = amagic_call(sv1, sv2, seq_amg, 0);
8116         if(ret)
8117             return SvTRUE(ret);
8118     }
8119 
8120     return sv_eq_flags(sv1, sv2, 0);
8121 }
8122 
8123 /*
8124 =for apidoc sv_numeq_flags
8125 
8126 Returns a boolean indicating whether the numbers in the two SVs are
8127 identical. If the flags argument has the C<SV_GMAGIC> bit set, it handles
8128 get-magic too. Will coerce its args to numbers if necessary. Treats
8129 C<NULL> as undef.
8130 
8131 If flags does not have the C<SV_SKIP_OVERLOAD> bit set, an attempt to use
8132 C<==> overloading will be made. If such overloading does not exist or the
8133 flag is set, then regular numerical comparison will be used instead.
8134 
8135 =for apidoc sv_numeq
8136 
8137 A convenient shortcut for calling C<sv_numeq_flags> with the C<SV_GMAGIC>
8138 flag. This function basically behaves like the Perl code C<$sv1 == $sv2>.
8139 
8140 =cut
8141 */
8142 
8143 bool
8144 Perl_sv_numeq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
8145 {
8146     PERL_ARGS_ASSERT_SV_NUMEQ_FLAGS;
8147 
8148     if(flags & SV_GMAGIC) {
8149         if(sv1)
8150             SvGETMAGIC(sv1);
8151         if(sv2)
8152             SvGETMAGIC(sv2);
8153     }
8154 
8155     /* Treat NULL as undef */
8156     if(!sv1)
8157         sv1 = &PL_sv_undef;
8158     if(!sv2)
8159         sv2 = &PL_sv_undef;
8160 
8161     if(!(flags & SV_SKIP_OVERLOAD) &&
8162             (SvAMAGIC(sv1) || SvAMAGIC(sv2))) {
8163         SV *ret = amagic_call(sv1, sv2, eq_amg, 0);
8164         if(ret)
8165             return SvTRUE(ret);
8166     }
8167 
8168     return do_ncmp(sv1, sv2) == 0;
8169 }
8170 
8171 /*
8172 =for apidoc sv_cmp
8173 
8174 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
8175 string in C<sv1> is less than, equal to, or greater than the string in
8176 C<sv2>.  Is UTF-8 and S<C<'use bytes'>> aware, handles get magic, and will
8177 coerce its args to strings if necessary.  See also C<L</sv_cmp_locale>>.
8178 
8179 =for apidoc sv_cmp_flags
8180 
8181 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
8182 string in C<sv1> is less than, equal to, or greater than the string in
8183 C<sv2>.  Is UTF-8 and S<C<'use bytes'>> aware and will coerce its args to strings
8184 if necessary.  If the flags has the C<SV_GMAGIC> bit set, it handles get magic.  See
8185 also C<L</sv_cmp_locale_flags>>.
8186 
8187 =cut
8188 */
8189 
8190 I32
8191 Perl_sv_cmp(pTHX_ SV *const sv1, SV *const sv2)
8192 {
8193     return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
8194 }
8195 
8196 I32
8197 Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2,
8198                   const U32 flags)
8199 {
8200     STRLEN cur1, cur2;
8201     const char *pv1, *pv2;
8202     I32  cmp;
8203     SV *svrecode = NULL;
8204 
8205     if (!sv1) {
8206         pv1 = "";
8207         cur1 = 0;
8208     }
8209     else
8210         pv1 = SvPV_flags_const(sv1, cur1, flags);
8211 
8212     if (!sv2) {
8213         pv2 = "";
8214         cur2 = 0;
8215     }
8216     else
8217         pv2 = SvPV_flags_const(sv2, cur2, flags);
8218 
8219     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
8220         /* Differing utf8ness.  */
8221         if (SvUTF8(sv1)) {
8222                 const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2,
8223                                                    (const U8*)pv1, cur1);
8224                 return retval ? retval < 0 ? -1 : +1 : 0;
8225         }
8226         else {
8227                 const int retval = bytes_cmp_utf8((const U8*)pv1, cur1,
8228                                                   (const U8*)pv2, cur2);
8229                 return retval ? retval < 0 ? -1 : +1 : 0;
8230         }
8231     }
8232 
8233     /* Here, if both are non-NULL, then they have the same UTF8ness. */
8234 
8235     if (!cur1) {
8236         cmp = cur2 ? -1 : 0;
8237     } else if (!cur2) {
8238         cmp = 1;
8239     } else {
8240         STRLEN shortest_len = cur1 < cur2 ? cur1 : cur2;
8241 
8242 #ifdef EBCDIC
8243         if (! DO_UTF8(sv1)) {
8244 #endif
8245             const I32 retval = memcmp((const void*)pv1,
8246                                       (const void*)pv2,
8247                                       shortest_len);
8248             if (retval) {
8249                 cmp = retval < 0 ? -1 : 1;
8250             } else if (cur1 == cur2) {
8251                 cmp = 0;
8252             } else {
8253                 cmp = cur1 < cur2 ? -1 : 1;
8254             }
8255 #ifdef EBCDIC
8256         }
8257         else {  /* Both are to be treated as UTF-EBCDIC */
8258 
8259             /* EBCDIC UTF-8 is complicated by the fact that it is based on I8
8260              * which remaps code points 0-255.  We therefore generally have to
8261              * unmap back to the original values to get an accurate comparison.
8262              * But we don't have to do that for UTF-8 invariants, as by
8263              * definition, they aren't remapped, nor do we have to do it for
8264              * above-latin1 code points, as they also aren't remapped.  (This
8265              * code also works on ASCII platforms, but the memcmp() above is
8266              * much faster). */
8267 
8268             const char *e = pv1 + shortest_len;
8269 
8270             /* Find the first bytes that differ between the two strings */
8271             while (pv1 < e && *pv1 == *pv2) {
8272                 pv1++;
8273                 pv2++;
8274             }
8275 
8276 
8277             if (pv1 == e) { /* Are the same all the way to the end */
8278                 if (cur1 == cur2) {
8279                     cmp = 0;
8280                 } else {
8281                     cmp = cur1 < cur2 ? -1 : 1;
8282                 }
8283             }
8284             else   /* Here *pv1 and *pv2 are not equal, but all bytes earlier
8285                     * in the strings were.  The current bytes may or may not be
8286                     * at the beginning of a character.  But neither or both are
8287                     * (or else earlier bytes would have been different).  And
8288                     * if we are in the middle of a character, the two
8289                     * characters are comprised of the same number of bytes
8290                     * (because in this case the start bytes are the same, and
8291                     * the start bytes encode the character's length). */
8292                  if (UTF8_IS_INVARIANT(*pv1))
8293             {
8294                 /* If both are invariants; can just compare directly */
8295                 if (UTF8_IS_INVARIANT(*pv2)) {
8296                     cmp = ((U8) *pv1 < (U8) *pv2) ? -1 : 1;
8297                 }
8298                 else   /* Since *pv1 is invariant, it is the whole character,
8299                           which means it is at the beginning of a character.
8300                           That means pv2 is also at the beginning of a
8301                           character (see earlier comment).  Since it isn't
8302                           invariant, it must be a start byte.  If it starts a
8303                           character whose code point is above 255, that
8304                           character is greater than any single-byte char, which
8305                           *pv1 is */
8306                       if (UTF8_IS_ABOVE_LATIN1_START(*pv2))
8307                 {
8308                     cmp = -1;
8309                 }
8310                 else {
8311                     /* Here, pv2 points to a character composed of 2 bytes
8312                      * whose code point is < 256.  Get its code point and
8313                      * compare with *pv1 */
8314                     cmp = ((U8) *pv1 < EIGHT_BIT_UTF8_TO_NATIVE(*pv2, *(pv2 + 1)))
8315                            ?  -1
8316                            : 1;
8317                 }
8318             }
8319             else   /* The code point starting at pv1 isn't a single byte */
8320                  if (UTF8_IS_INVARIANT(*pv2))
8321             {
8322                 /* But here, the code point starting at *pv2 is a single byte,
8323                  * and so *pv1 must begin a character, hence is a start byte.
8324                  * If that character is above 255, it is larger than any
8325                  * single-byte char, which *pv2 is */
8326                 if (UTF8_IS_ABOVE_LATIN1_START(*pv1)) {
8327                     cmp = 1;
8328                 }
8329                 else {
8330                     /* Here, pv1 points to a character composed of 2 bytes
8331                      * whose code point is < 256.  Get its code point and
8332                      * compare with the single byte character *pv2 */
8333                     cmp = (EIGHT_BIT_UTF8_TO_NATIVE(*pv1, *(pv1 + 1)) < (U8) *pv2)
8334                           ?  -1
8335                           : 1;
8336                 }
8337             }
8338             else   /* Here, we've ruled out either *pv1 and *pv2 being
8339                       invariant.  That means both are part of variants, but not
8340                       necessarily at the start of a character */
8341                  if (   UTF8_IS_ABOVE_LATIN1_START(*pv1)
8342                      || UTF8_IS_ABOVE_LATIN1_START(*pv2))
8343             {
8344                 /* Here, at least one is the start of a character, which means
8345                  * the other is also a start byte.  And the code point of at
8346                  * least one of the characters is above 255.  It is a
8347                  * characteristic of UTF-EBCDIC that all start bytes for
8348                  * above-latin1 code points are well behaved as far as code
8349                  * point comparisons go, and all are larger than all other
8350                  * start bytes, so the comparison with those is also well
8351                  * behaved */
8352                 cmp = ((U8) *pv1 < (U8) *pv2) ? -1 : 1;
8353             }
8354             else {
8355                 /* Here both *pv1 and *pv2 are part of variant characters.
8356                  * They could be both continuations, or both start characters.
8357                  * (One or both could even be an illegal start character (for
8358                  * an overlong) which for the purposes of sorting we treat as
8359                  * legal. */
8360                 if (UTF8_IS_CONTINUATION(*pv1)) {
8361 
8362                     /* If they are continuations for code points above 255,
8363                      * then comparing the current byte is sufficient, as there
8364                      * is no remapping of these and so the comparison is
8365                      * well-behaved.   We determine if they are such
8366                      * continuations by looking at the preceding byte.  It
8367                      * could be a start byte, from which we can tell if it is
8368                      * for an above 255 code point.  Or it could be a
8369                      * continuation, which means the character occupies at
8370                      * least 3 bytes, so must be above 255.  */
8371                     if (   UTF8_IS_CONTINUATION(*(pv2 - 1))
8372                         || UTF8_IS_ABOVE_LATIN1_START(*(pv2 -1)))
8373                     {
8374                         cmp = ((U8) *pv1 < (U8) *pv2) ? -1 : 1;
8375                         goto cmp_done;
8376                     }
8377 
8378                     /* Here, the continuations are for code points below 256;
8379                      * back up one to get to the start byte */
8380                     pv1--;
8381                     pv2--;
8382                 }
8383 
8384                 /* We need to get the actual native code point of each of these
8385                  * variants in order to compare them */
8386                 cmp =  (  EIGHT_BIT_UTF8_TO_NATIVE(*pv1, *(pv1 + 1))
8387                         < EIGHT_BIT_UTF8_TO_NATIVE(*pv2, *(pv2 + 1)))
8388                         ? -1
8389                         : 1;
8390             }
8391         }
8392       cmp_done: ;
8393 #endif
8394     }
8395 
8396     SvREFCNT_dec(svrecode);
8397 
8398     return cmp;
8399 }
8400 
8401 /*
8402 =for apidoc sv_cmp_locale
8403 
8404 Compares the strings in two SVs in a locale-aware manner.  Is UTF-8 and
8405 S<C<'use bytes'>> aware, handles get magic, and will coerce its args to strings
8406 if necessary.  See also C<L</sv_cmp>>.
8407 
8408 =for apidoc sv_cmp_locale_flags
8409 
8410 Compares the strings in two SVs in a locale-aware manner.  Is UTF-8 and
8411 S<C<'use bytes'>> aware and will coerce its args to strings if necessary.  If
8412 the flags contain C<SV_GMAGIC>, it handles get magic.  See also
8413 C<L</sv_cmp_flags>>.
8414 
8415 =cut
8416 */
8417 
8418 I32
8419 Perl_sv_cmp_locale(pTHX_ SV *const sv1, SV *const sv2)
8420 {
8421     return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
8422 }
8423 
8424 I32
8425 Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2,
8426                          const U32 flags)
8427 {
8428 #ifdef USE_LOCALE_COLLATE
8429 
8430     char *pv1, *pv2;
8431     STRLEN len1, len2;
8432     I32 retval;
8433 
8434     if (PL_collation_standard)
8435         goto raw_compare;
8436 
8437     len1 = len2 = 0;
8438 
8439     /* Revert to using raw compare if both operands exist, but either one
8440      * doesn't transform properly for collation */
8441     if (sv1 && sv2) {
8442         pv1 = sv_collxfrm_flags(sv1, &len1, flags);
8443         if (! pv1) {
8444             goto raw_compare;
8445         }
8446         pv2 = sv_collxfrm_flags(sv2, &len2, flags);
8447         if (! pv2) {
8448             goto raw_compare;
8449         }
8450     }
8451     else {
8452         pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
8453         pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
8454     }
8455 
8456     if (!pv1 || !len1) {
8457         if (pv2 && len2)
8458             return -1;
8459         else
8460             goto raw_compare;
8461     }
8462     else {
8463         if (!pv2 || !len2)
8464             return 1;
8465     }
8466 
8467     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
8468 
8469     if (retval)
8470         return retval < 0 ? -1 : 1;
8471 
8472     /*
8473      * When the result of collation is equality, that doesn't mean
8474      * that there are no differences -- some locales exclude some
8475      * characters from consideration.  So to avoid false equalities,
8476      * we use the raw string as a tiebreaker.
8477      */
8478 
8479   raw_compare:
8480     /* FALLTHROUGH */
8481 
8482 #else
8483     PERL_UNUSED_ARG(flags);
8484 #endif /* USE_LOCALE_COLLATE */
8485 
8486     return sv_cmp(sv1, sv2);
8487 }
8488 
8489 
8490 #ifdef USE_LOCALE_COLLATE
8491 
8492 /*
8493 =for apidoc sv_collxfrm
8494 
8495 This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag.  See
8496 C<L</sv_collxfrm_flags>>.
8497 
8498 =for apidoc sv_collxfrm_flags
8499 
8500 Add Collate Transform magic to an SV if it doesn't already have it.  If the
8501 flags contain C<SV_GMAGIC>, it handles get-magic.
8502 
8503 Any scalar variable may carry C<PERL_MAGIC_collxfrm> magic that contains the
8504 scalar data of the variable, but transformed to such a format that a normal
8505 memory comparison can be used to compare the data according to the locale
8506 settings.
8507 
8508 =cut
8509 */
8510 
8511 char *
8512 Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
8513 {
8514     MAGIC *mg;
8515 
8516     PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
8517 
8518     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
8519 
8520     /* If we don't have collation magic on 'sv', or the locale has changed
8521      * since the last time we calculated it, get it and save it now */
8522     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
8523         const char *s;
8524         char *xf;
8525         STRLEN len, xlen;
8526 
8527         /* Free the old space */
8528         if (mg)
8529             Safefree(mg->mg_ptr);
8530 
8531         s = SvPV_flags_const(sv, len, flags);
8532         if ((xf = mem_collxfrm_(s, len, &xlen, cBOOL(SvUTF8(sv))))) {
8533             if (! mg) {
8534                 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
8535                                  0, 0);
8536                 assert(mg);
8537             }
8538             mg->mg_ptr = xf;
8539             mg->mg_len = xlen;
8540         }
8541         else {
8542             if (mg) {
8543                 mg->mg_ptr = NULL;
8544                 mg->mg_len = -1;
8545             }
8546         }
8547     }
8548 
8549     if (mg && mg->mg_ptr) {
8550         *nxp = mg->mg_len;
8551         return mg->mg_ptr + sizeof(PL_collation_ix);
8552     }
8553     else {
8554         *nxp = 0;
8555         return NULL;
8556     }
8557 }
8558 
8559 #endif /* USE_LOCALE_COLLATE */
8560 
8561 static char *
8562 S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
8563 {
8564     SV * const tsv = newSV_type(SVt_NULL);
8565     ENTER;
8566     SAVEFREESV(tsv);
8567     sv_gets(tsv, fp, 0);
8568     sv_utf8_upgrade_nomg(tsv);
8569     SvCUR_set(sv,append);
8570     sv_catsv(sv,tsv);
8571     LEAVE;
8572     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
8573 }
8574 
8575 static char *
8576 S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
8577 {
8578     SSize_t bytesread;
8579     const STRLEN recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
8580       /* Grab the size of the record we're getting */
8581     char *buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
8582 
8583     /* Go yank in */
8584 #ifdef __VMS
8585     int fd;
8586     Stat_t st;
8587 
8588     /* With a true, record-oriented file on VMS, we need to use read directly
8589      * to ensure that we respect RMS record boundaries.  The user is responsible
8590      * for providing a PL_rs value that corresponds to the FAB$W_MRS (maximum
8591      * record size) field.  N.B. This is likely to produce invalid results on
8592      * varying-width character data when a record ends mid-character.
8593      */
8594     fd = PerlIO_fileno(fp);
8595     if (fd != -1
8596         && PerlLIO_fstat(fd, &st) == 0
8597         && (st.st_fab_rfm == FAB$C_VAR
8598             || st.st_fab_rfm == FAB$C_VFC
8599             || st.st_fab_rfm == FAB$C_FIX)) {
8600 
8601         bytesread = PerlLIO_read(fd, buffer, recsize);
8602     }
8603     else /* in-memory file from PerlIO::Scalar
8604           * or not a record-oriented file
8605           */
8606 #endif
8607     {
8608         bytesread = PerlIO_read(fp, buffer, recsize);
8609 
8610         /* At this point, the logic in sv_get() means that sv will
8611            be treated as utf-8 if the handle is utf8.
8612         */
8613         if (PerlIO_isutf8(fp) && bytesread > 0) {
8614             char *bend = buffer + bytesread;
8615             char *bufp = buffer;
8616             size_t charcount = 0;
8617             bool charstart = TRUE;
8618             STRLEN skip = 0;
8619 
8620             while (charcount < recsize) {
8621                 /* count accumulated characters */
8622                 while (bufp < bend) {
8623                     if (charstart) {
8624                         skip = UTF8SKIP(bufp);
8625                     }
8626                     if (bufp + skip > bend) {
8627                         /* partial at the end */
8628                         charstart = FALSE;
8629                         break;
8630                     }
8631                     else {
8632                         ++charcount;
8633                         bufp += skip;
8634                         charstart = TRUE;
8635                     }
8636                 }
8637 
8638                 if (charcount < recsize) {
8639                     STRLEN readsize;
8640                     STRLEN bufp_offset = bufp - buffer;
8641                     SSize_t morebytesread;
8642 
8643                     /* originally I read enough to fill any incomplete
8644                        character and the first byte of the next
8645                        character if needed, but if there's many
8646                        multi-byte encoded characters we're going to be
8647                        making a read call for every character beyond
8648                        the original read size.
8649 
8650                        So instead, read the rest of the character if
8651                        any, and enough bytes to match at least the
8652                        start bytes for each character we're going to
8653                        read.
8654                     */
8655                     if (charstart)
8656                         readsize = recsize - charcount;
8657                     else
8658                         readsize = skip - (bend - bufp) + recsize - charcount - 1;
8659                     buffer = SvGROW(sv, append + bytesread + readsize + 1) + append;
8660                     bend = buffer + bytesread;
8661                     morebytesread = PerlIO_read(fp, bend, readsize);
8662                     if (morebytesread <= 0) {
8663                         /* we're done, if we still have incomplete
8664                            characters the check code in sv_gets() will
8665                            warn about them.
8666 
8667                            I'd originally considered doing
8668                            PerlIO_ungetc() on all but the lead
8669                            character of the incomplete character, but
8670                            read() doesn't do that, so I don't.
8671                         */
8672                         break;
8673                     }
8674 
8675                     /* prepare to scan some more */
8676                     bytesread += morebytesread;
8677                     bend = buffer + bytesread;
8678                     bufp = buffer + bufp_offset;
8679                 }
8680             }
8681         }
8682     }
8683 
8684     if (bytesread < 0)
8685         bytesread = 0;
8686     SvCUR_set(sv, bytesread + append);
8687     buffer[bytesread] = '\0';
8688     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
8689 }
8690 
8691 /*
8692 =for apidoc sv_gets
8693 
8694 Get a line from the filehandle and store it into the SV, optionally
8695 appending to the currently-stored string.  If C<append> is not 0, the
8696 line is appended to the SV instead of overwriting it.  C<append> should
8697 be set to the byte offset that the appended string should start at
8698 in the SV (typically, C<SvCUR(sv)> is a suitable choice).
8699 
8700 =cut
8701 */
8702 
8703 char *
8704 Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
8705 {
8706     const char *rsptr;
8707     STRLEN rslen;
8708     STDCHAR rslast;
8709     STDCHAR *bp;
8710     SSize_t cnt;
8711     int i = 0;
8712     int rspara = 0;
8713 
8714     PERL_ARGS_ASSERT_SV_GETS;
8715 
8716     if (SvTHINKFIRST(sv))
8717         sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
8718     /* XXX. If you make this PVIV, then copy on write can copy scalars read
8719        from <>.
8720        However, perlbench says it's slower, because the existing swipe code
8721        is faster than copy on write.
8722        Swings and roundabouts.  */
8723     SvUPGRADE(sv, SVt_PV);
8724 
8725     if (append) {
8726         /* line is going to be appended to the existing buffer in the sv */
8727         if (PerlIO_isutf8(fp)) {
8728             if (!SvUTF8(sv)) {
8729                 sv_utf8_upgrade_nomg(sv);
8730                 sv_pos_u2b(sv,&append,0);
8731             }
8732         } else if (SvUTF8(sv)) {
8733             return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append);
8734         }
8735     }
8736 
8737     SvPOK_only(sv);
8738     if (!append) {
8739         /* not appending - "clear" the string by setting SvCUR to 0,
8740          * the pv is still available. */
8741         SvCUR_set(sv,0);
8742     }
8743     if (PerlIO_isutf8(fp))
8744         SvUTF8_on(sv);
8745 
8746     if (IN_PERL_COMPILETIME) {
8747         /* we always read code in line mode */
8748         rsptr = "\n";
8749         rslen = 1;
8750     }
8751     else if (RsSNARF(PL_rs)) {
8752         /* If it is a regular disk file use size from stat() as estimate
8753            of amount we are going to read -- may result in mallocing
8754            more memory than we really need if the layers below reduce
8755            the size we read (e.g. CRLF or a gzip layer).
8756          */
8757         Stat_t st;
8758         int fd = PerlIO_fileno(fp);
8759         if (fd >= 0 && (PerlLIO_fstat(fd, &st) == 0) && S_ISREG(st.st_mode))  {
8760             const Off_t offset = PerlIO_tell(fp);
8761             if (offset != (Off_t) -1 && st.st_size + append > offset) {
8762 #ifdef PERL_COPY_ON_WRITE
8763                 /* Add an extra byte for the sake of copy-on-write's
8764                  * buffer reference count. */
8765                 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 2));
8766 #else
8767                 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
8768 #endif
8769             }
8770         }
8771         rsptr = NULL;
8772         rslen = 0;
8773     }
8774     else if (RsRECORD(PL_rs)) {
8775         return S_sv_gets_read_record(aTHX_ sv, fp, append);
8776     }
8777     else if (RsPARA(PL_rs)) {
8778         rsptr = "\n\n";
8779         rslen = 2;
8780         rspara = 1;
8781     }
8782     else {
8783         /* Get $/ i.e. PL_rs into same encoding as stream wants */
8784         if (PerlIO_isutf8(fp)) {
8785             rsptr = SvPVutf8(PL_rs, rslen);
8786         }
8787         else {
8788             if (SvUTF8(PL_rs)) {
8789                 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
8790                     Perl_croak(aTHX_ "Wide character in $/");
8791                 }
8792             }
8793             /* extract the raw pointer to the record separator */
8794             rsptr = SvPV_const(PL_rs, rslen);
8795         }
8796     }
8797 
8798     /* rslast is the last character in the record separator
8799      * note we don't use rslast except when rslen is true, so the
8800      * null assign is a placeholder. */
8801     rslast = rslen ? rsptr[rslen - 1] : '\0';
8802 
8803     if (rspara) {        /* have to do this both before and after */
8804                          /* to make sure file boundaries work right */
8805         while (1) {
8806             if (PerlIO_eof(fp))
8807                 return 0;
8808             i = PerlIO_getc(fp);
8809             if (i != '\n') {
8810                 if (i == -1)
8811                     return 0;
8812                 PerlIO_ungetc(fp,i);
8813                 break;
8814             }
8815         }
8816     }
8817 
8818     /* See if we know enough about I/O mechanism to cheat it ! */
8819 
8820     /* This used to be #ifdef test - it is made run-time test for ease
8821        of abstracting out stdio interface. One call should be cheap
8822        enough here - and may even be a macro allowing compile
8823        time optimization.
8824      */
8825 
8826     if (PerlIO_fast_gets(fp)) {
8827     /*
8828      * We can do buffer based IO operations on this filehandle.
8829      *
8830      * This means we can bypass a lot of subcalls and process
8831      * the buffer directly, it also means we know the upper bound
8832      * on the amount of data we might read of the current buffer
8833      * into our sv. Knowing this allows us to preallocate the pv
8834      * to be able to hold that maximum, which allows us to simplify
8835      * a lot of logic. */
8836 
8837     /*
8838      * We're going to steal some values from the stdio struct
8839      * and put EVERYTHING in the innermost loop into registers.
8840      */
8841     STDCHAR *ptr;       /* pointer into fp's read-ahead buffer */
8842     STRLEN bpx;         /* length of the data in the target sv
8843                            used to fix pointers after a SvGROW */
8844     I32 shortbuffered;  /* If the pv buffer is shorter than the amount
8845                            of data left in the read-ahead buffer.
8846                            If 0 then the pv buffer can hold the full
8847                            amount left, otherwise this is the amount it
8848                            can hold. */
8849 
8850     /* Here is some breathtakingly efficient cheating */
8851 
8852     /* When you read the following logic resist the urge to think
8853      * of record separators that are 1 byte long. They are an
8854      * uninteresting special (simple) case.
8855      *
8856      * Instead think of record separators which are at least 2 bytes
8857      * long, and keep in mind that we need to deal with such
8858      * separators when they cross a read-ahead buffer boundary.
8859      *
8860      * Also consider that we need to gracefully deal with separators
8861      * that may be longer than a single read ahead buffer.
8862      *
8863      * Lastly do not forget we want to copy the delimiter as well. We
8864      * are copying all data in the file _up_to_and_including_ the separator
8865      * itself.
8866      *
8867      * Now that you have all that in mind here is what is happening below:
8868      *
8869      * 1. When we first enter the loop we do some memory book keeping to see
8870      * how much free space there is in the target SV. (This sub assumes that
8871      * it is operating on the same SV most of the time via $_ and that it is
8872      * going to be able to reuse the same pv buffer each call.) If there is
8873      * "enough" room then we set "shortbuffered" to how much space there is
8874      * and start reading forward.
8875      *
8876      * 2. When we scan forward we copy from the read-ahead buffer to the target
8877      * SV's pv buffer. While we go we watch for the end of the read-ahead buffer,
8878      * and the end of the of pv, as well as for the "rslast", which is the last
8879      * char of the separator.
8880      *
8881      * 3. When scanning forward if we see rslast then we jump backwards in *pv*
8882      * (which has a "complete" record up to the point we saw rslast) and check
8883      * it to see if it matches the separator. If it does we are done. If it doesn't
8884      * we continue on with the scan/copy.
8885      *
8886      * 4. If we run out of read-ahead buffer (cnt goes to 0) then we have to get
8887      * the IO system to read the next buffer. We do this by doing a getc(), which
8888      * returns a single char read (or EOF), and prefills the buffer, and also
8889      * allows us to find out how full the buffer is.  We use this information to
8890      * SvGROW() the sv to the size remaining in the buffer, after which we copy
8891      * the returned single char into the target sv, and then go back into scan
8892      * forward mode.
8893      *
8894      * 5. If we run out of write-buffer then we SvGROW() it by the size of the
8895      * remaining space in the read-buffer.
8896      *
8897      * Note that this code despite its twisty-turny nature is pretty darn slick.
8898      * It manages single byte separators, multi-byte cross boundary separators,
8899      * and cross-read-buffer separators cleanly and efficiently at the cost
8900      * of potentially greatly overallocating the target SV.
8901      *
8902      * Yves
8903      */
8904 
8905 
8906     /* get the number of bytes remaining in the read-ahead buffer
8907      * on first call on a given fp this will return 0.*/
8908     cnt = PerlIO_get_cnt(fp);
8909 
8910     /* make sure we have the room */
8911     if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
8912         /* Not room for all of it
8913            if we are looking for a separator and room for some
8914          */
8915         if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
8916             /* just process what we have room for */
8917             shortbuffered = cnt - SvLEN(sv) + append + 1;
8918             cnt -= shortbuffered;
8919         }
8920         else {
8921             /* ensure that the target sv has enough room to hold
8922              * the rest of the read-ahead buffer */
8923             shortbuffered = 0;
8924             /* remember that cnt can be negative */
8925             SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
8926         }
8927     }
8928     else {
8929         /* we have enough room to hold the full buffer, lets scream */
8930         shortbuffered = 0;
8931     }
8932 
8933     /* extract the pointer to sv's string buffer, offset by append as necessary */
8934     bp = (STDCHAR*)SvPVX_const(sv) + append;  /* move these two too to registers */
8935     /* extract the point to the read-ahead buffer */
8936     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
8937 
8938     /* some trace debug output */
8939     DEBUG_P(PerlIO_printf(Perl_debug_log,
8940         "Screamer: entering, ptr=%" UVuf ", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
8941     DEBUG_P(PerlIO_printf(Perl_debug_log,
8942         "Screamer: entering: PerlIO * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%"
8943          UVuf "\n",
8944                PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
8945                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
8946 
8947     for (;;) {
8948       screamer:
8949         /* if there is stuff left in the read-ahead buffer */
8950         if (cnt > 0) {
8951             /* if there is a separator */
8952             if (rslen) {
8953                 /* find next rslast */
8954                 STDCHAR *p;
8955 
8956                 /* shortcut common case of blank line */
8957                 cnt--;
8958                 if ((*bp++ = *ptr++) == rslast)
8959                     goto thats_all_folks;
8960 
8961                 p = (STDCHAR *)memchr(ptr, rslast, cnt);
8962                 if (p) {
8963                     SSize_t got = p - ptr + 1;
8964                     Copy(ptr, bp, got, STDCHAR);
8965                     ptr += got;
8966                     bp  += got;
8967                     cnt -= got;
8968                     goto thats_all_folks;
8969                 }
8970                 Copy(ptr, bp, cnt, STDCHAR);
8971                 ptr += cnt;
8972                 bp  += cnt;
8973                 cnt = 0;
8974             }
8975             else {
8976                 /* no separator, slurp the full buffer */
8977                 Copy(ptr, bp, cnt, char);	     /* this     |  eat */
8978                 bp += cnt;			     /* screams  |  dust */
8979                 ptr += cnt;			     /* louder   |  sed :-) */
8980                 cnt = 0;
8981                 assert (!shortbuffered);
8982                 goto cannot_be_shortbuffered;
8983             }
8984         }
8985 
8986         if (shortbuffered) {		/* oh well, must extend */
8987             /* we didn't have enough room to fit the line into the target buffer
8988              * so we must extend the target buffer and keep going */
8989             cnt = shortbuffered;
8990             shortbuffered = 0;
8991             bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
8992             SvCUR_set(sv, bpx);
8993             /* extned the target sv's buffer so it can hold the full read-ahead buffer */
8994             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
8995             bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
8996             continue;
8997         }
8998 
8999     cannot_be_shortbuffered:
9000         /* we need to refill the read-ahead buffer if possible */
9001 
9002         DEBUG_P(PerlIO_printf(Perl_debug_log,
9003                              "Screamer: going to getc, ptr=%" UVuf ", cnt=%" IVdf "\n",
9004                               PTR2UV(ptr),(IV)cnt));
9005         PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
9006 
9007         DEBUG_Pv(PerlIO_printf(Perl_debug_log,
9008            "Screamer: pre: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf "\n",
9009             PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
9010             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
9011 
9012         /*
9013             call PerlIO_getc() to let it prefill the lookahead buffer
9014 
9015             This used to call 'filbuf' in stdio form, but as that behaves like
9016             getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
9017             another abstraction.
9018 
9019             Note we have to deal with the char in 'i' if we are not at EOF
9020         */
9021         bpx = bp - (STDCHAR*)SvPVX_const(sv);
9022         /* signals might be called here, possibly modifying sv */
9023         i   = PerlIO_getc(fp);		/* get more characters */
9024         bp = (STDCHAR*)SvPVX_const(sv) + bpx;
9025 
9026         DEBUG_Pv(PerlIO_printf(Perl_debug_log,
9027            "Screamer: post: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf "\n",
9028             PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
9029             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
9030 
9031         /* find out how much is left in the read-ahead buffer, and rextract its pointer */
9032         cnt = PerlIO_get_cnt(fp);
9033         ptr = (STDCHAR*)PerlIO_get_ptr(fp);	/* reregisterize cnt and ptr */
9034         DEBUG_P(PerlIO_printf(Perl_debug_log,
9035             "Screamer: after getc, ptr=%" UVuf ", cnt=%" IVdf "\n",
9036             PTR2UV(ptr),(IV)cnt));
9037 
9038         if (i == EOF)			/* all done for ever? */
9039             goto thats_really_all_folks;
9040 
9041         /* make sure we have enough space in the target sv */
9042         bpx = bp - (STDCHAR*)SvPVX_const(sv);	/* box up before relocation */
9043         SvCUR_set(sv, bpx);
9044         SvGROW(sv, bpx + cnt + 2);
9045         bp = (STDCHAR*)SvPVX_const(sv) + bpx;	/* unbox after relocation */
9046 
9047         /* copy of the char we got from getc() */
9048         *bp++ = (STDCHAR)i;		/* store character from PerlIO_getc */
9049 
9050         /* make sure we deal with the i being the last character of a separator */
9051         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
9052             goto thats_all_folks;
9053     }
9054 
9055   thats_all_folks:
9056     /* check if we have actually found the separator - only really applies
9057      * when rslen > 1 */
9058     if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
9059           memNE((char*)bp - rslen, rsptr, rslen))
9060         goto screamer;				/* go back to the fray */
9061   thats_really_all_folks:
9062     if (shortbuffered)
9063         cnt += shortbuffered;
9064     DEBUG_P(PerlIO_printf(Perl_debug_log,
9065          "Screamer: quitting, ptr=%" UVuf ", cnt=%" IVdf "\n",PTR2UV(ptr),(IV)cnt));
9066     PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt);	/* put these back or we're in trouble */
9067     DEBUG_P(PerlIO_printf(Perl_debug_log,
9068         "Screamer: end: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf
9069         "\n",
9070         PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
9071         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
9072     *bp = '\0';
9073     SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv));	/* set length */
9074     DEBUG_P(PerlIO_printf(Perl_debug_log,
9075         "Screamer: done, len=%ld, string=|%.*s|\n",
9076         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
9077     }
9078    else
9079     {
9080        /*The big, slow, and stupid way. */
9081         STDCHAR buf[8192];
9082 
9083       screamer2:
9084         if (rslen) {
9085             const STDCHAR * const bpe = buf + sizeof(buf);
9086             bp = buf;
9087             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
9088                 ; /* keep reading */
9089             cnt = bp - buf;
9090         }
9091         else {
9092             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
9093             /* Accommodate broken VAXC compiler, which applies U8 cast to
9094              * both args of ?: operator, causing EOF to change into 255
9095              */
9096             if (cnt > 0)
9097                  i = (U8)buf[cnt - 1];
9098             else
9099                  i = EOF;
9100         }
9101 
9102         if (cnt < 0)
9103             cnt = 0;  /* we do need to re-set the sv even when cnt <= 0 */
9104         if (append)
9105             sv_catpvn_nomg(sv, (char *) buf, cnt);
9106         else
9107             sv_setpvn(sv, (char *) buf, cnt);   /* "nomg" is implied */
9108 
9109         if (i != EOF &&			/* joy */
9110             (!rslen ||
9111              SvCUR(sv) < rslen ||
9112              memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
9113         {
9114             append = -1;
9115             /*
9116              * If we're reading from a TTY and we get a short read,
9117              * indicating that the user hit his EOF character, we need
9118              * to notice it now, because if we try to read from the TTY
9119              * again, the EOF condition will disappear.
9120              *
9121              * The comparison of cnt to sizeof(buf) is an optimization
9122              * that prevents unnecessary calls to feof().
9123              *
9124              * - jik 9/25/96
9125              */
9126             if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
9127                 goto screamer2;
9128         }
9129 
9130     }
9131 
9132     if (rspara) {		/* have to do this both before and after */
9133         while (i != EOF) {	/* to make sure file boundaries work right */
9134             i = PerlIO_getc(fp);
9135             if (i != '\n') {
9136                 PerlIO_ungetc(fp,i);
9137                 break;
9138             }
9139         }
9140     }
9141 
9142     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
9143 }
9144 
9145 /*
9146 =for apidoc sv_inc
9147 =for apidoc_item sv_inc_nomg
9148 
9149 These auto-increment the value in the SV, doing string to numeric conversion
9150 if necessary.  They both handle operator overloading.
9151 
9152 They differ only in that C<sv_inc> performs 'get' magic; C<sv_inc_nomg> skips
9153 any magic.
9154 
9155 =cut
9156 */
9157 
9158 void
9159 Perl_sv_inc(pTHX_ SV *const sv)
9160 {
9161     if (!sv)
9162         return;
9163     SvGETMAGIC(sv);
9164     sv_inc_nomg(sv);
9165 }
9166 
9167 void
9168 Perl_sv_inc_nomg(pTHX_ SV *const sv)
9169 {
9170     char *d;
9171     int flags;
9172 
9173     if (!sv)
9174         return;
9175     if (SvTHINKFIRST(sv)) {
9176         if (SvREADONLY(sv)) {
9177                 Perl_croak_no_modify();
9178         }
9179         if (SvROK(sv)) {
9180             IV i;
9181             if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg))
9182                 return;
9183             i = PTR2IV(SvRV(sv));
9184             sv_unref(sv);
9185             sv_setiv(sv, i);
9186         }
9187         else sv_force_normal_flags(sv, 0);
9188     }
9189     flags = SvFLAGS(sv);
9190     if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
9191         /* It's (privately or publicly) a float, but not tested as an
9192            integer, so test it to see. */
9193         (void) SvIV(sv);
9194         flags = SvFLAGS(sv);
9195     }
9196     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
9197         /* It's publicly an integer, or privately an integer-not-float */
9198 #ifdef PERL_PRESERVE_IVUV
9199       oops_its_int:
9200 #endif
9201         if (SvIsUV(sv)) {
9202             if (SvUVX(sv) == UV_MAX)
9203                 sv_setnv(sv, UV_MAX_P1);
9204             else {
9205                 (void)SvIOK_only_UV(sv);
9206                 SvUV_set(sv, SvUVX(sv) + 1);
9207             }
9208         } else {
9209             if (SvIVX(sv) == IV_MAX)
9210                 sv_setuv(sv, (UV)IV_MAX + 1);
9211             else {
9212                 (void)SvIOK_only(sv);
9213                 SvIV_set(sv, SvIVX(sv) + 1);
9214             }
9215         }
9216         return;
9217     }
9218     if (flags & SVp_NOK) {
9219         const NV was = SvNVX(sv);
9220         if (NV_OVERFLOWS_INTEGERS_AT != 0.0 &&
9221             /* If NVX was NaN, the following comparisons return always false */
9222             UNLIKELY(was >= NV_OVERFLOWS_INTEGERS_AT ||
9223                      was < -NV_OVERFLOWS_INTEGERS_AT) &&
9224 #if defined(NAN_COMPARE_BROKEN)
9225             LIKELY(!Perl_isinfnan(was))
9226 #else
9227             LIKELY(!Perl_isinf(was))
9228 #endif
9229             ) {
9230             /* diag_listed_as: Lost precision when %s %f by 1 */
9231             Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
9232                            "Lost precision when incrementing %" NVff " by 1",
9233                            was);
9234         }
9235         (void)SvNOK_only(sv);
9236         SvNV_set(sv, was + 1.0);
9237         return;
9238     }
9239 
9240     /* treat AV/HV/CV/FM/IO and non-fake GVs as immutable */
9241     if (SvTYPE(sv) >= SVt_PVAV || (isGV_with_GP(sv) && !SvFAKE(sv)))
9242         Perl_croak_no_modify();
9243 
9244     if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
9245         if ((flags & SVTYPEMASK) < SVt_PVIV)
9246             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
9247         (void)SvIOK_only(sv);
9248         SvIV_set(sv, 1);
9249         return;
9250     }
9251     d = SvPVX(sv);
9252     while (isALPHA(*d)) d++;
9253     while (isDIGIT(*d)) d++;
9254     if (d < SvEND(sv)) {
9255         const int numtype = grok_number_flags(SvPVX_const(sv), SvCUR(sv), NULL, PERL_SCAN_TRAILING);
9256 #ifdef PERL_PRESERVE_IVUV
9257         /* Got to punt this as an integer if needs be, but we don't issue
9258            warnings. Probably ought to make the sv_iv_please() that does
9259            the conversion if possible, and silently.  */
9260         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
9261             /* Need to try really hard to see if it's an integer.
9262                9.22337203685478e+18 is an integer.
9263                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
9264                so $a="9.22337203685478e+18"; $a+0; $a++
9265                needs to be the same as $a="9.22337203685478e+18"; $a++
9266                or we go insane. */
9267 
9268             (void) sv_2iv(sv);
9269             if (SvIOK(sv))
9270                 goto oops_its_int;
9271 
9272             /* sv_2iv *should* have made this an NV */
9273             if (flags & SVp_NOK) {
9274                 (void)SvNOK_only(sv);
9275                 SvNV_set(sv, SvNVX(sv) + 1.0);
9276                 return;
9277             }
9278             /* I don't think we can get here. Maybe I should assert this
9279                And if we do get here I suspect that sv_setnv will croak. NWC
9280                Fall through. */
9281             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%" UVxf " NV=%" NVgf "\n",
9282                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
9283         }
9284 #endif /* PERL_PRESERVE_IVUV */
9285         if (!numtype && ckWARN(WARN_NUMERIC))
9286             not_incrementable(sv);
9287         sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
9288         return;
9289     }
9290     d--;
9291     while (d >= SvPVX_const(sv)) {
9292         if (isDIGIT(*d)) {
9293             if (++*d <= '9')
9294                 return;
9295             *(d--) = '0';
9296         }
9297         else {
9298 #ifdef EBCDIC
9299             /* MKS: The original code here died if letters weren't consecutive.
9300              * at least it didn't have to worry about non-C locales.  The
9301              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
9302              * arranged in order (although not consecutively) and that only
9303              * [A-Za-z] are accepted by isALPHA in the C locale.
9304              */
9305             if (isALPHA_FOLD_NE(*d, 'z')) {
9306                 do { ++*d; } while (!isALPHA(*d));
9307                 return;
9308             }
9309             *(d--) -= 'z' - 'a';
9310 #else
9311             ++*d;
9312             if (isALPHA(*d))
9313                 return;
9314             *(d--) -= 'z' - 'a' + 1;
9315 #endif
9316         }
9317     }
9318     /* oh,oh, the number grew */
9319     SvGROW(sv, SvCUR(sv) + 2);
9320     SvCUR_set(sv, SvCUR(sv) + 1);
9321     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
9322         *d = d[-1];
9323     if (isDIGIT(d[1]))
9324         *d = '1';
9325     else
9326         *d = d[1];
9327 }
9328 
9329 /*
9330 =for apidoc sv_dec
9331 =for apidoc_item sv_dec_nomg
9332 
9333 These auto-decrement the value in the SV, doing string to numeric conversion
9334 if necessary.  They both handle operator overloading.
9335 
9336 They differ only in that:
9337 
9338 C<sv_dec> handles 'get' magic; C<sv_dec_nomg> skips 'get' magic.
9339 
9340 =cut
9341 */
9342 
9343 void
9344 Perl_sv_dec(pTHX_ SV *const sv)
9345 {
9346     if (!sv)
9347         return;
9348     SvGETMAGIC(sv);
9349     sv_dec_nomg(sv);
9350 }
9351 
9352 void
9353 Perl_sv_dec_nomg(pTHX_ SV *const sv)
9354 {
9355     int flags;
9356 
9357     if (!sv)
9358         return;
9359     if (SvTHINKFIRST(sv)) {
9360         if (SvREADONLY(sv)) {
9361                 Perl_croak_no_modify();
9362         }
9363         if (SvROK(sv)) {
9364             IV i;
9365             if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg))
9366                 return;
9367             i = PTR2IV(SvRV(sv));
9368             sv_unref(sv);
9369             sv_setiv(sv, i);
9370         }
9371         else sv_force_normal_flags(sv, 0);
9372     }
9373     /* Unlike sv_inc we don't have to worry about string-never-numbers
9374        and keeping them magic. But we mustn't warn on punting */
9375     flags = SvFLAGS(sv);
9376     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
9377         /* It's publicly an integer, or privately an integer-not-float */
9378 #ifdef PERL_PRESERVE_IVUV
9379       oops_its_int:
9380 #endif
9381         if (SvIsUV(sv)) {
9382             if (SvUVX(sv) == 0) {
9383                 (void)SvIOK_only(sv);
9384                 SvIV_set(sv, -1);
9385             }
9386             else {
9387                 (void)SvIOK_only_UV(sv);
9388                 SvUV_set(sv, SvUVX(sv) - 1);
9389             }
9390         } else {
9391             if (SvIVX(sv) == IV_MIN) {
9392                 sv_setnv(sv, (NV)IV_MIN);
9393                 goto oops_its_num;
9394             }
9395             else {
9396                 (void)SvIOK_only(sv);
9397                 SvIV_set(sv, SvIVX(sv) - 1);
9398             }
9399         }
9400         return;
9401     }
9402     if (flags & SVp_NOK) {
9403     oops_its_num:
9404         {
9405             const NV was = SvNVX(sv);
9406             if (NV_OVERFLOWS_INTEGERS_AT != 0.0 &&
9407                 /* If NVX was NaN, these comparisons return always false */
9408                 UNLIKELY(was <= -NV_OVERFLOWS_INTEGERS_AT ||
9409                          was > NV_OVERFLOWS_INTEGERS_AT) &&
9410 #if defined(NAN_COMPARE_BROKEN)
9411                 LIKELY(!Perl_isinfnan(was))
9412 #else
9413                 LIKELY(!Perl_isinf(was))
9414 #endif
9415                 ) {
9416                 /* diag_listed_as: Lost precision when %s %f by 1 */
9417                 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
9418                                "Lost precision when decrementing %" NVff " by 1",
9419                                was);
9420             }
9421             (void)SvNOK_only(sv);
9422             SvNV_set(sv, was - 1.0);
9423             return;
9424         }
9425     }
9426 
9427     /* treat AV/HV/CV/FM/IO and non-fake GVs as immutable */
9428     if (SvTYPE(sv) >= SVt_PVAV || (isGV_with_GP(sv) && !SvFAKE(sv)))
9429         Perl_croak_no_modify();
9430 
9431     if (!(flags & SVp_POK)) {
9432         if ((flags & SVTYPEMASK) < SVt_PVIV)
9433             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
9434         SvIV_set(sv, -1);
9435         (void)SvIOK_only(sv);
9436         return;
9437     }
9438 #ifdef PERL_PRESERVE_IVUV
9439     {
9440         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
9441         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
9442             /* Need to try really hard to see if it's an integer.
9443                9.22337203685478e+18 is an integer.
9444                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
9445                so $a="9.22337203685478e+18"; $a+0; $a--
9446                needs to be the same as $a="9.22337203685478e+18"; $a--
9447                or we go insane. */
9448 
9449             (void) sv_2iv(sv);
9450             if (SvIOK(sv))
9451                 goto oops_its_int;
9452 
9453             /* sv_2iv *should* have made this an NV */
9454             if (flags & SVp_NOK) {
9455                 (void)SvNOK_only(sv);
9456                 SvNV_set(sv, SvNVX(sv) - 1.0);
9457                 return;
9458             }
9459             /* I don't think we can get here. Maybe I should assert this
9460                And if we do get here I suspect that sv_setnv will croak. NWC
9461                Fall through. */
9462             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%" UVxf " NV=%" NVgf "\n",
9463                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
9464         }
9465     }
9466 #endif /* PERL_PRESERVE_IVUV */
9467     sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0);	/* punt */
9468 }
9469 
9470 /* this define is used to eliminate a chunk of duplicated but shared logic
9471  * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
9472  * used anywhere but here - yves
9473  */
9474 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
9475     STMT_START {      \
9476         SSize_t ix = ++PL_tmps_ix;		\
9477         if (UNLIKELY(ix >= PL_tmps_max))	\
9478             ix = tmps_grow_p(ix);			\
9479         PL_tmps_stack[ix] = (AnSv); \
9480     } STMT_END
9481 
9482 /*
9483 =for apidoc sv_mortalcopy
9484 
9485 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
9486 The new SV is marked as mortal.  It will be destroyed "soon", either by an
9487 explicit call to C<FREETMPS>, or by an implicit call at places such as
9488 statement boundaries.  See also C<L</sv_newmortal>> and C<L</sv_2mortal>>.
9489 
9490 =for apidoc sv_mortalcopy_flags
9491 
9492 Like C<sv_mortalcopy>, but the extra C<flags> are passed to the
9493 C<sv_setsv_flags>.
9494 
9495 =cut
9496 */
9497 
9498 /* Make a string that will exist for the duration of the expression
9499  * evaluation.  Actually, it may have to last longer than that, but
9500  * hopefully we won't free it until it has been assigned to a
9501  * permanent location. */
9502 
9503 SV *
9504 Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags)
9505 {
9506     SV *sv;
9507 
9508     if (flags & SV_GMAGIC)
9509         SvGETMAGIC(oldstr); /* before new_SV, in case it dies */
9510     new_SV(sv);
9511     sv_setsv_flags(sv,oldstr,flags & ~SV_GMAGIC);
9512     PUSH_EXTEND_MORTAL__SV_C(sv);
9513     SvTEMP_on(sv);
9514     return sv;
9515 }
9516 
9517 /*
9518 =for apidoc sv_newmortal
9519 
9520 Creates a new null SV which is mortal.  The reference count of the SV is
9521 set to 1.  It will be destroyed "soon", either by an explicit call to
9522 C<FREETMPS>, or by an implicit call at places such as statement boundaries.
9523 See also C<L</sv_mortalcopy>> and C<L</sv_2mortal>>.
9524 
9525 =cut
9526 */
9527 
9528 SV *
9529 Perl_sv_newmortal(pTHX)
9530 {
9531     SV *sv;
9532 
9533     new_SV(sv);
9534     SvFLAGS(sv) = SVs_TEMP;
9535     PUSH_EXTEND_MORTAL__SV_C(sv);
9536     return sv;
9537 }
9538 
9539 
9540 /*
9541 =for apidoc newSVpvn_flags
9542 
9543 Creates a new SV and copies a string (which may contain C<NUL> (C<\0>)
9544 characters) into it.  The reference count for the
9545 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
9546 string.  You are responsible for ensuring that the source string is at least
9547 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
9548 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
9549 If C<SVs_TEMP> is set, then C<sv_2mortal()> is called on the result before
9550 returning.  If C<SVf_UTF8> is set, C<s>
9551 is considered to be in UTF-8 and the
9552 C<SVf_UTF8> flag will be set on the new SV.
9553 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
9554 
9555     #define newSVpvn_utf8(s, len, u)			\
9556         newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
9557 
9558 =for apidoc Amnh||SVs_TEMP
9559 
9560 =cut
9561 */
9562 
9563 SV *
9564 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
9565 {
9566     SV *sv;
9567 
9568     /* All the flags we don't support must be zero.
9569        And we're new code so I'm going to assert this from the start.  */
9570     assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
9571     sv = newSV_type(SVt_PV);
9572     sv_setpvn_fresh(sv,s,len);
9573 
9574     /* This code used to do a sv_2mortal(), however we now unroll the call to
9575      * sv_2mortal() and do what it does ourselves here.  Since we have asserted
9576      * that flags can only have the SVf_UTF8 and/or SVs_TEMP flags set above we
9577      * can use it to enable the sv flags directly (bypassing SvTEMP_on), which
9578      * in turn means we don't need to mask out the SVf_UTF8 flag below, which
9579      * means that we eliminate quite a few steps than it looks - Yves
9580      * (explaining patch by gfx) */
9581 
9582     SvFLAGS(sv) |= flags;
9583 
9584     if(flags & SVs_TEMP){
9585         PUSH_EXTEND_MORTAL__SV_C(sv);
9586     }
9587 
9588     return sv;
9589 }
9590 
9591 /*
9592 =for apidoc sv_2mortal
9593 
9594 Marks an existing SV as mortal.  The SV will be destroyed "soon", either
9595 by an explicit call to C<FREETMPS>, or by an implicit call at places such as
9596 statement boundaries.  C<SvTEMP()> is turned on which means that the SV's
9597 string buffer can be "stolen" if this SV is copied.  See also
9598 C<L</sv_newmortal>> and C<L</sv_mortalcopy>>.
9599 
9600 =cut
9601 */
9602 
9603 SV *
9604 Perl_sv_2mortal(pTHX_ SV *const sv)
9605 {
9606     if (!sv)
9607         return sv;
9608     if (SvIMMORTAL(sv))
9609         return sv;
9610     PUSH_EXTEND_MORTAL__SV_C(sv);
9611     SvTEMP_on(sv);
9612     return sv;
9613 }
9614 
9615 /*
9616 =for apidoc newSVpv
9617 
9618 Creates a new SV and copies a string (which may contain C<NUL> (C<\0>)
9619 characters) into it.  The reference count for the
9620 SV is set to 1.  If C<len> is zero, Perl will compute the length using
9621 C<strlen()>, (which means if you use this option, that C<s> can't have embedded
9622 C<NUL> characters and has to have a terminating C<NUL> byte).
9623 
9624 This function can cause reliability issues if you are likely to pass in
9625 empty strings that are not null terminated, because it will run
9626 strlen on the string and potentially run past valid memory.
9627 
9628 Using L</newSVpvn> is a safer alternative for non C<NUL> terminated strings.
9629 For string literals use L</newSVpvs> instead.  This function will work fine for
9630 C<NUL> terminated strings, but if you want to avoid the if statement on whether
9631 to call C<strlen> use C<newSVpvn> instead (calling C<strlen> yourself).
9632 
9633 =cut
9634 */
9635 
9636 SV *
9637 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
9638 {
9639     SV *sv = newSV_type(SVt_PV);
9640     sv_setpvn_fresh(sv, s, len || s == NULL ? len : strlen(s));
9641     return sv;
9642 }
9643 
9644 /*
9645 =for apidoc newSVpvn
9646 
9647 Creates a new SV and copies a string into it, which may contain C<NUL> characters
9648 (C<\0>) and other binary data.  The reference count for the SV is set to 1.
9649 Note that if C<len> is zero, Perl will create a zero length (Perl) string.  You
9650 are responsible for ensuring that the source buffer is at least
9651 C<len> bytes long.  If the C<buffer> argument is NULL the new SV will be
9652 undefined.
9653 
9654 =cut
9655 */
9656 
9657 SV *
9658 Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len)
9659 {
9660     SV *sv = newSV_type(SVt_PV);
9661     sv_setpvn_fresh(sv,buffer,len);
9662     return sv;
9663 }
9664 
9665 /*
9666 =for apidoc newSVhek_mortal
9667 
9668 Creates a new mortal SV from the hash key structure.  It will generate
9669 scalars that point to the shared string table where possible.  Returns
9670 a new (undefined) SV if C<hek> is NULL.
9671 
9672 This is more efficient than using sv_2mortal(newSVhek( ... ))
9673 
9674 =cut
9675 */
9676 
9677 SV *
9678 Perl_newSVhek_mortal(pTHX_ const HEK *const hek)
9679 {
9680     SV * const sv = newSVhek(hek);
9681     assert(sv);
9682     assert(!SvIMMORTAL(sv));
9683 
9684     PUSH_EXTEND_MORTAL__SV_C(sv);
9685     SvTEMP_on(sv);
9686     return sv;
9687 }
9688 
9689 /*
9690 =for apidoc newSVhek
9691 
9692 Creates a new SV from the hash key structure.  It will generate scalars that
9693 point to the shared string table where possible.  Returns a new (undefined)
9694 SV if C<hek> is NULL.
9695 
9696 =cut
9697 */
9698 
9699 SV *
9700 Perl_newSVhek(pTHX_ const HEK *const hek)
9701 {
9702     if (!hek) {
9703         SV *sv;
9704 
9705         new_SV(sv);
9706         return sv;
9707     }
9708 
9709     if (HEK_LEN(hek) == HEf_SVKEY) {
9710         return newSVsv(*(SV**)HEK_KEY(hek));
9711     } else {
9712         const int flags = HEK_FLAGS(hek);
9713         if (flags & HVhek_WASUTF8) {
9714             /* Trouble :-)
9715                Andreas would like keys he put in as utf8 to come back as utf8
9716             */
9717             STRLEN utf8_len = HEK_LEN(hek);
9718             SV * const sv = newSV_type(SVt_PV);
9719             char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
9720             /* bytes_to_utf8() allocates a new string, which we can repurpose: */
9721             sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
9722             SvUTF8_on (sv);
9723             return sv;
9724         } else if (flags & HVhek_NOTSHARED) {
9725             /* A hash that isn't using shared hash keys has to have
9726                the flag in every key so that we know not to try to call
9727                share_hek_hek on it.  */
9728 
9729             SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
9730             if (HEK_UTF8(hek))
9731                 SvUTF8_on (sv);
9732             return sv;
9733         }
9734         /* This will be overwhelmingly the most common case.  */
9735         {
9736             /* Inline most of newSVpvn_share(), because share_hek_hek() is far
9737                more efficient than sharepvn().  */
9738             SV *sv = newSV_type(SVt_PV);
9739 
9740             SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
9741             SvCUR_set(sv, HEK_LEN(hek));
9742             SvLEN_set(sv, 0);
9743             SvIsCOW_on(sv);
9744             SvPOK_on(sv);
9745             if (HEK_UTF8(hek))
9746                 SvUTF8_on(sv);
9747             return sv;
9748         }
9749     }
9750 }
9751 
9752 /*
9753 =for apidoc newSVpvn_share
9754 
9755 Creates a new SV with its C<SvPVX_const> pointing to a shared string in the string
9756 table.  If the string does not already exist in the table, it is
9757 created first.  Turns on the C<SvIsCOW> flag (or C<READONLY>
9758 and C<FAKE> in 5.16 and earlier).  If the C<hash> parameter
9759 is non-zero, that value is used; otherwise the hash is computed.
9760 The string's hash can later be retrieved from the SV
9761 with the C<L</SvSHARED_HASH>> macro.  The idea here is
9762 that as the string table is used for shared hash keys these strings will have
9763 C<SvPVX_const == HeKEY> and hash lookup will avoid string compare.
9764 
9765 =cut
9766 */
9767 
9768 SV *
9769 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
9770 {
9771     SV *sv;
9772     bool is_utf8 = FALSE;
9773     const char *const orig_src = src;
9774 
9775     if (len < 0) {
9776         STRLEN tmplen = -len;
9777         is_utf8 = TRUE;
9778         /* See the note in hv.c:hv_fetch() --jhi */
9779         src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
9780         len = tmplen;
9781     }
9782     if (!hash)
9783         PERL_HASH(hash, src, len);
9784     sv = newSV_type(SVt_PV);
9785     /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
9786        changes here, update it there too.  */
9787     SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
9788     SvCUR_set(sv, len);
9789     SvLEN_set(sv, 0);
9790     SvIsCOW_on(sv);
9791     SvPOK_on(sv);
9792     if (is_utf8)
9793         SvUTF8_on(sv);
9794     if (src != orig_src)
9795         Safefree(src);
9796     return sv;
9797 }
9798 
9799 /*
9800 =for apidoc newSVpv_share
9801 
9802 Like C<newSVpvn_share>, but takes a C<NUL>-terminated string instead of a
9803 string/length pair.
9804 
9805 =cut
9806 */
9807 
9808 SV *
9809 Perl_newSVpv_share(pTHX_ const char *src, U32 hash)
9810 {
9811     return newSVpvn_share(src, strlen(src), hash);
9812 }
9813 
9814 #if defined(MULTIPLICITY)
9815 
9816 /* pTHX_ magic can't cope with varargs, so this is a no-context
9817  * version of the main function, (which may itself be aliased to us).
9818  * Don't access this version directly.
9819  */
9820 
9821 SV *
9822 Perl_newSVpvf_nocontext(const char *const pat, ...)
9823 {
9824     dTHX;
9825     SV *sv;
9826     va_list args;
9827 
9828     PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
9829 
9830     va_start(args, pat);
9831     sv = vnewSVpvf(pat, &args);
9832     va_end(args);
9833     return sv;
9834 }
9835 #endif
9836 
9837 /*
9838 =for apidoc newSVpvf
9839 
9840 Creates a new SV and initializes it with the string formatted like
9841 C<sv_catpvf>.
9842 
9843 =for apidoc newSVpvf_nocontext
9844 Like C<L</newSVpvf>> but does not take a thread context (C<aTHX>) parameter,
9845 so is used in situations where the caller doesn't already have the thread
9846 context.
9847 
9848 =for apidoc vnewSVpvf
9849 Like C<L</newSVpvf>> but the arguments are an encapsulated argument list.
9850 
9851 =cut
9852 */
9853 
9854 SV *
9855 Perl_newSVpvf(pTHX_ const char *const pat, ...)
9856 {
9857     SV *sv;
9858     va_list args;
9859 
9860     PERL_ARGS_ASSERT_NEWSVPVF;
9861 
9862     va_start(args, pat);
9863     sv = vnewSVpvf(pat, &args);
9864     va_end(args);
9865     return sv;
9866 }
9867 
9868 /* backend for newSVpvf() and newSVpvf_nocontext() */
9869 
9870 SV *
9871 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
9872 {
9873     SV *sv;
9874 
9875     PERL_ARGS_ASSERT_VNEWSVPVF;
9876 
9877     sv = newSV(1);
9878     SvPVCLEAR_FRESH(sv);
9879     sv_vcatpvfn_flags(sv, pat, strlen(pat), args, NULL, 0, NULL, 0);
9880     return sv;
9881 }
9882 
9883 /*
9884 =for apidoc newSVnv
9885 
9886 Creates a new SV and copies a floating point value into it.
9887 The reference count for the SV is set to 1.
9888 
9889 =cut
9890 */
9891 
9892 SV *
9893 Perl_newSVnv(pTHX_ const NV n)
9894 {
9895     SV *sv = newSV_type(SVt_NV);
9896     (void)SvNOK_on(sv);
9897 
9898     SvNV_set(sv, n);
9899     SvTAINT(sv);
9900 
9901     return sv;
9902 }
9903 
9904 /*
9905 =for apidoc newSViv
9906 
9907 Creates a new SV and copies an integer into it.  The reference count for the
9908 SV is set to 1.
9909 
9910 =cut
9911 */
9912 
9913 SV *
9914 Perl_newSViv(pTHX_ const IV i)
9915 {
9916     SV *sv = newSV_type(SVt_IV);
9917     (void)SvIOK_on(sv);
9918 
9919     SvIV_set(sv, i);
9920     SvTAINT(sv);
9921 
9922     return sv;
9923 }
9924 
9925 /*
9926 =for apidoc newSVuv
9927 
9928 Creates a new SV and copies an unsigned integer into it.
9929 The reference count for the SV is set to 1.
9930 
9931 =cut
9932 */
9933 
9934 SV *
9935 Perl_newSVuv(pTHX_ const UV u)
9936 {
9937     SV *sv;
9938 
9939     /* Inlining ONLY the small relevant subset of sv_setuv here
9940      * for performance. Makes a significant difference. */
9941 
9942     /* Using ivs is more efficient than using uvs - see sv_setuv */
9943     if (u <= (UV)IV_MAX) {
9944         return newSViv((IV)u);
9945     }
9946 
9947     new_SV(sv);
9948 
9949     /* We're starting from SVt_FIRST, so provided that's
9950      * actual 0, we don't have to unset any SV type flags
9951      * to promote to SVt_IV. */
9952     STATIC_ASSERT_STMT(SVt_FIRST == 0);
9953 
9954     SET_SVANY_FOR_BODYLESS_IV(sv);
9955     SvFLAGS(sv) |= SVt_IV;
9956     (void)SvIOK_on(sv);
9957     (void)SvIsUV_on(sv);
9958 
9959     SvUV_set(sv, u);
9960     SvTAINT(sv);
9961 
9962     return sv;
9963 }
9964 
9965 /*
9966 =for apidoc newSVbool
9967 
9968 Creates a new SV boolean.
9969 
9970 =cut
9971 */
9972 
9973 SV *
9974 Perl_newSVbool(pTHX_ bool bool_val)
9975 {
9976     PERL_ARGS_ASSERT_NEWSVBOOL;
9977     SV *sv = newSVsv(bool_val ? &PL_sv_yes : &PL_sv_no);
9978 
9979     return sv;
9980 }
9981 
9982 /*
9983 =for apidoc newSV_true
9984 
9985 Creates a new SV that is a boolean true.
9986 
9987 =cut
9988 */
9989 SV *
9990 Perl_newSV_true(pTHX)
9991 {
9992     PERL_ARGS_ASSERT_NEWSV_TRUE;
9993     SV *sv = newSVsv(&PL_sv_yes);
9994 
9995     return sv;
9996 }
9997 
9998 /*
9999 =for apidoc newSV_false
10000 
10001 Creates a new SV that is a boolean false.
10002 
10003 =cut
10004 */
10005 
10006 SV *
10007 Perl_newSV_false(pTHX)
10008 {
10009     PERL_ARGS_ASSERT_NEWSV_FALSE;
10010     SV *sv = newSVsv(&PL_sv_no);
10011 
10012     return sv;
10013 }
10014 
10015 /* newRV_inc is the official function name to use now.
10016  * newRV_inc is in fact #defined to newRV in sv.h
10017  */
10018 
10019 SV *
10020 Perl_newRV(pTHX_ SV *const sv)
10021 {
10022     PERL_ARGS_ASSERT_NEWRV;
10023 
10024     return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
10025 }
10026 
10027 /*
10028 =for apidoc newSVsv
10029 =for apidoc_item newSVsv_flags
10030 =for apidoc_item newSVsv_nomg
10031 
10032 These create a new SV which is an exact duplicate of the original SV
10033 (using C<sv_setsv>.)
10034 
10035 They differ only in that C<newSVsv> performs 'get' magic; C<newSVsv_nomg> skips
10036 any magic; and C<newSVsv_flags> allows you to explicitly set a C<flags>
10037 parameter.
10038 
10039 =cut
10040 */
10041 
10042 SV *
10043 Perl_newSVsv_flags(pTHX_ SV *const old, I32 flags)
10044 {
10045     SV *sv;
10046 
10047     if (!old)
10048         return NULL;
10049     if (SvIS_FREED(old)) {
10050         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
10051         return NULL;
10052     }
10053     /* Do this here, otherwise we leak the new SV if this croaks. */
10054     if (flags & SV_GMAGIC)
10055         SvGETMAGIC(old);
10056     new_SV(sv);
10057     sv_setsv_flags(sv, old, flags & ~SV_GMAGIC);
10058     return sv;
10059 }
10060 
10061 /*
10062 =for apidoc sv_reset
10063 
10064 Underlying implementation for the C<reset> Perl function.
10065 Note that the perl-level function is vaguely deprecated.
10066 
10067 =cut
10068 */
10069 
10070 void
10071 Perl_sv_reset(pTHX_ const char *s, HV *const stash)
10072 {
10073     PERL_ARGS_ASSERT_SV_RESET;
10074 
10075     sv_resetpvn(*s ? s : NULL, strlen(s), stash);
10076 }
10077 
10078 void
10079 Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash)
10080 {
10081     char todo[PERL_UCHAR_MAX+1];
10082     const char *send;
10083 
10084     if (!stash || SvTYPE(stash) != SVt_PVHV)
10085         return;
10086 
10087     if (!s) {		/* reset ?? searches */
10088         MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
10089         if (mg && mg->mg_len) {
10090             const U32 count = mg->mg_len / sizeof(PMOP**);
10091             PMOP **pmp = (PMOP**) mg->mg_ptr;
10092             PMOP *const *const end = pmp + count;
10093 
10094             while (pmp < end) {
10095 #ifdef USE_ITHREADS
10096                 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
10097 #else
10098                 (*pmp)->op_pmflags &= ~PMf_USED;
10099 #endif
10100                 ++pmp;
10101             }
10102         }
10103         return;
10104     }
10105 
10106     /* reset variables */
10107 
10108     if (!HvTOTALKEYS(stash))
10109         return;
10110 
10111     Zero(todo, 256, char);
10112     send = s + len;
10113     while (s < send) {
10114         I32 max;
10115         I32 i = (unsigned char)*s;
10116         if (s[1] == '-') {
10117             s += 2;
10118         }
10119         max = (unsigned char)*s++;
10120         for ( ; i <= max; i++) {
10121             todo[i] = 1;
10122         }
10123         for (i = 0; i <= (I32) HvMAX(stash); i++) {
10124             HE *entry;
10125             for (entry = HvARRAY(stash)[i];
10126                  entry;
10127                  entry = HeNEXT(entry))
10128             {
10129                 GV *gv;
10130                 SV *sv;
10131 
10132                 if (!todo[(U8)*HeKEY(entry)])
10133                     continue;
10134                 gv = MUTABLE_GV(HeVAL(entry));
10135                 if (!isGV(gv))
10136                     continue;
10137                 sv = GvSV(gv);
10138                 if (sv && !SvREADONLY(sv)) {
10139                     SV_CHECK_THINKFIRST_COW_DROP(sv);
10140                     if (!isGV(sv)) SvOK_off(sv);
10141                 }
10142                 if (GvAV(gv)) {
10143                     av_clear(GvAV(gv));
10144                 }
10145                 if (GvHV(gv) && !HvHasNAME(GvHV(gv))) {
10146                     hv_clear(GvHV(gv));
10147                 }
10148             }
10149         }
10150     }
10151 }
10152 
10153 /*
10154 =for apidoc sv_2io
10155 
10156 Using various gambits, try to get an IO from an SV: the IO slot if its a
10157 GV; or the recursive result if we're an RV; or the IO slot of the symbol
10158 named after the PV if we're a string.
10159 
10160 'Get' magic is ignored on the C<sv> passed in, but will be called on
10161 C<SvRV(sv)> if C<sv> is an RV.
10162 
10163 =cut
10164 */
10165 
10166 IO*
10167 Perl_sv_2io(pTHX_ SV *const sv)
10168 {
10169     IO* io;
10170     GV* gv;
10171 
10172     PERL_ARGS_ASSERT_SV_2IO;
10173 
10174     switch (SvTYPE(sv)) {
10175     case SVt_PVIO:
10176         io = MUTABLE_IO(sv);
10177         break;
10178     case SVt_PVGV:
10179     case SVt_PVLV:
10180         if (isGV_with_GP(sv)) {
10181             gv = MUTABLE_GV(sv);
10182             io = GvIO(gv);
10183             if (!io)
10184                 Perl_croak(aTHX_ "Bad filehandle: %" HEKf,
10185                                     HEKfARG(GvNAME_HEK(gv)));
10186             break;
10187         }
10188         /* FALLTHROUGH */
10189     default:
10190         if (!SvOK(sv))
10191             Perl_croak(aTHX_ PL_no_usym, "filehandle");
10192         if (SvROK(sv)) {
10193             SvGETMAGIC(SvRV(sv));
10194             return sv_2io(SvRV(sv));
10195         }
10196         gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
10197         if (gv)
10198             io = GvIO(gv);
10199         else
10200             io = 0;
10201         if (!io) {
10202             SV *newsv = sv;
10203             if (SvGMAGICAL(sv)) {
10204                 newsv = sv_newmortal();
10205                 sv_setsv_nomg(newsv, sv);
10206             }
10207             Perl_croak(aTHX_ "Bad filehandle: %" SVf, SVfARG(newsv));
10208         }
10209         break;
10210     }
10211     return io;
10212 }
10213 
10214 /*
10215 =for apidoc sv_2cv
10216 
10217 Using various gambits, try to get a CV from an SV; in addition, try if
10218 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
10219 The flags in C<lref> are passed to C<gv_fetchsv>.
10220 
10221 =cut
10222 */
10223 
10224 CV *
10225 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
10226 {
10227     GV *gv = NULL;
10228     CV *cv = NULL;
10229 
10230     PERL_ARGS_ASSERT_SV_2CV;
10231 
10232     if (!sv) {
10233         *st = NULL;
10234         *gvp = NULL;
10235         return NULL;
10236     }
10237     switch (SvTYPE(sv)) {
10238     case SVt_PVCV:
10239         *st = CvSTASH(sv);
10240         *gvp = NULL;
10241         return MUTABLE_CV(sv);
10242     case SVt_PVHV:
10243     case SVt_PVAV:
10244         *st = NULL;
10245         *gvp = NULL;
10246         return NULL;
10247     default:
10248         SvGETMAGIC(sv);
10249         if (SvROK(sv)) {
10250             if (SvAMAGIC(sv))
10251                 sv = amagic_deref_call(sv, to_cv_amg);
10252 
10253             sv = SvRV(sv);
10254             if (SvTYPE(sv) == SVt_PVCV) {
10255                 cv = MUTABLE_CV(sv);
10256                 *gvp = NULL;
10257                 *st = CvSTASH(cv);
10258                 return cv;
10259             }
10260             else if(SvGETMAGIC(sv), isGV_with_GP(sv))
10261                 gv = MUTABLE_GV(sv);
10262             else
10263                 Perl_croak(aTHX_ "Not a subroutine reference");
10264         }
10265         else if (isGV_with_GP(sv)) {
10266             gv = MUTABLE_GV(sv);
10267         }
10268         else {
10269             gv = gv_fetchsv_nomg(sv, lref, SVt_PVCV);
10270         }
10271         *gvp = gv;
10272         if (!gv) {
10273             *st = NULL;
10274             return NULL;
10275         }
10276         /* Some flags to gv_fetchsv mean don't really create the GV  */
10277         if (!isGV_with_GP(gv)) {
10278             *st = NULL;
10279             return NULL;
10280         }
10281         *st = GvESTASH(gv);
10282         if (lref & ~GV_ADDMG && !GvCVu(gv)) {
10283             /* XXX this is probably not what they think they're getting.
10284              * It has the same effect as "sub name;", i.e. just a forward
10285              * declaration! */
10286             newSTUB(gv,0);
10287         }
10288         return GvCVu(gv);
10289     }
10290 }
10291 
10292 /*
10293 =for apidoc sv_true
10294 
10295 Returns true if the SV has a true value by Perl's rules.
10296 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
10297 instead use an in-line version.
10298 
10299 =cut
10300 */
10301 
10302 I32
10303 Perl_sv_true(pTHX_ SV *const sv)
10304 {
10305     if (!sv)
10306         return 0;
10307     if (SvPOK(sv)) {
10308         const XPV* const tXpv = (XPV*)SvANY(sv);
10309         if (tXpv &&
10310                 (tXpv->xpv_cur > 1 ||
10311                 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
10312             return 1;
10313         else
10314             return 0;
10315     }
10316     else {
10317         if (SvIOK(sv))
10318             return SvIVX(sv) != 0;
10319         else {
10320             if (SvNOK(sv))
10321                 return SvNVX(sv) != 0.0;
10322             else
10323                 return sv_2bool(sv);
10324         }
10325     }
10326 }
10327 
10328 /*
10329 =for apidoc sv_pvn_force
10330 
10331 Get a sensible string out of the SV somehow.
10332 A private implementation of the C<SvPV_force> macro for compilers which
10333 can't cope with complex macro expressions.  Always use the macro instead.
10334 
10335 =for apidoc sv_pvn_force_flags
10336 
10337 Get a sensible string out of the SV somehow.
10338 If C<flags> has the C<SV_GMAGIC> bit set, will C<L</mg_get>> on C<sv> if
10339 appropriate, else not.  C<sv_pvn_force> and C<sv_pvn_force_nomg> are
10340 implemented in terms of this function.
10341 You normally want to use the various wrapper macros instead: see
10342 C<L</SvPV_force>> and C<L</SvPV_force_nomg>>.
10343 
10344 =cut
10345 */
10346 
10347 char *
10348 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const U32 flags)
10349 {
10350     PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
10351 
10352     if (flags & SV_GMAGIC) SvGETMAGIC(sv);
10353     if (SvTHINKFIRST(sv) && (!SvROK(sv) || SvREADONLY(sv)))
10354         sv_force_normal_flags(sv, 0);
10355 
10356     if (SvPOK(sv)) {
10357         if (lp)
10358             *lp = SvCUR(sv);
10359     }
10360     else {
10361         char *s;
10362         STRLEN len;
10363 
10364         if (SvTYPE(sv) > SVt_PVLV
10365             || isGV_with_GP(sv))
10366             /* diag_listed_as: Can't coerce %s to %s in %s */
10367             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
10368                 OP_DESC(PL_op));
10369         s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC);
10370         if (!s) {
10371           s = (char *)"";
10372         }
10373         if (lp)
10374             *lp = len;
10375 
10376         if (SvTYPE(sv) < SVt_PV ||
10377             s != SvPVX_const(sv)) {	/* Almost, but not quite, sv_setpvn() */
10378             if (SvROK(sv))
10379                 sv_unref(sv);
10380             SvUPGRADE(sv, SVt_PV);		/* Never FALSE */
10381             SvGROW(sv, len + 1);
10382             Move(s,SvPVX(sv),len,char);
10383             SvCUR_set(sv, len);
10384             SvPVX(sv)[len] = '\0';
10385         }
10386         if (!SvPOK(sv)) {
10387             SvPOK_on(sv);		/* validate pointer */
10388             SvTAINT(sv);
10389             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2pv(%s)\n",
10390                                   PTR2UV(sv),SvPVX_const(sv)));
10391         }
10392     }
10393     (void)SvPOK_only_UTF8(sv);
10394     return SvPVX_mutable(sv);
10395 }
10396 
10397 /*
10398 =for apidoc sv_pvbyten_force
10399 
10400 The backend for the C<SvPVbytex_force> macro.  Always use the macro
10401 instead.  If the SV cannot be downgraded from UTF-8, this croaks.
10402 
10403 =cut
10404 */
10405 
10406 char *
10407 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
10408 {
10409     PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
10410 
10411     sv_pvn_force(sv,lp);
10412     (void)sv_utf8_downgrade(sv,0);
10413     *lp = SvCUR(sv);
10414     return SvPVX(sv);
10415 }
10416 
10417 /*
10418 =for apidoc sv_pvutf8n_force
10419 
10420 The backend for the C<SvPVutf8x_force> macro.  Always use the macro
10421 instead.
10422 
10423 =cut
10424 */
10425 
10426 char *
10427 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
10428 {
10429     PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
10430 
10431     sv_pvn_force(sv,0);
10432     sv_utf8_upgrade_nomg(sv);
10433     *lp = SvCUR(sv);
10434     return SvPVX(sv);
10435 }
10436 
10437 /*
10438 =for apidoc sv_reftype
10439 
10440 Returns a string describing what the SV is a reference to.
10441 
10442 If ob is true and the SV is blessed, the string is the class name,
10443 otherwise it is the type of the SV, "SCALAR", "ARRAY" etc.
10444 
10445 =cut
10446 */
10447 
10448 const char *
10449 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
10450 {
10451     PERL_ARGS_ASSERT_SV_REFTYPE;
10452     if (ob && SvOBJECT(sv)) {
10453         return SvPV_nolen_const(sv_ref(NULL, sv, ob));
10454     }
10455     else {
10456         /* WARNING - There is code, for instance in mg.c, that assumes that
10457          * the only reason that sv_reftype(sv,0) would return a string starting
10458          * with 'L' or 'S' is that it is a LVALUE or a SCALAR.
10459          * Yes this a dodgy way to do type checking, but it saves practically reimplementing
10460          * this routine inside other subs, and it saves time.
10461          * Do not change this assumption without searching for "dodgy type check" in
10462          * the code.
10463          * - Yves */
10464         switch (SvTYPE(sv)) {
10465         case SVt_NULL:
10466         case SVt_IV:
10467         case SVt_NV:
10468         case SVt_PV:
10469         case SVt_PVIV:
10470         case SVt_PVNV:
10471         case SVt_PVMG:
10472                                 if (SvVOK(sv))
10473                                     return "VSTRING";
10474                                 if (SvROK(sv))
10475                                     return "REF";
10476                                 else
10477                                     return "SCALAR";
10478 
10479         case SVt_PVLV:		return (char *)  (SvROK(sv) ? "REF"
10480                                 /* tied lvalues should appear to be
10481                                  * scalars for backwards compatibility */
10482                                 : (isALPHA_FOLD_EQ(LvTYPE(sv), 't'))
10483                                     ? "SCALAR" : "LVALUE");
10484         case SVt_PVAV:		return "ARRAY";
10485         case SVt_PVHV:		return "HASH";
10486         case SVt_PVCV:		return "CODE";
10487         case SVt_PVGV:		return (char *) (isGV_with_GP(sv)
10488                                     ? "GLOB" : "SCALAR");
10489         case SVt_PVFM:		return "FORMAT";
10490         case SVt_PVIO:		return "IO";
10491         case SVt_INVLIST:	return "INVLIST";
10492         case SVt_REGEXP:	return "REGEXP";
10493         case SVt_PVOBJ:         return "OBJECT";
10494         default:		return "UNKNOWN";
10495         }
10496     }
10497 }
10498 
10499 /*
10500 =for apidoc sv_ref
10501 
10502 Returns a SV describing what the SV passed in is a reference to.
10503 
10504 dst can be a SV to be set to the description or NULL, in which case a
10505 mortal SV is returned.
10506 
10507 If ob is true and the SV is blessed, the description is the class
10508 name, otherwise it is the type of the SV, "SCALAR", "ARRAY" etc.
10509 
10510 =cut
10511 */
10512 
10513 SV *
10514 Perl_sv_ref(pTHX_ SV *dst, const SV *const sv, const int ob)
10515 {
10516     PERL_ARGS_ASSERT_SV_REF;
10517 
10518     if (!dst)
10519         dst = sv_newmortal();
10520 
10521     if (ob && SvOBJECT(sv)) {
10522         if (HvHasNAME(SvSTASH(sv)))
10523             sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)));
10524         else
10525             sv_setpvs(dst, "__ANON__");
10526     }
10527     else {
10528         const char * reftype = sv_reftype(sv, 0);
10529         sv_setpv(dst, reftype);
10530     }
10531     return dst;
10532 }
10533 
10534 /*
10535 =for apidoc sv_isobject
10536 
10537 Returns a boolean indicating whether the SV is an RV pointing to a blessed
10538 object.  If the SV is not an RV, or if the object is not blessed, then this
10539 will return false.
10540 
10541 =cut
10542 */
10543 
10544 int
10545 Perl_sv_isobject(pTHX_ SV *sv)
10546 {
10547     if (!sv)
10548         return 0;
10549     SvGETMAGIC(sv);
10550     if (!SvROK(sv))
10551         return 0;
10552     sv = SvRV(sv);
10553     if (!SvOBJECT(sv))
10554         return 0;
10555     return 1;
10556 }
10557 
10558 /*
10559 =for apidoc sv_isa
10560 
10561 Returns a boolean indicating whether the SV is blessed into the specified
10562 class.
10563 
10564 This does not check for subtypes or method overloading. Use C<sv_isa_sv> to
10565 verify an inheritance relationship in the same way as the C<isa> operator by
10566 respecting any C<isa()> method overloading; or C<sv_derived_from_sv> to test
10567 directly on the actual object type.
10568 
10569 =cut
10570 */
10571 
10572 int
10573 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
10574 {
10575     const char *hvname;
10576 
10577     PERL_ARGS_ASSERT_SV_ISA;
10578 
10579     if (!sv)
10580         return 0;
10581     SvGETMAGIC(sv);
10582     if (!SvROK(sv))
10583         return 0;
10584     sv = SvRV(sv);
10585     if (!SvOBJECT(sv))
10586         return 0;
10587     hvname = HvNAME_get(SvSTASH(sv));
10588     if (!hvname)
10589         return 0;
10590 
10591     return strEQ(hvname, name);
10592 }
10593 
10594 /*
10595 =for apidoc newSVrv
10596 
10597 Creates a new SV for the existing RV, C<rv>, to point to.  If C<rv> is not an
10598 RV then it will be upgraded to one.  If C<classname> is non-null then the new
10599 SV will be blessed in the specified package.  The new SV is returned and its
10600 reference count is 1.  The reference count 1 is owned by C<rv>. See also
10601 newRV_inc() and newRV_noinc() for creating a new RV properly.
10602 
10603 =cut
10604 */
10605 
10606 SV*
10607 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
10608 {
10609     SV *sv;
10610 
10611     PERL_ARGS_ASSERT_NEWSVRV;
10612 
10613     new_SV(sv);
10614 
10615     SV_CHECK_THINKFIRST_COW_DROP(rv);
10616 
10617     if (UNLIKELY( SvTYPE(rv) >= SVt_PVMG )) {
10618         const U32 refcnt = SvREFCNT(rv);
10619         SvREFCNT(rv) = 0;
10620         sv_clear(rv);
10621         SvFLAGS(rv) = 0;
10622         SvREFCNT(rv) = refcnt;
10623 
10624         sv_upgrade(rv, SVt_IV);
10625     } else if (SvROK(rv)) {
10626         SvREFCNT_dec(SvRV(rv));
10627     } else {
10628         prepare_SV_for_RV(rv);
10629     }
10630 
10631     SvOK_off(rv);
10632     SvRV_set(rv, sv);
10633     SvROK_on(rv);
10634 
10635     if (classname) {
10636         HV* const stash = gv_stashpv(classname, GV_ADD);
10637         (void)sv_bless(rv, stash);
10638     }
10639     return sv;
10640 }
10641 
10642 SV *
10643 Perl_newSVavdefelem(pTHX_ AV *av, SSize_t ix, bool extendible)
10644 {
10645     SV * const lv = newSV_type(SVt_PVLV);
10646     PERL_ARGS_ASSERT_NEWSVAVDEFELEM;
10647     LvTYPE(lv) = 'y';
10648     sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
10649     LvTARG(lv) = SvREFCNT_inc_simple_NN(av);
10650     LvSTARGOFF(lv) = ix;
10651     LvTARGLEN(lv) = extendible ? 1 : (STRLEN)UV_MAX;
10652     return lv;
10653 }
10654 
10655 /*
10656 =for apidoc sv_setref_pv
10657 
10658 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
10659 argument will be upgraded to an RV.  That RV will be modified to point to
10660 the new SV.  If the C<pv> argument is C<NULL>, then C<PL_sv_undef> will be placed
10661 into the SV.  The C<classname> argument indicates the package for the
10662 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
10663 will have a reference count of 1, and the RV will be returned.
10664 
10665 Do not use with other Perl types such as HV, AV, SV, CV, because those
10666 objects will become corrupted by the pointer copy process.
10667 
10668 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
10669 
10670 =cut
10671 */
10672 
10673 SV*
10674 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
10675 {
10676     PERL_ARGS_ASSERT_SV_SETREF_PV;
10677 
10678     if (!pv) {
10679         sv_set_undef(rv);
10680         SvSETMAGIC(rv);
10681     }
10682     else
10683         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
10684     return rv;
10685 }
10686 
10687 /*
10688 =for apidoc sv_setref_iv
10689 
10690 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
10691 argument will be upgraded to an RV.  That RV will be modified to point to
10692 the new SV.  The C<classname> argument indicates the package for the
10693 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
10694 will have a reference count of 1, and the RV will be returned.
10695 
10696 =cut
10697 */
10698 
10699 SV*
10700 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
10701 {
10702     PERL_ARGS_ASSERT_SV_SETREF_IV;
10703 
10704     sv_setiv(newSVrv(rv,classname), iv);
10705     return rv;
10706 }
10707 
10708 /*
10709 =for apidoc sv_setref_uv
10710 
10711 Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
10712 argument will be upgraded to an RV.  That RV will be modified to point to
10713 the new SV.  The C<classname> argument indicates the package for the
10714 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
10715 will have a reference count of 1, and the RV will be returned.
10716 
10717 =cut
10718 */
10719 
10720 SV*
10721 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
10722 {
10723     PERL_ARGS_ASSERT_SV_SETREF_UV;
10724 
10725     sv_setuv(newSVrv(rv,classname), uv);
10726     return rv;
10727 }
10728 
10729 /*
10730 =for apidoc sv_setref_nv
10731 
10732 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
10733 argument will be upgraded to an RV.  That RV will be modified to point to
10734 the new SV.  The C<classname> argument indicates the package for the
10735 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
10736 will have a reference count of 1, and the RV will be returned.
10737 
10738 =cut
10739 */
10740 
10741 SV*
10742 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
10743 {
10744     PERL_ARGS_ASSERT_SV_SETREF_NV;
10745 
10746     sv_setnv(newSVrv(rv,classname), nv);
10747     return rv;
10748 }
10749 
10750 /*
10751 =for apidoc sv_setref_pvn
10752 
10753 Copies a string into a new SV, optionally blessing the SV.  The length of the
10754 string must be specified with C<n>.  The C<rv> argument will be upgraded to
10755 an RV.  That RV will be modified to point to the new SV.  The C<classname>
10756 argument indicates the package for the blessing.  Set C<classname> to
10757 C<NULL> to avoid the blessing.  The new SV will have a reference count
10758 of 1, and the RV will be returned.
10759 
10760 Note that C<sv_setref_pv> copies the pointer while this copies the string.
10761 
10762 =cut
10763 */
10764 
10765 SV*
10766 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
10767                    const char *const pv, const STRLEN n)
10768 {
10769     PERL_ARGS_ASSERT_SV_SETREF_PVN;
10770 
10771     sv_setpvn(newSVrv(rv,classname), pv, n);
10772     return rv;
10773 }
10774 
10775 /*
10776 =for apidoc sv_bless
10777 
10778 Blesses an SV into a specified package.  The SV must be an RV.  The package
10779 must be designated by its stash (see C<L</gv_stashpv>>).  The reference count
10780 of the SV is unaffected.
10781 
10782 =cut
10783 */
10784 
10785 SV*
10786 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
10787 {
10788     SV *tmpRef;
10789     HV *oldstash = NULL;
10790 
10791     PERL_ARGS_ASSERT_SV_BLESS;
10792 
10793     SvGETMAGIC(sv);
10794     if (!SvROK(sv))
10795         Perl_croak(aTHX_ "Can't bless non-reference value");
10796     if (HvSTASH_IS_CLASS(stash))
10797         Perl_croak(aTHX_ "Attempt to bless into a class");
10798 
10799     tmpRef = SvRV(sv);
10800     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY|SVf_PROTECT)) {
10801         if (SvREADONLY(tmpRef))
10802             Perl_croak_no_modify();
10803         if (SvTYPE(tmpRef) == SVt_PVOBJ)
10804             Perl_croak(aTHX_ "Can't bless an object reference");
10805         if (SvOBJECT(tmpRef)) {
10806             oldstash = SvSTASH(tmpRef);
10807         }
10808     }
10809     SvOBJECT_on(tmpRef);
10810     SvUPGRADE(tmpRef, SVt_PVMG);
10811     SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
10812     SvREFCNT_dec(oldstash);
10813 
10814     if(SvSMAGICAL(tmpRef))
10815         if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
10816             mg_set(tmpRef);
10817 
10818 
10819 
10820     return sv;
10821 }
10822 
10823 /* Downgrades a PVGV to a PVMG. If it's actually a PVLV, we leave the type
10824  * as it is after unglobbing it.
10825  */
10826 
10827 PERL_STATIC_INLINE void
10828 S_sv_unglob(pTHX_ SV *const sv, U32 flags)
10829 {
10830     void *xpvmg;
10831     HV *stash;
10832     SV * const temp = flags & SV_COW_DROP_PV ? NULL : sv_newmortal();
10833 
10834     PERL_ARGS_ASSERT_SV_UNGLOB;
10835 
10836     assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
10837     SvFAKE_off(sv);
10838     if (!(flags & SV_COW_DROP_PV))
10839         gv_efullname3(temp, MUTABLE_GV(sv), "*");
10840 
10841     SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
10842     if (GvGP(sv)) {
10843         if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
10844            && HvHasNAME(stash))
10845             mro_method_changed_in(stash);
10846         gp_free(MUTABLE_GV(sv));
10847     }
10848     if (GvSTASH(sv)) {
10849         sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
10850         GvSTASH(sv) = NULL;
10851     }
10852     GvMULTI_off(sv);
10853     if (GvNAME_HEK(sv)) {
10854         unshare_hek(GvNAME_HEK(sv));
10855     }
10856     isGV_with_GP_off(sv);
10857 
10858     if(SvTYPE(sv) == SVt_PVGV) {
10859         /* need to keep SvANY(sv) in the right arena */
10860         xpvmg = new_XPVMG();
10861         StructCopy(SvANY(sv), xpvmg, XPVMG);
10862         del_body_by_type(SvANY(sv), SVt_PVGV);
10863         SvANY(sv) = xpvmg;
10864 
10865         SvFLAGS(sv) &= ~SVTYPEMASK;
10866         SvFLAGS(sv) |= SVt_PVMG;
10867     }
10868 
10869     /* Intentionally not calling any local SET magic, as this isn't so much a
10870        set operation as merely an internal storage change.  */
10871     if (flags & SV_COW_DROP_PV) SvOK_off(sv);
10872     else sv_setsv_flags(sv, temp, 0);
10873 
10874     if ((const GV *)sv == PL_last_in_gv)
10875         PL_last_in_gv = NULL;
10876     else if ((const GV *)sv == PL_statgv)
10877         PL_statgv = NULL;
10878 }
10879 
10880 /*
10881 =for apidoc sv_unref_flags
10882 
10883 Unsets the RV status of the SV, and decrements the reference count of
10884 whatever was being referenced by the RV.  This can almost be thought of
10885 as a reversal of C<newSVrv>.  The C<cflags> argument can contain
10886 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
10887 (otherwise the decrementing is conditional on the reference count being
10888 different from one or the reference being a readonly SV).
10889 See C<L</SvROK_off>>.
10890 
10891 =for apidoc Amnh||SV_IMMEDIATE_UNREF
10892 
10893 =cut
10894 */
10895 
10896 void
10897 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
10898 {
10899     SV* const target = SvRV(ref);
10900 
10901     PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
10902 
10903     if (SvWEAKREF(ref)) {
10904         sv_del_backref(target, ref);
10905         SvWEAKREF_off(ref);
10906         SvRV_set(ref, NULL);
10907         return;
10908     }
10909     SvRV_set(ref, NULL);
10910     SvROK_off(ref);
10911     /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
10912        assigned to as BEGIN {$a = \"Foo"} will fail.  */
10913     if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
10914         SvREFCNT_dec_NN(target);
10915     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
10916         sv_2mortal(target);	/* Schedule for freeing later */
10917 }
10918 
10919 /*
10920 =for apidoc sv_untaint
10921 
10922 Untaint an SV.  Use C<SvTAINTED_off> instead.
10923 
10924 =cut
10925 */
10926 
10927 void
10928 Perl_sv_untaint(pTHX_ SV *const sv)
10929 {
10930     PERL_ARGS_ASSERT_SV_UNTAINT;
10931     PERL_UNUSED_CONTEXT;
10932 
10933     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
10934         MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
10935         if (mg)
10936             mg->mg_len &= ~1;
10937     }
10938 }
10939 
10940 /*
10941 =for apidoc sv_tainted
10942 
10943 Test an SV for taintedness.  Use C<SvTAINTED> instead.
10944 
10945 =cut
10946 */
10947 
10948 bool
10949 Perl_sv_tainted(pTHX_ SV *const sv)
10950 {
10951     PERL_ARGS_ASSERT_SV_TAINTED;
10952     PERL_UNUSED_CONTEXT;
10953 
10954     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
10955         const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
10956         if (mg && (mg->mg_len & 1) )
10957             return TRUE;
10958     }
10959     return FALSE;
10960 }
10961 
10962 #if defined(MULTIPLICITY)
10963 
10964 /* pTHX_ magic can't cope with varargs, so this is a no-context
10965  * version of the main function, (which may itself be aliased to us).
10966  * Don't access this version directly.
10967  */
10968 
10969 void
10970 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
10971 {
10972     dTHX;
10973     va_list args;
10974 
10975     PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
10976 
10977     va_start(args, pat);
10978     sv_vsetpvf(sv, pat, &args);
10979     va_end(args);
10980 }
10981 
10982 /* pTHX_ magic can't cope with varargs, so this is a no-context
10983  * version of the main function, (which may itself be aliased to us).
10984  * Don't access this version directly.
10985  */
10986 
10987 void
10988 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
10989 {
10990     dTHX;
10991     va_list args;
10992 
10993     PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
10994 
10995     va_start(args, pat);
10996     sv_vsetpvf_mg(sv, pat, &args);
10997     va_end(args);
10998 }
10999 #endif
11000 
11001 /*
11002 =for apidoc      sv_setpvf
11003 =for apidoc_item sv_setpvf_mg
11004 =for apidoc_item sv_setpvf_mg_nocontext
11005 =for apidoc_item sv_setpvf_nocontext
11006 
11007 These work like C<L</sv_catpvf>> but copy the text into the SV instead of
11008 appending it.
11009 
11010 The differences between these are:
11011 
11012 C<sv_setpvf_mg> and C<sv_setpvf_mg_nocontext> perform 'set' magic; C<sv_setpvf>
11013 and C<sv_setpvf_nocontext> skip all magic.
11014 
11015 C<sv_setpvf_nocontext> and C<sv_setpvf_mg_nocontext> do not take a thread
11016 context (C<aTHX>) parameter, so are used in situations where the caller
11017 doesn't already have the thread context.
11018 
11019 =cut
11020 */
11021 
11022 void
11023 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
11024 {
11025     va_list args;
11026 
11027     PERL_ARGS_ASSERT_SV_SETPVF;
11028 
11029     va_start(args, pat);
11030     sv_vsetpvf(sv, pat, &args);
11031     va_end(args);
11032 }
11033 
11034 /*
11035 =for apidoc sv_vsetpvf
11036 =for apidoc_item sv_vsetpvf_mg
11037 
11038 These work like C<L</sv_vcatpvf>> but copy the text into the SV instead of
11039 appending it.
11040 
11041 They differ only in that C<sv_vsetpvf_mg> performs 'set' magic;
11042 C<sv_vsetpvf> skips all magic.
11043 
11044 They are usually used via their frontends, C<L</sv_setpvf>> and
11045 C<L</sv_setpvf_mg>>.
11046 
11047 =cut
11048 */
11049 
11050 void
11051 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
11052 {
11053     PERL_ARGS_ASSERT_SV_VSETPVF;
11054 
11055     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
11056 }
11057 
11058 void
11059 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
11060 {
11061     va_list args;
11062 
11063     PERL_ARGS_ASSERT_SV_SETPVF_MG;
11064 
11065     va_start(args, pat);
11066     sv_vsetpvf_mg(sv, pat, &args);
11067     va_end(args);
11068 }
11069 
11070 void
11071 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
11072 {
11073     PERL_ARGS_ASSERT_SV_VSETPVF_MG;
11074 
11075     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
11076     SvSETMAGIC(sv);
11077 }
11078 
11079 #if defined(MULTIPLICITY)
11080 
11081 /* pTHX_ magic can't cope with varargs, so this is a no-context
11082  * version of the main function, (which may itself be aliased to us).
11083  * Don't access this version directly.
11084  */
11085 
11086 void
11087 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
11088 {
11089     dTHX;
11090     va_list args;
11091 
11092     PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
11093 
11094     va_start(args, pat);
11095     sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
11096     va_end(args);
11097 }
11098 
11099 /* pTHX_ magic can't cope with varargs, so this is a no-context
11100  * version of the main function, (which may itself be aliased to us).
11101  * Don't access this version directly.
11102  */
11103 
11104 void
11105 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
11106 {
11107     dTHX;
11108     va_list args;
11109 
11110     PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
11111 
11112     va_start(args, pat);
11113     sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
11114     SvSETMAGIC(sv);
11115     va_end(args);
11116 }
11117 #endif
11118 
11119 /*
11120 =for apidoc sv_catpvf
11121 =for apidoc_item sv_catpvf_mg
11122 =for apidoc_item sv_catpvf_mg_nocontext
11123 =for apidoc_item sv_catpvf_nocontext
11124 
11125 These process their arguments like C<sprintf>, and append the formatted
11126 output to an SV.  As with C<sv_vcatpvfn>, argument reordering is not supporte
11127 when called with a non-null C-style variable argument list.
11128 
11129 If the appended data contains "wide" characters
11130 (including, but not limited to, SVs with a UTF-8 PV formatted with C<%s>,
11131 and characters >255 formatted with C<%c>), the original SV might get
11132 upgraded to UTF-8.
11133 
11134 If the original SV was UTF-8, the pattern should be
11135 valid UTF-8; if the original SV was bytes, the pattern should be too.
11136 
11137 All perform 'get' magic, but only C<sv_catpvf_mg> and C<sv_catpvf_mg_nocontext>
11138 perform 'set' magic.
11139 
11140 C<sv_catpvf_nocontext> and C<sv_catpvf_mg_nocontext> do not take a thread
11141 context (C<aTHX>) parameter, so are used in situations where the caller
11142 doesn't already have the thread context.
11143 
11144 =cut
11145 */
11146 
11147 void
11148 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
11149 {
11150     va_list args;
11151 
11152     PERL_ARGS_ASSERT_SV_CATPVF;
11153 
11154     va_start(args, pat);
11155     sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
11156     va_end(args);
11157 }
11158 
11159 /*
11160 =for apidoc sv_vcatpvf
11161 =for apidoc_item sv_vcatpvf_mg
11162 
11163 These process their arguments like C<sv_vcatpvfn> called with a non-null
11164 C-style variable argument list, and append the formatted output to C<sv>.
11165 
11166 They differ only in that C<sv_vcatpvf_mg> performs 'set' magic;
11167 C<sv_vcatpvf> skips 'set' magic.
11168 
11169 Both perform 'get' magic.
11170 
11171 They are usually accessed via their frontends C<L</sv_catpvf>> and
11172 C<L</sv_catpvf_mg>>.
11173 
11174 =cut
11175 */
11176 
11177 void
11178 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
11179 {
11180     PERL_ARGS_ASSERT_SV_VCATPVF;
11181 
11182     sv_vcatpvfn_flags(sv, pat, strlen(pat), args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
11183 }
11184 
11185 void
11186 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
11187 {
11188     va_list args;
11189 
11190     PERL_ARGS_ASSERT_SV_CATPVF_MG;
11191 
11192     va_start(args, pat);
11193     sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
11194     SvSETMAGIC(sv);
11195     va_end(args);
11196 }
11197 
11198 void
11199 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
11200 {
11201     PERL_ARGS_ASSERT_SV_VCATPVF_MG;
11202 
11203     sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
11204     SvSETMAGIC(sv);
11205 }
11206 
11207 /*
11208 =for apidoc sv_vsetpvfn
11209 
11210 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
11211 appending it.
11212 
11213 Usually used via one of its frontends L</C<sv_vsetpvf>> and
11214 L</C<sv_vsetpvf_mg>>.
11215 
11216 =cut
11217 */
11218 
11219 void
11220 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
11221                  va_list *const args, SV **const svargs, const Size_t sv_count, bool *const maybe_tainted)
11222 {
11223     PERL_ARGS_ASSERT_SV_VSETPVFN;
11224 
11225     SvPVCLEAR(sv);
11226     sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, sv_count, maybe_tainted, 0);
11227 }
11228 
11229 
11230 /* simplified inline Perl_sv_catpvn_nomg() when you know the SV's SvPOK */
11231 
11232 PERL_STATIC_INLINE void
11233 S_sv_catpvn_simple(pTHX_ SV *const sv, const char* const buf, const STRLEN len)
11234 {
11235     STRLEN const need = len + SvCUR(sv) + 1;
11236     char *end;
11237 
11238     /* can't wrap as both len and SvCUR() are allocated in
11239      * memory and together can't consume all the address space
11240      */
11241     assert(need > len);
11242 
11243     assert(SvPOK(sv));
11244     SvGROW(sv, need);
11245     end = SvEND(sv);
11246     Copy(buf, end, len, char);
11247     end += len;
11248     *end = '\0';
11249     SvCUR_set(sv, need - 1);
11250 }
11251 
11252 
11253 /*
11254  * Warn of missing argument to sprintf. The value used in place of such
11255  * arguments should be &PL_sv_no; an undefined value would yield
11256  * inappropriate "use of uninit" warnings [perl #71000].
11257  */
11258 STATIC void
11259 S_warn_vcatpvfn_missing_argument(pTHX) {
11260     if (ckWARN(WARN_MISSING)) {
11261         Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
11262                 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
11263     }
11264 }
11265 
11266 
11267 static void
11268 S_croak_overflow()
11269 {
11270     dTHX;
11271     Perl_croak(aTHX_ "Integer overflow in format string for %s",
11272                     (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
11273 }
11274 
11275 
11276 /* Given an int i from the next arg (if args is true) or an sv from an arg
11277  * (if args is false), try to extract a STRLEN-ranged value from the arg,
11278  * with overflow checking.
11279  * Sets *neg to true if the value was negative (untouched otherwise.
11280  * Returns the absolute value.
11281  * As an extra margin of safety, it croaks if the returned value would
11282  * exceed the maximum value of a STRLEN / 4.
11283  */
11284 
11285 static STRLEN
11286 S_sprintf_arg_num_val(pTHX_ va_list *const args, int i, SV *sv, bool *neg)
11287 {
11288     IV iv;
11289 
11290     if (args) {
11291         iv = i;
11292         goto do_iv;
11293     }
11294 
11295     if (!sv)
11296         return 0;
11297 
11298     SvGETMAGIC(sv);
11299 
11300     if (UNLIKELY(SvIsUV(sv))) {
11301         UV uv = SvUV_nomg(sv);
11302         if (uv > IV_MAX)
11303             S_croak_overflow();
11304         iv = uv;
11305     }
11306     else {
11307         iv = SvIV_nomg(sv);
11308       do_iv:
11309         if (iv < 0) {
11310             if (iv < -IV_MAX)
11311                 S_croak_overflow();
11312             iv = -iv;
11313             *neg = TRUE;
11314         }
11315     }
11316 
11317     if (iv > (IV)(((STRLEN)~0) / 4))
11318         S_croak_overflow();
11319 
11320     return (STRLEN)iv;
11321 }
11322 
11323 /* Read in and return a number. Updates *pattern to point to the char
11324  * following the number. Expects the first char to 1..9.
11325  * Croaks if the number exceeds 1/4 of the maximum value of STRLEN.
11326  * This is a belt-and-braces safety measure to complement any
11327  * overflow/wrap checks done in the main body of sv_vcatpvfn_flags.
11328  * It means that e.g. on a 32-bit system the width/precision can't be more
11329  * than 1G, which seems reasonable.
11330  */
11331 
11332 STATIC STRLEN
11333 S_expect_number(pTHX_ const char **const pattern)
11334 {
11335     STRLEN var;
11336 
11337     PERL_ARGS_ASSERT_EXPECT_NUMBER;
11338 
11339     assert(inRANGE(**pattern, '1', '9'));
11340 
11341     var = *(*pattern)++ - '0';
11342     while (isDIGIT(**pattern)) {
11343         /* if var * 10 + 9 would exceed 1/4 max strlen, croak */
11344         if (var > ((((STRLEN)~0) / 4 - 9) / 10))
11345             S_croak_overflow();
11346         var = var * 10 + (*(*pattern)++ - '0');
11347     }
11348     return var;
11349 }
11350 
11351 /* Implement a fast "%.0f": given a pointer to the end of a buffer (caller
11352  * ensures it's big enough), back fill it with the rounded integer part of
11353  * nv. Returns ptr to start of string, and sets *len to its length.
11354  * Returns NULL if not convertible.
11355  */
11356 
11357 STATIC char *
11358 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
11359 {
11360     const int neg = nv < 0;
11361     UV uv;
11362 
11363     PERL_ARGS_ASSERT_F0CONVERT;
11364 
11365     assert(!Perl_isinfnan(nv));
11366     if (neg)
11367         nv = -nv;
11368     if (nv != 0.0 && nv < (NV) UV_MAX) {
11369         char *p = endbuf;
11370         uv = (UV)nv;
11371         if (uv != nv) {
11372             nv += 0.5;
11373             uv = (UV)nv;
11374             if (uv & 1 && uv == nv)
11375                 uv--;			/* Round to even */
11376         }
11377         do {
11378             const unsigned dig = uv % 10;
11379             *--p = '0' + dig;
11380         } while (uv /= 10);
11381         if (neg)
11382             *--p = '-';
11383         *len = endbuf - p;
11384         return p;
11385     }
11386     return NULL;
11387 }
11388 
11389 
11390 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
11391 
11392 void
11393 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
11394                  va_list *const args, SV **const svargs, const Size_t sv_count, bool *const maybe_tainted)
11395 {
11396     PERL_ARGS_ASSERT_SV_VCATPVFN;
11397 
11398     sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, sv_count, maybe_tainted, SV_GMAGIC|SV_SMAGIC);
11399 }
11400 
11401 
11402 /* For the vcatpvfn code, we need a long double target in case
11403  * HAS_LONG_DOUBLE, even without USE_LONG_DOUBLE, so that we can printf
11404  * with long double formats, even without NV being long double.  But we
11405  * call the target 'fv' instead of 'nv', since most of the time it is not
11406  * (most compilers these days recognize "long double", even if only as a
11407  * synonym for "double").
11408 */
11409 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE && \
11410         defined(PERL_PRIgldbl) && !defined(USE_QUADMATH)
11411 #  define VCATPVFN_FV_GF PERL_PRIgldbl
11412 #  if defined(__VMS) && defined(__ia64) && defined(__IEEE_FLOAT)
11413        /* Work around breakage in OTS$CVT_FLOAT_T_X */
11414 #    define VCATPVFN_NV_TO_FV(nv,fv)                    \
11415             STMT_START {                                \
11416                 double _dv = nv;                        \
11417                 fv = Perl_isnan(_dv) ? LDBL_QNAN : _dv; \
11418             } STMT_END
11419 #  else
11420 #    define VCATPVFN_NV_TO_FV(nv,fv) (fv)=(nv)
11421 #  endif
11422    typedef long double vcatpvfn_long_double_t;
11423 #else
11424 #  define VCATPVFN_FV_GF NVgf
11425 #  define VCATPVFN_NV_TO_FV(nv,fv) (fv)=(nv)
11426    typedef NV vcatpvfn_long_double_t;
11427 #endif
11428 
11429 #ifdef LONGDOUBLE_DOUBLEDOUBLE
11430 /* The first double can be as large as 2**1023, or '1' x '0' x 1023.
11431  * The second double can be as small as 2**-1074, or '0' x 1073 . '1'.
11432  * The sum of them can be '1' . '0' x 2096 . '1', with implied radix point
11433  * after the first 1023 zero bits.
11434  *
11435  * XXX The 2098 is quite large (262.25 bytes) and therefore some sort
11436  * of dynamically growing buffer might be better, start at just 16 bytes
11437  * (for example) and grow only when necessary.  Or maybe just by looking
11438  * at the exponents of the two doubles? */
11439 #  define DOUBLEDOUBLE_MAXBITS 2098
11440 #endif
11441 
11442 /* vhex will contain the values (0..15) of the hex digits ("nybbles"
11443  * of 4 bits); 1 for the implicit 1, and the mantissa bits, four bits
11444  * per xdigit.  For the double-double case, this can be rather many.
11445  * The non-double-double-long-double overshoots since all bits of NV
11446  * are not mantissa bits, there are also exponent bits. */
11447 #ifdef LONGDOUBLE_DOUBLEDOUBLE
11448 #  define VHEX_SIZE (3+DOUBLEDOUBLE_MAXBITS/4)
11449 #else
11450 #  define VHEX_SIZE (1+(NVSIZE * 8)/4)
11451 #endif
11452 
11453 /* If we do not have a known long double format, (including not using
11454  * long doubles, or long doubles being equal to doubles) then we will
11455  * fall back to the ldexp/frexp route, with which we can retrieve at
11456  * most as many bits as our widest unsigned integer type is.  We try
11457  * to get a 64-bit unsigned integer even if we are not using a 64-bit UV.
11458  *
11459  * (If you want to test the case of UVSIZE == 4, NVSIZE == 8,
11460  *  set the MANTISSATYPE to int and the MANTISSASIZE to 4.)
11461  */
11462 #if defined(HAS_QUAD) && defined(Uquad_t)
11463 #  define MANTISSATYPE Uquad_t
11464 #  define MANTISSASIZE 8
11465 #else
11466 #  define MANTISSATYPE UV
11467 #  define MANTISSASIZE UVSIZE
11468 #endif
11469 
11470 #if defined(DOUBLE_LITTLE_ENDIAN) || defined(LONGDOUBLE_LITTLE_ENDIAN)
11471 #  define HEXTRACT_LITTLE_ENDIAN
11472 #elif defined(DOUBLE_BIG_ENDIAN) || defined(LONGDOUBLE_BIG_ENDIAN)
11473 #  define HEXTRACT_BIG_ENDIAN
11474 #else
11475 #  define HEXTRACT_MIX_ENDIAN
11476 #endif
11477 
11478 /* S_hextract() is a helper for S_format_hexfp, for extracting
11479  * the hexadecimal values (for %a/%A).  The nv is the NV where the value
11480  * are being extracted from (either directly from the long double in-memory
11481  * presentation, or from the uquad computed via frexp+ldexp).  frexp also
11482  * is used to update the exponent.  The subnormal is set to true
11483  * for IEEE 754 subnormals/denormals (including the x86 80-bit format).
11484  * The vhex is the pointer to the beginning of the output buffer of VHEX_SIZE.
11485  *
11486  * The tricky part is that S_hextract() needs to be called twice:
11487  * the first time with vend as NULL, and the second time with vend as
11488  * the pointer returned by the first call.  What happens is that on
11489  * the first round the output size is computed, and the intended
11490  * extraction sanity checked.  On the second round the actual output
11491  * (the extraction of the hexadecimal values) takes place.
11492  * Sanity failures cause fatal failures during both rounds. */
11493 STATIC U8*
11494 S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal,
11495            U8* vhex, U8* vend)
11496 {
11497     U8* v = vhex;
11498     int ix;
11499     int ixmin = 0, ixmax = 0;
11500 
11501     /* XXX Inf/NaN are not handled here, since it is
11502      * assumed they are to be output as "Inf" and "NaN". */
11503 
11504     /* These macros are just to reduce typos, they have multiple
11505      * repetitions below, but usually only one (or sometimes two)
11506      * of them is really being used. */
11507     /* HEXTRACT_OUTPUT() extracts the high nybble first. */
11508 #define HEXTRACT_OUTPUT_HI(ix) (*v++ = nvp[ix] >> 4)
11509 #define HEXTRACT_OUTPUT_LO(ix) (*v++ = nvp[ix] & 0xF)
11510 #define HEXTRACT_OUTPUT(ix) \
11511     STMT_START { \
11512       HEXTRACT_OUTPUT_HI(ix); HEXTRACT_OUTPUT_LO(ix); \
11513    } STMT_END
11514 #define HEXTRACT_COUNT(ix, c) \
11515     STMT_START { \
11516       v += c; if (ix < ixmin) ixmin = ix; else if (ix > ixmax) ixmax = ix; \
11517    } STMT_END
11518 #define HEXTRACT_BYTE(ix) \
11519     STMT_START { \
11520       if (vend) HEXTRACT_OUTPUT(ix); else HEXTRACT_COUNT(ix, 2); \
11521    } STMT_END
11522 #define HEXTRACT_LO_NYBBLE(ix) \
11523     STMT_START { \
11524       if (vend) HEXTRACT_OUTPUT_LO(ix); else HEXTRACT_COUNT(ix, 1); \
11525    } STMT_END
11526     /* HEXTRACT_TOP_NYBBLE is just convenience disguise,
11527      * to make it look less odd when the top bits of a NV
11528      * are extracted using HEXTRACT_LO_NYBBLE: the highest
11529      * order bits can be in the "low nybble" of a byte. */
11530 #define HEXTRACT_TOP_NYBBLE(ix) HEXTRACT_LO_NYBBLE(ix)
11531 #define HEXTRACT_BYTES_LE(a, b) \
11532     for (ix = a; ix >= b; ix--) { HEXTRACT_BYTE(ix); }
11533 #define HEXTRACT_BYTES_BE(a, b) \
11534     for (ix = a; ix <= b; ix++) { HEXTRACT_BYTE(ix); }
11535 #define HEXTRACT_GET_SUBNORMAL(nv) *subnormal = Perl_fp_class_denorm(nv)
11536 #define HEXTRACT_IMPLICIT_BIT(nv) \
11537     STMT_START { \
11538         if (!*subnormal) { \
11539             if (vend) *v++ = ((nv) == 0.0) ? 0 : 1; else v++; \
11540         } \
11541    } STMT_END
11542 
11543 /* Most formats do.  Those which don't should undef this.
11544  *
11545  * But also note that IEEE 754 subnormals do not have it, or,
11546  * expressed alternatively, their implicit bit is zero. */
11547 #define HEXTRACT_HAS_IMPLICIT_BIT
11548 
11549 /* Many formats do.  Those which don't should undef this. */
11550 #define HEXTRACT_HAS_TOP_NYBBLE
11551 
11552     /* HEXTRACTSIZE is the maximum number of xdigits. */
11553 #if defined(USE_LONG_DOUBLE) && defined(LONGDOUBLE_DOUBLEDOUBLE)
11554 #  define HEXTRACTSIZE (2+DOUBLEDOUBLE_MAXBITS/4)
11555 #else
11556 #  define HEXTRACTSIZE 2 * NVSIZE
11557 #endif
11558 
11559     const U8* vmaxend = vhex + HEXTRACTSIZE;
11560 
11561     assert(HEXTRACTSIZE <= VHEX_SIZE);
11562 
11563     PERL_UNUSED_VAR(ix); /* might happen */
11564     (void)Perl_frexp(PERL_ABS(nv), exponent);
11565     *subnormal = FALSE;
11566     if (vend && (vend <= vhex || vend > vmaxend)) {
11567         /* diag_listed_as: Hexadecimal float: internal error (%s) */
11568         Perl_croak(aTHX_ "Hexadecimal float: internal error (entry)");
11569     }
11570     {
11571         /* First check if using long doubles. */
11572 #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE)
11573 #  if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
11574         /* Used in e.g. VMS and HP-UX IA-64, e.g. -0.1L:
11575          * 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb bf */
11576         /* The bytes 13..0 are the mantissa/fraction,
11577          * the 15,14 are the sign+exponent. */
11578         const U8* nvp = (const U8*)(&nv);
11579         HEXTRACT_GET_SUBNORMAL(nv);
11580         HEXTRACT_IMPLICIT_BIT(nv);
11581 #    undef HEXTRACT_HAS_TOP_NYBBLE
11582         HEXTRACT_BYTES_LE(13, 0);
11583 #  elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN
11584         /* Used in e.g. Solaris Sparc and HP-UX PA-RISC, e.g. -0.1L:
11585          * bf fb 99 99 99 99 99 99 99 99 99 99 99 99 99 9a */
11586         /* The bytes 2..15 are the mantissa/fraction,
11587          * the 0,1 are the sign+exponent. */
11588         const U8* nvp = (const U8*)(&nv);
11589         HEXTRACT_GET_SUBNORMAL(nv);
11590         HEXTRACT_IMPLICIT_BIT(nv);
11591 #    undef HEXTRACT_HAS_TOP_NYBBLE
11592         HEXTRACT_BYTES_BE(2, 15);
11593 #  elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
11594         /* x86 80-bit "extended precision", 64 bits of mantissa / fraction /
11595          * significand, 15 bits of exponent, 1 bit of sign.  No implicit bit.
11596          * NVSIZE can be either 12 (ILP32, Solaris x86) or 16 (LP64, Linux
11597          * and OS X), meaning that 2 or 6 bytes are empty padding. */
11598         /* The bytes 0..1 are the sign+exponent,
11599          * the bytes 2..9 are the mantissa/fraction. */
11600         const U8* nvp = (const U8*)(&nv);
11601 #    undef HEXTRACT_HAS_IMPLICIT_BIT
11602 #    undef HEXTRACT_HAS_TOP_NYBBLE
11603         HEXTRACT_GET_SUBNORMAL(nv);
11604         HEXTRACT_BYTES_LE(7, 0);
11605 #  elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
11606         /* Does this format ever happen? (Wikipedia says the Motorola
11607          * 6888x math coprocessors used format _like_ this but padded
11608          * to 96 bits with 16 unused bits between the exponent and the
11609          * mantissa.) */
11610         const U8* nvp = (const U8*)(&nv);
11611 #    undef HEXTRACT_HAS_IMPLICIT_BIT
11612 #    undef HEXTRACT_HAS_TOP_NYBBLE
11613         HEXTRACT_GET_SUBNORMAL(nv);
11614         HEXTRACT_BYTES_BE(0, 7);
11615 #  else
11616 #    define HEXTRACT_FALLBACK
11617         /* Double-double format: two doubles next to each other.
11618          * The first double is the high-order one, exactly like
11619          * it would be for a "lone" double.  The second double
11620          * is shifted down using the exponent so that that there
11621          * are no common bits.  The tricky part is that the value
11622          * of the double-double is the SUM of the two doubles and
11623          * the second one can be also NEGATIVE.
11624          *
11625          * Because of this tricky construction the bytewise extraction we
11626          * use for the other long double formats doesn't work, we must
11627          * extract the values bit by bit.
11628          *
11629          * The little-endian double-double is used .. somewhere?
11630          *
11631          * The big endian double-double is used in e.g. PPC/Power (AIX)
11632          * and MIPS (SGI).
11633          *
11634          * The mantissa bits are in two separate stretches, e.g. for -0.1L:
11635          * 9a 99 99 99 99 99 59 bc 9a 99 99 99 99 99 b9 3f (LE)
11636          * 3f b9 99 99 99 99 99 9a bc 59 99 99 99 99 99 9a (BE)
11637          */
11638 #  endif
11639 #else /* #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE) */
11640         /* Using normal doubles, not long doubles.
11641          *
11642          * We generate 4-bit xdigits (nybble/nibble) instead of 8-bit
11643          * bytes, since we might need to handle printf precision, and
11644          * also need to insert the radix. */
11645 #  if NVSIZE == 8
11646 #    ifdef HEXTRACT_LITTLE_ENDIAN
11647         /* 0 1 2 3 4 5 6 7 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */
11648         const U8* nvp = (const U8*)(&nv);
11649         HEXTRACT_GET_SUBNORMAL(nv);
11650         HEXTRACT_IMPLICIT_BIT(nv);
11651         HEXTRACT_TOP_NYBBLE(6);
11652         HEXTRACT_BYTES_LE(5, 0);
11653 #    elif defined(HEXTRACT_BIG_ENDIAN)
11654         /* 7 6 5 4 3 2 1 0 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */
11655         const U8* nvp = (const U8*)(&nv);
11656         HEXTRACT_GET_SUBNORMAL(nv);
11657         HEXTRACT_IMPLICIT_BIT(nv);
11658         HEXTRACT_TOP_NYBBLE(1);
11659         HEXTRACT_BYTES_BE(2, 7);
11660 #    elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_LE_BE
11661         /* 4 5 6 7 0 1 2 3 (MSB = 7, LSB = 0, 6:7 = nybble:exponent:sign) */
11662         const U8* nvp = (const U8*)(&nv);
11663         HEXTRACT_GET_SUBNORMAL(nv);
11664         HEXTRACT_IMPLICIT_BIT(nv);
11665         HEXTRACT_TOP_NYBBLE(2); /* 6 */
11666         HEXTRACT_BYTE(1); /* 5 */
11667         HEXTRACT_BYTE(0); /* 4 */
11668         HEXTRACT_BYTE(7); /* 3 */
11669         HEXTRACT_BYTE(6); /* 2 */
11670         HEXTRACT_BYTE(5); /* 1 */
11671         HEXTRACT_BYTE(4); /* 0 */
11672 #    elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_BE_LE
11673         /* 3 2 1 0 7 6 5 4 (MSB = 7, LSB = 0, 7:6 = sign:exponent:nybble) */
11674         const U8* nvp = (const U8*)(&nv);
11675         HEXTRACT_GET_SUBNORMAL(nv);
11676         HEXTRACT_IMPLICIT_BIT(nv);
11677         HEXTRACT_TOP_NYBBLE(5); /* 6 */
11678         HEXTRACT_BYTE(6); /* 5 */
11679         HEXTRACT_BYTE(7); /* 4 */
11680         HEXTRACT_BYTE(0); /* 3 */
11681         HEXTRACT_BYTE(1); /* 2 */
11682         HEXTRACT_BYTE(2); /* 1 */
11683         HEXTRACT_BYTE(3); /* 0 */
11684 #    else
11685 #      define HEXTRACT_FALLBACK
11686 #    endif
11687 #  else
11688 #    define HEXTRACT_FALLBACK
11689 #  endif
11690 #endif /* #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE) #else */
11691 
11692 #ifdef HEXTRACT_FALLBACK
11693         HEXTRACT_GET_SUBNORMAL(nv);
11694 #  undef HEXTRACT_HAS_TOP_NYBBLE /* Meaningless, but consistent. */
11695         /* The fallback is used for the double-double format, and
11696          * for unknown long double formats, and for unknown double
11697          * formats, or in general unknown NV formats. */
11698         if (nv == (NV)0.0) {
11699             if (vend)
11700                 *v++ = 0;
11701             else
11702                 v++;
11703             *exponent = 0;
11704         }
11705         else {
11706             NV d = nv < 0 ? -nv : nv;
11707             NV e = (NV)1.0;
11708             U8 ha = 0x0; /* hexvalue accumulator */
11709             U8 hd = 0x8; /* hexvalue digit */
11710 
11711             /* Shift d and e (and update exponent) so that e <= d < 2*e,
11712              * this is essentially manual frexp(). Multiplying by 0.5 and
11713              * doubling should be lossless in binary floating point. */
11714 
11715             *exponent = 1;
11716 
11717             while (e > d) {
11718                 e *= (NV)0.5;
11719                 (*exponent)--;
11720             }
11721             /* Now d >= e */
11722 
11723             while (d >= e + e) {
11724                 e += e;
11725                 (*exponent)++;
11726             }
11727             /* Now e <= d < 2*e */
11728 
11729             /* First extract the leading hexdigit (the implicit bit). */
11730             if (d >= e) {
11731                 d -= e;
11732                 if (vend)
11733                     *v++ = 1;
11734                 else
11735                     v++;
11736             }
11737             else {
11738                 if (vend)
11739                     *v++ = 0;
11740                 else
11741                     v++;
11742             }
11743             e *= (NV)0.5;
11744 
11745             /* Then extract the remaining hexdigits. */
11746             while (d > (NV)0.0) {
11747                 if (d >= e) {
11748                     ha |= hd;
11749                     d -= e;
11750                 }
11751                 if (hd == 1) {
11752                     /* Output or count in groups of four bits,
11753                      * that is, when the hexdigit is down to one. */
11754                     if (vend)
11755                         *v++ = ha;
11756                     else
11757                         v++;
11758                     /* Reset the hexvalue. */
11759                     ha = 0x0;
11760                     hd = 0x8;
11761                 }
11762                 else
11763                     hd >>= 1;
11764                 e *= (NV)0.5;
11765             }
11766 
11767             /* Flush possible pending hexvalue. */
11768             if (ha) {
11769                 if (vend)
11770                     *v++ = ha;
11771                 else
11772                     v++;
11773             }
11774         }
11775 #endif
11776     }
11777     /* Croak for various reasons: if the output pointer escaped the
11778      * output buffer, if the extraction index escaped the extraction
11779      * buffer, or if the ending output pointer didn't match the
11780      * previously computed value. */
11781     if (v <= vhex || v - vhex >= VHEX_SIZE ||
11782         /* For double-double the ixmin and ixmax stay at zero,
11783          * which is convenient since the HEXTRACTSIZE is tricky
11784          * for double-double. */
11785         ixmin < 0 || ixmax >= NVSIZE ||
11786         (vend && v != vend)) {
11787         /* diag_listed_as: Hexadecimal float: internal error (%s) */
11788         Perl_croak(aTHX_ "Hexadecimal float: internal error (overflow)");
11789     }
11790     return v;
11791 }
11792 
11793 
11794 /* S_format_hexfp(): helper function for Perl_sv_vcatpvfn_flags().
11795  *
11796  * Processes the %a/%A hexadecimal floating-point format, since the
11797  * built-in snprintf()s which are used for most of the f/p formats, don't
11798  * universally handle %a/%A.
11799  * Populates buf of length bufsize, and returns the length of the created
11800  * string.
11801  * The rest of the args have the same meaning as the local vars of the
11802  * same name within Perl_sv_vcatpvfn_flags().
11803  *
11804  * The caller's determination of IN_LC(LC_NUMERIC), passed as in_lc_numeric,
11805  * is used to ensure we do the right thing when we need to access the locale's
11806  * numeric radix.
11807  *
11808  * It requires the caller to make buf large enough.
11809  */
11810 
11811 static STRLEN
11812 S_format_hexfp(pTHX_ char * const buf, const STRLEN bufsize, const char c,
11813                     const NV nv, const vcatpvfn_long_double_t fv,
11814                     bool has_precis, STRLEN precis, STRLEN width,
11815                     bool alt, char plus, bool left, bool fill, bool in_lc_numeric)
11816 {
11817     /* Hexadecimal floating point. */
11818     char* p = buf;
11819     U8 vhex[VHEX_SIZE];
11820     U8* v = vhex; /* working pointer to vhex */
11821     U8* vend; /* pointer to one beyond last digit of vhex */
11822     U8* vfnz = NULL; /* first non-zero */
11823     U8* vlnz = NULL; /* last non-zero */
11824     U8* v0 = NULL; /* first output */
11825     const bool lower = (c == 'a');
11826     /* At output the values of vhex (up to vend) will
11827      * be mapped through the xdig to get the actual
11828      * human-readable xdigits. */
11829     const char* xdig = PL_hexdigit;
11830     STRLEN zerotail = 0; /* how many extra zeros to append */
11831     int exponent = 0; /* exponent of the floating point input */
11832     bool hexradix = FALSE; /* should we output the radix */
11833     bool subnormal = FALSE; /* IEEE 754 subnormal/denormal */
11834     bool negative = FALSE;
11835     STRLEN elen;
11836 
11837     /* XXX: NaN, Inf -- though they are printed as "NaN" and "Inf".
11838      *
11839      * For example with denormals, (assuming the vanilla
11840      * 64-bit double): the exponent is zero. 1xp-1074 is
11841      * the smallest denormal and the smallest double, it
11842      * could be output also as 0x0.0000000000001p-1022 to
11843      * match its internal structure. */
11844 
11845     vend = S_hextract(aTHX_ nv, &exponent, &subnormal, vhex, NULL);
11846     S_hextract(aTHX_ nv, &exponent, &subnormal, vhex, vend);
11847 
11848 #if NVSIZE > DOUBLESIZE
11849 #  ifdef HEXTRACT_HAS_IMPLICIT_BIT
11850     /* In this case there is an implicit bit,
11851      * and therefore the exponent is shifted by one. */
11852     exponent--;
11853 #  elif defined(NV_X86_80_BIT)
11854     if (subnormal) {
11855         /* The subnormals of the x86-80 have a base exponent of -16382,
11856          * (while the physical exponent bits are zero) but the frexp()
11857          * returned the scientific-style floating exponent.  We want
11858          * to map the last one as:
11859          * -16831..-16384 -> -16382 (the last normal is 0x1p-16382)
11860          * -16835..-16388 -> -16384
11861          * since we want to keep the first hexdigit
11862          * as one of the [8421]. */
11863         exponent = -4 * ( (exponent + 1) / -4) - 2;
11864     } else {
11865         exponent -= 4;
11866     }
11867     /* TBD: other non-implicit-bit platforms than the x86-80. */
11868 #  endif
11869 #endif
11870 
11871     negative = fv < 0 || Perl_signbit(nv);
11872     if (negative)
11873         *p++ = '-';
11874     else if (plus)
11875         *p++ = plus;
11876     *p++ = '0';
11877     if (lower) {
11878         *p++ = 'x';
11879     }
11880     else {
11881         *p++ = 'X';
11882         xdig += 16; /* Use uppercase hex. */
11883     }
11884 
11885     /* Find the first non-zero xdigit. */
11886     for (v = vhex; v < vend; v++) {
11887         if (*v) {
11888             vfnz = v;
11889             break;
11890         }
11891     }
11892 
11893     if (vfnz) {
11894         /* Find the last non-zero xdigit. */
11895         for (v = vend - 1; v >= vhex; v--) {
11896             if (*v) {
11897                 vlnz = v;
11898                 break;
11899             }
11900         }
11901 
11902 #if NVSIZE == DOUBLESIZE
11903         if (fv != 0.0)
11904             exponent--;
11905 #endif
11906 
11907         if (subnormal) {
11908 #ifndef NV_X86_80_BIT
11909           if (vfnz[0] > 1) {
11910             /* IEEE 754 subnormals (but not the x86 80-bit):
11911              * we want "normalize" the subnormal,
11912              * so we need to right shift the hex nybbles
11913              * so that the output of the subnormal starts
11914              * from the first true bit.  (Another, equally
11915              * valid, policy would be to dump the subnormal
11916              * nybbles as-is, to display the "physical" layout.) */
11917             int i, n;
11918             U8 *vshr;
11919             /* Find the ceil(log2(v[0])) of
11920              * the top non-zero nybble. */
11921             for (i = vfnz[0], n = 0; i > 1; i >>= 1, n++) { }
11922             assert(n < 4);
11923             assert(vlnz);
11924             vlnz[1] = 0;
11925             for (vshr = vlnz; vshr >= vfnz; vshr--) {
11926               vshr[1] |= (vshr[0] & (0xF >> (4 - n))) << (4 - n);
11927               vshr[0] >>= n;
11928             }
11929             if (vlnz[1]) {
11930               vlnz++;
11931             }
11932           }
11933 #endif
11934           v0 = vfnz;
11935         } else {
11936           v0 = vhex;
11937         }
11938 
11939         if (has_precis) {
11940             U8* ve = (subnormal ? vlnz + 1 : vend);
11941             SSize_t vn = ve - v0;
11942             assert(vn >= 1);
11943             if (precis < (Size_t)(vn - 1)) {
11944                 bool overflow = FALSE;
11945                 if (v0[precis + 1] < 0x8) {
11946                     /* Round down, nothing to do. */
11947                 } else if (v0[precis + 1] > 0x8) {
11948                     /* Round up. */
11949                     v0[precis]++;
11950                     overflow = v0[precis] > 0xF;
11951                     v0[precis] &= 0xF;
11952                 } else { /* v0[precis] == 0x8 */
11953                     /* Half-point: round towards the one
11954                      * with the even least-significant digit:
11955                      * 08 -> 0  88 -> 8
11956                      * 18 -> 2  98 -> a
11957                      * 28 -> 2  a8 -> a
11958                      * 38 -> 4  b8 -> c
11959                      * 48 -> 4  c8 -> c
11960                      * 58 -> 6  d8 -> e
11961                      * 68 -> 6  e8 -> e
11962                      * 78 -> 8  f8 -> 10 */
11963                     if ((v0[precis] & 0x1)) {
11964                         v0[precis]++;
11965                     }
11966                     overflow = v0[precis] > 0xF;
11967                     v0[precis] &= 0xF;
11968                 }
11969 
11970                 if (overflow) {
11971                     for (v = v0 + precis - 1; v >= v0; v--) {
11972                         (*v)++;
11973                         overflow = *v > 0xF;
11974                         (*v) &= 0xF;
11975                         if (!overflow) {
11976                             break;
11977                         }
11978                     }
11979                     if (v == v0 - 1 && overflow) {
11980                         /* If the overflow goes all the
11981                          * way to the front, we need to
11982                          * insert 0x1 in front, and adjust
11983                          * the exponent. */
11984                         Move(v0, v0 + 1, vn - 1, char);
11985                         *v0 = 0x1;
11986                         exponent += 4;
11987                     }
11988                 }
11989 
11990                 /* The new effective "last non zero". */
11991                 vlnz = v0 + precis;
11992             }
11993             else {
11994                 zerotail =
11995                   subnormal ? precis - vn + 1 :
11996                   precis - (vlnz - vhex);
11997             }
11998         }
11999 
12000         v = v0;
12001         *p++ = xdig[*v++];
12002 
12003         /* If there are non-zero xdigits, the radix
12004          * is output after the first one. */
12005         if (vfnz < vlnz) {
12006           hexradix = TRUE;
12007         }
12008     }
12009     else {
12010         *p++ = '0';
12011         exponent = 0;
12012         zerotail = has_precis ? precis : 0;
12013     }
12014 
12015     /* The radix is always output if precis, or if alt. */
12016     if ((has_precis && precis > 0) || alt) {
12017       hexradix = TRUE;
12018     }
12019 
12020     if (hexradix) {
12021 #ifndef USE_LOCALE_NUMERIC
12022         PERL_UNUSED_ARG(in_lc_numeric);
12023 
12024         *p++ = '.';
12025 #else
12026         if (in_lc_numeric) {
12027             STRLEN n;
12028             WITH_LC_NUMERIC_SET_TO_NEEDED_IN(TRUE, {
12029                 const char* r = SvPV(PL_numeric_radix_sv, n);
12030                 Copy(r, p, n, char);
12031             });
12032             p += n;
12033         }
12034         else {
12035             *p++ = '.';
12036         }
12037 #endif
12038     }
12039 
12040     if (vlnz) {
12041         while (v <= vlnz)
12042             *p++ = xdig[*v++];
12043     }
12044 
12045     if (zerotail > 0) {
12046       while (zerotail--) {
12047         *p++ = '0';
12048       }
12049     }
12050 
12051     elen = p - buf;
12052 
12053     /* sanity checks */
12054     if (elen >= bufsize || width >= bufsize)
12055         /* diag_listed_as: Hexadecimal float: internal error (%s) */
12056         Perl_croak(aTHX_ "Hexadecimal float: internal error (overflow)");
12057 
12058     elen += my_snprintf(p, bufsize - elen,
12059                         "%c%+d", lower ? 'p' : 'P',
12060                         exponent);
12061 
12062     if (elen < width) {
12063         STRLEN gap = (STRLEN)(width - elen);
12064         if (left) {
12065             /* Pad the back with spaces. */
12066             memset(buf + elen, ' ', gap);
12067         }
12068         else if (fill) {
12069             /* Insert the zeros after the "0x" and the
12070              * the potential sign, but before the digits,
12071              * otherwise we end up with "0000xH.HHH...",
12072              * when we want "0x000H.HHH..."  */
12073             STRLEN nzero = gap;
12074             char* zerox = buf + 2;
12075             STRLEN nmove = elen - 2;
12076             if (negative || plus) {
12077                 zerox++;
12078                 nmove--;
12079             }
12080             Move(zerox, zerox + nzero, nmove, char);
12081             memset(zerox, fill ? '0' : ' ', nzero);
12082         }
12083         else {
12084             /* Move it to the right. */
12085             Move(buf, buf + gap,
12086                  elen, char);
12087             /* Pad the front with spaces. */
12088             memset(buf, ' ', gap);
12089         }
12090         elen = width;
12091     }
12092     return elen;
12093 }
12094 
12095 /*
12096 =for apidoc sv_vcatpvfn
12097 =for apidoc_item sv_vcatpvfn_flags
12098 
12099 These process their arguments like C<L<vsprintf(3)>> and append the formatted output
12100 to an SV.  They use an array of SVs if the C-style variable argument list is
12101 missing (C<NULL>). Argument reordering (using format specifiers like C<%2$d> or
12102 C<%*2$d>) is supported only when using an array of SVs; using a C-style
12103 C<va_list> argument list with a format string that uses argument reordering
12104 will yield an exception.
12105 
12106 When running with taint checks enabled, they indicate via C<maybe_tainted> if
12107 results are untrustworthy (often due to the use of locales).
12108 
12109 They assume that C<pat> has the same utf8-ness as C<sv>.  It's the caller's
12110 responsibility to ensure that this is so.
12111 
12112 They differ in that C<sv_vcatpvfn_flags> has a C<flags> parameter in which you
12113 can set or clear the C<SV_GMAGIC> and/or S<SV_SMAGIC> flags, to specify which
12114 magic to handle or not handle; whereas plain C<sv_vcatpvfn> always specifies
12115 both 'get' and 'set' magic.
12116 
12117 They are usually used via one of the frontends L</C<sv_vcatpvf>> and
12118 L</C<sv_vcatpvf_mg>>.
12119 
12120 =cut
12121 */
12122 
12123 
12124 void
12125 Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
12126                        va_list *const args, SV **const svargs, const Size_t sv_count, bool *const maybe_tainted,
12127                        const U32 flags)
12128 {
12129     const char *fmtstart; /* character following the current '%' */
12130     const char *q;        /* current position within format */
12131     const char *patend;
12132     STRLEN origlen;
12133     Size_t svix = 0;
12134     static const char nullstr[] = "(null)";
12135     bool has_utf8 = DO_UTF8(sv);    /* has the result utf8? */
12136     const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
12137     /* Times 4: a decimal digit takes more than 3 binary digits.
12138      * NV_DIG: mantissa takes that many decimal digits.
12139      * Plus 32: Playing safe. */
12140     char ebuf[IV_DIG * 4 + NV_DIG + 32];
12141     bool no_redundant_warning = FALSE; /* did we use any explicit format parameter index? */
12142 #ifdef USE_LOCALE_NUMERIC
12143     bool have_in_lc_numeric = FALSE;
12144 #endif
12145     /* we never change this unless USE_LOCALE_NUMERIC */
12146     bool in_lc_numeric = FALSE;
12147     SV *tmp_sv = NULL;
12148 
12149     PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
12150     PERL_UNUSED_ARG(maybe_tainted);
12151 
12152     if (flags & SV_GMAGIC)
12153         SvGETMAGIC(sv);
12154 
12155     /* no matter what, this is a string now */
12156     (void)SvPV_force_nomg(sv, origlen);
12157 
12158     /* the code that scans for flags etc following a % relies on
12159      * a '\0' being present to avoid falling off the end. Ideally that
12160      * should be fixed */
12161     assert(pat[patlen] == '\0');
12162 
12163 
12164     /* Special-case "", "%s", "%-p" (SVf - see below) and "%.0f".
12165      * In each case, if there isn't the correct number of args, instead
12166      * fall through to the main code to handle the issuing of any
12167      * warnings etc.
12168      */
12169 
12170     if (patlen == 0 && (args || sv_count == 0))
12171         return;
12172 
12173     if (patlen <= 4 && pat[0] == '%' && (args || sv_count == 1)) {
12174 
12175         /* "%s" */
12176         if (patlen == 2 && pat[1] == 's') {
12177             if (args) {
12178                 const char * const s = va_arg(*args, char*);
12179                 sv_catpv_nomg(sv, s ? s : nullstr);
12180             }
12181             else {
12182                 /* we want get magic on the source but not the target.
12183                  * sv_catsv can't do that, though */
12184                 SvGETMAGIC(*svargs);
12185                 sv_catsv_nomg(sv, *svargs);
12186             }
12187             return;
12188         }
12189 
12190         /* "%-p" */
12191         if (args) {
12192             if (patlen == 3  && pat[1] == '-' && pat[2] == 'p') {
12193                 SV *asv = MUTABLE_SV(va_arg(*args, void*));
12194                 sv_catsv_nomg(sv, asv);
12195                 return;
12196             }
12197         }
12198 #if !defined(USE_LONG_DOUBLE) && !defined(USE_QUADMATH)
12199         /* special-case "%.0f" */
12200         else if (   patlen == 4
12201                  && pat[1] == '.' && pat[2] == '0' && pat[3] == 'f')
12202         {
12203             const NV nv = SvNV(*svargs);
12204             if (LIKELY(!Perl_isinfnan(nv))) {
12205                 STRLEN l;
12206                 char *p;
12207 
12208                 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
12209                     sv_catpvn_nomg(sv, p, l);
12210                     return;
12211                 }
12212             }
12213         }
12214 #endif /* !USE_LONG_DOUBLE */
12215     }
12216 
12217 
12218     patend = (char*)pat + patlen;
12219     for (fmtstart = pat; fmtstart < patend; fmtstart = q) {
12220         char intsize     = 0;         /* size qualifier in "%hi..." etc */
12221         bool alt         = FALSE;     /* has      "%#..."    */
12222         bool left        = FALSE;     /* has      "%-..."    */
12223         bool fill        = FALSE;     /* has      "%0..."    */
12224         char plus        = 0;         /* has      "%+..."    */
12225         STRLEN width     = 0;         /* value of "%NNN..."  */
12226         bool has_precis  = FALSE;     /* has      "%.NNN..." */
12227         STRLEN precis    = 0;         /* value of "%.NNN..." */
12228         int base         = 0;         /* base to print in, e.g. 8 for %o */
12229         UV uv            = 0;         /* the value to print of int-ish args */
12230 
12231         bool vectorize   = FALSE;     /* has      "%v..."    */
12232         bool vec_utf8    = FALSE;     /* SvUTF8(vec arg)     */
12233         const U8 *vecstr = NULL;      /* SvPVX(vec arg)      */
12234         STRLEN veclen    = 0;         /* SvCUR(vec arg)      */
12235         const char *dotstr = NULL;    /* separator string for %v */
12236         STRLEN dotstrlen;             /* length of separator string for %v */
12237 
12238         Size_t efix      = 0;         /* explicit format parameter index */
12239         const Size_t osvix  = svix;   /* original index in case of bad fmt */
12240 
12241         SV *argsv        = NULL;
12242         bool is_utf8     = FALSE;     /* is this item utf8?   */
12243         bool arg_missing = FALSE;     /* give "Missing argument" warning */
12244         char esignbuf[4];             /* holds sign prefix, e.g. "-0x" */
12245         STRLEN esignlen  = 0;         /* length of e.g. "-0x" */
12246         STRLEN zeros     = 0;         /* how many '0' to prepend */
12247 
12248         const char *eptr = NULL;      /* the address of the element string */
12249         STRLEN elen      = 0;         /* the length  of the element string */
12250 
12251         char c;                       /* the actual format ('d', s' etc) */
12252 
12253         bool escape_it   = FALSE;     /* if this is a string should we quote and escape it? */
12254 
12255 
12256         /* echo everything up to the next format specification */
12257         for (q = fmtstart; q < patend && *q != '%'; ++q)
12258             {};
12259 
12260         if (q > fmtstart) {
12261             if (has_utf8 && !pat_utf8) {
12262                 /* upgrade and copy the bytes of fmtstart..q-1 to utf8 on
12263                  * the fly */
12264                 const char *p;
12265                 char *dst;
12266                 STRLEN need = SvCUR(sv) + (q - fmtstart) + 1;
12267 
12268                 for (p = fmtstart; p < q; p++)
12269                     if (!NATIVE_BYTE_IS_INVARIANT(*p))
12270                         need++;
12271                 SvGROW(sv, need);
12272 
12273                 dst = SvEND(sv);
12274                 for (p = fmtstart; p < q; p++)
12275                     append_utf8_from_native_byte((U8)*p, (U8**)&dst);
12276                 *dst = '\0';
12277                 SvCUR_set(sv, need - 1);
12278             }
12279             else
12280                 S_sv_catpvn_simple(aTHX_ sv, fmtstart, q - fmtstart);
12281         }
12282         if (q++ >= patend)
12283             break;
12284 
12285         fmtstart = q; /* fmtstart is char following the '%' */
12286 
12287 /*
12288     We allow format specification elements in this order:
12289         \d+\$              explicit format parameter index
12290         [-+ 0#]+           flags
12291         v|\*(\d+\$)?v      vector with optional (optionally specified) arg
12292         0		   flag (as above): repeated to allow "v02"
12293         \d+|\*(\d+\$)?     width using optional (optionally specified) arg
12294         \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
12295         [hlqLV]            size
12296     [%bcdefginopsuxDFOUX] format (mandatory)
12297 */
12298 
12299         if (inRANGE(*q, '1', '9')) {
12300             width = expect_number(&q);
12301             if (*q == '$') {
12302                 if (args)
12303                     Perl_croak_nocontext(
12304                         "Cannot yet reorder sv_vcatpvfn() arguments from va_list");
12305                 ++q;
12306                 efix = (Size_t)width;
12307                 width = 0;
12308                 no_redundant_warning = TRUE;
12309             } else {
12310                 goto gotwidth;
12311             }
12312         }
12313 
12314         /* FLAGS */
12315 
12316         while (*q) {
12317             switch (*q) {
12318             case ' ':
12319             case '+':
12320                 if (plus == '+' && *q == ' ') /* '+' over ' ' */
12321                     q++;
12322                 else
12323                     plus = *q++;
12324                 continue;
12325 
12326             case '-':
12327                 left = TRUE;
12328                 q++;
12329                 continue;
12330 
12331             case '0':
12332                 fill = TRUE;
12333                 q++;
12334                 continue;
12335 
12336             case '#':
12337                 alt = TRUE;
12338                 q++;
12339                 continue;
12340 
12341             default:
12342                 break;
12343             }
12344             break;
12345         }
12346 
12347       /* at this point we can expect one of:
12348        *
12349        *  123  an explicit width
12350        *  *    width taken from next arg
12351        *  *12$ width taken from 12th arg
12352        *       or no width
12353        *
12354        * But any width specification may be preceded by a v, in one of its
12355        * forms:
12356        *        v
12357        *        *v
12358        *        *12$v
12359        * So an asterisk may be either a width specifier or a vector
12360        * separator arg specifier, and we don't know which initially
12361        */
12362 
12363       tryasterisk:
12364         if (*q == '*') {
12365             STRLEN ix; /* explicit width/vector separator index */
12366             q++;
12367             if (inRANGE(*q, '1', '9')) {
12368                 ix = expect_number(&q);
12369                 if (*q++ == '$') {
12370                     if (args)
12371                         Perl_croak_nocontext(
12372                             "Cannot yet reorder sv_vcatpvfn() arguments from va_list");
12373                     no_redundant_warning = TRUE;
12374                 } else
12375                     goto unknown;
12376             }
12377             else
12378                 ix = 0;
12379 
12380             if (*q == 'v') {
12381                 SV *vecsv;
12382                 /* The asterisk was for  *v, *NNN$v: vectorizing, but not
12383                  * with the default "." */
12384                 q++;
12385                 if (vectorize)
12386                     goto unknown;
12387                 if (args)
12388                     vecsv = va_arg(*args, SV*);
12389                 else {
12390                     ix = ix ? ix - 1 : svix++;
12391                     vecsv = ix < sv_count ? svargs[ix]
12392                                        : (arg_missing = TRUE, &PL_sv_no);
12393                 }
12394                 dotstr = SvPV_const(vecsv, dotstrlen);
12395                 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
12396                    bad with tied or overloaded values that return UTF8.  */
12397                 if (DO_UTF8(vecsv))
12398                     is_utf8 = TRUE;
12399                 else if (has_utf8) {
12400                     vecsv = sv_mortalcopy(vecsv);
12401                     sv_utf8_upgrade(vecsv);
12402                     dotstr = SvPV_const(vecsv, dotstrlen);
12403                     is_utf8 = TRUE;
12404                 }
12405                 vectorize = TRUE;
12406                 goto tryasterisk;
12407             }
12408 
12409             /* the asterisk specified a width */
12410             {
12411                 int i = 0;
12412                 SV *width_sv = NULL;
12413                 if (args)
12414                     i = va_arg(*args, int);
12415                 else {
12416                     ix = ix ? ix - 1 : svix++;
12417                     width_sv = (ix < sv_count) ? svargs[ix]
12418                                       : (arg_missing = TRUE, (SV*)NULL);
12419                 }
12420                 width = S_sprintf_arg_num_val(aTHX_ args, i, width_sv, &left);
12421             }
12422         }
12423         else if (*q == 'v') {
12424             q++;
12425             if (vectorize)
12426                 goto unknown;
12427             vectorize = TRUE;
12428             dotstr = ".";
12429             dotstrlen = 1;
12430             goto tryasterisk;
12431 
12432         }
12433         else {
12434         /* explicit width? */
12435             if(*q == '0') {
12436                 fill = TRUE;
12437                 q++;
12438             }
12439             if (inRANGE(*q, '1', '9'))
12440                 width = expect_number(&q);
12441         }
12442 
12443       gotwidth:
12444 
12445         /* PRECISION */
12446 
12447         if (*q == '.') {
12448             q++;
12449             if (*q == '*') {
12450                 STRLEN ix; /* explicit precision index */
12451                 q++;
12452                 if (inRANGE(*q, '1', '9')) {
12453                     ix = expect_number(&q);
12454                     if (*q++ == '$') {
12455                         if (args)
12456                             Perl_croak_nocontext(
12457                                 "Cannot yet reorder sv_vcatpvfn() arguments from va_list");
12458                         no_redundant_warning = TRUE;
12459                     } else
12460                         goto unknown;
12461                 }
12462                 else
12463                     ix = 0;
12464 
12465                 {
12466                     int i = 0;
12467                     SV *width_sv = NULL;
12468                     bool neg = FALSE;
12469 
12470                     if (args)
12471                         i = va_arg(*args, int);
12472                     else {
12473                         ix = ix ? ix - 1 : svix++;
12474                         width_sv = (ix < sv_count) ? svargs[ix]
12475                                           : (arg_missing = TRUE, (SV*)NULL);
12476                     }
12477                     precis = S_sprintf_arg_num_val(aTHX_ args, i, width_sv, &neg);
12478                     has_precis = !neg;
12479                     /* ignore negative precision */
12480                     if (!has_precis)
12481                         precis = 0;
12482                 }
12483             }
12484             else {
12485                 /* although it doesn't seem documented, this code has long
12486                  * behaved so that:
12487                  *   no digits following the '.' is treated like '.0'
12488                  *   the number may be preceded by any number of zeroes,
12489                  *      e.g. "%.0001f", which is the same as "%.1f"
12490                  * so I've kept that behaviour. DAPM May 2017
12491                  */
12492                 while (*q == '0')
12493                     q++;
12494                 precis = inRANGE(*q, '1', '9') ? expect_number(&q) : 0;
12495                 has_precis = TRUE;
12496             }
12497         }
12498 
12499         /* SIZE */
12500 
12501         switch (*q) {
12502 #ifdef WIN32
12503         case 'I':			/* Ix, I32x, and I64x */
12504 #  ifdef USE_64_BIT_INT
12505             if (q[1] == '6' && q[2] == '4') {
12506                 q += 3;
12507                 intsize = 'q';
12508                 break;
12509             }
12510 #  endif
12511             if (q[1] == '3' && q[2] == '2') {
12512                 q += 3;
12513                 break;
12514             }
12515 #  ifdef USE_64_BIT_INT
12516             intsize = 'q';
12517 #  endif
12518             q++;
12519             break;
12520 #endif
12521 #if (IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)) || \
12522     (IVSIZE == 4 && !defined(HAS_LONG_DOUBLE))
12523         case 'L':			/* Ld */
12524             /* FALLTHROUGH */
12525 #  if IVSIZE >= 8
12526         case 'q':			/* qd */
12527 #  endif
12528             intsize = 'q';
12529             q++;
12530             break;
12531 #endif
12532         case 'l':
12533             ++q;
12534 #if (IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)) || \
12535     (IVSIZE == 4 && !defined(HAS_LONG_DOUBLE))
12536             if (*q == 'l') {	/* lld, llf */
12537                 intsize = 'q';
12538                 ++q;
12539             }
12540             else
12541 #endif
12542                 intsize = 'l';
12543             break;
12544         case 'h':
12545             if (*++q == 'h') {	/* hhd, hhu */
12546                 intsize = 'c';
12547                 ++q;
12548             }
12549             else
12550                 intsize = 'h';
12551             break;
12552 #ifdef USE_QUADMATH
12553         case 'Q':
12554 #endif
12555         case 'V':
12556         case 'z':
12557         case 't':
12558         case 'j':
12559             intsize = *q++;
12560             break;
12561         }
12562 
12563         /* CONVERSION */
12564 
12565         c = *q++; /* c now holds the conversion type */
12566 
12567         /* '%' doesn't have an arg, so skip arg processing */
12568         if (c == '%') {
12569             eptr = q - 1;
12570             elen = 1;
12571             if (vectorize)
12572                 goto unknown;
12573             goto string;
12574         }
12575 
12576         if (vectorize && !memCHRs("BbDdiOouUXx", c))
12577             goto unknown;
12578 
12579         /* get next arg (individual branches do their own va_arg()
12580          * handling for the args case) */
12581 
12582         if (!args) {
12583             efix = efix ? efix - 1 : svix++;
12584             argsv = efix < sv_count ? svargs[efix]
12585                                  : (arg_missing = TRUE, &PL_sv_no);
12586         }
12587 
12588 
12589         switch (c) {
12590 
12591             /* STRINGS */
12592 
12593         case 's':
12594             if (args) {
12595                 eptr = va_arg(*args, char*);
12596                 if (eptr)
12597                     if (has_precis)
12598                         elen = my_strnlen(eptr, precis);
12599                     else
12600                         elen = strlen(eptr);
12601                 else {
12602                     eptr = (char *)nullstr;
12603                     elen = sizeof nullstr - 1;
12604                 }
12605             }
12606             else {
12607                 eptr = SvPV_const(argsv, elen);
12608                 if (DO_UTF8(argsv)) {
12609                     STRLEN old_precis = precis;
12610                     if (has_precis && precis < elen) {
12611                         STRLEN ulen = sv_or_pv_len_utf8(argsv, eptr, elen);
12612                         STRLEN p = precis > ulen ? ulen : precis;
12613                         precis = sv_or_pv_pos_u2b(argsv, eptr, p, 0);
12614                                                         /* sticks at end */
12615                     }
12616                     if (width) { /* fudge width (can't fudge elen) */
12617                         if (has_precis && precis < elen)
12618                             width += precis - old_precis;
12619                         else
12620                             width +=
12621                                 elen - sv_or_pv_len_utf8(argsv,eptr,elen);
12622                     }
12623                     is_utf8 = TRUE;
12624                 }
12625             }
12626 
12627         string:
12628             if (escape_it) {
12629                 U32 flags = PERL_PV_PRETTY_QUOTEDPREFIX;
12630                 if (is_utf8)
12631                     flags |= PERL_PV_ESCAPE_UNI;
12632 
12633                 if (!tmp_sv) {
12634                     /* "blah"... where blah might be made up
12635                      * of characters like \x{1234} */
12636                     tmp_sv = newSV(1 + (PERL_QUOTEDPREFIX_LEN * 8) + 1 + 3);
12637                     sv_2mortal(tmp_sv);
12638                 }
12639                 pv_pretty(tmp_sv, eptr, elen, PERL_QUOTEDPREFIX_LEN,
12640                             NULL, NULL, flags);
12641                 eptr = SvPV_const(tmp_sv, elen);
12642             }
12643             if (has_precis && precis < elen)
12644                 elen = precis;
12645             break;
12646 
12647             /* INTEGERS */
12648 
12649         case 'p':
12650 
12651             /* BEGIN NOTE
12652              *
12653              * We want to extend the C level sprintf format API with
12654              * custom formats for specific types (eg SV*) and behavior.
12655              * However some C compilers are "sprintf aware" and will
12656              * throw compile time exceptions when an illegal sprintf is
12657              * encountered, so we can't just add new format letters.
12658              *
12659              * However it turns out the length argument to the %p format
12660              * is more or less useless (the size of a pointer does not
12661              * change over time) and is not really used in the C level
12662              * code. Accordingly we can map our special behavior to
12663              * specific "length" options to the %p format. We hide these
12664              * mappings behind defines anyway, so nobody needs to know
12665              * that HEKf is actually %2p. This keeps the C compiler
12666              * happy while allowing us to add new formats.
12667              *
12668              * Note the existing logic for which number is used for what
12669              * is torturous. All negative values are used for SVf, and
12670              * non-negative values have arbitrary meanings with no
12671              * structure to them. This may change in the future.
12672              *
12673              * NEVER use the raw %p values directly. Always use the define
12674              * as the underlying mapping may change in the future.
12675              *
12676              * END NOTE
12677              *
12678              * %p extensions:
12679              *
12680              * "%...p" is normally treated like "%...x", except that the
12681              * number to print is the SV's address (or a pointer address
12682              * for C-ish sprintf).
12683              *
12684              * However, the C-ish sprintf variant allows a few special
12685              * extensions. These are currently:
12686              *
12687              * %-p       (SVf)  Like %s, but gets the string from an SV*
12688              *                  arg rather than a char* arg. Use C<SVfARG()>
12689              *                  to set up the argument properly.
12690              *                  (This was previously %_).
12691              *
12692              * %-<num>p         Ditto but like %.<num>s (i.e. num is max
12693              *                  width), there is no escaped and quoted version
12694              *                  of this.
12695              *
12696              * %1p       (PVf_QUOTEDPREFIX). Like raw %s, but it is escaped
12697              *                  and quoted.
12698              *
12699              * %5p       (SVf_QUOTEDPREFIX) Like SVf, but length restricted,
12700              *                  escaped and quoted with pv_pretty. Intended
12701              *                  for error messages.
12702              *
12703              * %2p       (HEKf) Like %s, but using the key string in a HEK
12704              * %7p       (HEKf_QUOTEDPREFIX) ... but escaped and quoted.
12705              *
12706              * %3p       (HEKf256) Ditto but like %.256s
12707              * %8p       (HEKf256_QUOTEDPREFIX) ... but escaped and quoted
12708              *
12709              * %d%lu%4p  (UTF8f) A utf8 string. Consumes 3 args:
12710              *                       (cBOOL(utf8), len, string_buf).
12711              *                   It's handled by the "case 'd'" branch
12712              *                   rather than here.
12713              * %d%lu%9p  (UTF8f_QUOTEDPREFIX) .. but escaped and quoted.
12714              *
12715              * %6p       (HvNAMEf) Like %s, but using the HvNAME() and HvNAMELEN()
12716              * %10p      (HvNAMEf_QUOTEDPREFIX) ... but escaped and quoted
12717              *
12718              * %<num>p   where num is > 9: reserved for future
12719              *           extensions. Warns, but then is treated as a
12720              *           general %p (print hex address) format.
12721              *
12722              * NOTE: If you add a new magic %p value you will
12723              * need to update F<t/porting/diag.t> to be aware of it
12724              * on top of adding the various defines and etc. Do not
12725              * forget to add it to F<pod/perlguts.pod> as well.
12726              */
12727 
12728             if (   args
12729                 && !intsize
12730                 && !fill
12731                 && !plus
12732                 && !has_precis
12733                     /* not %*p or %*1$p - any width was explicit */
12734                 && q[-2] != '*'
12735                 && q[-2] != '$'
12736             ) {
12737                 if (left || width == 5) {                /* %-p (SVf), %-NNNp, %5p */
12738                     if (left && width) {
12739                         precis = width;
12740                         has_precis = TRUE;
12741                     } else if (width == 5) {
12742                         escape_it = TRUE;
12743                     }
12744                     argsv = MUTABLE_SV(va_arg(*args, void*));
12745                     eptr = SvPV_const(argsv, elen);
12746                     if (DO_UTF8(argsv))
12747                         is_utf8 = TRUE;
12748                     width = 0;
12749                     goto string;
12750                 }
12751                 else if (width == 2 || width == 3 ||
12752                          width == 7 || width == 8)
12753                 {        /* HEKf, HEKf256, HEKf_QUOTEDPREFIX, HEKf256_QUOTEDPREFIX */
12754                     HEK * const hek = va_arg(*args, HEK *);
12755                     eptr = HEK_KEY(hek);
12756                     elen = HEK_LEN(hek);
12757                     if (HEK_UTF8(hek))
12758                         is_utf8 = TRUE;
12759                     if (width == 3) {
12760                         precis = 256;
12761                         has_precis = TRUE;
12762                     }
12763                     if (width > 5)
12764                         escape_it = TRUE;
12765                     width = 0;
12766                     goto string;
12767                 }
12768                 else if (width == 1) {
12769                     eptr = va_arg(*args,char *);
12770                     elen = strlen(eptr);
12771                     escape_it = TRUE;
12772                     width = 0;
12773                     goto string;
12774                 }
12775                 else if (width == 6 || width == 10) {
12776                     HV *hv = va_arg(*args, HV *);
12777                     eptr = HvNAME(hv);
12778                     elen = HvNAMELEN(hv);
12779                     if (HvNAMEUTF8(hv))
12780                         is_utf8 = TRUE;
12781                     if (width == 10)
12782                         escape_it = TRUE;
12783                     width = 0;
12784                     goto string;
12785                 }
12786                 else if (width) {
12787                     /* note width=4 or width=9 is handled under %d */
12788                     Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
12789                          "internal %%<num>p might conflict with future printf extensions");
12790                 }
12791             }
12792 
12793             /* treat as normal %...p */
12794 
12795             uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
12796             base = 16;
12797             c = 'x';    /* in case the format string contains '#' */
12798             goto do_integer;
12799 
12800         case 'c':
12801             /* Ignore any size specifiers, since they're not documented as
12802              * being allowed for %c (ideally we should warn on e.g. '%hc').
12803              * Setting a default intsize, along with a positive
12804              * (which signals unsigned) base, causes, for C-ish use, the
12805              * va_arg to be interpreted as an unsigned int, when it's
12806              * actually signed, which will convert -ve values to high +ve
12807              * values. Note that unlike the libc %c, values > 255 will
12808              * convert to high unicode points rather than being truncated
12809              * to 8 bits. For perlish use, it will do SvUV(argsv), which
12810              * will again convert -ve args to high -ve values.
12811              */
12812             intsize = 0;
12813             base = 1; /* special value that indicates we're doing a 'c' */
12814             goto get_int_arg_val;
12815 
12816         case 'D':
12817 #ifdef IV_IS_QUAD
12818             intsize = 'q';
12819 #else
12820             intsize = 'l';
12821 #endif
12822             base = -10;
12823             goto get_int_arg_val;
12824 
12825         case 'd':
12826             /* probably just a plain %d, but it might be the start of the
12827              * special UTF8f format, which usually looks something like
12828              * "%d%lu%4p" (the lu may vary by platform) or
12829              * "%d%lu%9p" for an escaped version.
12830              */
12831             assert((UTF8f)[0] == 'd');
12832             assert((UTF8f)[1] == '%');
12833 
12834              if (   args              /* UTF8f only valid for C-ish sprintf */
12835                  && q == fmtstart + 1 /* plain %d, not %....d */
12836                  && patend >= fmtstart + sizeof(UTF8f) - 1 /* long enough */
12837                  && *q == '%'
12838                  && strnEQ(q + 1, (UTF8f) + 2, sizeof(UTF8f) - 5)
12839                  && q[sizeof(UTF8f)-3] == 'p'
12840                  && (q[sizeof(UTF8f)-4] == '4' ||
12841                      q[sizeof(UTF8f)-4] == '9'))
12842             {
12843                 /* The argument has already gone through cBOOL, so the cast
12844                    is safe. */
12845                 if (q[sizeof(UTF8f)-4] == '9')
12846                     escape_it = TRUE;
12847                 is_utf8 = (bool)va_arg(*args, int);
12848                 elen = va_arg(*args, UV);
12849                 /* if utf8 length is larger than 0x7ffff..., then it might
12850                  * have been a signed value that wrapped */
12851                 if (elen  > ((~(STRLEN)0) >> 1)) {
12852                     assert(0); /* in DEBUGGING build we want to crash */
12853                     elen = 0; /* otherwise we want to treat this as an empty string */
12854                 }
12855                 eptr = va_arg(*args, char *);
12856                 q += sizeof(UTF8f) - 2;
12857                 goto string;
12858             }
12859 
12860             /* FALLTHROUGH */
12861         case 'i':
12862             base = -10;
12863             goto get_int_arg_val;
12864 
12865         case 'U':
12866 #ifdef IV_IS_QUAD
12867             intsize = 'q';
12868 #else
12869             intsize = 'l';
12870 #endif
12871             /* FALLTHROUGH */
12872         case 'u':
12873             base = 10;
12874             goto get_int_arg_val;
12875 
12876         case 'B':
12877         case 'b':
12878             base = 2;
12879             goto get_int_arg_val;
12880 
12881         case 'O':
12882 #ifdef IV_IS_QUAD
12883             intsize = 'q';
12884 #else
12885             intsize = 'l';
12886 #endif
12887             /* FALLTHROUGH */
12888         case 'o':
12889             base = 8;
12890             goto get_int_arg_val;
12891 
12892         case 'X':
12893         case 'x':
12894             base = 16;
12895 
12896           get_int_arg_val:
12897 
12898             if (vectorize) {
12899                 STRLEN ulen;
12900                 SV *vecsv;
12901 
12902                 if (base < 0) {
12903                     base = -base;
12904                     if (plus)
12905                          esignbuf[esignlen++] = plus;
12906                 }
12907 
12908                 /* initialise the vector string to iterate over */
12909 
12910                 vecsv = args ? va_arg(*args, SV*) : argsv;
12911 
12912                 /* if this is a version object, we need to convert
12913                  * back into v-string notation and then let the
12914                  * vectorize happen normally
12915                  */
12916                 if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) {
12917                     if ( hv_existss(MUTABLE_HV(SvRV(vecsv)), "alpha") ) {
12918                         Perl_ck_warner_d(aTHX_ packWARN(WARN_PRINTF),
12919                         "vector argument not supported with alpha versions");
12920                         vecsv = &PL_sv_no;
12921                     }
12922                     else {
12923                         vecstr = (U8*)SvPV_const(vecsv,veclen);
12924                         vecsv = sv_newmortal();
12925                         scan_vstring((char *)vecstr, (char *)vecstr + veclen,
12926                                      vecsv);
12927                     }
12928                 }
12929                 vecstr = (U8*)SvPV_const(vecsv, veclen);
12930                 vec_utf8 = DO_UTF8(vecsv);
12931 
12932               /* This is the re-entry point for when we're iterating
12933                * over the individual characters of a vector arg */
12934               vector:
12935                 if (!veclen)
12936                     goto done_valid_conversion;
12937                 if (vec_utf8)
12938                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
12939                                         UTF8_ALLOW_ANYUV);
12940                 else {
12941                     uv = *vecstr;
12942                     ulen = 1;
12943                 }
12944                 vecstr += ulen;
12945                 veclen -= ulen;
12946             }
12947             else {
12948                 /* test arg for inf/nan. This can trigger an unwanted
12949                  * 'str' overload, so manually force 'num' overload first
12950                  * if necessary */
12951                 if (argsv) {
12952                     SvGETMAGIC(argsv);
12953                     if (UNLIKELY(SvAMAGIC(argsv)))
12954                         argsv = sv_2num(argsv);
12955                     if (UNLIKELY(isinfnansv(argsv)))
12956                         goto handle_infnan_argsv;
12957                 }
12958 
12959                 if (base < 0) {
12960                     /* signed int type */
12961                     IV iv;
12962                     base = -base;
12963                     if (args) {
12964                         switch (intsize) {
12965                         case 'c':  iv = (char)va_arg(*args, int);  break;
12966                         case 'h':  iv = (short)va_arg(*args, int); break;
12967                         case 'l':  iv = va_arg(*args, long);       break;
12968                         case 'V':  iv = va_arg(*args, IV);         break;
12969                         case 'z':  iv = va_arg(*args, SSize_t);    break;
12970 #ifdef HAS_PTRDIFF_T
12971                         case 't':  iv = va_arg(*args, ptrdiff_t);  break;
12972 #endif
12973                         default:   iv = va_arg(*args, int);        break;
12974                         case 'j':  iv = (IV) va_arg(*args, PERL_INTMAX_T); break;
12975                         case 'q':
12976 #if IVSIZE >= 8
12977                                    iv = va_arg(*args, Quad_t);     break;
12978 #else
12979                                    goto unknown;
12980 #endif
12981                         }
12982                     }
12983                     else {
12984                         /* assign to tiv then cast to iv to work around
12985                          * 2003 GCC cast bug (gnu.org bugzilla #13488) */
12986                         IV tiv = SvIV_nomg(argsv);
12987                         switch (intsize) {
12988                         case 'c':  iv = (char)tiv;   break;
12989                         case 'h':  iv = (short)tiv;  break;
12990                         case 'l':  iv = (long)tiv;   break;
12991                         case 'V':
12992                         default:   iv = tiv;         break;
12993                         case 'q':
12994 #if IVSIZE >= 8
12995                                    iv = (Quad_t)tiv; break;
12996 #else
12997                                    goto unknown;
12998 #endif
12999                         }
13000                     }
13001 
13002                     /* now convert iv to uv */
13003                     if (iv >= 0) {
13004                         uv = iv;
13005                         if (plus)
13006                             esignbuf[esignlen++] = plus;
13007                     }
13008                     else {
13009                         /* Using 0- here to silence bogus warning from MS VC */
13010                         uv = (UV) (0 - (UV) iv);
13011                         esignbuf[esignlen++] = '-';
13012                     }
13013                 }
13014                 else {
13015                     /* unsigned int type */
13016                     if (args) {
13017                         switch (intsize) {
13018                         case 'c': uv = (unsigned char)va_arg(*args, unsigned);
13019                                   break;
13020                         case 'h': uv = (unsigned short)va_arg(*args, unsigned);
13021                                   break;
13022                         case 'l': uv = va_arg(*args, unsigned long); break;
13023                         case 'V': uv = va_arg(*args, UV);            break;
13024                         case 'z': uv = va_arg(*args, Size_t);        break;
13025 #ifdef HAS_PTRDIFF_T
13026                                   /* will sign extend, but there is no
13027                                    * uptrdiff_t, so oh well */
13028                         case 't': uv = va_arg(*args, ptrdiff_t);     break;
13029 #endif
13030                         case 'j': uv = (UV) va_arg(*args, PERL_UINTMAX_T); break;
13031                         default:  uv = va_arg(*args, unsigned);      break;
13032                         case 'q':
13033 #if IVSIZE >= 8
13034                                   uv = va_arg(*args, Uquad_t);       break;
13035 #else
13036                                   goto unknown;
13037 #endif
13038                         }
13039                     }
13040                     else {
13041                         /* assign to tiv then cast to iv to work around
13042                          * 2003 GCC cast bug (gnu.org bugzilla #13488) */
13043                         UV tuv = SvUV_nomg(argsv);
13044                         switch (intsize) {
13045                         case 'c': uv = (unsigned char)tuv;  break;
13046                         case 'h': uv = (unsigned short)tuv; break;
13047                         case 'l': uv = (unsigned long)tuv;  break;
13048                         case 'V':
13049                         default:  uv = tuv;                 break;
13050                         case 'q':
13051 #if IVSIZE >= 8
13052                                   uv = (Uquad_t)tuv;        break;
13053 #else
13054                                   goto unknown;
13055 #endif
13056                         }
13057                     }
13058                 }
13059             }
13060 
13061         do_integer:
13062             {
13063                 char *ptr = ebuf + sizeof ebuf;
13064                 unsigned dig;
13065                 zeros = 0;
13066 
13067                 switch (base) {
13068                 case 16:
13069                     {
13070                     const char * const p =
13071                             (c == 'X') ? PL_hexdigit + 16 : PL_hexdigit;
13072 
13073                         do {
13074                             dig = uv & 15;
13075                             *--ptr = p[dig];
13076                         } while (uv >>= 4);
13077                         if (alt && *ptr != '0') {
13078                             esignbuf[esignlen++] = '0';
13079                             esignbuf[esignlen++] = c;  /* 'x' or 'X' */
13080                         }
13081                         break;
13082                     }
13083                 case 8:
13084                     do {
13085                         dig = uv & 7;
13086                         *--ptr = '0' + dig;
13087                     } while (uv >>= 3);
13088                     if (alt && *ptr != '0')
13089                         *--ptr = '0';
13090                     break;
13091                 case 2:
13092                     do {
13093                         dig = uv & 1;
13094                         *--ptr = '0' + dig;
13095                     } while (uv >>= 1);
13096                     if (alt && *ptr != '0') {
13097                         esignbuf[esignlen++] = '0';
13098                         esignbuf[esignlen++] = c; /* 'b' or 'B' */
13099                     }
13100                     break;
13101 
13102                 case 1:
13103                     /* special-case: base 1 indicates a 'c' format:
13104                      * we use the common code for extracting a uv,
13105                      * but handle that value differently here than
13106                      * all the other int types */
13107                     if ((uv > 255 ||
13108                          (!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv)))
13109                         && !IN_BYTES)
13110                     {
13111                         STATIC_ASSERT_STMT(sizeof(ebuf) >= UTF8_MAXBYTES + 1);
13112                         eptr = ebuf;
13113                         elen = uvchr_to_utf8((U8*)eptr, uv) - (U8*)ebuf;
13114                         is_utf8 = TRUE;
13115                     }
13116                     else {
13117                         eptr = ebuf;
13118                         ebuf[0] = (char)uv;
13119                         elen = 1;
13120                     }
13121                     goto string;
13122 
13123                 default:		/* it had better be ten or less */
13124                     do {
13125                         dig = uv % base;
13126                         *--ptr = '0' + dig;
13127                     } while (uv /= base);
13128                     break;
13129                 }
13130                 elen = (ebuf + sizeof ebuf) - ptr;
13131                 eptr = ptr;
13132                 if (has_precis) {
13133                     if (precis > elen)
13134                         zeros = precis - elen;
13135                     else if (precis == 0 && elen == 1 && *eptr == '0'
13136                              && !(base == 8 && alt)) /* "%#.0o" prints "0" */
13137                         elen = 0;
13138 
13139                     /* a precision nullifies the 0 flag. */
13140                     fill = FALSE;
13141                 }
13142             }
13143             break;
13144 
13145             /* FLOATING POINT */
13146 
13147         case 'F':
13148             c = 'f';		/* maybe %F isn't supported here */
13149             /* FALLTHROUGH */
13150         case 'e': case 'E':
13151         case 'f':
13152         case 'g': case 'G':
13153         case 'a': case 'A':
13154 
13155         {
13156             STRLEN float_need; /* what PL_efloatsize needs to become */
13157             bool hexfp;        /* hexadecimal floating point? */
13158 
13159             vcatpvfn_long_double_t fv;
13160             NV                     nv;
13161 
13162             /* This is evil, but floating point is even more evil */
13163 
13164             /* for SV-style calling, we can only get NV
13165                for C-style calling, we assume %f is double;
13166                for simplicity we allow any of %Lf, %llf, %qf for long double
13167             */
13168             switch (intsize) {
13169 #if defined(USE_QUADMATH)
13170             case 'Q':
13171                 break;
13172 #endif
13173             case 'V':
13174 #if defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH)
13175                 intsize = 'q';
13176 #endif
13177                 break;
13178 /* [perl #20339] - we should accept and ignore %lf rather than die */
13179             case 'l':
13180                 /* FALLTHROUGH */
13181             default:
13182 #if defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH)
13183                 intsize = args ? 0 : 'q';
13184 #endif
13185                 break;
13186             case 'q':
13187 #if defined(HAS_LONG_DOUBLE)
13188                 break;
13189 #else
13190                 /* FALLTHROUGH */
13191 #endif
13192             case 'c':
13193             case 'h':
13194             case 'z':
13195             case 't':
13196             case 'j':
13197                 goto unknown;
13198             }
13199 
13200             /* Now we need (long double) if intsize == 'q', else (double). */
13201             if (args) {
13202                 /* Note: do not pull NVs off the va_list with va_arg()
13203                  * (pull doubles instead) because if you have a build
13204                  * with long doubles, you would always be pulling long
13205                  * doubles, which would badly break anyone using only
13206                  * doubles (i.e. the majority of builds). In other
13207                  * words, you cannot mix doubles and long doubles.
13208                  * The only case where you can pull off long doubles
13209                  * is when the format specifier explicitly asks so with
13210                  * e.g. "%Lg". */
13211 #ifdef USE_QUADMATH
13212                 nv = intsize == 'Q' ? va_arg(*args, NV) :
13213                     intsize == 'q' ? va_arg(*args, long double) :
13214                     va_arg(*args, double);
13215                 fv = nv;
13216 #elif LONG_DOUBLESIZE > DOUBLESIZE
13217                 if (intsize == 'q') {
13218                     fv = va_arg(*args, long double);
13219                     nv = fv;
13220                 } else {
13221                     nv = va_arg(*args, double);
13222                     VCATPVFN_NV_TO_FV(nv, fv);
13223                 }
13224 #else
13225                 nv = va_arg(*args, double);
13226                 fv = nv;
13227 #endif
13228             }
13229             else
13230             {
13231                 SvGETMAGIC(argsv);
13232                 /* we jump here if an int-ish format encountered an
13233                  * infinite/Nan argsv. After setting nv/fv, it falls
13234                  * into the isinfnan block which follows */
13235               handle_infnan_argsv:
13236                 nv = SvNV_nomg(argsv);
13237                 VCATPVFN_NV_TO_FV(nv, fv);
13238             }
13239 
13240             if (Perl_isinfnan(nv)) {
13241                 if (c == 'c')
13242                     Perl_croak(aTHX_ "Cannot printf %" NVgf " with '%c'",
13243                                nv, (int)c);
13244 
13245                 elen = S_infnan_2pv(nv, ebuf, sizeof(ebuf), plus);
13246                 assert(elen);
13247                 eptr = ebuf;
13248                 zeros     = 0;
13249                 esignlen  = 0;
13250                 dotstrlen = 0;
13251                 break;
13252             }
13253 
13254             /* special-case "%.0f" */
13255             if (   c == 'f'
13256                 && !precis
13257                 && has_precis
13258                 && !(width || left || plus || alt)
13259                 && !fill
13260                 && intsize != 'q'
13261                 && ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
13262             )
13263                 goto float_concat;
13264 
13265             /* Determine the buffer size needed for the various
13266              * floating-point formats.
13267              *
13268              * The basic possibilities are:
13269              *
13270              *               <---P--->
13271              *    %f 1111111.123456789
13272              *    %e       1.111111123e+06
13273              *    %a     0x1.0f4471f9bp+20
13274              *    %g        1111111.12
13275              *    %g        1.11111112e+15
13276              *
13277              * where P is the value of the precision in the format, or 6
13278              * if not specified. Note the two possible output formats of
13279              * %g; in both cases the number of significant digits is <=
13280              * precision.
13281              *
13282              * For most of the format types the maximum buffer size needed
13283              * is precision, plus: any leading 1 or 0x1, the radix
13284              * point, and an exponent.  The difficult one is %f: for a
13285              * large positive exponent it can have many leading digits,
13286              * which needs to be calculated specially. Also %a is slightly
13287              * different in that in the absence of a specified precision,
13288              * it uses as many digits as necessary to distinguish
13289              * different values.
13290              *
13291              * First, here are the constant bits. For ease of calculation
13292              * we over-estimate the needed buffer size, for example by
13293              * assuming all formats have an exponent and a leading 0x1.
13294              *
13295              * Also for production use, add a little extra overhead for
13296              * safety's sake. Under debugging don't, as it means we're
13297              * more likely to quickly spot issues during development.
13298              */
13299 
13300             float_need =     1  /* possible unary minus */
13301                           +  4  /* "0x1" plus very unlikely carry */
13302                           +  1  /* default radix point '.' */
13303                           +  2  /* "e-", "p+" etc */
13304                           +  6  /* exponent: up to 16383 (quad fp) */
13305 #ifndef DEBUGGING
13306                           + 20  /* safety net */
13307 #endif
13308                           +  1; /* \0 */
13309 
13310 
13311             /* determine the radix point len, e.g. length(".") in "1.2" */
13312 #ifdef USE_LOCALE_NUMERIC
13313             /* note that we may either explicitly use PL_numeric_radix_sv
13314              * below, or implicitly, via an snprintf() variant.
13315              * Note also things like ps_AF.utf8 which has
13316              * "\N{ARABIC DECIMAL SEPARATOR} as a radix point */
13317             if (! have_in_lc_numeric) {
13318                 in_lc_numeric = IN_LC(LC_NUMERIC);
13319                 have_in_lc_numeric = TRUE;
13320             }
13321 
13322             if (in_lc_numeric) {
13323                 WITH_LC_NUMERIC_SET_TO_NEEDED_IN(TRUE, {
13324                     /* this can't wrap unless PL_numeric_radix_sv is a string
13325                      * consuming virtually all the 32-bit or 64-bit address
13326                      * space
13327                      */
13328                     float_need += (SvCUR(PL_numeric_radix_sv) - 1);
13329 
13330                     /* floating-point formats only get utf8 if the radix point
13331                      * is utf8. All other characters in the string are < 128
13332                      * and so can be safely appended to both a non-utf8 and utf8
13333                      * string as-is.
13334                      * Note that this will convert the output to utf8 even if
13335                      * the radix point didn't get output.
13336                      */
13337                     if (SvUTF8(PL_numeric_radix_sv) && !has_utf8) {
13338                         sv_utf8_upgrade(sv);
13339                         has_utf8 = TRUE;
13340                     }
13341                 });
13342             }
13343 #endif
13344 
13345             hexfp = FALSE;
13346 
13347             if (isALPHA_FOLD_EQ(c, 'f')) {
13348                 /* Determine how many digits before the radix point
13349                  * might be emitted.  frexp() (or frexpl) has some
13350                  * unspecified behaviour for nan/inf/-inf, so lucky we've
13351                  * already handled them above */
13352                 STRLEN digits;
13353                 int i = PERL_INT_MIN;
13354                 (void)Perl_frexp((NV)fv, &i);
13355                 if (i == PERL_INT_MIN)
13356                     Perl_die(aTHX_ "panic: frexp: %" VCATPVFN_FV_GF, fv);
13357 
13358                 if (i > 0) {
13359                     digits = BIT_DIGITS(i);
13360                     /* this can't overflow. 'digits' will only be a few
13361                      * thousand even for the largest floating-point types.
13362                      * And up until now float_need is just some small
13363                      * constants plus radix len, which can't be in
13364                      * overflow territory unless the radix SV is consuming
13365                      * over 1/2 the address space */
13366                     assert(float_need < ((STRLEN)~0) - digits);
13367                     float_need += digits;
13368                 }
13369             }
13370             else if (UNLIKELY(isALPHA_FOLD_EQ(c, 'a'))) {
13371                 hexfp = TRUE;
13372                 if (!has_precis) {
13373                     /* %a in the absence of precision may print as many
13374                      * digits as needed to represent the entire mantissa
13375                      * bit pattern.
13376                      * This estimate seriously overshoots in most cases,
13377                      * but better the undershooting.  Firstly, all bytes
13378                      * of the NV are not mantissa, some of them are
13379                      * exponent.  Secondly, for the reasonably common
13380                      * long doubles case, the "80-bit extended", two
13381                      * or six bytes of the NV are unused. Also, we'll
13382                      * still pick up an extra +6 from the default
13383                      * precision calculation below. */
13384                     STRLEN digits =
13385 #ifdef LONGDOUBLE_DOUBLEDOUBLE
13386                         /* For the "double double", we need more.
13387                          * Since each double has their own exponent, the
13388                          * doubles may float (haha) rather far from each
13389                          * other, and the number of required bits is much
13390                          * larger, up to total of DOUBLEDOUBLE_MAXBITS bits.
13391                          * See the definition of DOUBLEDOUBLE_MAXBITS.
13392                          *
13393                          * Need 2 hexdigits for each byte. */
13394                         (DOUBLEDOUBLE_MAXBITS/8 + 1) * 2;
13395 #else
13396                         NVSIZE * 2; /* 2 hexdigits for each byte */
13397 #endif
13398                     /* see "this can't overflow" comment above */
13399                     assert(float_need < ((STRLEN)~0) - digits);
13400                     float_need += digits;
13401                 }
13402             }
13403             /* special-case "%.<number>g" if it will fit in ebuf */
13404             else if (c == 'g'
13405                 && precis   /* See earlier comment about buggy Gconvert
13406                                when digits, aka precis, is 0  */
13407                 && has_precis
13408                 /* check that "%.<number>g" formatting will fit in ebuf  */
13409                 && sizeof(ebuf) - float_need > precis
13410                 /* sizeof(ebuf) - float_need will have wrapped if float_need > sizeof(ebuf).     *
13411                  * Therefore we should check that float_need < sizeof(ebuf). Normally, we would  *
13412                  * have run this check first, but that triggers incorrect -Wformat-overflow      *
13413                  * compilation warnings with some versions of gcc if Gconvert invokes sprintf(). *
13414                  * ( See: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89161 )                   *
13415                  * So, instead, we check it next:                                                */
13416                 && float_need < sizeof(ebuf)
13417                 && !(width || left || plus || alt)
13418                 && !fill
13419                 && intsize != 'q'
13420             ) {
13421                 WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric,
13422                     SNPRINTF_G(fv, ebuf, sizeof(ebuf), precis)
13423                 );
13424                 elen = strlen(ebuf);
13425                 eptr = ebuf;
13426                 goto float_concat;
13427             }
13428 
13429 
13430             {
13431                 STRLEN pr = has_precis ? precis : 6; /* known default */
13432                 /* this probably can't wrap, since precis is limited
13433                  * to 1/4 address space size, but better safe than sorry
13434                  */
13435                 if (float_need >= ((STRLEN)~0) - pr)
13436                     croak_memory_wrap();
13437                 float_need += pr;
13438             }
13439 
13440             if (float_need < width)
13441                 float_need = width;
13442 
13443             if (float_need > INT_MAX) {
13444                 /* snprintf() returns an int, and we use that return value,
13445                    so die horribly if the expected size is too large for int
13446                 */
13447                 Perl_croak(aTHX_ "Numeric format result too large");
13448             }
13449 
13450             if (PL_efloatsize <= float_need) {
13451                 /* PL_efloatbuf should be at least 1 greater than
13452                  * float_need to allow a trailing \0 to be returned by
13453                  * snprintf().  If we need to grow, overgrow for the
13454                  * benefit of future generations */
13455                 const STRLEN extra = 0x20;
13456                 if (float_need >= ((STRLEN)~0) - extra)
13457                     croak_memory_wrap();
13458                 float_need += extra;
13459                 Safefree(PL_efloatbuf);
13460                 PL_efloatsize = float_need;
13461                 Newx(PL_efloatbuf, PL_efloatsize, char);
13462                 PL_efloatbuf[0] = '\0';
13463             }
13464 
13465             if (UNLIKELY(hexfp)) {
13466                 elen = S_format_hexfp(aTHX_ PL_efloatbuf, PL_efloatsize, c,
13467                                 nv, fv, has_precis, precis, width,
13468                                 alt, plus, left, fill, in_lc_numeric);
13469             }
13470             else {
13471                 char *ptr = ebuf + sizeof ebuf;
13472                 *--ptr = '\0';
13473                 *--ptr = c;
13474 #if defined(USE_QUADMATH)
13475                 /* always use Q here.  my_snprint() throws an exception if we
13476                    fallthrough to the double/long double code, even when the
13477                    format is correct, presumably to avoid any accidentally
13478                    missing Q.
13479                 */
13480                 *--ptr = 'Q';
13481                 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
13482 #elif defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
13483                 /* Note that this is HAS_LONG_DOUBLE and PERL_PRIfldbl,
13484                  * not USE_LONG_DOUBLE and NVff.  In other words,
13485                  * this needs to work without USE_LONG_DOUBLE. */
13486                 if (intsize == 'q') {
13487                     /* Copy the one or more characters in a long double
13488                      * format before the 'base' ([efgEFG]) character to
13489                      * the format string. */
13490                     static char const ldblf[] = PERL_PRIfldbl;
13491                     char const *p = ldblf + sizeof(ldblf) - 3;
13492                     while (p >= ldblf) { *--ptr = *p--; }
13493                 }
13494 #endif
13495                 if (has_precis) {
13496                     base = precis;
13497                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
13498                     *--ptr = '.';
13499                 }
13500                 if (width) {
13501                     base = width;
13502                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
13503                 }
13504                 if (fill)
13505                     *--ptr = '0';
13506                 if (left)
13507                     *--ptr = '-';
13508                 if (plus)
13509                     *--ptr = plus;
13510                 if (alt)
13511                     *--ptr = '#';
13512                 *--ptr = '%';
13513 
13514                 /* No taint.  Otherwise we are in the strange situation
13515                  * where printf() taints but print($float) doesn't.
13516                  * --jhi */
13517 
13518                 /* hopefully the above makes ptr a very constrained format
13519                  * that is safe to use, even though it's not literal */
13520                 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
13521 #ifdef USE_QUADMATH
13522                 {
13523                     if (!quadmath_format_valid(ptr))
13524                         Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", ptr);
13525                     WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric,
13526                         elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize,
13527                                                  ptr, nv);
13528                     );
13529                     if ((IV)elen == -1) {
13530                         Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", ptr);
13531                     }
13532                 }
13533 #elif defined(HAS_LONG_DOUBLE)
13534                 WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric,
13535                     elen = ((intsize == 'q')
13536                             ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv)
13537                             : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)fv))
13538                 );
13539 #else
13540                 WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric,
13541                     elen = my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv)
13542                 );
13543 #endif
13544                 GCC_DIAG_RESTORE_STMT;
13545             }
13546 
13547             eptr = PL_efloatbuf;
13548 
13549           float_concat:
13550 
13551             /* Since floating-point formats do their own formatting and
13552              * padding, we skip the main block of code at the end of this
13553              * loop which handles appending eptr to sv, and do our own
13554              * stripped-down version */
13555 
13556             assert(!zeros);
13557             assert(!esignlen);
13558             assert(elen);
13559             assert(elen >= width);
13560 
13561             S_sv_catpvn_simple(aTHX_ sv, eptr, elen);
13562 
13563             goto done_valid_conversion;
13564         }
13565 
13566             /* SPECIAL */
13567 
13568         case 'n':
13569             {
13570                 STRLEN len;
13571                 /* XXX ideally we should warn if any flags etc have been
13572                  * set, e.g. "%-4.5n" */
13573                 /* XXX if sv was originally non-utf8 with a char in the
13574                  * range 0x80-0xff, then if it got upgraded, we should
13575                  * calculate char len rather than byte len here */
13576                 len = SvCUR(sv) - origlen;
13577                 if (args) {
13578                     int i = (len > PERL_INT_MAX) ? PERL_INT_MAX : (int)len;
13579 
13580                     switch (intsize) {
13581                     case 'c':  *(va_arg(*args, char*))      = i; break;
13582                     case 'h':  *(va_arg(*args, short*))     = i; break;
13583                     default:   *(va_arg(*args, int*))       = i; break;
13584                     case 'l':  *(va_arg(*args, long*))      = i; break;
13585                     case 'V':  *(va_arg(*args, IV*))        = i; break;
13586                     case 'z':  *(va_arg(*args, SSize_t*))   = i; break;
13587 #ifdef HAS_PTRDIFF_T
13588                     case 't':  *(va_arg(*args, ptrdiff_t*)) = i; break;
13589 #endif
13590                     case 'j':  *(va_arg(*args, PERL_INTMAX_T*)) = i; break;
13591                     case 'q':
13592 #if IVSIZE >= 8
13593                                *(va_arg(*args, Quad_t*))    = i; break;
13594 #else
13595                                goto unknown;
13596 #endif
13597                     }
13598                 }
13599                 else {
13600                     if (arg_missing)
13601                         Perl_croak_nocontext(
13602                             "Missing argument for %%n in %s",
13603                                 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
13604                     sv_setuv_mg(argsv, has_utf8
13605                         ? (UV)utf8_length((U8*)SvPVX(sv), (U8*)SvEND(sv))
13606                         : (UV)len);
13607                 }
13608                 goto done_valid_conversion;
13609             }
13610 
13611             /* UNKNOWN */
13612 
13613         default:
13614       unknown:
13615             if (!args
13616                 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
13617                 && ckWARN(WARN_PRINTF))
13618             {
13619                 SV * const msg = sv_newmortal();
13620                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
13621                           (PL_op->op_type == OP_PRTF) ? "" : "s");
13622                 if (fmtstart < patend) {
13623                     const char * const fmtend = q < patend ? q : patend;
13624                     const char * f;
13625                     sv_catpvs(msg, "\"%");
13626                     for (f = fmtstart; f < fmtend; f++) {
13627                         if (isPRINT(*f)) {
13628                             sv_catpvn_nomg(msg, f, 1);
13629                         } else {
13630                             Perl_sv_catpvf(aTHX_ msg, "\\%03o", (U8) *f);
13631                         }
13632                     }
13633                     sv_catpvs(msg, "\"");
13634                 } else {
13635                     sv_catpvs(msg, "end of string");
13636                 }
13637                 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%" SVf, SVfARG(msg)); /* yes, this is reentrant */
13638             }
13639 
13640             /* mangled format: output the '%', then continue from the
13641              * character following that */
13642             sv_catpvn_nomg(sv, fmtstart-1, 1);
13643             q = fmtstart;
13644             svix = osvix;
13645             /* Any "redundant arg" warning from now onwards will probably
13646              * just be misleading, so don't bother. */
13647             no_redundant_warning = TRUE;
13648             continue;	/* not "break" */
13649         }
13650 
13651         if (is_utf8 != has_utf8) {
13652             if (is_utf8) {
13653                 if (SvCUR(sv))
13654                     sv_utf8_upgrade(sv);
13655             }
13656             else {
13657                 const STRLEN old_elen = elen;
13658                 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
13659                 sv_utf8_upgrade(nsv);
13660                 eptr = SvPVX_const(nsv);
13661                 elen = SvCUR(nsv);
13662 
13663                 if (width) { /* fudge width (can't fudge elen) */
13664                     width += elen - old_elen;
13665                 }
13666                 is_utf8 = TRUE;
13667             }
13668         }
13669 
13670 
13671         /* append esignbuf, filler, zeros, eptr and dotstr to sv */
13672 
13673         {
13674             STRLEN need, have, gap;
13675             STRLEN i;
13676             char *s;
13677 
13678             /* signed value that's wrapped? */
13679             assert(elen  <= ((~(STRLEN)0) >> 1));
13680 
13681             /* if zeros is non-zero, then it represents filler between
13682              * elen and precis. So adding elen and zeros together will
13683              * always be <= precis, and the addition can never wrap */
13684             assert(!zeros || (precis > elen && precis - elen == zeros));
13685             have = elen + zeros;
13686 
13687             if (have >= (((STRLEN)~0) - esignlen))
13688                 croak_memory_wrap();
13689             have += esignlen;
13690 
13691             need = (have > width ? have : width);
13692             gap = need - have;
13693 
13694             if (need >= (((STRLEN)~0) - (SvCUR(sv) + 1)))
13695                 croak_memory_wrap();
13696             need += (SvCUR(sv) + 1);
13697 
13698             SvGROW(sv, need);
13699 
13700             s = SvEND(sv);
13701 
13702             if (left) {
13703                 for (i = 0; i < esignlen; i++)
13704                     *s++ = esignbuf[i];
13705                 for (i = zeros; i; i--)
13706                     *s++ = '0';
13707                 Copy(eptr, s, elen, char);
13708                 s += elen;
13709                 for (i = gap; i; i--)
13710                     *s++ = ' ';
13711             }
13712             else {
13713                 if (fill) {
13714                     for (i = 0; i < esignlen; i++)
13715                         *s++ = esignbuf[i];
13716                     assert(!zeros);
13717                     zeros = gap;
13718                 }
13719                 else {
13720                     for (i = gap; i; i--)
13721                         *s++ = ' ';
13722                     for (i = 0; i < esignlen; i++)
13723                         *s++ = esignbuf[i];
13724                 }
13725 
13726                 for (i = zeros; i; i--)
13727                     *s++ = '0';
13728                 Copy(eptr, s, elen, char);
13729                 s += elen;
13730             }
13731 
13732             *s = '\0';
13733             SvCUR_set(sv, s - SvPVX_const(sv));
13734 
13735             if (is_utf8)
13736                 has_utf8 = TRUE;
13737             if (has_utf8)
13738                 SvUTF8_on(sv);
13739         }
13740 
13741         if (vectorize && veclen) {
13742             /* we append the vector separator separately since %v isn't
13743              * very common: don't slow down the general case by adding
13744              * dotstrlen to need etc */
13745             sv_catpvn_nomg(sv, dotstr, dotstrlen);
13746             esignlen = 0;
13747             goto vector; /* do next iteration */
13748         }
13749 
13750       done_valid_conversion:
13751 
13752         if (arg_missing)
13753             S_warn_vcatpvfn_missing_argument(aTHX);
13754     }
13755 
13756     /* Now that we've consumed all our printf format arguments (svix)
13757      * do we have things left on the stack that we didn't use?
13758      */
13759     if (!no_redundant_warning && sv_count >= svix + 1 && ckWARN(WARN_REDUNDANT)) {
13760         Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
13761                 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
13762     }
13763 
13764     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
13765         /* while we shouldn't set the cache, it may have been previously
13766            set in the caller, so clear it */
13767         MAGIC *mg = mg_find(sv, PERL_MAGIC_utf8);
13768         if (mg)
13769             magic_setutf8(sv,mg); /* clear UTF8 cache */
13770     }
13771     SvTAINT(sv);
13772 }
13773 
13774 /* =========================================================================
13775 
13776 =for apidoc_section $embedding
13777 
13778 =cut
13779 
13780 All the macros and functions in this section are for the private use of
13781 the main function, perl_clone().
13782 
13783 The foo_dup() functions make an exact copy of an existing foo thingy.
13784 During the course of a cloning, a hash table is used to map old addresses
13785 to new addresses.  The table is created and manipulated with the
13786 ptr_table_* functions.
13787 
13788  * =========================================================================*/
13789 
13790 
13791 #if defined(USE_ITHREADS)
13792 
13793 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
13794 #ifndef GpREFCNT_inc
13795 #  define GpREFCNT_inc(gp)	((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
13796 #endif
13797 
13798 
13799 #define SAVEPV(p)	((p) ? savepv(p) : NULL)
13800 #define SAVEPVN(p,n)	((p) ? savepvn(p,n) : NULL)
13801 
13802 /* clone a parser */
13803 
13804 yy_parser *
13805 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
13806 {
13807     yy_parser *parser;
13808 
13809     PERL_ARGS_ASSERT_PARSER_DUP;
13810 
13811     if (!proto)
13812         return NULL;
13813 
13814     /* look for it in the table first */
13815     parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
13816     if (parser)
13817         return parser;
13818 
13819     /* create anew and remember what it is */
13820     Newxz(parser, 1, yy_parser);
13821     ptr_table_store(PL_ptr_table, proto, parser);
13822 
13823     /* XXX eventually, just Copy() most of the parser struct ? */
13824 
13825     parser->lex_brackets = proto->lex_brackets;
13826     parser->lex_casemods = proto->lex_casemods;
13827     parser->lex_brackstack = savepvn(proto->lex_brackstack,
13828                     (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
13829     parser->lex_casestack = savepvn(proto->lex_casestack,
13830                     (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
13831     parser->lex_defer	= proto->lex_defer;
13832     parser->lex_dojoin	= proto->lex_dojoin;
13833     parser->lex_formbrack = proto->lex_formbrack;
13834     parser->lex_inpat	= proto->lex_inpat;
13835     parser->lex_inwhat	= proto->lex_inwhat;
13836     parser->lex_op	= proto->lex_op;
13837     parser->lex_repl	= sv_dup_inc(proto->lex_repl, param);
13838     parser->lex_starts	= proto->lex_starts;
13839     parser->lex_stuff	= sv_dup_inc(proto->lex_stuff, param);
13840     parser->multi_close	= proto->multi_close;
13841     parser->multi_open	= proto->multi_open;
13842     parser->multi_start	= proto->multi_start;
13843     parser->multi_end	= proto->multi_end;
13844     parser->preambled	= proto->preambled;
13845     parser->lex_super_state = proto->lex_super_state;
13846     parser->lex_sub_inwhat  = proto->lex_sub_inwhat;
13847     parser->lex_sub_op	= proto->lex_sub_op;
13848     parser->lex_sub_repl= sv_dup_inc(proto->lex_sub_repl, param);
13849     parser->linestr	= sv_dup_inc(proto->linestr, param);
13850     parser->expect	= proto->expect;
13851     parser->copline	= proto->copline;
13852     parser->last_lop_op	= proto->last_lop_op;
13853     parser->lex_state	= proto->lex_state;
13854     parser->rsfp	= fp_dup(proto->rsfp, '<', param);
13855     /* rsfp_filters entries have fake IoDIRP() */
13856     parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
13857     parser->in_my	= proto->in_my;
13858     parser->in_my_stash	= hv_dup(proto->in_my_stash, param);
13859     parser->error_count	= proto->error_count;
13860     parser->sig_elems	= proto->sig_elems;
13861     parser->sig_optelems= proto->sig_optelems;
13862     parser->sig_slurpy  = proto->sig_slurpy;
13863     parser->recheck_utf8_validity = proto->recheck_utf8_validity;
13864 
13865     {
13866         char * const ols = SvPVX(proto->linestr);
13867         char * const ls  = SvPVX(parser->linestr);
13868 
13869         parser->bufptr	    = ls + (proto->bufptr >= ols ?
13870                                     proto->bufptr -  ols : 0);
13871         parser->oldbufptr   = ls + (proto->oldbufptr >= ols ?
13872                                     proto->oldbufptr -  ols : 0);
13873         parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
13874                                     proto->oldoldbufptr -  ols : 0);
13875         parser->linestart   = ls + (proto->linestart >= ols ?
13876                                     proto->linestart -  ols : 0);
13877         parser->last_uni    = ls + (proto->last_uni >= ols ?
13878                                     proto->last_uni -  ols : 0);
13879         parser->last_lop    = ls + (proto->last_lop >= ols ?
13880                                     proto->last_lop -  ols : 0);
13881 
13882         parser->bufend	    = ls + SvCUR(parser->linestr);
13883     }
13884 
13885     Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
13886 
13887 
13888     Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
13889     Copy(proto->nexttype, parser->nexttype, 5,	I32);
13890     parser->nexttoke	= proto->nexttoke;
13891 
13892     /* XXX should clone saved_curcop here, but we aren't passed
13893      * proto_perl; so do it in perl_clone_using instead */
13894 
13895     return parser;
13896 }
13897 
13898 /*
13899 =for apidoc_section $io
13900 =for apidoc fp_dup
13901 
13902 Duplicate a file handle, returning a pointer to the cloned object.
13903 
13904 =cut
13905 */
13906 
13907 PerlIO *
13908 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
13909 {
13910     PerlIO *ret;
13911 
13912     PERL_ARGS_ASSERT_FP_DUP;
13913     PERL_UNUSED_ARG(type);
13914 
13915     if (!fp)
13916         return (PerlIO*)NULL;
13917 
13918     /* look for it in the table first */
13919     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
13920     if (ret)
13921         return ret;
13922 
13923     /* create anew and remember what it is */
13924 #ifdef __amigaos4__
13925     ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE|PERLIO_DUP_FD);
13926 #else
13927     ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
13928 #endif
13929     ptr_table_store(PL_ptr_table, fp, ret);
13930     return ret;
13931 }
13932 
13933 /*
13934 =for apidoc_section $io
13935 =for apidoc dirp_dup
13936 
13937 Duplicate a directory handle, returning a pointer to the cloned object.
13938 
13939 =cut
13940 */
13941 
13942 DIR *
13943 Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
13944 {
13945     DIR *ret;
13946 
13947 #if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR)
13948     DIR *pwd;
13949     const Direntry_t *dirent;
13950     char smallbuf[256]; /* XXX MAXPATHLEN, surely? */
13951     char *name = NULL;
13952     STRLEN len = 0;
13953     long pos;
13954 #endif
13955 
13956     PERL_UNUSED_CONTEXT;
13957     PERL_ARGS_ASSERT_DIRP_DUP;
13958 
13959     if (!dp)
13960         return (DIR*)NULL;
13961 
13962     /* look for it in the table first */
13963     ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
13964     if (ret)
13965         return ret;
13966 
13967 #if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR)
13968 
13969     PERL_UNUSED_ARG(param);
13970 
13971     /* create anew */
13972 
13973     /* open the current directory (so we can switch back) */
13974     if (!(pwd = PerlDir_open("."))) return (DIR *)NULL;
13975 
13976     /* chdir to our dir handle and open the present working directory */
13977     if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) {
13978         PerlDir_close(pwd);
13979         return (DIR *)NULL;
13980     }
13981     /* Now we should have two dir handles pointing to the same dir. */
13982 
13983     /* Be nice to the calling code and chdir back to where we were. */
13984     /* XXX If this fails, then what? */
13985     PERL_UNUSED_RESULT(fchdir(my_dirfd(pwd)));
13986 
13987     /* We have no need of the pwd handle any more. */
13988     PerlDir_close(pwd);
13989 
13990 #ifdef DIRNAMLEN
13991 # define d_namlen(d) (d)->d_namlen
13992 #else
13993 # define d_namlen(d) strlen((d)->d_name)
13994 #endif
13995     /* Iterate once through dp, to get the file name at the current posi-
13996        tion. Then step back. */
13997     pos = PerlDir_tell(dp);
13998     if ((dirent = PerlDir_read(dp))) {
13999         len = d_namlen(dirent);
14000         if (len > sizeof(dirent->d_name) && sizeof(dirent->d_name) > PTRSIZE) {
14001             /* If the len is somehow magically longer than the
14002              * maximum length of the directory entry, even though
14003              * we could fit it in a buffer, we could not copy it
14004              * from the dirent.  Bail out. */
14005             PerlDir_close(ret);
14006             return (DIR*)NULL;
14007         }
14008         if (len <= sizeof smallbuf) name = smallbuf;
14009         else Newx(name, len, char);
14010         Move(dirent->d_name, name, len, char);
14011     }
14012     PerlDir_seek(dp, pos);
14013 
14014     /* Iterate through the new dir handle, till we find a file with the
14015        right name. */
14016     if (!dirent) /* just before the end */
14017         for(;;) {
14018             pos = PerlDir_tell(ret);
14019             if (PerlDir_read(ret)) continue; /* not there yet */
14020             PerlDir_seek(ret, pos); /* step back */
14021             break;
14022         }
14023     else {
14024         const long pos0 = PerlDir_tell(ret);
14025         for(;;) {
14026             pos = PerlDir_tell(ret);
14027             if ((dirent = PerlDir_read(ret))) {
14028                 if (len == (STRLEN)d_namlen(dirent)
14029                     && memEQ(name, dirent->d_name, len)) {
14030                     /* found it */
14031                     PerlDir_seek(ret, pos); /* step back */
14032                     break;
14033                 }
14034                 /* else we are not there yet; keep iterating */
14035             }
14036             else { /* This is not meant to happen. The best we can do is
14037                       reset the iterator to the beginning. */
14038                 PerlDir_seek(ret, pos0);
14039                 break;
14040             }
14041         }
14042     }
14043 #undef d_namlen
14044 
14045     if (name && name != smallbuf)
14046         Safefree(name);
14047 #endif
14048 
14049 #ifdef WIN32
14050     ret = win32_dirp_dup(dp, param);
14051 #endif
14052 
14053     /* pop it in the pointer table */
14054     if (ret)
14055         ptr_table_store(PL_ptr_table, dp, ret);
14056 
14057     return ret;
14058 }
14059 
14060 /*
14061 =for apidoc_section $GV
14062 =for apidoc gp_dup
14063 
14064 Duplicate a typeglob, returning a pointer to the cloned object.
14065 
14066 =cut
14067 */
14068 
14069 GP *
14070 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
14071 {
14072     GP *ret;
14073 
14074     PERL_ARGS_ASSERT_GP_DUP;
14075 
14076     if (!gp)
14077         return (GP*)NULL;
14078     /* look for it in the table first */
14079     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
14080     if (ret)
14081         return ret;
14082 
14083     /* create anew and remember what it is */
14084     Newxz(ret, 1, GP);
14085     ptr_table_store(PL_ptr_table, gp, ret);
14086 
14087     /* clone */
14088     /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
14089        on Newxz() to do this for us.  */
14090     ret->gp_sv		= sv_dup_inc(gp->gp_sv, param);
14091     ret->gp_io		= io_dup_inc(gp->gp_io, param);
14092     ret->gp_form	= cv_dup_inc(gp->gp_form, param);
14093     ret->gp_av		= av_dup_inc(gp->gp_av, param);
14094     ret->gp_hv		= hv_dup_inc(gp->gp_hv, param);
14095     ret->gp_egv	= gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
14096     ret->gp_cv		= cv_dup_inc(gp->gp_cv, param);
14097     ret->gp_cvgen	= gp->gp_cvgen;
14098     ret->gp_line	= gp->gp_line;
14099     ret->gp_file_hek	= hek_dup(gp->gp_file_hek, param);
14100     return ret;
14101 }
14102 
14103 
14104 /*
14105 =for apidoc_section $magic
14106 =for apidoc mg_dup
14107 
14108 Duplicate a chain of magic, returning a pointer to the cloned object.
14109 
14110 =cut
14111 */
14112 
14113 MAGIC *
14114 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
14115 {
14116     MAGIC *mgret = NULL;
14117     MAGIC **mgprev_p = &mgret;
14118 
14119     PERL_ARGS_ASSERT_MG_DUP;
14120 
14121     for (; mg; mg = mg->mg_moremagic) {
14122         MAGIC *nmg;
14123 
14124         if ((param->flags & CLONEf_JOIN_IN)
14125                 && mg->mg_type == PERL_MAGIC_backref)
14126             /* when joining, we let the individual SVs add themselves to
14127              * backref as needed. */
14128             continue;
14129 
14130         Newx(nmg, 1, MAGIC);
14131         *mgprev_p = nmg;
14132         mgprev_p = &(nmg->mg_moremagic);
14133 
14134         /* There was a comment "XXX copy dynamic vtable?" but as we don't have
14135            dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
14136            from the original commit adding Perl_mg_dup() - revision 4538.
14137            Similarly there is the annotation "XXX random ptr?" next to the
14138            assignment to nmg->mg_ptr.  */
14139         *nmg = *mg;
14140 
14141         /* FIXME for plugins
14142         if (nmg->mg_type == PERL_MAGIC_qr) {
14143             nmg->mg_obj	= MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
14144         }
14145         else
14146         */
14147         nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
14148                           ? nmg->mg_type == PERL_MAGIC_backref
14149                                 /* The backref AV has its reference
14150                                  * count deliberately bumped by 1 */
14151                                 ? SvREFCNT_inc(av_dup_inc((const AV *)
14152                                                     nmg->mg_obj, param))
14153                                 : sv_dup_inc(nmg->mg_obj, param)
14154                           : (nmg->mg_type == PERL_MAGIC_regdatum ||
14155                              nmg->mg_type == PERL_MAGIC_regdata)
14156                                   ? nmg->mg_obj
14157                                   : sv_dup(nmg->mg_obj, param);
14158 
14159         if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
14160             if (nmg->mg_len > 0) {
14161                 nmg->mg_ptr	= SAVEPVN(nmg->mg_ptr, nmg->mg_len);
14162                 if (nmg->mg_type == PERL_MAGIC_overload_table &&
14163                         AMT_AMAGIC((AMT*)nmg->mg_ptr))
14164                 {
14165                     AMT * const namtp = (AMT*)nmg->mg_ptr;
14166                     sv_dup_inc_multiple((SV**)(namtp->table),
14167                                         (SV**)(namtp->table), NofAMmeth, param);
14168                 }
14169             }
14170             else if (nmg->mg_len == HEf_SVKEY)
14171                 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
14172         }
14173         if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
14174             nmg->mg_virtual->svt_dup(aTHX_ nmg, param);
14175         }
14176     }
14177     return mgret;
14178 }
14179 
14180 #endif /* USE_ITHREADS */
14181 
14182 struct ptr_tbl_arena {
14183     struct ptr_tbl_arena *next;
14184     struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers.  */
14185 };
14186 
14187 /*
14188 =for apidoc_section $embedding
14189 =for apidoc ptr_table_new
14190 
14191 Create a new pointer-mapping table
14192 
14193 =cut
14194 */
14195 
14196 PTR_TBL_t *
14197 Perl_ptr_table_new(pTHX)
14198 {
14199     PTR_TBL_t *tbl;
14200     PERL_UNUSED_CONTEXT;
14201 
14202     Newx(tbl, 1, PTR_TBL_t);
14203     tbl->tbl_max	= 511;
14204     tbl->tbl_items	= 0;
14205     tbl->tbl_arena	= NULL;
14206     tbl->tbl_arena_next	= NULL;
14207     tbl->tbl_arena_end	= NULL;
14208     Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
14209     return tbl;
14210 }
14211 
14212 #define PTR_TABLE_HASH(ptr) \
14213   ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
14214 
14215 /* map an existing pointer using a table */
14216 
14217 STATIC PTR_TBL_ENT_t *
14218 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
14219 {
14220     PTR_TBL_ENT_t *tblent;
14221     const UV hash = PTR_TABLE_HASH(sv);
14222 
14223     PERL_ARGS_ASSERT_PTR_TABLE_FIND;
14224 
14225     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
14226     for (; tblent; tblent = tblent->next) {
14227         if (tblent->oldval == sv)
14228             return tblent;
14229     }
14230     return NULL;
14231 }
14232 
14233 /*
14234 =for apidoc ptr_table_fetch
14235 
14236 Look for C<sv> in the pointer-mapping table C<tbl>, returning its value, or
14237 NULL if not found.
14238 
14239 =cut
14240 */
14241 
14242 void *
14243 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
14244 {
14245     PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
14246 
14247     PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
14248     PERL_UNUSED_CONTEXT;
14249 
14250     return tblent ? tblent->newval : NULL;
14251 }
14252 
14253 /*
14254 =for apidoc ptr_table_store
14255 
14256 Add a new entry to a pointer-mapping table C<tbl>.
14257 In hash terms, C<oldsv> is the key; Cnewsv> is the value.
14258 
14259 The names "old" and "new" are specific to the core's typical use of ptr_tables
14260 in thread cloning.
14261 
14262 =cut
14263 */
14264 
14265 void
14266 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
14267 {
14268     PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
14269 
14270     PERL_ARGS_ASSERT_PTR_TABLE_STORE;
14271     PERL_UNUSED_CONTEXT;
14272 
14273     if (tblent) {
14274         tblent->newval = newsv;
14275     } else {
14276         const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
14277 
14278         if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
14279             struct ptr_tbl_arena *new_arena;
14280 
14281             Newx(new_arena, 1, struct ptr_tbl_arena);
14282             new_arena->next = tbl->tbl_arena;
14283             tbl->tbl_arena = new_arena;
14284             tbl->tbl_arena_next = new_arena->array;
14285             tbl->tbl_arena_end = C_ARRAY_END(new_arena->array);
14286         }
14287 
14288         tblent = tbl->tbl_arena_next++;
14289 
14290         tblent->oldval = oldsv;
14291         tblent->newval = newsv;
14292         tblent->next = tbl->tbl_ary[entry];
14293         tbl->tbl_ary[entry] = tblent;
14294         tbl->tbl_items++;
14295         if (tblent->next && tbl->tbl_items > tbl->tbl_max)
14296             ptr_table_split(tbl);
14297     }
14298 }
14299 
14300 /*
14301 =for apidoc ptr_table_split
14302 
14303 Double the hash bucket size of an existing ptr table
14304 
14305 =cut
14306 */
14307 
14308 void
14309 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
14310 {
14311     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
14312     const UV oldsize = tbl->tbl_max + 1;
14313     UV newsize = oldsize * 2;
14314     UV i;
14315 
14316     PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
14317     PERL_UNUSED_CONTEXT;
14318 
14319     Renew(ary, newsize, PTR_TBL_ENT_t*);
14320     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
14321     tbl->tbl_max = --newsize;
14322     tbl->tbl_ary = ary;
14323     for (i=0; i < oldsize; i++, ary++) {
14324         PTR_TBL_ENT_t **entp = ary;
14325         PTR_TBL_ENT_t *ent = *ary;
14326         PTR_TBL_ENT_t **curentp;
14327         if (!ent)
14328             continue;
14329         curentp = ary + oldsize;
14330         do {
14331             if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
14332                 *entp = ent->next;
14333                 ent->next = *curentp;
14334                 *curentp = ent;
14335             }
14336             else
14337                 entp = &ent->next;
14338             ent = *entp;
14339         } while (ent);
14340     }
14341 }
14342 
14343 /*
14344 =for apidoc ptr_table_free
14345 
14346 Clear and free a ptr table
14347 
14348 =cut
14349 */
14350 
14351 void
14352 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
14353 {
14354     struct ptr_tbl_arena *arena;
14355 
14356     PERL_UNUSED_CONTEXT;
14357 
14358     if (!tbl) {
14359         return;
14360     }
14361 
14362     arena = tbl->tbl_arena;
14363 
14364     while (arena) {
14365         struct ptr_tbl_arena *next = arena->next;
14366 
14367         Safefree(arena);
14368         arena = next;
14369     }
14370 
14371     Safefree(tbl->tbl_ary);
14372     Safefree(tbl);
14373 }
14374 
14375 #if defined(USE_ITHREADS)
14376 
14377 void
14378 Perl_rvpv_dup(pTHX_ SV *const dsv, const SV *const ssv, CLONE_PARAMS *const param)
14379 {
14380     PERL_ARGS_ASSERT_RVPV_DUP;
14381 
14382     assert(!isREGEXP(ssv));
14383     if (SvROK(ssv)) {
14384         if (SvWEAKREF(ssv)) {
14385             SvRV_set(dsv, sv_dup(SvRV_const(ssv), param));
14386             if (param->flags & CLONEf_JOIN_IN) {
14387                 /* if joining, we add any back references individually rather
14388                  * than copying the whole backref array */
14389                 Perl_sv_add_backref(aTHX_ SvRV(dsv), dsv);
14390             }
14391         }
14392         else
14393             SvRV_set(dsv, sv_dup_inc(SvRV_const(ssv), param));
14394     }
14395     else if (SvPVX_const(ssv)) {
14396         /* Has something there */
14397         if (SvLEN(ssv)) {
14398             /* Normal PV - clone whole allocated space */
14399             SvPV_set(dsv, SAVEPVN(SvPVX_const(ssv), SvLEN(ssv)-1));
14400             /* ssv may not be that normal, but actually copy on write.
14401                But we are a true, independent SV, so:  */
14402             SvIsCOW_off(dsv);
14403         }
14404         else {
14405             /* Special case - not normally malloced for some reason */
14406             if (isGV_with_GP(ssv)) {
14407                 /* Don't need to do anything here.  */
14408             }
14409             else if ((SvIsCOW_shared_hash(ssv))) {
14410                 /* A "shared" PV - clone it as "shared" PV */
14411                 SvPV_set(dsv,
14412                          HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv)),
14413                                          param)));
14414             }
14415             else {
14416                 /* Some other special case - random pointer */
14417                 SvPV_set(dsv, (char *) SvPVX_const(ssv));
14418             }
14419         }
14420     }
14421     else {
14422         /* Copy the NULL */
14423         SvPV_set(dsv, NULL);
14424     }
14425 }
14426 
14427 /* duplicate a list of SVs. source and dest may point to the same memory.  */
14428 static SV **
14429 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
14430                       SSize_t items, CLONE_PARAMS *const param)
14431 {
14432     PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
14433 
14434     while (items-- > 0) {
14435         *dest++ = sv_dup_inc(*source++, param);
14436     }
14437 
14438     return dest;
14439 }
14440 
14441 /* duplicate the HvAUX of an HV */
14442 static void
14443 S_sv_dup_hvaux(pTHX_ const SV *const ssv, SV *dsv, CLONE_PARAMS *const param)
14444 {
14445     PERL_ARGS_ASSERT_SV_DUP_HVAUX;
14446 
14447     const struct xpvhv_aux * const saux = HvAUX(ssv);
14448     struct xpvhv_aux * const daux = HvAUX(dsv);
14449     /* This flag isn't copied.  */
14450     SvFLAGS(dsv) |= SVphv_HasAUX;
14451 
14452     if (saux->xhv_name_count) {
14453         HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
14454         const I32 count = saux->xhv_name_count < 0
14455             ? -saux->xhv_name_count
14456             :  saux->xhv_name_count;
14457         HEK **shekp = sname + count;
14458         HEK **dhekp;
14459         Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *);
14460         dhekp = daux->xhv_name_u.xhvnameu_names + count;
14461         while (shekp-- > sname) {
14462             dhekp--;
14463             *dhekp = hek_dup(*shekp, param);
14464         }
14465     }
14466     else {
14467         daux->xhv_name_u.xhvnameu_name = hek_dup(saux->xhv_name_u.xhvnameu_name, param);
14468     }
14469     daux->xhv_name_count = saux->xhv_name_count;
14470 
14471     daux->xhv_aux_flags = saux->xhv_aux_flags;
14472 #ifdef PERL_HASH_RANDOMIZE_KEYS
14473     daux->xhv_rand = saux->xhv_rand;
14474     daux->xhv_last_rand = saux->xhv_last_rand;
14475 #endif
14476     daux->xhv_riter = saux->xhv_riter;
14477     daux->xhv_eiter = saux->xhv_eiter ? he_dup(saux->xhv_eiter, FALSE, param) : 0;
14478     /* backref array needs refcnt=2; see sv_add_backref */
14479     daux->xhv_backreferences =
14480         (param->flags & CLONEf_JOIN_IN)
14481             /* when joining, we let the individual GVs and
14482              * CVs add themselves to backref as
14483              * needed. This avoids pulling in stuff
14484              * that isn't required, and simplifies the
14485              * case where stashes aren't cloned back
14486              * if they already exist in the parent
14487              * thread */
14488         ? NULL
14489         : saux->xhv_backreferences
14490             ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
14491                 ? MUTABLE_AV(SvREFCNT_inc(
14492                       sv_dup_inc((const SV *)
14493                         saux->xhv_backreferences, param)))
14494                 : MUTABLE_AV(sv_dup((const SV *)
14495                         saux->xhv_backreferences, param))
14496             : 0;
14497 
14498     daux->xhv_mro_meta = saux->xhv_mro_meta
14499         ? mro_meta_dup(saux->xhv_mro_meta, param)
14500         : 0;
14501 
14502     /* Record stashes for possible cloning in Perl_clone(). */
14503     if (HvNAME(ssv))
14504         av_push(param->stashes, dsv);
14505 
14506     if (HvSTASH_IS_CLASS(ssv)) {
14507         daux->xhv_class_superclass    = hv_dup_inc(saux->xhv_class_superclass,    param);
14508         daux->xhv_class_initfields_cv = cv_dup_inc(saux->xhv_class_initfields_cv, param);
14509         daux->xhv_class_adjust_blocks = av_dup_inc(saux->xhv_class_adjust_blocks, param);
14510         daux->xhv_class_fields        = padnamelist_dup_inc(saux->xhv_class_fields, param);
14511         daux->xhv_class_next_fieldix  = saux->xhv_class_next_fieldix;
14512         daux->xhv_class_param_map     = hv_dup_inc(saux->xhv_class_param_map,     param);
14513 
14514         /* TODO: This does mean that we can't compile more `field` expressions
14515          * in the cloned thread, but surely we're done with compiletime now..?
14516          */
14517         daux->xhv_class_suspended_initfields_compcv = NULL;
14518     }
14519 }
14520 
14521 /* duplicate an SV of any type (including AV, HV etc) */
14522 
14523 static SV *
14524 S_sv_dup_common(pTHX_ const SV *const ssv, CLONE_PARAMS *const param)
14525 {
14526     SV *dsv;
14527 
14528     PERL_ARGS_ASSERT_SV_DUP_COMMON;
14529 
14530     if (SvIS_FREED(ssv)) {
14531 #ifdef DEBUG_LEAKING_SCALARS_ABORT
14532         abort();
14533 #endif
14534         return NULL;
14535     }
14536     /* look for it in the table first */
14537     dsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, ssv));
14538     if (dsv)
14539         return dsv;
14540 
14541     if(param->flags & CLONEf_JOIN_IN) {
14542         /** We are joining here so we don't want do clone
14543             something that is bad **/
14544         if (SvTYPE(ssv) == SVt_PVHV) {
14545             const HEK * const hvname = HvNAME_HEK(ssv);
14546             if (hvname) {
14547                 /** don't clone stashes if they already exist **/
14548                 dsv = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
14549                                                 HEK_UTF8(hvname) ? SVf_UTF8 : 0));
14550                 ptr_table_store(PL_ptr_table, ssv, dsv);
14551                 return dsv;
14552             }
14553         }
14554         else if (SvTYPE(ssv) == SVt_PVGV && !SvFAKE(ssv)) {
14555             HV *stash = GvSTASH(ssv);
14556             const HEK * hvname;
14557             if (stash && (hvname = HvNAME_HEK(stash))) {
14558                 /** don't clone GVs if they already exist **/
14559                 SV **svp;
14560                 stash = gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
14561                                     HEK_UTF8(hvname) ? SVf_UTF8 : 0);
14562                 svp = hv_fetch(
14563                         stash, GvNAME(ssv),
14564                         GvNAMEUTF8(ssv)
14565                             ? -GvNAMELEN(ssv)
14566                             :  GvNAMELEN(ssv),
14567                         0
14568                       );
14569                 if (svp && *svp && SvTYPE(*svp) == SVt_PVGV) {
14570                     ptr_table_store(PL_ptr_table, ssv, *svp);
14571                     return *svp;
14572                 }
14573             }
14574         }
14575     }
14576 
14577     /* create anew and remember what it is */
14578     new_SV(dsv);
14579 
14580 #ifdef DEBUG_LEAKING_SCALARS
14581     dsv->sv_debug_optype = ssv->sv_debug_optype;
14582     dsv->sv_debug_line = ssv->sv_debug_line;
14583     dsv->sv_debug_inpad = ssv->sv_debug_inpad;
14584     dsv->sv_debug_parent = (SV*)ssv;
14585     FREE_SV_DEBUG_FILE(dsv);
14586     dsv->sv_debug_file = savesharedpv(ssv->sv_debug_file);
14587 #endif
14588 
14589     ptr_table_store(PL_ptr_table, ssv, dsv);
14590 
14591     /* clone */
14592     SvFLAGS(dsv)	= SvFLAGS(ssv);
14593     SvFLAGS(dsv)	&= ~SVf_OOK;		/* don't propagate OOK hack */
14594     SvREFCNT(dsv)	= 0;			/* must be before any other dups! */
14595 
14596 #ifdef DEBUGGING
14597     if (SvANY(ssv) && PL_watch_pvx && SvPVX_const(ssv) == PL_watch_pvx)
14598         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
14599                       (void*)PL_watch_pvx, SvPVX_const(ssv));
14600 #endif
14601 
14602     /* don't clone objects whose class has asked us not to */
14603     if (SvOBJECT(ssv)
14604      && ! (SvFLAGS(SvSTASH(ssv)) & SVphv_CLONEABLE))
14605     {
14606         SvFLAGS(dsv) = 0;
14607         return dsv;
14608     }
14609 
14610     switch (SvTYPE(ssv)) {
14611     case SVt_NULL:
14612         SvANY(dsv)	= NULL;
14613         break;
14614     case SVt_IV:
14615         SET_SVANY_FOR_BODYLESS_IV(dsv);
14616         if(SvROK(ssv)) {
14617             Perl_rvpv_dup(aTHX_ dsv, ssv, param);
14618         } else {
14619             SvIV_set(dsv, SvIVX(ssv));
14620         }
14621         break;
14622     case SVt_NV:
14623 #if NVSIZE <= IVSIZE
14624         SET_SVANY_FOR_BODYLESS_NV(dsv);
14625 #else
14626         SvANY(dsv)	= new_XNV();
14627 #endif
14628         SvNV_set(dsv, SvNVX(ssv));
14629         break;
14630     default:
14631         {
14632             /* These are all the types that need complex bodies allocating.  */
14633             void *new_body;
14634             const svtype sv_type = SvTYPE(ssv);
14635             const struct body_details *sv_type_details
14636                 = bodies_by_type + sv_type;
14637 
14638             switch (sv_type) {
14639             default:
14640                 Perl_croak(param->proto_perl, "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(ssv));
14641                 NOT_REACHED; /* NOTREACHED */
14642                 break;
14643 
14644             case SVt_PVHV:
14645                 if (HvHasAUX(ssv)) {
14646                     sv_type_details = &fake_hv_with_aux;
14647 #ifdef PURIFY
14648                     new_body = new_NOARENA(sv_type_details);
14649 #else
14650                     new_body_from_arena(new_body, HVAUX_ARENA_ROOT_IX, fake_hv_with_aux);
14651 #endif
14652                     goto have_body;
14653                 }
14654                 /* FALLTHROUGH */
14655             case SVt_PVOBJ:
14656             case SVt_PVGV:
14657             case SVt_PVIO:
14658             case SVt_PVFM:
14659             case SVt_PVAV:
14660             case SVt_PVCV:
14661             case SVt_PVLV:
14662             case SVt_REGEXP:
14663             case SVt_PVMG:
14664             case SVt_PVNV:
14665             case SVt_PVIV:
14666             case SVt_INVLIST:
14667             case SVt_PV:
14668                 assert(sv_type_details->body_size);
14669 #ifndef PURIFY
14670                 if (sv_type_details->arena) {
14671                     new_body = S_new_body(aTHX_ sv_type);
14672                     new_body
14673                         = (void*)((char*)new_body - sv_type_details->offset);
14674                 } else
14675 #endif
14676                 {
14677                     new_body = new_NOARENA(sv_type_details);
14678                 }
14679             }
14680         have_body:
14681             assert(new_body);
14682             SvANY(dsv) = new_body;
14683 
14684 #ifndef PURIFY
14685             Copy(((char*)SvANY(ssv)) + sv_type_details->offset,
14686                  ((char*)SvANY(dsv)) + sv_type_details->offset,
14687                  sv_type_details->copy, char);
14688 #else
14689             Copy(((char*)SvANY(ssv)),
14690                  ((char*)SvANY(dsv)),
14691                  sv_type_details->body_size + sv_type_details->offset, char);
14692 #endif
14693 
14694             if (sv_type != SVt_PVAV && sv_type != SVt_PVHV && sv_type != SVt_PVOBJ
14695                 && !isGV_with_GP(dsv)
14696                 && !isREGEXP(dsv)
14697                 && !(sv_type == SVt_PVIO && !(IoFLAGS(dsv) & IOf_FAKE_DIRP)))
14698                 Perl_rvpv_dup(aTHX_ dsv, ssv, param);
14699 
14700             /* The Copy above means that all the source (unduplicated) pointers
14701                are now in the destination.  We can check the flags and the
14702                pointers in either, but it's possible that there's less cache
14703                missing by always going for the destination.
14704                FIXME - instrument and check that assumption  */
14705             if (sv_type >= SVt_PVMG) {
14706                 if (SvMAGIC(dsv))
14707                     SvMAGIC_set(dsv, mg_dup(SvMAGIC(dsv), param));
14708                 if (SvOBJECT(dsv) && SvSTASH(dsv))
14709                     SvSTASH_set(dsv, hv_dup_inc(SvSTASH(dsv), param));
14710                 else SvSTASH_set(dsv, 0); /* don't copy DESTROY cache */
14711             }
14712 
14713             /* The cast silences a GCC warning about unhandled types.  */
14714             switch ((int)sv_type) {
14715             case SVt_PV:
14716                 break;
14717             case SVt_PVIV:
14718                 break;
14719             case SVt_PVNV:
14720                 break;
14721             case SVt_PVMG:
14722                 break;
14723             case SVt_REGEXP:
14724               duprex:
14725                 /* FIXME for plugins */
14726                 re_dup_guts((REGEXP*) ssv, (REGEXP*) dsv, param);
14727                 break;
14728             case SVt_PVLV:
14729                 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
14730                 if (LvTYPE(dsv) == 't') /* for tie: unrefcnted fake (SV**) */
14731                     LvTARG(dsv) = dsv;
14732                 else if (LvTYPE(dsv) == 'T') /* for tie: fake HE */
14733                     LvTARG(dsv) = MUTABLE_SV(he_dup((HE*)LvTARG(dsv), FALSE, param));
14734                 else
14735                     LvTARG(dsv) = sv_dup_inc(LvTARG(dsv), param);
14736                 if (isREGEXP(ssv)) goto duprex;
14737                 /* FALLTHROUGH */
14738             case SVt_PVGV:
14739                 /* non-GP case already handled above */
14740                 if(isGV_with_GP(ssv)) {
14741                     GvNAME_HEK(dsv) = hek_dup(GvNAME_HEK(dsv), param);
14742                     /* Don't call sv_add_backref here as it's going to be
14743                        created as part of the magic cloning of the symbol
14744                        table--unless this is during a join and the stash
14745                        is not actually being cloned.  */
14746                     /* Danger Will Robinson - GvGP(dsv) isn't initialised
14747                        at the point of this comment.  */
14748                     GvSTASH(dsv) = hv_dup(GvSTASH(dsv), param);
14749                     if (param->flags & CLONEf_JOIN_IN)
14750                         Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dsv)), dsv);
14751                     GvGP_set(dsv, gp_dup(GvGP(ssv), param));
14752                     (void)GpREFCNT_inc(GvGP(dsv));
14753                 }
14754                 break;
14755             case SVt_PVIO:
14756                 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
14757                 if(IoFLAGS(dsv) & IOf_FAKE_DIRP) {
14758                     /* I have no idea why fake dirp (rsfps)
14759                        should be treated differently but otherwise
14760                        we end up with leaks -- sky*/
14761                     IoTOP_GV(dsv)      = gv_dup_inc(IoTOP_GV(dsv), param);
14762                     IoFMT_GV(dsv)      = gv_dup_inc(IoFMT_GV(dsv), param);
14763                     IoBOTTOM_GV(dsv)   = gv_dup_inc(IoBOTTOM_GV(dsv), param);
14764                 } else {
14765                     IoTOP_GV(dsv)      = gv_dup(IoTOP_GV(dsv), param);
14766                     IoFMT_GV(dsv)      = gv_dup(IoFMT_GV(dsv), param);
14767                     IoBOTTOM_GV(dsv)   = gv_dup(IoBOTTOM_GV(dsv), param);
14768                     if (IoDIRP(dsv)) {
14769                         IoDIRP(dsv)	= dirp_dup(IoDIRP(dsv), param);
14770                     } else {
14771                         NOOP;
14772                         /* IoDIRP(dsv) is already a copy of IoDIRP(ssv)  */
14773                     }
14774                     IoIFP(dsv)	= fp_dup(IoIFP(ssv), IoTYPE(dsv), param);
14775                 }
14776                 if (IoOFP(dsv) == IoIFP(ssv))
14777                     IoOFP(dsv) = IoIFP(dsv);
14778                 else
14779                     IoOFP(dsv)	= fp_dup(IoOFP(dsv), IoTYPE(dsv), param);
14780                 IoTOP_NAME(dsv)	= SAVEPV(IoTOP_NAME(dsv));
14781                 IoFMT_NAME(dsv)	= SAVEPV(IoFMT_NAME(dsv));
14782                 IoBOTTOM_NAME(dsv)	= SAVEPV(IoBOTTOM_NAME(dsv));
14783                 break;
14784             case SVt_PVAV:
14785                 /* avoid cloning an empty array */
14786                 if (AvARRAY((const AV *)ssv) && AvFILLp((const AV *)ssv) >= 0) {
14787                     SV **dst_ary, **src_ary;
14788                     SSize_t items = AvFILLp((const AV *)ssv) + 1;
14789 
14790                     src_ary = AvARRAY((const AV *)ssv);
14791                     Newx(dst_ary, AvMAX((const AV *)ssv)+1, SV*);
14792                     ptr_table_store(PL_ptr_table, src_ary, dst_ary);
14793                     AvARRAY(MUTABLE_AV(dsv)) = dst_ary;
14794                     AvALLOC((const AV *)dsv) = dst_ary;
14795                     if (AvREAL((const AV *)ssv)) {
14796                         dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
14797                                                       param);
14798                     }
14799                     else {
14800                         while (items-- > 0)
14801                             *dst_ary++ = sv_dup(*src_ary++, param);
14802                     }
14803                     items = AvMAX((const AV *)ssv) - AvFILLp((const AV *)ssv);
14804                     while (items-- > 0) {
14805                         *dst_ary++ = NULL;
14806                     }
14807                 }
14808                 else {
14809                     AvARRAY(MUTABLE_AV(dsv))	= NULL;
14810                     AvALLOC((const AV *)dsv)	= (SV**)NULL;
14811                     AvMAX(  (const AV *)dsv)	= -1;
14812                     AvFILLp((const AV *)dsv)	= -1;
14813                 }
14814                 break;
14815             case SVt_PVHV:
14816                 if (HvARRAY((const HV *)ssv)) {
14817                     STRLEN i = 0;
14818                     XPVHV * const dxhv = (XPVHV*)SvANY(dsv);
14819                     XPVHV * const sxhv = (XPVHV*)SvANY(ssv);
14820                     char *darray;
14821                     Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1),
14822                         char);
14823                     HvARRAY(dsv) = (HE**)darray;
14824                     while (i <= sxhv->xhv_max) {
14825                         const HE * const source = HvARRAY(ssv)[i];
14826                         HvARRAY(dsv)[i] = source
14827                             ? he_dup(source, FALSE, param) : 0;
14828                         ++i;
14829                     }
14830                     if (HvHasAUX(ssv))
14831                         sv_dup_hvaux(ssv, dsv, param);
14832                 }
14833                 else
14834                     HvARRAY(MUTABLE_HV(dsv)) = NULL;
14835                 break;
14836             case SVt_PVCV:
14837                 if (!(param->flags & CLONEf_COPY_STACKS)) {
14838                     CvDEPTH(dsv) = 0;
14839                 }
14840                 /* FALLTHROUGH */
14841             case SVt_PVFM:
14842                 /* NOTE: not refcounted */
14843                 SvANY(MUTABLE_CV(dsv))->xcv_stash =
14844                     hv_dup(CvSTASH(dsv), param);
14845                 if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dsv))
14846                     Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dsv)), dsv);
14847                 if (!CvISXSUB(dsv)) {
14848                     OP_REFCNT_LOCK;
14849                     CvROOT(dsv) = OpREFCNT_inc(CvROOT(dsv));
14850                     OP_REFCNT_UNLOCK;
14851                     CvSLABBED_off(dsv);
14852                 } else if (CvCONST(dsv)) {
14853                     CvXSUBANY(dsv).any_ptr =
14854                         sv_dup_inc((const SV *)CvXSUBANY(dsv).any_ptr, param);
14855                 } else if (CvREFCOUNTED_ANYSV(dsv)) {
14856                     CvXSUBANY(dsv).any_sv =
14857                         sv_dup_inc((const SV *)CvXSUBANY(dsv).any_sv, param);
14858                 }
14859                 assert(!CvSLABBED(dsv));
14860                 if (CvDYNFILE(dsv)) CvFILE(dsv) = SAVEPV(CvFILE(dsv));
14861                 if (CvNAMED(dsv))
14862                     SvANY((CV *)dsv)->xcv_gv_u.xcv_hek =
14863                         hek_dup(CvNAME_HEK((CV *)ssv), param);
14864                 /* don't dup if copying back - CvGV isn't refcounted, so the
14865                  * duped GV may never be freed. A bit of a hack! DAPM */
14866                 else
14867                   SvANY(MUTABLE_CV(dsv))->xcv_gv_u.xcv_gv =
14868                     CvCVGV_RC(dsv)
14869                     ? gv_dup_inc(CvGV(ssv), param)
14870                     : (param->flags & CLONEf_JOIN_IN)
14871                         ? NULL
14872                         : gv_dup(CvGV(ssv), param);
14873 
14874                 if (!CvISXSUB(ssv)) {
14875                     PADLIST * padlist = CvPADLIST(ssv);
14876                     if(padlist)
14877                         padlist = padlist_dup(padlist, param);
14878                     CvPADLIST_set(dsv, padlist);
14879                 } else
14880 /* unthreaded perl can't sv_dup so we don't support unthreaded's CvHSCXT */
14881                     PoisonPADLIST(dsv);
14882 
14883                 CvOUTSIDE(dsv)	=
14884                     CvWEAKOUTSIDE(ssv)
14885                     ? cv_dup(    CvOUTSIDE(dsv), param)
14886                     : cv_dup_inc(CvOUTSIDE(dsv), param);
14887                 break;
14888             case SVt_PVOBJ:
14889                 {
14890                     Size_t fieldcount = ObjectMAXFIELD(ssv) + 1;
14891 
14892                     Newx(ObjectFIELDS(dsv), fieldcount, SV *);
14893                     ObjectMAXFIELD(dsv) = fieldcount - 1;
14894 
14895                     sv_dup_inc_multiple(ObjectFIELDS(ssv), ObjectFIELDS(dsv), fieldcount, param);
14896                 }
14897                 break;
14898             }
14899         }
14900     }
14901 
14902     return dsv;
14903  }
14904 
14905 SV *
14906 Perl_sv_dup_inc(pTHX_ const SV *const ssv, CLONE_PARAMS *const param)
14907 {
14908     PERL_ARGS_ASSERT_SV_DUP_INC;
14909     return ssv ? SvREFCNT_inc(sv_dup_common(ssv, param)) : NULL;
14910 }
14911 
14912 SV *
14913 Perl_sv_dup(pTHX_ const SV *const ssv, CLONE_PARAMS *const param)
14914 {
14915     SV *dsv = ssv ? sv_dup_common(ssv, param) : NULL;
14916     PERL_ARGS_ASSERT_SV_DUP;
14917 
14918     /* Track every SV that (at least initially) had a reference count of 0.
14919        We need to do this by holding an actual reference to it in this array.
14920        If we attempt to cheat, turn AvREAL_off(), and store only pointers
14921        (akin to the stashes hash, and the perl stack), we come unstuck if
14922        a weak reference (or other SV legitimately SvREFCNT() == 0 for this
14923        thread) is manipulated in a CLONE method, because CLONE runs before the
14924        unreferenced array is walked to find SVs still with SvREFCNT() == 0
14925        (and fix things up by giving each a reference via the temps stack).
14926        Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
14927        then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
14928        before the walk of unreferenced happens and a reference to that is SV
14929        added to the temps stack. At which point we have the same SV considered
14930        to be in use, and free to be re-used. Not good.
14931     */
14932     if (dsv && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dsv)) {
14933         assert(param->unreferenced);
14934         av_push(param->unreferenced, SvREFCNT_inc(dsv));
14935     }
14936 
14937     return dsv;
14938 }
14939 
14940 /* duplicate a context */
14941 
14942 PERL_CONTEXT *
14943 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
14944 {
14945     PERL_CONTEXT *ncxs;
14946 
14947     PERL_ARGS_ASSERT_CX_DUP;
14948 
14949     if (!cxs)
14950         return (PERL_CONTEXT*)NULL;
14951 
14952     /* look for it in the table first */
14953     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
14954     if (ncxs)
14955         return ncxs;
14956 
14957     /* create anew and remember what it is */
14958     Newx(ncxs, max + 1, PERL_CONTEXT);
14959     ptr_table_store(PL_ptr_table, cxs, ncxs);
14960     Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
14961 
14962     while (ix >= 0) {
14963         PERL_CONTEXT * const ncx = &ncxs[ix];
14964         if (CxTYPE(ncx) == CXt_SUBST) {
14965             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
14966         }
14967         else {
14968             ncx->blk_oldcop = (COP*)any_dup(ncx->blk_oldcop, param->proto_perl);
14969             switch (CxTYPE(ncx)) {
14970             case CXt_SUB:
14971                 ncx->blk_sub.cv		= cv_dup_inc(ncx->blk_sub.cv, param);
14972                 if(CxHASARGS(ncx)){
14973                     ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,param);
14974                 } else {
14975                     ncx->blk_sub.savearray = NULL;
14976                 }
14977                 ncx->blk_sub.prevcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
14978                                            ncx->blk_sub.prevcomppad);
14979                 break;
14980             case CXt_EVAL:
14981                 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
14982                                                       param);
14983                 /* XXX should this sv_dup_inc? Or only if CxEVAL_TXT_REFCNTED ???? */
14984                 ncx->blk_eval.cur_text	= sv_dup(ncx->blk_eval.cur_text, param);
14985                 ncx->blk_eval.cv = cv_dup(ncx->blk_eval.cv, param);
14986                 /* XXX what to do with cur_top_env ???? */
14987                 break;
14988             case CXt_LOOP_LAZYSV:
14989                 ncx->blk_loop.state_u.lazysv.end
14990                     = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
14991                 /* Fallthrough: duplicate lazysv.cur by using the ary.ary
14992                    duplication code instead.
14993                    We are taking advantage of (1) av_dup_inc and sv_dup_inc
14994                    actually being the same function, and (2) order
14995                    equivalence of the two unions.
14996                    We can assert the later [but only at run time :-(]  */
14997                 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
14998                         (void *) &ncx->blk_loop.state_u.lazysv.cur);
14999                 /* FALLTHROUGH */
15000             case CXt_LOOP_ARY:
15001                 ncx->blk_loop.state_u.ary.ary
15002                     = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
15003                 /* FALLTHROUGH */
15004             case CXt_LOOP_LIST:
15005             case CXt_LOOP_LAZYIV:
15006                 /* code common to all 'for' CXt_LOOP_* types */
15007                 ncx->blk_loop.itersave =
15008                                     sv_dup_inc(ncx->blk_loop.itersave, param);
15009                 if (CxPADLOOP(ncx)) {
15010                     PADOFFSET off = ncx->blk_loop.itervar_u.svp
15011                                     - &CX_CURPAD_SV(ncx->blk_loop, 0);
15012                     ncx->blk_loop.oldcomppad =
15013                                     (PAD*)ptr_table_fetch(PL_ptr_table,
15014                                                 ncx->blk_loop.oldcomppad);
15015                     ncx->blk_loop.itervar_u.svp =
15016                                     &CX_CURPAD_SV(ncx->blk_loop, off);
15017                 }
15018                 else {
15019                     /* this copies the GV if CXp_FOR_GV, or the SV for an
15020                      * alias (for \$x (...)) - relies on gv_dup being the
15021                      * same as sv_dup */
15022                     ncx->blk_loop.itervar_u.gv
15023                         = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
15024                                     param);
15025                 }
15026                 break;
15027             case CXt_LOOP_PLAIN:
15028                 break;
15029             case CXt_FORMAT:
15030                 ncx->blk_format.prevcomppad =
15031                         (PAD*)ptr_table_fetch(PL_ptr_table,
15032                                            ncx->blk_format.prevcomppad);
15033                 ncx->blk_format.cv	= cv_dup_inc(ncx->blk_format.cv, param);
15034                 ncx->blk_format.gv	= gv_dup(ncx->blk_format.gv, param);
15035                 ncx->blk_format.dfoutgv	= gv_dup_inc(ncx->blk_format.dfoutgv,
15036                                                      param);
15037                 break;
15038             case CXt_GIVEN:
15039                 ncx->blk_givwhen.defsv_save =
15040                                 sv_dup_inc(ncx->blk_givwhen.defsv_save, param);
15041                 break;
15042             case CXt_BLOCK:
15043             case CXt_NULL:
15044             case CXt_WHEN:
15045             case CXt_DEFER:
15046                 break;
15047             }
15048         }
15049         --ix;
15050     }
15051     return ncxs;
15052 }
15053 
15054 /*
15055 =for apidoc si_dup
15056 
15057 Duplicate a stack info structure, returning a pointer to the cloned object.
15058 
15059 =cut
15060 */
15061 
15062 PERL_SI *
15063 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
15064 {
15065     PERL_SI *nsi;
15066 
15067     PERL_ARGS_ASSERT_SI_DUP;
15068 
15069     if (!si)
15070         return (PERL_SI*)NULL;
15071 
15072     /* look for it in the table first */
15073     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
15074     if (nsi)
15075         return nsi;
15076 
15077     /* create anew and remember what it is */
15078     Newx(nsi, 1, PERL_SI);
15079     ptr_table_store(PL_ptr_table, si, nsi);
15080 
15081     nsi->si_stack	= av_dup_inc(si->si_stack, param);
15082     nsi->si_cxix	= si->si_cxix;
15083     nsi->si_cxsubix	= si->si_cxsubix;
15084     nsi->si_cxmax	= si->si_cxmax;
15085     nsi->si_cxstack	= cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
15086     nsi->si_type	= si->si_type;
15087     nsi->si_prev	= si_dup(si->si_prev, param);
15088     nsi->si_next	= si_dup(si->si_next, param);
15089     nsi->si_markoff	= si->si_markoff;
15090 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
15091     nsi->si_stack_hwm   = 0;
15092 #endif
15093 
15094     return nsi;
15095 }
15096 
15097 #define POPINT(ss,ix)	((ss)[--(ix)].any_i32)
15098 #define TOPINT(ss,ix)	((ss)[ix].any_i32)
15099 #define POPLONG(ss,ix)	((ss)[--(ix)].any_long)
15100 #define TOPLONG(ss,ix)	((ss)[ix].any_long)
15101 #define POPIV(ss,ix)	((ss)[--(ix)].any_iv)
15102 #define TOPIV(ss,ix)	((ss)[ix].any_iv)
15103 #define POPUV(ss,ix)	((ss)[--(ix)].any_uv)
15104 #define TOPUV(ss,ix)	((ss)[ix].any_uv)
15105 #define POPBOOL(ss,ix)	((ss)[--(ix)].any_bool)
15106 #define TOPBOOL(ss,ix)	((ss)[ix].any_bool)
15107 #define POPPTR(ss,ix)	((ss)[--(ix)].any_ptr)
15108 #define TOPPTR(ss,ix)	((ss)[ix].any_ptr)
15109 #define POPDPTR(ss,ix)	((ss)[--(ix)].any_dptr)
15110 #define TOPDPTR(ss,ix)	((ss)[ix].any_dptr)
15111 #define POPDXPTR(ss,ix)	((ss)[--(ix)].any_dxptr)
15112 #define TOPDXPTR(ss,ix)	((ss)[ix].any_dxptr)
15113 
15114 /* XXXXX todo */
15115 #define pv_dup_inc(p)	SAVEPV(p)
15116 #define pv_dup(p)	SAVEPV(p)
15117 #define svp_dup_inc(p,pp)	any_dup(p,pp)
15118 
15119 /* map any object to the new equivalent - either something in the
15120  * ptr table, or something in the interpreter structure
15121  */
15122 
15123 void *
15124 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
15125 {
15126     void *ret;
15127 
15128     PERL_ARGS_ASSERT_ANY_DUP;
15129 
15130     if (!v)
15131         return (void*)NULL;
15132 
15133     /* look for it in the table first */
15134     ret = ptr_table_fetch(PL_ptr_table, v);
15135     if (ret)
15136         return ret;
15137 
15138     /* see if it is part of the interpreter structure */
15139     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
15140         ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
15141     else {
15142         ret = v;
15143     }
15144 
15145     return ret;
15146 }
15147 
15148 /*
15149 =for apidoc ss_dup
15150 
15151 Duplicate the save stack, returning a pointer to the cloned object.
15152 
15153 =cut
15154 */
15155 
15156 ANY *
15157 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
15158 {
15159     ANY * const ss	= proto_perl->Isavestack;
15160     const I32 max	= proto_perl->Isavestack_max + SS_MAXPUSH;
15161     I32 ix		= proto_perl->Isavestack_ix;
15162     ANY *nss;
15163     const SV *sv;
15164     const GV *gv;
15165     const AV *av;
15166     const HV *hv;
15167     char *pv; /* no const deliberately */
15168     void* ptr;
15169     int intval;
15170     long longval;
15171     GP *gp;
15172     IV iv;
15173     I32 i;
15174     char *c = NULL;
15175     void (*dptr) (void*);
15176     void (*dxptr) (pTHX_ void*);
15177 
15178     PERL_ARGS_ASSERT_SS_DUP;
15179 
15180     Newx(nss, max, ANY);
15181 
15182     while (ix > 0) {
15183         const UV uv = POPUV(ss,ix);
15184         const U8 type = (U8)uv & SAVE_MASK;
15185 
15186         TOPUV(nss,ix) = uv;
15187         switch (type) {
15188         case SAVEt_CLEARSV:
15189         case SAVEt_CLEARPADRANGE:
15190             break;
15191         case SAVEt_HELEM:		/* hash element */
15192         case SAVEt_SV:			/* scalar reference */
15193             sv = (const SV *)POPPTR(ss,ix);
15194             TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param));
15195             /* FALLTHROUGH */
15196         case SAVEt_ITEM:			/* normal string */
15197         case SAVEt_GVSV:			/* scalar slot in GV */
15198             sv = (const SV *)POPPTR(ss,ix);
15199             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
15200             if (type == SAVEt_SV)
15201                 break;
15202             /* FALLTHROUGH */
15203         case SAVEt_FREESV:
15204         case SAVEt_MORTALIZESV:
15205         case SAVEt_READONLY_OFF:
15206             sv = (const SV *)POPPTR(ss,ix);
15207             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
15208             break;
15209         case SAVEt_FREEPADNAME:
15210             ptr = POPPTR(ss,ix);
15211             TOPPTR(nss,ix) = padname_dup((PADNAME *)ptr, param);
15212             PadnameREFCNT((PADNAME *)TOPPTR(nss,ix))++;
15213             break;
15214         case SAVEt_SHARED_PVREF:		/* char* in shared space */
15215             c = (char*)POPPTR(ss,ix);
15216             TOPPTR(nss,ix) = savesharedpv(c);
15217             ptr = POPPTR(ss,ix);
15218             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
15219             break;
15220         case SAVEt_GENERIC_SVREF:		/* generic sv */
15221         case SAVEt_SVREF:			/* scalar reference */
15222             sv = (const SV *)POPPTR(ss,ix);
15223             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
15224             if (type == SAVEt_SVREF)
15225                 SvREFCNT_inc_simple_void((SV *)TOPPTR(nss,ix));
15226             ptr = POPPTR(ss,ix);
15227             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
15228             /* this feels very strange, we have a **SV from one thread,
15229              * we copy the SV, but dont change the **SV. But in this thread
15230              * the target of the **SV could be something from the *other* thread.
15231              * So how can this possibly work correctly? */
15232             break;
15233         case SAVEt_RCPV:
15234             pv = (char *)POPPTR(ss,ix);
15235             TOPPTR(nss,ix) = rcpv_copy(pv);
15236             ptr = POPPTR(ss,ix);
15237             (void)rcpv_copy(*((char **)ptr));
15238             TOPPTR(nss,ix) = ptr;
15239             /* XXXXX: see comment above. */
15240             break;
15241         case SAVEt_GVSLOT:		/* any slot in GV */
15242             sv = (const SV *)POPPTR(ss,ix);
15243             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
15244             ptr = POPPTR(ss,ix);
15245             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
15246             sv = (const SV *)POPPTR(ss,ix);
15247             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
15248             break;
15249         case SAVEt_HV:				/* hash reference */
15250         case SAVEt_AV:				/* array reference */
15251             sv = (const SV *) POPPTR(ss,ix);
15252             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
15253             /* FALLTHROUGH */
15254         case SAVEt_COMPPAD:
15255         case SAVEt_NSTAB:
15256             sv = (const SV *) POPPTR(ss,ix);
15257             TOPPTR(nss,ix) = sv_dup(sv, param);
15258             break;
15259         case SAVEt_INT:				/* int reference */
15260             ptr = POPPTR(ss,ix);
15261             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
15262             intval = (int)POPINT(ss,ix);
15263             TOPINT(nss,ix) = intval;
15264             break;
15265         case SAVEt_LONG:			/* long reference */
15266             ptr = POPPTR(ss,ix);
15267             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
15268             longval = (long)POPLONG(ss,ix);
15269             TOPLONG(nss,ix) = longval;
15270             break;
15271         case SAVEt_I32:				/* I32 reference */
15272             ptr = POPPTR(ss,ix);
15273             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
15274             i = POPINT(ss,ix);
15275             TOPINT(nss,ix) = i;
15276             break;
15277         case SAVEt_IV:				/* IV reference */
15278         case SAVEt_STRLEN:			/* STRLEN/size_t ref */
15279             ptr = POPPTR(ss,ix);
15280             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
15281             iv = POPIV(ss,ix);
15282             TOPIV(nss,ix) = iv;
15283             break;
15284         case SAVEt_TMPSFLOOR:
15285             iv = POPIV(ss,ix);
15286             TOPIV(nss,ix) = iv;
15287             break;
15288         case SAVEt_HPTR:			/* HV* reference */
15289         case SAVEt_APTR:			/* AV* reference */
15290         case SAVEt_SPTR:			/* SV* reference */
15291             ptr = POPPTR(ss,ix);
15292             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
15293             sv = (const SV *)POPPTR(ss,ix);
15294             TOPPTR(nss,ix) = sv_dup(sv, param);
15295             break;
15296         case SAVEt_VPTR:			/* random* reference */
15297             ptr = POPPTR(ss,ix);
15298             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
15299             /* FALLTHROUGH */
15300         case SAVEt_STRLEN_SMALL:
15301         case SAVEt_INT_SMALL:
15302         case SAVEt_I32_SMALL:
15303         case SAVEt_I16:				/* I16 reference */
15304         case SAVEt_I8:				/* I8 reference */
15305         case SAVEt_BOOL:
15306             ptr = POPPTR(ss,ix);
15307             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
15308             break;
15309         case SAVEt_GENERIC_PVREF:		/* generic char* */
15310         case SAVEt_PPTR:			/* char* reference */
15311             ptr = POPPTR(ss,ix);
15312             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
15313             c = (char*)POPPTR(ss,ix);
15314             TOPPTR(nss,ix) = pv_dup(c);
15315             break;
15316         case SAVEt_GP:				/* scalar reference */
15317             gp = (GP*)POPPTR(ss,ix);
15318             TOPPTR(nss,ix) = gp = gp_dup(gp, param);
15319             (void)GpREFCNT_inc(gp);
15320             gv = (const GV *)POPPTR(ss,ix);
15321             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
15322             break;
15323         case SAVEt_FREEOP:
15324             ptr = POPPTR(ss,ix);
15325             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
15326                 /* these are assumed to be refcounted properly */
15327                 OP *o;
15328                 switch (((OP*)ptr)->op_type) {
15329                 case OP_LEAVESUB:
15330                 case OP_LEAVESUBLV:
15331                 case OP_LEAVEEVAL:
15332                 case OP_LEAVE:
15333                 case OP_SCOPE:
15334                 case OP_LEAVEWRITE:
15335                     TOPPTR(nss,ix) = ptr;
15336                     o = (OP*)ptr;
15337                     OP_REFCNT_LOCK;
15338                     (void) OpREFCNT_inc(o);
15339                     OP_REFCNT_UNLOCK;
15340                     break;
15341                 default:
15342                     TOPPTR(nss,ix) = NULL;
15343                     break;
15344                 }
15345             }
15346             else
15347                 TOPPTR(nss,ix) = NULL;
15348             break;
15349         case SAVEt_FREECOPHH:
15350             ptr = POPPTR(ss,ix);
15351             TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr);
15352             break;
15353         case SAVEt_ADELETE:
15354             av = (const AV *)POPPTR(ss,ix);
15355             TOPPTR(nss,ix) = av_dup_inc(av, param);
15356             i = POPINT(ss,ix);
15357             TOPINT(nss,ix) = i;
15358             break;
15359         case SAVEt_DELETE:
15360             hv = (const HV *)POPPTR(ss,ix);
15361             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
15362             i = POPINT(ss,ix);
15363             TOPINT(nss,ix) = i;
15364             /* FALLTHROUGH */
15365         case SAVEt_FREEPV:
15366             c = (char*)POPPTR(ss,ix);
15367             TOPPTR(nss,ix) = pv_dup_inc(c);
15368             break;
15369         case SAVEt_FREERCPV:
15370             c = (char *)POPPTR(ss,ix);
15371             TOPPTR(nss,ix) = rcpv_copy(c);
15372             break;
15373         case SAVEt_STACK_POS:		/* Position on Perl stack */
15374             i = POPINT(ss,ix);
15375             TOPINT(nss,ix) = i;
15376             break;
15377         case SAVEt_DESTRUCTOR:
15378             ptr = POPPTR(ss,ix);
15379             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);	/* XXX quite arbitrary */
15380             dptr = POPDPTR(ss,ix);
15381             TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
15382                                         any_dup(FPTR2DPTR(void *, dptr),
15383                                                 proto_perl));
15384             break;
15385         case SAVEt_DESTRUCTOR_X:
15386             ptr = POPPTR(ss,ix);
15387             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);	/* XXX quite arbitrary */
15388             dxptr = POPDXPTR(ss,ix);
15389             TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
15390                                          any_dup(FPTR2DPTR(void *, dxptr),
15391                                                  proto_perl));
15392             break;
15393         case SAVEt_REGCONTEXT:
15394         case SAVEt_ALLOC:
15395             ix -= uv >> SAVE_TIGHT_SHIFT;
15396             break;
15397         case SAVEt_AELEM:		/* array element */
15398             sv = (const SV *)POPPTR(ss,ix);
15399             TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param));
15400             iv = POPIV(ss,ix);
15401             TOPIV(nss,ix) = iv;
15402             av = (const AV *)POPPTR(ss,ix);
15403             TOPPTR(nss,ix) = av_dup_inc(av, param);
15404             break;
15405         case SAVEt_OP:
15406             ptr = POPPTR(ss,ix);
15407             TOPPTR(nss,ix) = ptr;
15408             break;
15409         case SAVEt_HINTS_HH:
15410             hv = (const HV *)POPPTR(ss,ix);
15411             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
15412             /* FALLTHROUGH */
15413         case SAVEt_HINTS:
15414             ptr = POPPTR(ss,ix);
15415             ptr = cophh_copy((COPHH*)ptr);
15416             TOPPTR(nss,ix) = ptr;
15417             i = POPINT(ss,ix);
15418             TOPINT(nss,ix) = i;
15419             break;
15420         case SAVEt_PADSV_AND_MORTALIZE:
15421             longval = (long)POPLONG(ss,ix);
15422             TOPLONG(nss,ix) = longval;
15423             ptr = POPPTR(ss,ix);
15424             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
15425             sv = (const SV *)POPPTR(ss,ix);
15426             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
15427             break;
15428         case SAVEt_SET_SVFLAGS:
15429             i = POPINT(ss,ix);
15430             TOPINT(nss,ix) = i;
15431             i = POPINT(ss,ix);
15432             TOPINT(nss,ix) = i;
15433             sv = (const SV *)POPPTR(ss,ix);
15434             TOPPTR(nss,ix) = sv_dup(sv, param);
15435             break;
15436         case SAVEt_CURCOP_WARNINGS:
15437             /* FALLTHROUGH */
15438         case SAVEt_COMPILE_WARNINGS:
15439             ptr = POPPTR(ss,ix);
15440             TOPPTR(nss,ix) = DUP_WARNINGS((char*)ptr);
15441             break;
15442         case SAVEt_PARSER:
15443             ptr = POPPTR(ss,ix);
15444             TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
15445             break;
15446         default:
15447             Perl_croak(aTHX_
15448                        "panic: ss_dup inconsistency (%" IVdf ")", (IV) type);
15449         }
15450     }
15451 
15452     return nss;
15453 }
15454 
15455 
15456 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
15457  * flag to the result. This is done for each stash before cloning starts,
15458  * so we know which stashes want their objects cloned */
15459 
15460 static void
15461 do_mark_cloneable_stash(pTHX_ SV *const sv)
15462 {
15463     const HEK * const hvname = HvNAME_HEK((const HV *)sv);
15464     if (hvname) {
15465         GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
15466         SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
15467         if (cloner && GvCV(cloner)) {
15468             dSP;
15469             UV status;
15470 
15471             ENTER;
15472             SAVETMPS;
15473             PUSHMARK(SP);
15474             mXPUSHs(newSVhek(hvname));
15475             PUTBACK;
15476             call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
15477             SPAGAIN;
15478             status = POPu;
15479             PUTBACK;
15480             FREETMPS;
15481             LEAVE;
15482             if (status)
15483                 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
15484         }
15485     }
15486 }
15487 
15488 
15489 
15490 /*
15491 =for apidoc perl_clone
15492 
15493 Create and return a new interpreter by cloning the current one.
15494 
15495 C<perl_clone> takes these flags as parameters:
15496 
15497 C<CLONEf_COPY_STACKS> - is used to, well, copy the stacks also,
15498 without it we only clone the data and zero the stacks,
15499 with it we copy the stacks and the new perl interpreter is
15500 ready to run at the exact same point as the previous one.
15501 The pseudo-fork code uses C<COPY_STACKS> while the
15502 threads->create doesn't.
15503 
15504 C<CLONEf_KEEP_PTR_TABLE> -
15505 C<perl_clone> keeps a ptr_table with the pointer of the old
15506 variable as a key and the new variable as a value,
15507 this allows it to check if something has been cloned and not
15508 clone it again, but rather just use the value and increase the
15509 refcount.
15510 If C<KEEP_PTR_TABLE> is not set then C<perl_clone> will kill the ptr_table
15511 using the function S<C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>>.
15512 A reason to keep it around is if you want to dup some of your own
15513 variables which are outside the graph that perl scans.
15514 
15515 C<CLONEf_CLONE_HOST> -
15516 This is a win32 thing, it is ignored on unix, it tells perl's
15517 win32host code (which is c++) to clone itself, this is needed on
15518 win32 if you want to run two threads at the same time,
15519 if you just want to do some stuff in a separate perl interpreter
15520 and then throw it away and return to the original one,
15521 you don't need to do anything.
15522 
15523 =cut
15524 */
15525 
15526 /* XXX the above needs expanding by someone who actually understands it ! */
15527 EXTERN_C PerlInterpreter *
15528 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
15529 
15530 PerlInterpreter *
15531 perl_clone(PerlInterpreter *proto_perl, UV flags)
15532 {
15533 #ifdef PERL_IMPLICIT_SYS
15534 
15535     PERL_ARGS_ASSERT_PERL_CLONE;
15536 
15537    /* perlhost.h so we need to call into it
15538    to clone the host, CPerlHost should have a c interface, sky */
15539 
15540 #ifndef __amigaos4__
15541    if (flags & CLONEf_CLONE_HOST) {
15542        return perl_clone_host(proto_perl,flags);
15543    }
15544 #endif
15545    return perl_clone_using(proto_perl, flags,
15546                             proto_perl->IMem,
15547                             proto_perl->IMemShared,
15548                             proto_perl->IMemParse,
15549                             proto_perl->IEnv,
15550                             proto_perl->IStdIO,
15551                             proto_perl->ILIO,
15552                             proto_perl->IDir,
15553                             proto_perl->ISock,
15554                             proto_perl->IProc);
15555 }
15556 
15557 PerlInterpreter *
15558 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
15559                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
15560                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
15561                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
15562                  struct IPerlDir* ipD, struct IPerlSock* ipS,
15563                  struct IPerlProc* ipP)
15564 {
15565     /* XXX many of the string copies here can be optimized if they're
15566      * constants; they need to be allocated as common memory and just
15567      * their pointers copied. */
15568 
15569     IV i;
15570     CLONE_PARAMS clone_params;
15571     CLONE_PARAMS* const param = &clone_params;
15572 
15573     PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
15574 
15575     PERL_ARGS_ASSERT_PERL_CLONE_USING;
15576 #else		/* !PERL_IMPLICIT_SYS */
15577     IV i;
15578     CLONE_PARAMS clone_params;
15579     CLONE_PARAMS* param = &clone_params;
15580     PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
15581 
15582     PERL_ARGS_ASSERT_PERL_CLONE;
15583 #endif		/* PERL_IMPLICIT_SYS */
15584 
15585     /* for each stash, determine whether its objects should be cloned */
15586     S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
15587     my_perl->Iphase = PERL_PHASE_CONSTRUCT;
15588     PERL_SET_THX(my_perl);
15589 
15590 #ifdef DEBUGGING
15591     PoisonNew(my_perl, 1, PerlInterpreter);
15592     PL_op = NULL;
15593     PL_curcop = NULL;
15594     PL_defstash = NULL; /* may be used by perl malloc() */
15595     PL_markstack = 0;
15596     PL_scopestack = 0;
15597     PL_scopestack_name = 0;
15598     PL_savestack = 0;
15599     PL_savestack_ix = 0;
15600     PL_savestack_max = -1;
15601     PL_sig_pending = 0;
15602     PL_parser = NULL;
15603     PL_eval_begin_nest_depth = proto_perl->Ieval_begin_nest_depth;
15604     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
15605     Zero(&PL_padname_undef, 1, PADNAME);
15606     Zero(&PL_padname_const, 1, PADNAME);
15607 #  ifdef DEBUG_LEAKING_SCALARS
15608     PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
15609 #  endif
15610 #  ifdef PERL_TRACE_OPS
15611     Zero(PL_op_exec_cnt, OP_max+2, UV);
15612 #  endif
15613 #else	/* !DEBUGGING */
15614     Zero(my_perl, 1, PerlInterpreter);
15615 #endif	/* DEBUGGING */
15616 
15617 #ifdef PERL_IMPLICIT_SYS
15618     /* host pointers */
15619     PL_Mem		= ipM;
15620     PL_MemShared	= ipMS;
15621     PL_MemParse		= ipMP;
15622     PL_Env		= ipE;
15623     PL_StdIO		= ipStd;
15624     PL_LIO		= ipLIO;
15625     PL_Dir		= ipD;
15626     PL_Sock		= ipS;
15627     PL_Proc		= ipP;
15628 #endif		/* PERL_IMPLICIT_SYS */
15629 
15630 
15631     param->flags = flags;
15632     /* Nothing in the core code uses this, but we make it available to
15633        extensions (using mg_dup).  */
15634     param->proto_perl = proto_perl;
15635     /* Likely nothing will use this, but it is initialised to be consistent
15636        with Perl_clone_params_new().  */
15637     param->new_perl = my_perl;
15638     param->unreferenced = NULL;
15639 
15640 
15641     INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
15642 
15643     PL_body_arenas = NULL;
15644     Zero(&PL_body_roots, 1, PL_body_roots);
15645 
15646     PL_sv_count		= 0;
15647     PL_sv_root		= NULL;
15648     PL_sv_arenaroot	= NULL;
15649 
15650     PL_debug		= proto_perl->Idebug;
15651 
15652     /* dbargs array probably holds garbage */
15653     PL_dbargs		= NULL;
15654 
15655     PL_compiling = proto_perl->Icompiling;
15656 
15657     /* pseudo environmental stuff */
15658     PL_origargc		= proto_perl->Iorigargc;
15659     PL_origargv		= proto_perl->Iorigargv;
15660 
15661 #ifndef NO_TAINT_SUPPORT
15662     /* Set tainting stuff before PerlIO_debug can possibly get called */
15663     PL_tainting		= proto_perl->Itainting;
15664     PL_taint_warn	= proto_perl->Itaint_warn;
15665 #else
15666     PL_tainting         = FALSE;
15667     PL_taint_warn	= FALSE;
15668 #endif
15669 
15670     PL_minus_c		= proto_perl->Iminus_c;
15671 
15672     PL_localpatches	= proto_perl->Ilocalpatches;
15673     PL_splitstr		= SAVEPV(proto_perl->Isplitstr);
15674     PL_minus_n		= proto_perl->Iminus_n;
15675     PL_minus_p		= proto_perl->Iminus_p;
15676     PL_minus_l		= proto_perl->Iminus_l;
15677     PL_minus_a		= proto_perl->Iminus_a;
15678     PL_minus_E		= proto_perl->Iminus_E;
15679     PL_minus_F		= proto_perl->Iminus_F;
15680     PL_doswitches	= proto_perl->Idoswitches;
15681     PL_dowarn		= proto_perl->Idowarn;
15682 #ifdef PERL_SAWAMPERSAND
15683     PL_sawampersand	= proto_perl->Isawampersand;
15684 #endif
15685     PL_unsafe		= proto_perl->Iunsafe;
15686     PL_perldb		= proto_perl->Iperldb;
15687     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
15688     PL_exit_flags       = proto_perl->Iexit_flags;
15689 
15690     /* XXX time(&PL_basetime) when asked for? */
15691     PL_basetime		= proto_perl->Ibasetime;
15692 
15693     PL_maxsysfd		= proto_perl->Imaxsysfd;
15694     PL_statusvalue	= proto_perl->Istatusvalue;
15695 #ifdef __VMS
15696     PL_statusvalue_vms	= proto_perl->Istatusvalue_vms;
15697 #else
15698     PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
15699 #endif
15700 
15701     /* RE engine related */
15702     PL_regmatch_slab	= NULL;
15703     PL_reg_curpm	= NULL;
15704 
15705     PL_sub_generation	= proto_perl->Isub_generation;
15706 
15707     /* funky return mechanisms */
15708     PL_forkprocess	= proto_perl->Iforkprocess;
15709 
15710     /* internal state */
15711     PL_main_start	= proto_perl->Imain_start;
15712     PL_eval_root	= proto_perl->Ieval_root;
15713     PL_eval_start	= proto_perl->Ieval_start;
15714 
15715     PL_filemode		= proto_perl->Ifilemode;
15716     PL_lastfd		= proto_perl->Ilastfd;
15717     PL_oldname		= proto_perl->Ioldname;		/* XXX not quite right */
15718     PL_gensym		= proto_perl->Igensym;
15719 
15720     PL_laststatval	= proto_perl->Ilaststatval;
15721     PL_laststype	= proto_perl->Ilaststype;
15722     PL_mess_sv		= NULL;
15723 
15724     PL_profiledata	= NULL;
15725 
15726     PL_generation	= proto_perl->Igeneration;
15727 
15728     PL_in_clean_objs	= proto_perl->Iin_clean_objs;
15729     PL_in_clean_all	= proto_perl->Iin_clean_all;
15730 
15731     PL_delaymagic_uid	= proto_perl->Idelaymagic_uid;
15732     PL_delaymagic_euid	= proto_perl->Idelaymagic_euid;
15733     PL_delaymagic_gid	= proto_perl->Idelaymagic_gid;
15734     PL_delaymagic_egid	= proto_perl->Idelaymagic_egid;
15735     PL_nomemok		= proto_perl->Inomemok;
15736     PL_an		= proto_perl->Ian;
15737     PL_evalseq		= proto_perl->Ievalseq;
15738     PL_origalen		= proto_perl->Iorigalen;
15739 
15740     PL_sighandlerp	= proto_perl->Isighandlerp;
15741     PL_sighandler1p	= proto_perl->Isighandler1p;
15742     PL_sighandler3p	= proto_perl->Isighandler3p;
15743 
15744     PL_runops		= proto_perl->Irunops;
15745 
15746     PL_subline		= proto_perl->Isubline;
15747 
15748     PL_cv_has_eval	= proto_perl->Icv_has_eval;
15749     /* Unicode features (see perlrun/-C) */
15750     PL_unicode		= proto_perl->Iunicode;
15751 
15752     /* Pre-5.8 signals control */
15753     PL_signals		= proto_perl->Isignals;
15754 
15755     /* times() ticks per second */
15756     PL_clocktick	= proto_perl->Iclocktick;
15757 
15758     /* Recursion stopper for PerlIO_find_layer */
15759     PL_in_load_module	= proto_perl->Iin_load_module;
15760 
15761     /* Not really needed/useful since the reenrant_retint is "volatile",
15762      * but do it for consistency's sake. */
15763     PL_reentrant_retint	= proto_perl->Ireentrant_retint;
15764 
15765     /* Hooks to shared SVs and locks. */
15766     PL_sharehook	= proto_perl->Isharehook;
15767     PL_lockhook		= proto_perl->Ilockhook;
15768     PL_unlockhook	= proto_perl->Iunlockhook;
15769     PL_threadhook	= proto_perl->Ithreadhook;
15770     PL_destroyhook	= proto_perl->Idestroyhook;
15771     PL_signalhook	= proto_perl->Isignalhook;
15772 
15773     PL_globhook		= proto_perl->Iglobhook;
15774 
15775     PL_srand_called	= proto_perl->Isrand_called;
15776     Copy(&(proto_perl->Irandom_state), &PL_random_state, 1, PL_RANDOM_STATE_TYPE);
15777     PL_srand_override   = proto_perl->Isrand_override;
15778     PL_srand_override_next = proto_perl->Isrand_override_next;
15779 
15780     if (flags & CLONEf_COPY_STACKS) {
15781         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
15782         PL_tmps_ix		= proto_perl->Itmps_ix;
15783         PL_tmps_max		= proto_perl->Itmps_max;
15784         PL_tmps_floor		= proto_perl->Itmps_floor;
15785 
15786         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
15787          * NOTE: unlike the others! */
15788         PL_scopestack_ix	= proto_perl->Iscopestack_ix;
15789         PL_scopestack_max	= proto_perl->Iscopestack_max;
15790 
15791         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
15792          * NOTE: unlike the others! */
15793         PL_savestack_ix		= proto_perl->Isavestack_ix;
15794         PL_savestack_max	= proto_perl->Isavestack_max;
15795     }
15796 
15797     PL_start_env	= proto_perl->Istart_env;	/* XXXXXX */
15798     PL_top_env		= &PL_start_env;
15799 
15800     PL_op		= proto_perl->Iop;
15801 
15802     PL_Sv		= NULL;
15803     PL_Xpv		= (XPV*)NULL;
15804     my_perl->Ina	= proto_perl->Ina;
15805 
15806     PL_statcache	= proto_perl->Istatcache;
15807 
15808 #ifndef NO_TAINT_SUPPORT
15809     PL_tainted		= proto_perl->Itainted;
15810 #else
15811     PL_tainted          = FALSE;
15812 #endif
15813     PL_curpm		= proto_perl->Icurpm;	/* XXX No PMOP ref count */
15814 
15815     PL_chopset		= proto_perl->Ichopset;	/* XXX never deallocated */
15816 
15817     PL_restartjmpenv	= proto_perl->Irestartjmpenv;
15818     PL_restartop	= proto_perl->Irestartop;
15819     PL_in_eval		= proto_perl->Iin_eval;
15820     PL_delaymagic	= proto_perl->Idelaymagic;
15821     PL_phase		= proto_perl->Iphase;
15822     PL_localizing	= proto_perl->Ilocalizing;
15823 
15824     PL_hv_fetch_ent_mh	= NULL;
15825     PL_modcount		= proto_perl->Imodcount;
15826     PL_lastgotoprobe	= NULL;
15827     PL_dumpindent	= proto_perl->Idumpindent;
15828 
15829     PL_efloatbuf	= NULL;		/* reinits on demand */
15830     PL_efloatsize	= 0;			/* reinits on demand */
15831 
15832     /* regex stuff */
15833 
15834     PL_colorset		= 0;		/* reinits PL_colors[] */
15835     /*PL_colors[6]	= {0,0,0,0,0,0};*/
15836 
15837     /* Pluggable optimizer */
15838     PL_peepp		= proto_perl->Ipeepp;
15839     PL_rpeepp		= proto_perl->Irpeepp;
15840     /* op_free() hook */
15841     PL_opfreehook	= proto_perl->Iopfreehook;
15842 
15843 #  ifdef PERL_MEM_LOG
15844     Zero(PL_mem_log, sizeof(PL_mem_log), char);
15845 #  endif
15846 
15847 #ifdef USE_REENTRANT_API
15848     /* XXX: things like -Dm will segfault here in perlio, but doing
15849      *  PERL_SET_CONTEXT(proto_perl);
15850      * breaks too many other things
15851      */
15852     Perl_reentrant_init(aTHX);
15853 #endif
15854 
15855     /* create SV map for pointer relocation */
15856     PL_ptr_table = ptr_table_new();
15857 
15858     /* initialize these special pointers as early as possible */
15859     init_constants();
15860     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
15861     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
15862     ptr_table_store(PL_ptr_table, &proto_perl->Isv_zero, &PL_sv_zero);
15863     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
15864     ptr_table_store(PL_ptr_table, &proto_perl->Ipadname_const,
15865                     &PL_padname_const);
15866 
15867     /* create (a non-shared!) shared string table */
15868     PL_strtab		= newHV();
15869     HvSHAREKEYS_off(PL_strtab);
15870     hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
15871     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
15872 
15873     Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
15874 
15875     PL_compiling.cop_file    = rcpv_copy(proto_perl->Icompiling.cop_file);
15876 
15877     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
15878     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
15879     CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling)));
15880     PL_curcop		= (COP*)any_dup(proto_perl->Icurcop, proto_perl);
15881 
15882     param->stashes      = newAV();  /* Setup array of objects to call clone on */
15883     /* This makes no difference to the implementation, as it always pushes
15884        and shifts pointers to other SVs without changing their reference
15885        count, with the array becoming empty before it is freed. However, it
15886        makes it conceptually clear what is going on, and will avoid some
15887        work inside av.c, filling slots between AvFILL() and AvMAX() with
15888        &PL_sv_undef, and SvREFCNT_dec()ing those.  */
15889     AvREAL_off(param->stashes);
15890 
15891     if (!(flags & CLONEf_COPY_STACKS)) {
15892         param->unreferenced = newAV();
15893     }
15894 
15895 #ifdef PERLIO_LAYERS
15896     /* Clone PerlIO tables as soon as we can handle general xx_dup() */
15897     PerlIO_clone(aTHX_ proto_perl, param);
15898 #endif
15899 
15900     PL_envgv		= gv_dup_inc(proto_perl->Ienvgv, param);
15901     PL_incgv		= gv_dup_inc(proto_perl->Iincgv, param);
15902     PL_hintgv		= gv_dup_inc(proto_perl->Ihintgv, param);
15903     PL_origfilename	= SAVEPV(proto_perl->Iorigfilename);
15904     PL_xsubfilename	= proto_perl->Ixsubfilename;
15905     PL_diehook		= sv_dup_inc(proto_perl->Idiehook, param);
15906     PL_warnhook		= sv_dup_inc(proto_perl->Iwarnhook, param);
15907 
15908     PL_hook__require__before = sv_dup_inc(proto_perl->Ihook__require__before, param);
15909     PL_hook__require__after  = sv_dup_inc(proto_perl->Ihook__require__after, param);
15910 
15911     /* switches */
15912     PL_patchlevel	= sv_dup_inc(proto_perl->Ipatchlevel, param);
15913     PL_inplace		= SAVEPV(proto_perl->Iinplace);
15914     PL_e_script		= sv_dup_inc(proto_perl->Ie_script, param);
15915 
15916     /* magical thingies */
15917 
15918     SvPVCLEAR(PERL_DEBUG_PAD(0));        /* For regex debugging. */
15919     SvPVCLEAR(PERL_DEBUG_PAD(1));        /* ext/re needs these */
15920     SvPVCLEAR(PERL_DEBUG_PAD(2));        /* even without DEBUGGING. */
15921 
15922 
15923     /* Clone the regex array */
15924     /* ORANGE FIXME for plugins, probably in the SV dup code.
15925        newSViv(PTR2IV(CALLREGDUPE(
15926        INT2PTR(REGEXP *, SvIVX(regex)), param))))
15927     */
15928     PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
15929     PL_regex_pad = AvARRAY(PL_regex_padav);
15930 
15931     PL_stashpadmax	= proto_perl->Istashpadmax;
15932     PL_stashpadix	= proto_perl->Istashpadix ;
15933     Newx(PL_stashpad, PL_stashpadmax, HV *);
15934     {
15935         PADOFFSET o = 0;
15936         for (; o < PL_stashpadmax; ++o)
15937             PL_stashpad[o] = hv_dup(proto_perl->Istashpad[o], param);
15938     }
15939 
15940     /* shortcuts to various I/O objects */
15941     PL_ofsgv            = gv_dup_inc(proto_perl->Iofsgv, param);
15942     PL_stdingv		= gv_dup(proto_perl->Istdingv, param);
15943     PL_stderrgv		= gv_dup(proto_perl->Istderrgv, param);
15944     PL_defgv		= gv_dup(proto_perl->Idefgv, param);
15945     PL_argvgv		= gv_dup_inc(proto_perl->Iargvgv, param);
15946     PL_argvoutgv	= gv_dup(proto_perl->Iargvoutgv, param);
15947     PL_argvout_stack	= av_dup_inc(proto_perl->Iargvout_stack, param);
15948 
15949     /* shortcuts to regexp stuff */
15950     PL_replgv		= gv_dup_inc(proto_perl->Ireplgv, param);
15951 
15952     /* shortcuts to misc objects */
15953     PL_errgv		= gv_dup(proto_perl->Ierrgv, param);
15954 
15955     /* shortcuts to debugging objects */
15956     PL_DBgv		= gv_dup_inc(proto_perl->IDBgv, param);
15957     PL_DBline		= gv_dup_inc(proto_perl->IDBline, param);
15958     PL_DBsub		= gv_dup_inc(proto_perl->IDBsub, param);
15959     PL_DBsingle		= sv_dup(proto_perl->IDBsingle, param);
15960     PL_DBtrace		= sv_dup(proto_perl->IDBtrace, param);
15961     PL_DBsignal		= sv_dup(proto_perl->IDBsignal, param);
15962     Copy(proto_perl->IDBcontrol, PL_DBcontrol, DBVARMG_COUNT, IV);
15963 
15964     /* symbol tables */
15965     PL_defstash		= hv_dup_inc(proto_perl->Idefstash, param);
15966     PL_curstash		= hv_dup_inc(proto_perl->Icurstash, param);
15967     PL_debstash		= hv_dup(proto_perl->Idebstash, param);
15968     PL_globalstash	= hv_dup(proto_perl->Iglobalstash, param);
15969     PL_curstname	= sv_dup_inc(proto_perl->Icurstname, param);
15970 
15971     PL_beginav		= av_dup_inc(proto_perl->Ibeginav, param);
15972     PL_beginav_save	= av_dup_inc(proto_perl->Ibeginav_save, param);
15973     PL_checkav_save	= av_dup_inc(proto_perl->Icheckav_save, param);
15974     PL_unitcheckav      = av_dup_inc(proto_perl->Iunitcheckav, param);
15975     PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
15976     PL_endav		= av_dup_inc(proto_perl->Iendav, param);
15977     PL_checkav		= av_dup_inc(proto_perl->Icheckav, param);
15978     PL_initav		= av_dup_inc(proto_perl->Iinitav, param);
15979     PL_savebegin	= proto_perl->Isavebegin;
15980 
15981     PL_isarev		= hv_dup_inc(proto_perl->Iisarev, param);
15982 
15983     /* subprocess state */
15984     PL_fdpid		= av_dup_inc(proto_perl->Ifdpid, param);
15985 
15986     if (proto_perl->Iop_mask)
15987         PL_op_mask	= SAVEPVN(proto_perl->Iop_mask, PL_maxo);
15988     else
15989         PL_op_mask 	= NULL;
15990     /* PL_asserting        = proto_perl->Iasserting; */
15991 
15992     /* current interpreter roots */
15993     PL_main_cv		= cv_dup_inc(proto_perl->Imain_cv, param);
15994     OP_REFCNT_LOCK;
15995     PL_main_root	= OpREFCNT_inc(proto_perl->Imain_root);
15996     OP_REFCNT_UNLOCK;
15997 
15998     /* runtime control stuff */
15999     PL_curcopdb		= (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
16000 
16001     PL_preambleav	= av_dup_inc(proto_perl->Ipreambleav, param);
16002 
16003     PL_ors_sv		= sv_dup_inc(proto_perl->Iors_sv, param);
16004 
16005     /* interpreter atexit processing */
16006     PL_exitlistlen	= proto_perl->Iexitlistlen;
16007     if (PL_exitlistlen) {
16008         Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
16009         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
16010     }
16011     else
16012         PL_exitlist	= (PerlExitListEntry*)NULL;
16013 
16014     PL_my_cxt_size = proto_perl->Imy_cxt_size;
16015     if (PL_my_cxt_size) {
16016         Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
16017         Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
16018     }
16019     else {
16020         PL_my_cxt_list	= (void**)NULL;
16021     }
16022     PL_modglobal	= hv_dup_inc(proto_perl->Imodglobal, param);
16023     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
16024     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
16025     PL_custom_ops	= hv_dup_inc(proto_perl->Icustom_ops, param);
16026 
16027     PL_compcv			= cv_dup(proto_perl->Icompcv, param);
16028 
16029     PAD_CLONE_VARS(proto_perl, param);
16030 
16031 #ifdef HAVE_INTERP_INTERN
16032     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
16033 #endif
16034 
16035     PL_DBcv		= cv_dup(proto_perl->IDBcv, param);
16036 
16037 #ifdef PERL_USES_PL_PIDSTATUS
16038     PL_pidstatus	= newHV();			/* XXX flag for cloning? */
16039 #endif
16040     PL_osname		= SAVEPV(proto_perl->Iosname);
16041     PL_parser		= parser_dup(proto_perl->Iparser, param);
16042 
16043     /* XXX this only works if the saved cop has already been cloned */
16044     if (proto_perl->Iparser) {
16045         PL_parser->saved_curcop = (COP*)any_dup(
16046                                     proto_perl->Iparser->saved_curcop,
16047                                     proto_perl);
16048     }
16049 
16050     PL_subname		= sv_dup_inc(proto_perl->Isubname, param);
16051 
16052 #ifdef USE_PL_CURLOCALES
16053     for (i = 0; i < (int) C_ARRAY_LENGTH(PL_curlocales); i++) {
16054         PL_curlocales[i] = SAVEPV("C");
16055     }
16056 #endif
16057 #ifdef USE_PL_CUR_LC_ALL
16058     PL_cur_LC_ALL = SAVEPV("C");
16059 #endif
16060 #ifdef USE_LOCALE_CTYPE
16061     Copy(PL_fold, PL_fold_locale, 256, U8);
16062 
16063     /* Should we warn if uses locale? */
16064     PL_ctype_name	= SAVEPV("C");
16065     PL_warn_locale      = sv_dup_inc(proto_perl->Iwarn_locale, param);
16066     PL_in_utf8_CTYPE_locale   = false;
16067     PL_in_utf8_turkic_locale  = false;
16068 #endif
16069 
16070     /* Did the locale setup indicate UTF-8? */
16071     PL_utf8locale	= false;
16072 
16073 #ifdef USE_LOCALE_COLLATE
16074     PL_in_utf8_COLLATE_locale = false;
16075     PL_collation_name	= SAVEPV("C");
16076     PL_collation_ix	= proto_perl->Icollation_ix;
16077     PL_collation_standard = true;
16078     PL_collxfrm_base	= 0;
16079     PL_collxfrm_mult	= 0;
16080     PL_strxfrm_max_cp   = 0;
16081     PL_strxfrm_is_behaved = proto_perl->Istrxfrm_is_behaved;
16082     PL_strxfrm_NUL_replacement = '\0';
16083 #endif /* USE_LOCALE_COLLATE */
16084 
16085 #ifdef USE_LOCALE_THREADS
16086     assert(PL_locale_mutex_depth <= 0);
16087     PL_locale_mutex_depth = 0;
16088 #endif
16089 
16090 #ifdef USE_LOCALE_NUMERIC
16091     PL_numeric_name	= SAVEPV("C");
16092     PL_numeric_radix_sv	= newSVpvs(".");
16093     PL_underlying_radix_sv = newSVpvs(".");
16094     PL_numeric_standard	= true;
16095     PL_numeric_underlying = true;
16096     PL_numeric_underlying_is_standard = true;
16097 
16098 #  if defined(USE_POSIX_2008_LOCALE)
16099     PL_underlying_numeric_obj = NULL;
16100 #  endif
16101 #endif /* !USE_LOCALE_NUMERIC */
16102 #if defined(USE_POSIX_2008_LOCALE)
16103     PL_scratch_locale_obj = NULL;
16104     PL_cur_locale_obj = PL_C_locale_obj;
16105 #endif
16106 
16107 #ifdef HAS_MBRLEN
16108     PL_mbrlen_ps = proto_perl->Imbrlen_ps;
16109 #endif
16110 #ifdef HAS_MBRTOWC
16111     PL_mbrtowc_ps = proto_perl->Imbrtowc_ps;
16112 #endif
16113 #ifdef HAS_WCRTOMB
16114     PL_wcrtomb_ps = proto_perl->Iwcrtomb_ps;
16115 #endif
16116 
16117     PL_langinfo_buf = NULL;
16118     PL_langinfo_bufsize = 0;
16119 
16120     PL_setlocale_buf = NULL;
16121     PL_setlocale_bufsize = 0;
16122 
16123     PL_stdize_locale_buf = NULL;
16124     PL_stdize_locale_bufsize = 0;
16125 
16126     /* Unicode inversion lists */
16127 
16128     PL_AboveLatin1            = sv_dup_inc(proto_perl->IAboveLatin1, param);
16129     PL_Assigned_invlist       = sv_dup_inc(proto_perl->IAssigned_invlist, param);
16130     PL_GCB_invlist            = sv_dup_inc(proto_perl->IGCB_invlist, param);
16131     PL_HasMultiCharFold       = sv_dup_inc(proto_perl->IHasMultiCharFold, param);
16132     PL_InMultiCharFold        = sv_dup_inc(proto_perl->IInMultiCharFold, param);
16133     PL_Latin1                 = sv_dup_inc(proto_perl->ILatin1, param);
16134     PL_LB_invlist             = sv_dup_inc(proto_perl->ILB_invlist, param);
16135     PL_SB_invlist             = sv_dup_inc(proto_perl->ISB_invlist, param);
16136     PL_SCX_invlist            = sv_dup_inc(proto_perl->ISCX_invlist, param);
16137     PL_UpperLatin1            = sv_dup_inc(proto_perl->IUpperLatin1, param);
16138     PL_in_some_fold           = sv_dup_inc(proto_perl->Iin_some_fold, param);
16139     PL_utf8_foldclosures      = sv_dup_inc(proto_perl->Iutf8_foldclosures, param);
16140     PL_utf8_idcont            = sv_dup_inc(proto_perl->Iutf8_idcont, param);
16141     PL_utf8_idstart           = sv_dup_inc(proto_perl->Iutf8_idstart, param);
16142     PL_utf8_perl_idcont       = sv_dup_inc(proto_perl->Iutf8_perl_idcont, param);
16143     PL_utf8_perl_idstart      = sv_dup_inc(proto_perl->Iutf8_perl_idstart, param);
16144     PL_utf8_xidcont           = sv_dup_inc(proto_perl->Iutf8_xidcont, param);
16145     PL_utf8_xidstart          = sv_dup_inc(proto_perl->Iutf8_xidstart, param);
16146     PL_WB_invlist             = sv_dup_inc(proto_perl->IWB_invlist, param);
16147     for (i = 0; i < POSIX_CC_COUNT; i++) {
16148         PL_XPosix_ptrs[i]     = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param);
16149         if (i != CC_CASED_ && i != CC_VERTSPACE_) {
16150             PL_Posix_ptrs[i]  = sv_dup_inc(proto_perl->IPosix_ptrs[i], param);
16151         }
16152     }
16153     PL_Posix_ptrs[CC_CASED_]  = PL_Posix_ptrs[CC_ALPHA_];
16154     PL_Posix_ptrs[CC_VERTSPACE_] = NULL;
16155 
16156     PL_utf8_toupper           = sv_dup_inc(proto_perl->Iutf8_toupper, param);
16157     PL_utf8_totitle           = sv_dup_inc(proto_perl->Iutf8_totitle, param);
16158     PL_utf8_tolower           = sv_dup_inc(proto_perl->Iutf8_tolower, param);
16159     PL_utf8_tofold            = sv_dup_inc(proto_perl->Iutf8_tofold, param);
16160     PL_utf8_tosimplefold      = sv_dup_inc(proto_perl->Iutf8_tosimplefold, param);
16161     PL_utf8_charname_begin    = sv_dup_inc(proto_perl->Iutf8_charname_begin, param);
16162     PL_utf8_charname_continue = sv_dup_inc(proto_perl->Iutf8_charname_continue, param);
16163     PL_utf8_mark              = sv_dup_inc(proto_perl->Iutf8_mark, param);
16164     PL_InBitmap               = sv_dup_inc(proto_perl->IInBitmap, param);
16165     PL_CCC_non0_non230        = sv_dup_inc(proto_perl->ICCC_non0_non230, param);
16166     PL_Private_Use            = sv_dup_inc(proto_perl->IPrivate_Use, param);
16167 
16168 #if 0
16169     PL_seen_deprecated_macro = hv_dup_inc(proto_perl->Iseen_deprecated_macro, param);
16170 #endif
16171 
16172     if (proto_perl->Ipsig_pend) {
16173         Newxz(PL_psig_pend, SIG_SIZE, int);
16174     }
16175     else {
16176         PL_psig_pend	= (int*)NULL;
16177     }
16178 
16179     if (proto_perl->Ipsig_name) {
16180         Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
16181         sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
16182                             param);
16183         PL_psig_ptr = PL_psig_name + SIG_SIZE;
16184     }
16185     else {
16186         PL_psig_ptr	= (SV**)NULL;
16187         PL_psig_name	= (SV**)NULL;
16188     }
16189 
16190     if (flags & CLONEf_COPY_STACKS) {
16191         Newx(PL_tmps_stack, PL_tmps_max, SV*);
16192         sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
16193                             PL_tmps_ix+1, param);
16194 
16195         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
16196         i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
16197         Newx(PL_markstack, i, I32);
16198         PL_markstack_max	= PL_markstack + (proto_perl->Imarkstack_max
16199                                                   - proto_perl->Imarkstack);
16200         PL_markstack_ptr	= PL_markstack + (proto_perl->Imarkstack_ptr
16201                                                   - proto_perl->Imarkstack);
16202         Copy(proto_perl->Imarkstack, PL_markstack,
16203              PL_markstack_ptr - PL_markstack + 1, I32);
16204 
16205         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
16206          * NOTE: unlike the others! */
16207         Newx(PL_scopestack, PL_scopestack_max, I32);
16208         Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
16209 
16210 #ifdef DEBUGGING
16211         Newx(PL_scopestack_name, PL_scopestack_max, const char *);
16212         Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
16213 #endif
16214         /* reset stack AV to correct length before its duped via
16215          * PL_curstackinfo */
16216         AvFILLp(proto_perl->Icurstack) =
16217                             proto_perl->Istack_sp - proto_perl->Istack_base;
16218 
16219         /* NOTE: si_dup() looks at PL_markstack */
16220         PL_curstackinfo		= si_dup(proto_perl->Icurstackinfo, param);
16221 
16222         /* PL_curstack		= PL_curstackinfo->si_stack; */
16223         PL_curstack		= av_dup(proto_perl->Icurstack, param);
16224         PL_mainstack		= av_dup(proto_perl->Imainstack, param);
16225 
16226         /* next PUSHs() etc. set *(PL_stack_sp+1) */
16227         PL_stack_base		= AvARRAY(PL_curstack);
16228         PL_stack_sp		= PL_stack_base + (proto_perl->Istack_sp
16229                                                    - proto_perl->Istack_base);
16230         PL_stack_max		= PL_stack_base + AvMAX(PL_curstack);
16231 
16232         /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
16233         PL_savestack		= ss_dup(proto_perl, param);
16234     }
16235     else {
16236         init_stacks();
16237         ENTER;			/* perl_destruct() wants to LEAVE; */
16238     }
16239 
16240     PL_statgv		= gv_dup(proto_perl->Istatgv, param);
16241     PL_statname		= sv_dup_inc(proto_perl->Istatname, param);
16242 
16243     PL_rs		= sv_dup_inc(proto_perl->Irs, param);
16244     PL_last_in_gv	= gv_dup(proto_perl->Ilast_in_gv, param);
16245     PL_defoutgv		= gv_dup_inc(proto_perl->Idefoutgv, param);
16246     PL_toptarget	= sv_dup_inc(proto_perl->Itoptarget, param);
16247     PL_bodytarget	= sv_dup_inc(proto_perl->Ibodytarget, param);
16248     PL_formtarget	= sv_dup(proto_perl->Iformtarget, param);
16249 
16250     PL_errors		= sv_dup_inc(proto_perl->Ierrors, param);
16251 
16252     PL_sortcop		= (OP*)any_dup(proto_perl->Isortcop, proto_perl);
16253     PL_firstgv		= gv_dup_inc(proto_perl->Ifirstgv, param);
16254     PL_secondgv		= gv_dup_inc(proto_perl->Isecondgv, param);
16255 
16256     PL_stashcache       = newHV();
16257 
16258     PL_watchaddr	= (char **) ptr_table_fetch(PL_ptr_table,
16259                                             proto_perl->Iwatchaddr);
16260     PL_watchok		= PL_watchaddr ? * PL_watchaddr : NULL;
16261     if (PL_debug && PL_watchaddr) {
16262         PerlIO_printf(Perl_debug_log,
16263           "WATCHING: %" UVxf " cloned as %" UVxf " with value %" UVxf "\n",
16264           PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
16265           PTR2UV(PL_watchok));
16266     }
16267 
16268     PL_registered_mros  = hv_dup_inc(proto_perl->Iregistered_mros, param);
16269     PL_blockhooks	= av_dup_inc(proto_perl->Iblockhooks, param);
16270 
16271     /* Call the ->CLONE method, if it exists, for each of the stashes
16272        identified by sv_dup() above.
16273     */
16274     while(av_count(param->stashes) != 0) {
16275         HV* const stash = MUTABLE_HV(av_shift(param->stashes));
16276         GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
16277         if (cloner && GvCV(cloner)) {
16278             dSP;
16279             ENTER;
16280             SAVETMPS;
16281             PUSHMARK(SP);
16282             mXPUSHs(newSVhek(HvNAME_HEK(stash)));
16283             PUTBACK;
16284             call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
16285             FREETMPS;
16286             LEAVE;
16287         }
16288     }
16289 
16290     if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
16291         ptr_table_free(PL_ptr_table);
16292         PL_ptr_table = NULL;
16293     }
16294 
16295     if (!(flags & CLONEf_COPY_STACKS)) {
16296         unreferenced_to_tmp_stack(param->unreferenced);
16297     }
16298 
16299     SvREFCNT_dec(param->stashes);
16300 
16301     /* orphaned? eg threads->new inside BEGIN or use */
16302     if (PL_compcv && ! SvREFCNT(PL_compcv)) {
16303         SvREFCNT_inc_simple_void(PL_compcv);
16304         SAVEFREESV(PL_compcv);
16305     }
16306 
16307     return my_perl;
16308 }
16309 
16310 static void
16311 S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
16312 {
16313     PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK;
16314 
16315     if (AvFILLp(unreferenced) > -1) {
16316         SV **svp = AvARRAY(unreferenced);
16317         SV **const last = svp + AvFILLp(unreferenced);
16318         SSize_t count = 0;
16319 
16320         do {
16321             if (SvREFCNT(*svp) == 1)
16322                 ++count;
16323         } while (++svp <= last);
16324 
16325         EXTEND_MORTAL(count);
16326         svp = AvARRAY(unreferenced);
16327 
16328         do {
16329             if (SvREFCNT(*svp) == 1) {
16330                 /* Our reference is the only one to this SV. This means that
16331                    in this thread, the scalar effectively has a 0 reference.
16332                    That doesn't work (cleanup never happens), so donate our
16333                    reference to it onto the save stack. */
16334                 PL_tmps_stack[++PL_tmps_ix] = *svp;
16335             } else {
16336                 /* As an optimisation, because we are already walking the
16337                    entire array, instead of above doing either
16338                    SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
16339                    release our reference to the scalar, so that at the end of
16340                    the array owns zero references to the scalars it happens to
16341                    point to. We are effectively converting the array from
16342                    AvREAL() on to AvREAL() off. This saves the av_clear()
16343                    (triggered by the SvREFCNT_dec(unreferenced) below) from
16344                    walking the array a second time.  */
16345                 SvREFCNT_dec(*svp);
16346             }
16347 
16348         } while (++svp <= last);
16349         AvREAL_off(unreferenced);
16350     }
16351     SvREFCNT_dec_NN(unreferenced);
16352 }
16353 
16354 void
16355 Perl_clone_params_del(CLONE_PARAMS *param)
16356 {
16357     PerlInterpreter *const was = PERL_GET_THX;
16358     PerlInterpreter *const to = param->new_perl;
16359     dTHXa(to);
16360 
16361     PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
16362 
16363     if (was != to) {
16364         PERL_SET_THX(to);
16365     }
16366 
16367     SvREFCNT_dec(param->stashes);
16368     if (param->unreferenced)
16369         unreferenced_to_tmp_stack(param->unreferenced);
16370 
16371     Safefree(param);
16372 
16373     if (was != to) {
16374         PERL_SET_THX(was);
16375     }
16376 }
16377 
16378 CLONE_PARAMS *
16379 Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
16380 {
16381     /* Need to play this game, as newAV() can call safesysmalloc(), and that
16382        does a dTHX; to get the context from thread local storage.
16383        FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
16384        a version that passes in my_perl.  */
16385     PerlInterpreter *const was = PERL_GET_THX;
16386     CLONE_PARAMS *param;
16387 
16388     PERL_ARGS_ASSERT_CLONE_PARAMS_NEW;
16389 
16390     if (was != to) {
16391         PERL_SET_THX(to);
16392     }
16393 
16394     /* Given that we've set the context, we can do this unshared.  */
16395     Newx(param, 1, CLONE_PARAMS);
16396 
16397     param->flags = 0;
16398     param->proto_perl = from;
16399     param->new_perl = to;
16400     param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
16401     AvREAL_off(param->stashes);
16402     param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
16403 
16404     if (was != to) {
16405         PERL_SET_THX(was);
16406     }
16407     return param;
16408 }
16409 
16410 #endif /* USE_ITHREADS */
16411 
16412 void
16413 Perl_init_constants(pTHX)
16414 {
16415 
16416     SvREFCNT(&PL_sv_undef)	= SvREFCNT_IMMORTAL;
16417     SvFLAGS(&PL_sv_undef)	= SVf_READONLY|SVf_PROTECT|SVt_NULL;
16418     SvANY(&PL_sv_undef)		= NULL;
16419 
16420     SvANY(&PL_sv_no)		= new_XPVNV();
16421     SvREFCNT(&PL_sv_no)		= SvREFCNT_IMMORTAL;
16422     SvFLAGS(&PL_sv_no)		= SVt_PVNV|SVf_READONLY|SVf_PROTECT
16423                                   |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
16424                                   |SVp_POK|SVf_POK|SVf_IsCOW|SVppv_STATIC;
16425 
16426     SvANY(&PL_sv_yes)		= new_XPVNV();
16427     SvREFCNT(&PL_sv_yes)	= SvREFCNT_IMMORTAL;
16428     SvFLAGS(&PL_sv_yes)		= SVt_PVNV|SVf_READONLY|SVf_PROTECT
16429                                   |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
16430                                   |SVp_POK|SVf_POK|SVf_IsCOW|SVppv_STATIC;
16431 
16432     SvANY(&PL_sv_zero)		= new_XPVNV();
16433     SvREFCNT(&PL_sv_zero)	= SvREFCNT_IMMORTAL;
16434     SvFLAGS(&PL_sv_zero)	= SVt_PVNV|SVf_READONLY|SVf_PROTECT
16435                                   |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
16436                                   |SVp_POK|SVf_POK
16437                                   |SVs_PADTMP;
16438 
16439     SvPV_set(&PL_sv_no, (char*)PL_No);
16440     SvCUR_set(&PL_sv_no, 0);
16441     SvLEN_set(&PL_sv_no, 0);
16442     SvIV_set(&PL_sv_no, 0);
16443     SvNV_set(&PL_sv_no, 0);
16444 
16445     SvPV_set(&PL_sv_yes, (char*)PL_Yes);
16446     SvCUR_set(&PL_sv_yes, 1);
16447     SvLEN_set(&PL_sv_yes, 0);
16448     SvIV_set(&PL_sv_yes, 1);
16449     SvNV_set(&PL_sv_yes, 1);
16450 
16451     SvPV_set(&PL_sv_zero, (char*)PL_Zero);
16452     SvCUR_set(&PL_sv_zero, 1);
16453     SvLEN_set(&PL_sv_zero, 0);
16454     SvIV_set(&PL_sv_zero, 0);
16455     SvNV_set(&PL_sv_zero, 0);
16456 
16457     PadnamePV(&PL_padname_const) = (char *)PL_No;
16458 
16459     assert(SvIMMORTAL_INTERP(&PL_sv_yes));
16460     assert(SvIMMORTAL_INTERP(&PL_sv_undef));
16461     assert(SvIMMORTAL_INTERP(&PL_sv_no));
16462     assert(SvIMMORTAL_INTERP(&PL_sv_zero));
16463 
16464     assert(SvIMMORTAL(&PL_sv_yes));
16465     assert(SvIMMORTAL(&PL_sv_undef));
16466     assert(SvIMMORTAL(&PL_sv_no));
16467     assert(SvIMMORTAL(&PL_sv_zero));
16468 
16469     assert( SvIMMORTAL_TRUE(&PL_sv_yes));
16470     assert(!SvIMMORTAL_TRUE(&PL_sv_undef));
16471     assert(!SvIMMORTAL_TRUE(&PL_sv_no));
16472     assert(!SvIMMORTAL_TRUE(&PL_sv_zero));
16473 
16474     assert( SvTRUE_nomg_NN(&PL_sv_yes));
16475     assert(!SvTRUE_nomg_NN(&PL_sv_undef));
16476     assert(!SvTRUE_nomg_NN(&PL_sv_no));
16477     assert(!SvTRUE_nomg_NN(&PL_sv_zero));
16478 }
16479 
16480 /*
16481 =for apidoc_section $unicode
16482 
16483 =for apidoc sv_recode_to_utf8
16484 
16485 C<encoding> is assumed to be an C<Encode> object, on entry the PV
16486 of C<sv> is assumed to be octets in that encoding, and C<sv>
16487 will be converted into Unicode (and UTF-8).
16488 
16489 If C<sv> already is UTF-8 (or if it is not C<POK>), or if C<encoding>
16490 is not a reference, nothing is done to C<sv>.  If C<encoding> is not
16491 an C<Encode::XS> Encoding object, bad things will happen.
16492 (See L<encoding> and L<Encode>.)
16493 
16494 The PV of C<sv> is returned.
16495 
16496 =cut */
16497 
16498 char *
16499 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
16500 {
16501     PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
16502 
16503     if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
16504         SV *uni;
16505         STRLEN len;
16506         const char *s;
16507         dSP;
16508         SV *nsv = sv;
16509         ENTER;
16510         PUSHSTACK;
16511         SAVETMPS;
16512         if (SvPADTMP(nsv)) {
16513             nsv = sv_newmortal();
16514             SvSetSV_nosteal(nsv, sv);
16515         }
16516         save_re_context();
16517         PUSHMARK(sp);
16518         EXTEND(SP, 3);
16519         PUSHs(encoding);
16520         PUSHs(nsv);
16521 /*
16522   NI-S 2002/07/09
16523   Passing sv_yes is wrong - it needs to be or'ed set of constants
16524   for Encode::XS, while UTf-8 decode (currently) assumes a true value means
16525   remove converted chars from source.
16526 
16527   Both will default the value - let them.
16528 
16529         XPUSHs(&PL_sv_yes);
16530 */
16531         PUTBACK;
16532         call_method("decode", G_SCALAR);
16533         SPAGAIN;
16534         uni = POPs;
16535         PUTBACK;
16536         s = SvPV_const(uni, len);
16537         if (s != SvPVX_const(sv)) {
16538             SvGROW(sv, len + 1);
16539             Move(s, SvPVX(sv), len + 1, char);
16540             SvCUR_set(sv, len);
16541         }
16542         FREETMPS;
16543         POPSTACK;
16544         LEAVE;
16545         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
16546             /* clear pos and any utf8 cache */
16547             MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
16548             if (mg)
16549                 mg->mg_len = -1;
16550             if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
16551                 magic_setutf8(sv,mg); /* clear UTF8 cache */
16552         }
16553         SvUTF8_on(sv);
16554         return SvPVX(sv);
16555     }
16556     return SvPOKp(sv) ? SvPVX(sv) : NULL;
16557 }
16558 
16559 /*
16560 =for apidoc sv_cat_decode
16561 
16562 C<encoding> is assumed to be an C<Encode> object, the PV of C<ssv> is
16563 assumed to be octets in that encoding and decoding the input starts
16564 from the position which S<C<(PV + *offset)>> pointed to.  C<dsv> will be
16565 concatenated with the decoded UTF-8 string from C<ssv>.  Decoding will terminate
16566 when the string C<tstr> appears in decoding output or the input ends on
16567 the PV of C<ssv>.  The value which C<offset> points will be modified
16568 to the last input position on C<ssv>.
16569 
16570 Returns TRUE if the terminator was found, else returns FALSE.
16571 
16572 =cut */
16573 
16574 bool
16575 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
16576                    SV *ssv, int *offset, char *tstr, int tlen)
16577 {
16578     bool ret = FALSE;
16579 
16580     PERL_ARGS_ASSERT_SV_CAT_DECODE;
16581 
16582     if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding)) {
16583         SV *offsv;
16584         dSP;
16585         ENTER;
16586         SAVETMPS;
16587         save_re_context();
16588         PUSHMARK(sp);
16589         EXTEND(SP, 6);
16590         PUSHs(encoding);
16591         PUSHs(dsv);
16592         PUSHs(ssv);
16593         offsv = newSViv(*offset);
16594         mPUSHs(offsv);
16595         mPUSHp(tstr, tlen);
16596         PUTBACK;
16597         call_method("cat_decode", G_SCALAR);
16598         SPAGAIN;
16599         ret = SvTRUE(TOPs);
16600         *offset = SvIV(offsv);
16601         PUTBACK;
16602         FREETMPS;
16603         LEAVE;
16604     }
16605     else
16606         Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
16607     return ret;
16608 
16609 }
16610 
16611 /* ---------------------------------------------------------------------
16612  *
16613  * support functions for report_uninit()
16614  */
16615 
16616 /* the maxiumum size of array or hash where we will scan looking
16617  * for the undefined element that triggered the warning */
16618 
16619 #define FUV_MAX_SEARCH_SIZE 1000
16620 
16621 /* Look for an entry in the hash whose value has the same SV as val;
16622  * If so, return a mortal copy of the key. */
16623 
16624 STATIC SV*
16625 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
16626 {
16627     HE **array;
16628     I32 i;
16629 
16630     PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
16631 
16632     if (!hv || SvMAGICAL(hv) || !HvTOTALKEYS(hv) ||
16633                         (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
16634         return NULL;
16635 
16636     if (val == &PL_sv_undef || val == &PL_sv_placeholder)
16637         return NULL;
16638 
16639     array = HvARRAY(hv);
16640 
16641     for (i=HvMAX(hv); i>=0; i--) {
16642         HE *entry;
16643         for (entry = array[i]; entry; entry = HeNEXT(entry)) {
16644             if (HeVAL(entry) == val)
16645                 return newSVhek_mortal(HeKEY_hek(entry));
16646         }
16647     }
16648     return NULL;
16649 }
16650 
16651 /* Look for an entry in the array whose value has the same SV as val;
16652  * If so, return the index, otherwise return -1. */
16653 
16654 STATIC SSize_t
16655 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
16656 {
16657     PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
16658 
16659     if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
16660                         (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
16661         return -1;
16662 
16663     if (val != &PL_sv_undef) {
16664         SV ** const svp = AvARRAY(av);
16665         SSize_t i;
16666 
16667         for (i=AvFILLp(av); i>=0; i--)
16668             if (svp[i] == val)
16669                 return i;
16670     }
16671     return -1;
16672 }
16673 
16674 /* varname(): return the name of a variable, optionally with a subscript.
16675  * If gv is non-zero, use the name of that global, along with gvtype (one
16676  * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
16677  * targ.  Depending on the value of the subscript_type flag, return:
16678  */
16679 
16680 #define FUV_SUBSCRIPT_NONE	1	/* "@foo"          */
16681 #define FUV_SUBSCRIPT_ARRAY	2	/* "$foo[aindex]"  */
16682 #define FUV_SUBSCRIPT_HASH	3	/* "$foo{keyname}" */
16683 #define FUV_SUBSCRIPT_WITHIN	4	/* "within @foo"   */
16684 
16685 SV*
16686 Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
16687         const SV *const keyname, SSize_t aindex, int subscript_type)
16688 {
16689 
16690     SV * const name = sv_newmortal();
16691     if (gv && isGV(gv)) {
16692         char buffer[2];
16693         buffer[0] = gvtype;
16694         buffer[1] = 0;
16695 
16696         /* as gv_fullname4(), but add literal '^' for $^FOO names  */
16697 
16698         gv_fullname4(name, gv, buffer, 0);
16699 
16700         if ((unsigned int)SvPVX(name)[1] <= 26) {
16701             buffer[0] = '^';
16702             buffer[1] = SvPVX(name)[1] + 'A' - 1;
16703 
16704             /* Swap the 1 unprintable control character for the 2 byte pretty
16705                version - ie substr($name, 1, 1) = $buffer; */
16706             sv_insert(name, 1, 1, buffer, 2);
16707         }
16708     }
16709     else {
16710         CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL);
16711         PADNAME *sv;
16712 
16713         assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
16714 
16715         if (!cv || !CvPADLIST(cv))
16716             return NULL;
16717         sv = padnamelist_fetch(PadlistNAMES(CvPADLIST(cv)), targ);
16718         sv_setpvn(name, PadnamePV(sv), PadnameLEN(sv));
16719         SvUTF8_on(name);
16720     }
16721 
16722     if (subscript_type == FUV_SUBSCRIPT_HASH) {
16723         SV * const sv = newSV_type(SVt_NULL);
16724         STRLEN len;
16725         const char * const pv = SvPV_nomg_const((SV*)keyname, len);
16726 
16727         *SvPVX(name) = '$';
16728         Perl_sv_catpvf(aTHX_ name, "{%s}",
16729             pv_pretty(sv, pv, len, 32, NULL, NULL,
16730                     PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT ));
16731         SvREFCNT_dec_NN(sv);
16732     }
16733     else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
16734         *SvPVX(name) = '$';
16735         Perl_sv_catpvf(aTHX_ name, "[%" IVdf "]", (IV)aindex);
16736     }
16737     else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
16738         /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
16739         Perl_sv_insert_flags(aTHX_ name, 0, 0,  STR_WITH_LEN("within "), 0);
16740     }
16741 
16742     return name;
16743 }
16744 
16745 
16746 /*
16747 =apidoc_section $warning
16748 =for apidoc find_uninit_var
16749 
16750 Find the name of the undefined variable (if any) that caused the operator
16751 to issue a "Use of uninitialized value" warning.
16752 If match is true, only return a name if its value matches C<uninit_sv>.
16753 So roughly speaking, if a unary operator (such as C<OP_COS>) generates a
16754 warning, then following the direct child of the op may yield an
16755 C<OP_PADSV> or C<OP_GV> that gives the name of the undefined variable.  On the
16756 other hand, with C<OP_ADD> there are two branches to follow, so we only print
16757 the variable name if we get an exact match.
16758 C<desc_p> points to a string pointer holding the description of the op.
16759 This may be updated if needed.
16760 
16761 The name is returned as a mortal SV.
16762 
16763 Assumes that C<PL_op> is the OP that originally triggered the error, and that
16764 C<PL_comppad>/C<PL_curpad> points to the currently executing pad.
16765 
16766 =cut
16767 */
16768 
16769 STATIC SV *
16770 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
16771                   bool match, const char **desc_p)
16772 {
16773     SV *sv;
16774     const GV *gv;
16775     const OP *o, *o2, *kid;
16776 
16777     PERL_ARGS_ASSERT_FIND_UNINIT_VAR;
16778 
16779     if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
16780                             uninit_sv == &PL_sv_placeholder)))
16781         return NULL;
16782 
16783     switch (obase->op_type) {
16784 
16785     case OP_UNDEF:
16786         /* the optimizer rewrites '$x = undef' to 'undef $x' for lexical
16787          * variables, which can occur as the source of warnings:
16788          *   ($x = undef) =~ s/a/b/;
16789          * The OPpUNDEF_KEEP_PV flag indicates that this used to be an
16790          * assignment op.
16791          * Otherwise undef should not care if its args are undef - any warnings
16792          * will be from tied/magic vars */
16793         if (
16794             (obase->op_private & (OPpTARGET_MY | OPpUNDEF_KEEP_PV)) == (OPpTARGET_MY | OPpUNDEF_KEEP_PV)
16795             && (!match || PAD_SVl(obase->op_targ) == uninit_sv)
16796         ) {
16797             return varname(NULL, '$', obase->op_targ, NULL, 0, FUV_SUBSCRIPT_NONE);
16798         }
16799         break;
16800 
16801     case OP_RV2AV:
16802     case OP_RV2HV:
16803     case OP_PADAV:
16804     case OP_PADHV:
16805       {
16806         const bool pad  = (    obase->op_type == OP_PADAV
16807                             || obase->op_type == OP_PADHV
16808                             || obase->op_type == OP_PADRANGE
16809                           );
16810 
16811         const bool hash = (    obase->op_type == OP_PADHV
16812                             || obase->op_type == OP_RV2HV
16813                             || (obase->op_type == OP_PADRANGE
16814                                 && SvTYPE(PAD_SVl(obase->op_targ)) == SVt_PVHV)
16815                           );
16816         SSize_t index = 0;
16817         SV *keysv = NULL;
16818         int subscript_type = FUV_SUBSCRIPT_WITHIN;
16819 
16820         if (pad) { /* @lex, %lex */
16821             sv = PAD_SVl(obase->op_targ);
16822             gv = NULL;
16823         }
16824         else {
16825             if (cUNOPx(obase)->op_first->op_type == OP_GV) {
16826             /* @global, %global */
16827                 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
16828                 if (!gv)
16829                     break;
16830                 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
16831             }
16832             else if (obase == PL_op) /* @{expr}, %{expr} */
16833                 return find_uninit_var(cUNOPx(obase)->op_first,
16834                                                 uninit_sv, match, desc_p);
16835             else /* @{expr}, %{expr} as a sub-expression */
16836                 return NULL;
16837         }
16838 
16839         /* attempt to find a match within the aggregate */
16840         if (hash) {
16841             keysv = find_hash_subscript((const HV*)sv, uninit_sv);
16842             if (keysv)
16843                 subscript_type = FUV_SUBSCRIPT_HASH;
16844         }
16845         else {
16846             index = find_array_subscript((const AV *)sv, uninit_sv);
16847             if (index >= 0)
16848                 subscript_type = FUV_SUBSCRIPT_ARRAY;
16849         }
16850 
16851         if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
16852             break;
16853 
16854         return varname(gv, (char)(hash ? '%' : '@'), obase->op_targ,
16855                                     keysv, index, subscript_type);
16856       }
16857 
16858     case OP_RV2SV:
16859         if (cUNOPx(obase)->op_first->op_type == OP_GV) {
16860             /* $global */
16861             gv = cGVOPx_gv(cUNOPx(obase)->op_first);
16862             if (!gv || !GvSTASH(gv))
16863                 break;
16864             if (match && (GvSV(gv) != uninit_sv))
16865                 break;
16866             return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
16867         }
16868         /* ${expr} */
16869         return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1, desc_p);
16870 
16871     case OP_PADSV:
16872         if (match && PAD_SVl(obase->op_targ) != uninit_sv)
16873             break;
16874         return varname(NULL, '$', obase->op_targ,
16875                                     NULL, 0, FUV_SUBSCRIPT_NONE);
16876 
16877     case OP_PADSV_STORE:
16878         if (match && PAD_SVl(obase->op_targ) != uninit_sv)
16879             goto do_op;
16880         return varname(NULL, '$', obase->op_targ,
16881                                     NULL, 0, FUV_SUBSCRIPT_NONE);
16882 
16883     case OP_GVSV:
16884         gv = cGVOPx_gv(obase);
16885         if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv))
16886             break;
16887         return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
16888 
16889     case OP_AELEMFAST_LEX:
16890         if (match) {
16891             SV **svp;
16892             AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
16893             if (!av || SvRMAGICAL(av))
16894                 break;
16895             svp = av_fetch(av, (I8)obase->op_private, FALSE);
16896             if (!svp || *svp != uninit_sv)
16897                 break;
16898         }
16899         return varname(NULL, '$', obase->op_targ,
16900                        NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY);
16901 
16902     case OP_AELEMFASTLEX_STORE:
16903         if (match) {
16904             SV **svp;
16905             AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
16906             if (!av || SvRMAGICAL(av))
16907                 goto do_op;
16908             svp = av_fetch(av, (I8)obase->op_private, FALSE);
16909             if (!svp || *svp != uninit_sv)
16910                 goto do_op;
16911         }
16912         return varname(NULL, '$', obase->op_targ,
16913                        NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY);
16914 
16915     case OP_AELEMFAST:
16916         {
16917             gv = cGVOPx_gv(obase);
16918             if (!gv)
16919                 break;
16920             if (match) {
16921                 SV **svp;
16922                 AV *const av = GvAV(gv);
16923                 if (!av || SvRMAGICAL(av))
16924                     break;
16925                 svp = av_fetch(av, (I8)obase->op_private, FALSE);
16926                 if (!svp || *svp != uninit_sv)
16927                     break;
16928             }
16929             return varname(gv, '$', 0,
16930                     NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY);
16931         }
16932         NOT_REACHED; /* NOTREACHED */
16933 
16934     case OP_EXISTS:
16935         o = cUNOPx(obase)->op_first;
16936         if (!o || o->op_type != OP_NULL ||
16937                 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
16938             break;
16939         return find_uninit_var(cBINOPo->op_last, uninit_sv, match, desc_p);
16940 
16941     case OP_AELEM:
16942     case OP_HELEM:
16943     {
16944         bool negate = FALSE;
16945 
16946         if (PL_op == obase)
16947             /* $a[uninit_expr] or $h{uninit_expr} */
16948             return find_uninit_var(cBINOPx(obase)->op_last,
16949                                                 uninit_sv, match, desc_p);
16950 
16951         gv = NULL;
16952         o = cBINOPx(obase)->op_first;
16953         kid = cBINOPx(obase)->op_last;
16954 
16955         /* get the av or hv, and optionally the gv */
16956         sv = NULL;
16957         if  (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
16958             sv = PAD_SV(o->op_targ);
16959         }
16960         else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
16961                 && cUNOPo->op_first->op_type == OP_GV)
16962         {
16963             gv = cGVOPx_gv(cUNOPo->op_first);
16964             if (!gv)
16965                 break;
16966             sv = o->op_type
16967                 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
16968         }
16969         if (!sv)
16970             break;
16971 
16972         if (kid && kid->op_type == OP_NEGATE) {
16973             negate = TRUE;
16974             kid = cUNOPx(kid)->op_first;
16975         }
16976 
16977         if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
16978             /* index is constant */
16979             SV* kidsv;
16980             if (negate) {
16981                 kidsv = newSVpvs_flags("-", SVs_TEMP);
16982                 sv_catsv(kidsv, cSVOPx_sv(kid));
16983             }
16984             else
16985                 kidsv = cSVOPx_sv(kid);
16986             if (match) {
16987                 if (SvMAGICAL(sv))
16988                     break;
16989                 if (obase->op_type == OP_HELEM) {
16990                     HE* he = hv_fetch_ent(MUTABLE_HV(sv), kidsv, 0, 0);
16991                     if (!he || HeVAL(he) != uninit_sv)
16992                         break;
16993                 }
16994                 else {
16995                     SV * const  opsv = cSVOPx_sv(kid);
16996                     const IV  opsviv = SvIV(opsv);
16997                     SV * const * const svp = av_fetch(MUTABLE_AV(sv),
16998                         negate ? - opsviv : opsviv,
16999                         FALSE);
17000                     if (!svp || *svp != uninit_sv)
17001                         break;
17002                 }
17003             }
17004             if (obase->op_type == OP_HELEM)
17005                 return varname(gv, '%', o->op_targ,
17006                             kidsv, 0, FUV_SUBSCRIPT_HASH);
17007             else
17008                 return varname(gv, '@', o->op_targ, NULL,
17009                     negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)),
17010                     FUV_SUBSCRIPT_ARRAY);
17011         }
17012         else {
17013             /* index is an expression;
17014              * attempt to find a match within the aggregate */
17015             if (obase->op_type == OP_HELEM) {
17016                 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
17017                 if (keysv)
17018                     return varname(gv, '%', o->op_targ,
17019                                                 keysv, 0, FUV_SUBSCRIPT_HASH);
17020             }
17021             else {
17022                 const SSize_t index
17023                     = find_array_subscript((const AV *)sv, uninit_sv);
17024                 if (index >= 0)
17025                     return varname(gv, '@', o->op_targ,
17026                                         NULL, index, FUV_SUBSCRIPT_ARRAY);
17027             }
17028             if (match)
17029                 break;
17030             return varname(gv,
17031                 (char)((o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
17032                 ? '@' : '%'),
17033                 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
17034         }
17035         NOT_REACHED; /* NOTREACHED */
17036     }
17037 
17038     case OP_MULTIDEREF: {
17039         /* If we were executing OP_MULTIDEREF when the undef warning
17040          * triggered, then it must be one of the index values within
17041          * that triggered it. If not, then the only possibility is that
17042          * the value retrieved by the last aggregate index might be the
17043          * culprit. For the former, we set PL_multideref_pc each time before
17044          * using an index, so work though the item list until we reach
17045          * that point. For the latter, just work through the entire item
17046          * list; the last aggregate retrieved will be the candidate.
17047          * There is a third rare possibility: something triggered
17048          * magic while fetching an array/hash element. Just display
17049          * nothing in this case.
17050          */
17051 
17052         /* the named aggregate, if any */
17053         PADOFFSET agg_targ = 0;
17054         GV       *agg_gv   = NULL;
17055         /* the last-seen index */
17056         UV        index_type;
17057         PADOFFSET index_targ;
17058         GV       *index_gv;
17059         IV        index_const_iv = 0; /* init for spurious compiler warn */
17060         SV       *index_const_sv;
17061         int       depth = 0;  /* how many array/hash lookups we've done */
17062 
17063         UNOP_AUX_item *items = cUNOP_AUXx(obase)->op_aux;
17064         UNOP_AUX_item *last = NULL;
17065         UV actions = items->uv;
17066         bool is_hv;
17067 
17068         if (PL_op == obase) {
17069             last = PL_multideref_pc;
17070             assert(last >= items && last <= items + items[-1].uv);
17071         }
17072 
17073         assert(actions);
17074 
17075         while (1) {
17076             is_hv = FALSE;
17077             switch (actions & MDEREF_ACTION_MASK) {
17078 
17079             case MDEREF_reload:
17080                 actions = (++items)->uv;
17081                 continue;
17082 
17083             case MDEREF_HV_padhv_helem:               /* $lex{...} */
17084                 is_hv = TRUE;
17085                 /* FALLTHROUGH */
17086             case MDEREF_AV_padav_aelem:               /* $lex[...] */
17087                 agg_targ = (++items)->pad_offset;
17088                 agg_gv = NULL;
17089                 break;
17090 
17091             case MDEREF_HV_gvhv_helem:                /* $pkg{...} */
17092                 is_hv = TRUE;
17093                 /* FALLTHROUGH */
17094             case MDEREF_AV_gvav_aelem:                /* $pkg[...] */
17095                 agg_targ = 0;
17096                 agg_gv = (GV*)UNOP_AUX_item_sv(++items);
17097                 assert(isGV_with_GP(agg_gv));
17098                 break;
17099 
17100             case MDEREF_HV_gvsv_vivify_rv2hv_helem:   /* $pkg->{...} */
17101             case MDEREF_HV_padsv_vivify_rv2hv_helem:  /* $lex->{...} */
17102                 ++items;
17103                 /* FALLTHROUGH */
17104             case MDEREF_HV_pop_rv2hv_helem:           /* expr->{...} */
17105             case MDEREF_HV_vivify_rv2hv_helem:        /* vivify, ->{...} */
17106                 agg_targ = 0;
17107                 agg_gv   = NULL;
17108                 is_hv    = TRUE;
17109                 break;
17110 
17111             case MDEREF_AV_gvsv_vivify_rv2av_aelem:   /* $pkg->[...] */
17112             case MDEREF_AV_padsv_vivify_rv2av_aelem:  /* $lex->[...] */
17113                 ++items;
17114                 /* FALLTHROUGH */
17115             case MDEREF_AV_pop_rv2av_aelem:           /* expr->[...] */
17116             case MDEREF_AV_vivify_rv2av_aelem:        /* vivify, ->[...] */
17117                 agg_targ = 0;
17118                 agg_gv   = NULL;
17119             } /* switch */
17120 
17121             index_targ     = 0;
17122             index_gv       = NULL;
17123             index_const_sv = NULL;
17124 
17125             index_type = (actions & MDEREF_INDEX_MASK);
17126             switch (index_type) {
17127             case MDEREF_INDEX_none:
17128                 break;
17129             case MDEREF_INDEX_const:
17130                 if (is_hv)
17131                     index_const_sv = UNOP_AUX_item_sv(++items)
17132                 else
17133                     index_const_iv = (++items)->iv;
17134                 break;
17135             case MDEREF_INDEX_padsv:
17136                 index_targ = (++items)->pad_offset;
17137                 break;
17138             case MDEREF_INDEX_gvsv:
17139                 index_gv = (GV*)UNOP_AUX_item_sv(++items);
17140                 assert(isGV_with_GP(index_gv));
17141                 break;
17142             }
17143 
17144             if (index_type != MDEREF_INDEX_none)
17145                 depth++;
17146 
17147             if (   index_type == MDEREF_INDEX_none
17148                 || (actions & MDEREF_FLAG_last)
17149                 || (last && items >= last)
17150             )
17151                 break;
17152 
17153             actions >>= MDEREF_SHIFT;
17154         } /* while */
17155 
17156         if (PL_op == obase) {
17157             /* most likely index was undef */
17158 
17159             *desc_p = (    (actions & MDEREF_FLAG_last)
17160                         && (obase->op_private
17161                                 & (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE)))
17162                         ?
17163                             (obase->op_private & OPpMULTIDEREF_EXISTS)
17164                                 ? "exists"
17165                                 : "delete"
17166                         : is_hv ? "hash element" : "array element";
17167             assert(index_type != MDEREF_INDEX_none);
17168             if (index_gv) {
17169                 if (GvSV(index_gv) == uninit_sv)
17170                     return varname(index_gv, '$', 0, NULL, 0,
17171                                                     FUV_SUBSCRIPT_NONE);
17172                 else
17173                     return NULL;
17174             }
17175             if (index_targ) {
17176                 if (PL_curpad[index_targ] == uninit_sv)
17177                     return varname(NULL, '$', index_targ,
17178                                     NULL, 0, FUV_SUBSCRIPT_NONE);
17179                 else
17180                     return NULL;
17181             }
17182             /* If we got to this point it was undef on a const subscript,
17183              * so magic probably involved, e.g. $ISA[0]. Give up. */
17184             return NULL;
17185         }
17186 
17187         /* the SV returned by pp_multideref() was undef, if anything was */
17188 
17189         if (depth != 1)
17190             break;
17191 
17192         if (agg_targ)
17193             sv = PAD_SV(agg_targ);
17194         else if (agg_gv) {
17195             sv = is_hv ? MUTABLE_SV(GvHV(agg_gv)) : MUTABLE_SV(GvAV(agg_gv));
17196             if (!sv)
17197                 break;
17198             }
17199         else
17200             break;
17201 
17202         if (index_type == MDEREF_INDEX_const) {
17203             if (match) {
17204                 if (SvMAGICAL(sv))
17205                     break;
17206                 if (is_hv) {
17207                     HE* he = hv_fetch_ent(MUTABLE_HV(sv), index_const_sv, 0, 0);
17208                     if (!he || HeVAL(he) != uninit_sv)
17209                         break;
17210                 }
17211                 else {
17212                     SV * const * const svp =
17213                             av_fetch(MUTABLE_AV(sv), index_const_iv, FALSE);
17214                     if (!svp || *svp != uninit_sv)
17215                         break;
17216                 }
17217             }
17218             return is_hv
17219                 ? varname(agg_gv, '%', agg_targ,
17220                                 index_const_sv, 0,    FUV_SUBSCRIPT_HASH)
17221                 : varname(agg_gv, '@', agg_targ,
17222                                 NULL, index_const_iv, FUV_SUBSCRIPT_ARRAY);
17223         }
17224         else {
17225             /* index is an var */
17226             if (is_hv) {
17227                 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
17228                 if (keysv)
17229                     return varname(agg_gv, '%', agg_targ,
17230                                                 keysv, 0, FUV_SUBSCRIPT_HASH);
17231             }
17232             else {
17233                 const SSize_t index
17234                     = find_array_subscript((const AV *)sv, uninit_sv);
17235                 if (index >= 0)
17236                     return varname(agg_gv, '@', agg_targ,
17237                                         NULL, index, FUV_SUBSCRIPT_ARRAY);
17238             }
17239             /* look for an element not found */
17240             if (!SvMAGICAL(sv)) {
17241                 SV *index_sv = NULL;
17242                 if (index_targ) {
17243                     index_sv = PL_curpad[index_targ];
17244                 }
17245                 else if (index_gv) {
17246                     index_sv = GvSV(index_gv);
17247                 }
17248                 if (index_sv && !SvMAGICAL(index_sv) && !SvROK(index_sv)) {
17249                     if (is_hv) {
17250                         SV *report_index_sv = SvOK(index_sv) ? index_sv : &PL_sv_no;
17251                         HE *he = hv_fetch_ent(MUTABLE_HV(sv), report_index_sv, 0, 0);
17252                         if (!he) {
17253                             return varname(agg_gv, '%', agg_targ,
17254                                            report_index_sv, 0, FUV_SUBSCRIPT_HASH);
17255                         }
17256                     }
17257                     else {
17258                         SSize_t index = SvOK(index_sv) ? SvIV(index_sv) : 0;
17259                         SV * const * const svp =
17260                             av_fetch(MUTABLE_AV(sv), index, FALSE);
17261                         if (!svp) {
17262                             return varname(agg_gv, '@', agg_targ,
17263                                            NULL, index, FUV_SUBSCRIPT_ARRAY);
17264                         }
17265                     }
17266                 }
17267             }
17268             if (match)
17269                 break;
17270             return varname(agg_gv,
17271                 is_hv ? '%' : '@',
17272                 agg_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
17273         }
17274         NOT_REACHED; /* NOTREACHED */
17275     }
17276 
17277     case OP_AASSIGN:
17278         /* only examine RHS */
17279         return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv,
17280                                                                 match, desc_p);
17281 
17282     case OP_OPEN:
17283         o = cUNOPx(obase)->op_first;
17284         if (   o->op_type == OP_PUSHMARK
17285            || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)
17286         )
17287             o = OpSIBLING(o);
17288 
17289         if (!OpHAS_SIBLING(o)) {
17290             /* one-arg version of open is highly magical */
17291 
17292             if (o->op_type == OP_GV) { /* open FOO; */
17293                 gv = cGVOPx_gv(o);
17294                 if (match && GvSV(gv) != uninit_sv)
17295                     break;
17296                 return varname(gv, '$', 0,
17297                             NULL, 0, FUV_SUBSCRIPT_NONE);
17298             }
17299             /* other possibilities not handled are:
17300              * open $x; or open my $x;	should return '${*$x}'
17301              * open expr;		should return '$'.expr ideally
17302              */
17303              break;
17304         }
17305         match = 1;
17306         goto do_op;
17307 
17308     /* ops where $_ may be an implicit arg */
17309     case OP_TRANS:
17310     case OP_TRANSR:
17311     case OP_SUBST:
17312     case OP_MATCH:
17313         if ( !(obase->op_flags & OPf_STACKED)) {
17314             if (uninit_sv == DEFSV)
17315                 return newSVpvs_flags("$_", SVs_TEMP);
17316             else if (obase->op_targ
17317                   && uninit_sv == PAD_SVl(obase->op_targ))
17318                 return varname(NULL, '$', obase->op_targ, NULL, 0,
17319                                FUV_SUBSCRIPT_NONE);
17320         }
17321         goto do_op;
17322 
17323     case OP_PRTF:
17324     case OP_PRINT:
17325     case OP_SAY:
17326         match = 1; /* print etc can return undef on defined args */
17327         /* skip filehandle as it can't produce 'undef' warning  */
17328         o = cUNOPx(obase)->op_first;
17329         if ((obase->op_flags & OPf_STACKED)
17330             &&
17331                (   o->op_type == OP_PUSHMARK
17332                || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)))
17333             o = OpSIBLING(OpSIBLING(o));
17334         goto do_op2;
17335 
17336 
17337     case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
17338     case OP_CUSTOM: /* XS or custom code could trigger random warnings */
17339 
17340         /* the following ops are capable of returning PL_sv_undef even for
17341          * defined arg(s) */
17342 
17343     case OP_BACKTICK:
17344     case OP_PIPE_OP:
17345     case OP_FILENO:
17346     case OP_BINMODE:
17347     case OP_TIED:
17348     case OP_GETC:
17349     case OP_SYSREAD:
17350     case OP_SEND:
17351     case OP_IOCTL:
17352     case OP_SOCKET:
17353     case OP_SOCKPAIR:
17354     case OP_BIND:
17355     case OP_CONNECT:
17356     case OP_LISTEN:
17357     case OP_ACCEPT:
17358     case OP_SHUTDOWN:
17359     case OP_SSOCKOPT:
17360     case OP_GETPEERNAME:
17361     case OP_FTRREAD:
17362     case OP_FTRWRITE:
17363     case OP_FTREXEC:
17364     case OP_FTROWNED:
17365     case OP_FTEREAD:
17366     case OP_FTEWRITE:
17367     case OP_FTEEXEC:
17368     case OP_FTEOWNED:
17369     case OP_FTIS:
17370     case OP_FTZERO:
17371     case OP_FTSIZE:
17372     case OP_FTFILE:
17373     case OP_FTDIR:
17374     case OP_FTLINK:
17375     case OP_FTPIPE:
17376     case OP_FTSOCK:
17377     case OP_FTBLK:
17378     case OP_FTCHR:
17379     case OP_FTTTY:
17380     case OP_FTSUID:
17381     case OP_FTSGID:
17382     case OP_FTSVTX:
17383     case OP_FTTEXT:
17384     case OP_FTBINARY:
17385     case OP_FTMTIME:
17386     case OP_FTATIME:
17387     case OP_FTCTIME:
17388     case OP_READLINK:
17389     case OP_OPEN_DIR:
17390     case OP_READDIR:
17391     case OP_TELLDIR:
17392     case OP_SEEKDIR:
17393     case OP_REWINDDIR:
17394     case OP_CLOSEDIR:
17395     case OP_GMTIME:
17396     case OP_ALARM:
17397     case OP_SEMGET:
17398     case OP_GETLOGIN:
17399     case OP_SUBSTR:
17400     case OP_AEACH:
17401     case OP_EACH:
17402     case OP_SORT:
17403     case OP_CALLER:
17404     case OP_DOFILE:
17405     case OP_PROTOTYPE:
17406     case OP_NCMP:
17407     case OP_SMARTMATCH:
17408     case OP_UNPACK:
17409     case OP_SYSOPEN:
17410     case OP_SYSSEEK:
17411         match = 1;
17412         goto do_op;
17413 
17414     case OP_ENTERSUB:
17415     case OP_GOTO:
17416         /* XXX tmp hack: these two may call an XS sub, and currently
17417           XS subs don't have a SUB entry on the context stack, so CV and
17418           pad determination goes wrong, and BAD things happen. So, just
17419           don't try to determine the value under those circumstances.
17420           Need a better fix at dome point. DAPM 11/2007 */
17421         break;
17422 
17423     case OP_FLIP:
17424     case OP_FLOP:
17425     {
17426         GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
17427         if (gv && GvSV(gv) == uninit_sv)
17428             return newSVpvs_flags("$.", SVs_TEMP);
17429         goto do_op;
17430     }
17431 
17432     case OP_POS:
17433         /* def-ness of rval pos() is independent of the def-ness of its arg */
17434         if ( !(obase->op_flags & OPf_MOD))
17435             break;
17436         /* FALLTHROUGH */
17437 
17438     case OP_SCHOMP:
17439     case OP_CHOMP:
17440         if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
17441             return newSVpvs_flags("${$/}", SVs_TEMP);
17442         /* FALLTHROUGH */
17443 
17444     default:
17445     do_op:
17446         if (!(obase->op_flags & OPf_KIDS))
17447             break;
17448         o = cUNOPx(obase)->op_first;
17449 
17450     do_op2:
17451         if (!o)
17452             break;
17453 
17454         /* This loop checks all the kid ops, skipping any that cannot pos-
17455          * sibly be responsible for the uninitialized value; i.e., defined
17456          * constants and ops that return nothing.  If there is only one op
17457          * left that is not skipped, then we *know* it is responsible for
17458          * the uninitialized value.  If there is more than one op left, we
17459          * have to look for an exact match in the while() loop below.
17460          * Note that we skip padrange, because the individual pad ops that
17461          * it replaced are still in the tree, so we work on them instead.
17462          */
17463         o2 = NULL;
17464         for (kid=o; kid; kid = OpSIBLING(kid)) {
17465             const OPCODE type = kid->op_type;
17466             if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
17467               || (type == OP_NULL  && ! (kid->op_flags & OPf_KIDS))
17468               || (type == OP_PUSHMARK)
17469               || (type == OP_PADRANGE)
17470             )
17471             continue;
17472 
17473             if (o2) { /* more than one found */
17474                 o2 = NULL;
17475                 break;
17476             }
17477             o2 = kid;
17478         }
17479         if (o2)
17480             return find_uninit_var(o2, uninit_sv, match, desc_p);
17481 
17482         /* scan all args */
17483         while (o) {
17484             sv = find_uninit_var(o, uninit_sv, 1, desc_p);
17485             if (sv)
17486                 return sv;
17487             o = OpSIBLING(o);
17488         }
17489         break;
17490     }
17491     return NULL;
17492 }
17493 
17494 
17495 /*
17496 =for apidoc_section $warning
17497 =for apidoc report_uninit
17498 
17499 Print appropriate "Use of uninitialized variable" warning.
17500 
17501 =cut
17502 */
17503 
17504 void
17505 Perl_report_uninit(pTHX_ const SV *uninit_sv)
17506 {
17507     const char *desc = NULL;
17508     SV* varname = NULL;
17509 
17510     if (PL_op) {
17511         desc = PL_op->op_type == OP_STRINGIFY && PL_op->op_folded
17512                 ? "join or string"
17513                 : PL_op->op_type == OP_MULTICONCAT
17514                     && (PL_op->op_private & OPpMULTICONCAT_FAKE)
17515                 ? "sprintf"
17516                 : OP_DESC(PL_op);
17517         if (uninit_sv && PL_curpad) {
17518             varname = find_uninit_var(PL_op, uninit_sv, 0, &desc);
17519             if (varname)
17520                 sv_insert(varname, 0, 0, " ", 1);
17521         }
17522     }
17523     else if (PL_curstackinfo->si_type == PERLSI_SORT && cxstack_ix == 0)
17524         /* we've reached the end of a sort block or sub,
17525          * and the uninit value is probably what that code returned */
17526         desc = "sort";
17527 
17528     /* PL_warn_uninit_sv is constant */
17529     GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
17530     if (desc)
17531         /* diag_listed_as: Use of uninitialized value%s */
17532         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
17533                 SVfARG(varname ? varname : &PL_sv_no),
17534                 " in ", desc);
17535     else
17536         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
17537                 "", "", "");
17538     GCC_DIAG_RESTORE_STMT;
17539 }
17540 
17541 /*
17542  * ex: set ts=8 sts=4 sw=4 et:
17543  */
17544