File Coverage

sv.c
Criterion Covered Total %
statement 3585 3928 91.3
branch 3563 4770 74.7
condition n/a
subroutine n/a
total 7148 8698 82.2


line stmt bran cond sub time code
1           /* sv.c
2           *
3           * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4           * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall
5           * and others
6           *
7           * You may distribute under the terms of either the GNU General Public
8           * License or the Artistic License, as specified in the README file.
9           *
10           */
11            
12           /*
13           * 'I wonder what the Entish is for "yes" and "no",' he thought.
14           * --Pippin
15           *
16           * [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
17           */
18            
19           /*
20           *
21           *
22           * This file contains the code that creates, manipulates and destroys
23           * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
24           * structure of an SV, so their creation and destruction is handled
25           * here; higher-level functions are in av.c, hv.c, and so on. Opcode
26           * level functions (eg. substr, split, join) for each of the types are
27           * in the pp*.c files.
28           */
29            
30           #include "EXTERN.h"
31           #define PERL_IN_SV_C
32           #include "perl.h"
33           #include "regcomp.h"
34            
35           #ifndef HAS_C99
36           # if __STDC_VERSION__ >= 199901L && !defined(VMS)
37           # define HAS_C99 1
38           # endif
39           #endif
40           #if HAS_C99
41           # include
42           #endif
43            
44           #define FCALL *f
45            
46           #ifdef __Lynx__
47           /* Missing proto on LynxOS */
48           char *gconvert(double, int, int, char *);
49           #endif
50            
51           #ifdef PERL_UTF8_CACHE_ASSERT
52           /* if adding more checks watch out for the following tests:
53           * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
54           * lib/utf8.t lib/Unicode/Collate/t/index.t
55           * --jhi
56           */
57           # define ASSERT_UTF8_CACHE(cache) \
58           STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
59           assert((cache)[2] <= (cache)[3]); \
60           assert((cache)[3] <= (cache)[1]);} \
61           } STMT_END
62           #else
63           # define ASSERT_UTF8_CACHE(cache) NOOP
64           #endif
65            
66           #ifdef PERL_OLD_COPY_ON_WRITE
67           #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
68           #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
69           #endif
70            
71           /* ============================================================================
72            
73           =head1 Allocation and deallocation of SVs.
74            
75           An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
76           sv, av, hv...) contains type and reference count information, and for
77           many types, a pointer to the body (struct xrv, xpv, xpviv...), which
78           contains fields specific to each type. Some types store all they need
79           in the head, so don't have a body.
80            
81           In all but the most memory-paranoid configurations (ex: PURIFY), heads
82           and bodies are allocated out of arenas, which by default are
83           approximately 4K chunks of memory parcelled up into N heads or bodies.
84           Sv-bodies are allocated by their sv-type, guaranteeing size
85           consistency needed to allocate safely from arrays.
86            
87           For SV-heads, the first slot in each arena is reserved, and holds a
88           link to the next arena, some flags, and a note of the number of slots.
89           Snaked through each arena chain is a linked list of free items; when
90           this becomes empty, an extra arena is allocated and divided up into N
91           items which are threaded into the free list.
92            
93           SV-bodies are similar, but they use arena-sets by default, which
94           separate the link and info from the arena itself, and reclaim the 1st
95           slot in the arena. SV-bodies are further described later.
96            
97           The following global variables are associated with arenas:
98            
99           PL_sv_arenaroot pointer to list of SV arenas
100           PL_sv_root pointer to list of free SV structures
101            
102           PL_body_arenas head of linked-list of body arenas
103           PL_body_roots[] array of pointers to list of free bodies of svtype
104           arrays are indexed by the svtype needed
105            
106           A few special SV heads are not allocated from an arena, but are
107           instead directly created in the interpreter structure, eg PL_sv_undef.
108           The size of arenas can be changed from the default by setting
109           PERL_ARENA_SIZE appropriately at compile time.
110            
111           The SV arena serves the secondary purpose of allowing still-live SVs
112           to be located and destroyed during final cleanup.
113            
114           At the lowest level, the macros new_SV() and del_SV() grab and free
115           an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
116           to return the SV to the free list with error checking.) new_SV() calls
117           more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
118           SVs in the free list have their SvTYPE field set to all ones.
119            
120           At the time of very final cleanup, sv_free_arenas() is called from
121           perl_destruct() to physically free all the arenas allocated since the
122           start of the interpreter.
123            
124           The function visit() scans the SV arenas list, and calls a specified
125           function for each SV it finds which is still live - ie which has an SvTYPE
126           other than all 1's, and a non-zero SvREFCNT. visit() is used by the
127           following functions (specified as [function that calls visit()] / [function
128           called by visit() for each SV]):
129            
130           sv_report_used() / do_report_used()
131           dump all remaining SVs (debugging aid)
132            
133           sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
134           do_clean_named_io_objs(),do_curse()
135           Attempt to free all objects pointed to by RVs,
136           try to do the same for all objects indir-
137           ectly referenced by typeglobs too, and
138           then do a final sweep, cursing any
139           objects that remain. Called once from
140           perl_destruct(), prior to calling sv_clean_all()
141           below.
142            
143           sv_clean_all() / do_clean_all()
144           SvREFCNT_dec(sv) each remaining SV, possibly
145           triggering an sv_free(). It also sets the
146           SVf_BREAK flag on the SV to indicate that the
147           refcnt has been artificially lowered, and thus
148           stopping sv_free() from giving spurious warnings
149           about SVs which unexpectedly have a refcnt
150           of zero. called repeatedly from perl_destruct()
151           until there are no SVs left.
152            
153           =head2 Arena allocator API Summary
154            
155           Private API to rest of sv.c
156            
157           new_SV(), del_SV(),
158            
159           new_XPVNV(), del_XPVGV(),
160           etc
161            
162           Public API:
163            
164           sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
165            
166           =cut
167            
168           * ========================================================================= */
169            
170           /*
171           * "A time to plant, and a time to uproot what was planted..."
172           */
173            
174           #ifdef PERL_MEM_LOG
175           # define MEM_LOG_NEW_SV(sv, file, line, func) \
176           Perl_mem_log_new_sv(sv, file, line, func)
177           # define MEM_LOG_DEL_SV(sv, file, line, func) \
178           Perl_mem_log_del_sv(sv, file, line, func)
179           #else
180           # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP
181           # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP
182           #endif
183            
184           #ifdef DEBUG_LEAKING_SCALARS
185           # define FREE_SV_DEBUG_FILE(sv) STMT_START { \
186           if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \
187           } STMT_END
188           # define DEBUG_SV_SERIAL(sv) \
189           DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
190           PTR2UV(sv), (long)(sv)->sv_debug_serial))
191           #else
192           # define FREE_SV_DEBUG_FILE(sv)
193           # define DEBUG_SV_SERIAL(sv) NOOP
194           #endif
195            
196           #ifdef PERL_POISON
197           # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
198           # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val))
199           /* Whilst I'd love to do this, it seems that things like to check on
200           unreferenced scalars
201           # define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
202           */
203           # define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
204           PoisonNew(&SvREFCNT(sv), 1, U32)
205           #else
206           # define SvARENA_CHAIN(sv) SvANY(sv)
207           # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val)
208           # define POSION_SV_HEAD(sv)
209           #endif
210            
211           /* Mark an SV head as unused, and add to free list.
212           *
213           * If SVf_BREAK is set, skip adding it to the free list, as this SV had
214           * its refcount artificially decremented during global destruction, so
215           * there may be dangling pointers to it. The last thing we want in that
216           * case is for it to be reused. */
217            
218           #define plant_SV(p) \
219           STMT_START { \
220           const U32 old_flags = SvFLAGS(p); \
221           MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
222           DEBUG_SV_SERIAL(p); \
223           FREE_SV_DEBUG_FILE(p); \
224           POSION_SV_HEAD(p); \
225           SvFLAGS(p) = SVTYPEMASK; \
226           if (!(old_flags & SVf_BREAK)) { \
227           SvARENA_CHAIN_SET(p, PL_sv_root); \
228           PL_sv_root = (p); \
229           } \
230           --PL_sv_count; \
231           } STMT_END
232            
233           #define uproot_SV(p) \
234           STMT_START { \
235           (p) = PL_sv_root; \
236           PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \
237           ++PL_sv_count; \
238           } STMT_END
239            
240            
241           /* make some more SVs by adding another arena */
242            
243           STATIC SV*
244 4257580         S_more_sv(pTHX)
245           {
246           dVAR;
247           SV* sv;
248           char *chunk; /* must use New here to match call to */
249 4257580         Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
250           sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
251 4257580         uproot_SV(sv);
252 4257580         return sv;
253           }
254            
255           /* new_SV(): return a new, empty SV head */
256            
257           #ifdef DEBUG_LEAKING_SCALARS
258           /* provide a real function for a debugger to play with */
259           STATIC SV*
260           S_new_SV(pTHX_ const char *file, int line, const char *func)
261           {
262           SV* sv;
263            
264           if (PL_sv_root)
265           uproot_SV(sv);
266           else
267           sv = S_more_sv(aTHX);
268           SvANY(sv) = 0;
269           SvREFCNT(sv) = 1;
270           SvFLAGS(sv) = 0;
271           sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
272           sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
273           ? PL_parser->copline
274           : PL_curcop
275           ? CopLINE(PL_curcop)
276           : 0
277           );
278           sv->sv_debug_inpad = 0;
279           sv->sv_debug_parent = NULL;
280           sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
281            
282           sv->sv_debug_serial = PL_sv_serial++;
283            
284           MEM_LOG_NEW_SV(sv, file, line, func);
285           DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
286           PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
287            
288           return sv;
289           }
290           # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
291            
292           #else
293           # define new_SV(p) \
294           STMT_START { \
295           if (PL_sv_root) \
296           uproot_SV(p); \
297           else \
298           (p) = S_more_sv(aTHX); \
299           SvANY(p) = 0; \
300           SvREFCNT(p) = 1; \
301           SvFLAGS(p) = 0; \
302           MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \
303           } STMT_END
304           #endif
305            
306            
307           /* del_SV(): return an empty SV head to the free list */
308            
309           #ifdef DEBUGGING
310            
311           #define del_SV(p) \
312           STMT_START { \
313           if (DEBUG_D_TEST) \
314           del_sv(p); \
315           else \
316           plant_SV(p); \
317           } STMT_END
318            
319           STATIC void
320           S_del_sv(pTHX_ SV *p)
321           {
322           dVAR;
323            
324           PERL_ARGS_ASSERT_DEL_SV;
325            
326           if (DEBUG_D_TEST) {
327           SV* sva;
328           bool ok = 0;
329           for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
330           const SV * const sv = sva + 1;
331           const SV * const svend = &sva[SvREFCNT(sva)];
332           if (p >= sv && p < svend) {
333           ok = 1;
334           break;
335           }
336           }
337           if (!ok) {
338           Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
339           "Attempt to free non-arena SV: 0x%"UVxf
340           pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
341           return;
342           }
343           }
344           plant_SV(p);
345           }
346            
347           #else /* ! DEBUGGING */
348            
349           #define del_SV(p) plant_SV(p)
350            
351           #endif /* DEBUGGING */
352            
353            
354           /*
355           =head1 SV Manipulation Functions
356            
357           =for apidoc sv_add_arena
358            
359           Given a chunk of memory, link it to the head of the list of arenas,
360           and split it into a list of free SVs.
361            
362           =cut
363           */
364            
365           static void
366           S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
367           {
368           dVAR;
369           SV *const sva = MUTABLE_SV(ptr);
370           SV* sv;
371           SV* svend;
372            
373           PERL_ARGS_ASSERT_SV_ADD_ARENA;
374            
375           /* The first SV in an arena isn't an SV. */
376 4257580         SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
377 4257580         SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
378 4257580         SvFLAGS(sva) = flags; /* FAKE if not to be freed */
379            
380 4257580         PL_sv_arenaroot = sva;
381 4257580         PL_sv_root = sva + 1;
382            
383 4257580         svend = &sva[SvREFCNT(sva) - 1];
384 4257580         sv = sva + 1;
385 719531020 100       while (sv < svend) {
386 715273440         SvARENA_CHAIN_SET(sv, (sv + 1));
387           #ifdef DEBUGGING
388           SvREFCNT(sv) = 0;
389           #endif
390           /* Must always set typemask because it's always checked in on cleanup
391           when the arenas are walked looking for objects. */
392 715273440         SvFLAGS(sv) = SVTYPEMASK;
393 715273440         sv++;
394           }
395 4257580         SvARENA_CHAIN_SET(sv, 0);
396           #ifdef DEBUGGING
397           SvREFCNT(sv) = 0;
398           #endif
399 4257580         SvFLAGS(sv) = SVTYPEMASK;
400           }
401            
402           /* visit(): call the named function for each non-free SV in the arenas
403           * whose flags field matches the flags/mask args. */
404            
405           STATIC I32
406 97372         S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
407           {
408           dVAR;
409           SV* sva;
410           I32 visited = 0;
411            
412           PERL_ARGS_ASSERT_VISIT;
413            
414 17127050 100       for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
415 17029682         const SV * const svend = &sva[SvREFCNT(sva)];
416           SV* sv;
417 2895045320 100       for (sv = sva + 1; sv < svend; ++sv) {
418 2878015642 100       if (SvTYPE(sv) != (svtype)SVTYPEMASK
419 1941832460 100       && (sv->sv_flags & mask) == flags
420 95168879 100       && SvREFCNT(sv))
421           {
422 95168875         (FCALL)(aTHX_ sv);
423 95168871         ++visited;
424           }
425           }
426           }
427 97368         return visited;
428           }
429            
430           #ifdef DEBUGGING
431            
432           /* called by sv_report_used() for each live SV */
433            
434           static void
435           do_report_used(pTHX_ SV *const sv)
436           {
437           if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
438           PerlIO_printf(Perl_debug_log, "****\n");
439           sv_dump(sv);
440           }
441           }
442           #endif
443            
444           /*
445           =for apidoc sv_report_used
446            
447           Dump the contents of all SVs not yet freed (debugging aid).
448            
449           =cut
450           */
451            
452           void
453 0         Perl_sv_report_used(pTHX)
454           {
455           #ifdef DEBUGGING
456           visit(do_report_used, 0, 0);
457           #else
458           PERL_UNUSED_CONTEXT;
459           #endif
460 0         }
461            
462           /* called by sv_clean_objs() for each live SV */
463            
464           static void
465 39575099         do_clean_objs(pTHX_ SV *const ref)
466           {
467           dVAR;
468           assert (SvROK(ref));
469           {
470 39575099         SV * const target = SvRV(ref);
471 39575099 100       if (SvOBJECT(target)) {
472           DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
473 1957680 100       if (SvWEAKREF(ref)) {
474 2         sv_del_backref(target, ref);
475 2         SvWEAKREF_off(ref);
476 2         SvRV_set(ref, NULL);
477           } else {
478 1957678         SvROK_off(ref);
479 1957678         SvRV_set(ref, NULL);
480 1957678         SvREFCNT_dec_NN(target);
481           }
482           }
483           }
484 39575095         }
485            
486            
487           /* clear any slots in a GV which hold objects - except IO;
488           * called by sv_clean_objs() for each live GV */
489            
490           static void
491 27766979         do_clean_named_objs(pTHX_ SV *const sv)
492           {
493           dVAR;
494           SV *obj;
495           assert(SvTYPE(sv) == SVt_PVGV);
496           assert(isGV_with_GP(sv));
497 27766979 50       if (!GvGP(sv))
498 27766979         return;
499            
500           /* freeing GP entries may indirectly free the current GV;
501           * hold onto it while we mess with the GP slots */
502           SvREFCNT_inc(sv);
503            
504 27766979 100       if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
    100        
505           DEBUG_D((PerlIO_printf(Perl_debug_log,
506           "Cleaning named glob SV object:\n "), sv_dump(obj)));
507 330         GvSV(sv) = NULL;
508 330         SvREFCNT_dec_NN(obj);
509           }
510 27766979 100       if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
    100        
511           DEBUG_D((PerlIO_printf(Perl_debug_log,
512           "Cleaning named glob AV object:\n "), sv_dump(obj)));
513 4         GvAV(sv) = NULL;
514 4         SvREFCNT_dec_NN(obj);
515           }
516 27766979 100       if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
    100        
517           DEBUG_D((PerlIO_printf(Perl_debug_log,
518           "Cleaning named glob HV object:\n "), sv_dump(obj)));
519 64         GvHV(sv) = NULL;
520 64         SvREFCNT_dec_NN(obj);
521           }
522 27766979 100       if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
    100        
523           DEBUG_D((PerlIO_printf(Perl_debug_log,
524           "Cleaning named glob CV object:\n "), sv_dump(obj)));
525 8         GvCV_set(sv, NULL);
526 8         SvREFCNT_dec_NN(obj);
527           }
528 27766979         SvREFCNT_dec_NN(sv); /* undo the inc above */
529           }
530            
531           /* clear any IO slots in a GV which hold objects (except stderr, defout);
532           * called by sv_clean_objs() for each live GV */
533            
534           static void
535 27821727         do_clean_named_io_objs(pTHX_ SV *const sv)
536           {
537           dVAR;
538           SV *obj;
539           assert(SvTYPE(sv) == SVt_PVGV);
540           assert(isGV_with_GP(sv));
541 27821727 50       if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
    100        
    100        
542 27821727         return;
543            
544           SvREFCNT_inc(sv);
545 27773283 50       if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
    50        
    50        
    100        
    50        
546           DEBUG_D((PerlIO_printf(Perl_debug_log,
547           "Cleaning named glob IO object:\n "), sv_dump(obj)));
548 270939         GvIOp(sv) = NULL;
549 270939         SvREFCNT_dec_NN(obj);
550           }
551 27773283         SvREFCNT_dec_NN(sv); /* undo the inc above */
552           }
553            
554           /* Void wrapper to pass to visit() */
555           static void
556 53514         do_curse(pTHX_ SV * const sv) {
557 53514 100       if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
    50        
    50        
    50        
    50        
    100        
558 29310 50       || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
    50        
    50        
    50        
    50        
    100        
559 53514         return;
560 9748         (void)curse(sv, 0);
561           }
562            
563           /*
564           =for apidoc sv_clean_objs
565            
566           Attempt to destroy all objects not yet freed.
567            
568           =cut
569           */
570            
571           void
572 24346         Perl_sv_clean_objs(pTHX)
573           {
574           dVAR;
575           GV *olddef, *olderr;
576 24346         PL_in_clean_objs = TRUE;
577 24346         visit(do_clean_objs, SVf_ROK, SVf_ROK);
578           /* Some barnacles may yet remain, clinging to typeglobs.
579           * Run the non-IO destructors first: they may want to output
580           * error messages, close files etc */
581 24342         visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
582 24342         visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
583           /* And if there are some very tenacious barnacles clinging to arrays,
584           closures, or what have you.... */
585 24342         visit(do_curse, SVs_OBJECT, SVs_OBJECT);
586 24342         olddef = PL_defoutgv;
587 24342         PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
588 24342 100       if (olddef && isGV_with_GP(olddef))
    50        
    50        
589 24224         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
590 24342         olderr = PL_stderrgv;
591 24342         PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
592 24342 100       if (olderr && isGV_with_GP(olderr))
    50        
    50        
593 24220         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
594 24342         SvREFCNT_dec(olddef);
595 24342         PL_in_clean_objs = FALSE;
596 24342         }
597            
598           /* called by sv_clean_all() for each live SV */
599            
600           static void
601 0         do_clean_all(pTHX_ SV *const sv)
602           {
603           dVAR;
604 0 0       if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
    0        
605           /* don't clean pid table and strtab */
606 0         return;
607           }
608           DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
609 0         SvFLAGS(sv) |= SVf_BREAK;
610 0         SvREFCNT_dec_NN(sv);
611           }
612            
613           /*
614           =for apidoc sv_clean_all
615            
616           Decrement the refcnt of each remaining SV, possibly triggering a
617           cleanup. This function may have to be called multiple times to free
618           SVs which are in complex self-referential hierarchies.
619            
620           =cut
621           */
622            
623           I32
624 0         Perl_sv_clean_all(pTHX)
625           {
626           dVAR;
627           I32 cleaned;
628 0         PL_in_clean_all = TRUE;
629 0         cleaned = visit(do_clean_all, 0,0);
630 0         return cleaned;
631           }
632            
633           /*
634           ARENASETS: a meta-arena implementation which separates arena-info
635           into struct arena_set, which contains an array of struct
636           arena_descs, each holding info for a single arena. By separating
637           the meta-info from the arena, we recover the 1st slot, formerly
638           borrowed for list management. The arena_set is about the size of an
639           arena, avoiding the needless malloc overhead of a naive linked-list.
640            
641           The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
642           memory in the last arena-set (1/2 on average). In trade, we get
643           back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
644           smaller types). The recovery of the wasted space allows use of
645           small arenas for large, rare body types, by changing array* fields
646           in body_details_by_type[] below.
647           */
648           struct arena_desc {
649           char *arena; /* the raw storage, allocated aligned */
650           size_t size; /* its size ~4k typ */
651           svtype utype; /* bodytype stored in arena */
652           };
653            
654           struct arena_set;
655            
656           /* Get the maximum number of elements in set[] such that struct arena_set
657           will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
658           therefore likely to be 1 aligned memory page. */
659            
660           #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
661           - 2 * sizeof(int)) / sizeof (struct arena_desc))
662            
663           struct arena_set {
664           struct arena_set* next;
665           unsigned int set_size; /* ie ARENAS_PER_SET */
666           unsigned int curr; /* index of next available arena-desc */
667           struct arena_desc set[ARENAS_PER_SET];
668           };
669            
670           /*
671           =for apidoc sv_free_arenas
672            
673           Deallocate the memory used by all arenas. Note that all the individual SV
674           heads and bodies within the arenas must already have been freed.
675            
676           =cut
677           */
678           void
679 0         Perl_sv_free_arenas(pTHX)
680           {
681           dVAR;
682           SV* sva;
683           SV* svanext;
684           unsigned int i;
685            
686           /* Free arenas here, but be careful about fake ones. (We assume
687           contiguity of the fake ones with the corresponding real ones.) */
688            
689 0 0       for (sva = PL_sv_arenaroot; sva; sva = svanext) {
690 0         svanext = MUTABLE_SV(SvANY(sva));
691 0 0       while (svanext && SvFAKE(svanext))
    0        
692 0         svanext = MUTABLE_SV(SvANY(svanext));
693            
694 0 0       if (!SvFAKE(sva))
695 0         Safefree(sva);
696           }
697            
698           {
699 0         struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
700            
701 0 0       while (aroot) {
702           struct arena_set *current = aroot;
703 0         i = aroot->curr;
704 0 0       while (i--) {
705           assert(aroot->set[i].arena);
706 0         Safefree(aroot->set[i].arena);
707           }
708 0         aroot = aroot->next;
709 0         Safefree(current);
710           }
711           }
712 0         PL_body_arenas = 0;
713            
714           i = PERL_ARENA_ROOTS_SIZE;
715 0 0       while (i--)
716 0         PL_body_roots[i] = 0;
717            
718 0         PL_sv_arenaroot = 0;
719 0         PL_sv_root = 0;
720 0         }
721            
722           /*
723           Here are mid-level routines that manage the allocation of bodies out
724           of the various arenas. There are 5 kinds of arenas:
725            
726           1. SV-head arenas, which are discussed and handled above
727           2. regular body arenas
728           3. arenas for reduced-size bodies
729           4. Hash-Entry arenas
730            
731           Arena types 2 & 3 are chained by body-type off an array of
732           arena-root pointers, which is indexed by svtype. Some of the
733           larger/less used body types are malloced singly, since a large
734           unused block of them is wasteful. Also, several svtypes dont have
735           bodies; the data fits into the sv-head itself. The arena-root
736           pointer thus has a few unused root-pointers (which may be hijacked
737           later for arena types 4,5)
738            
739           3 differs from 2 as an optimization; some body types have several
740           unused fields in the front of the structure (which are kept in-place
741           for consistency). These bodies can be allocated in smaller chunks,
742           because the leading fields arent accessed. Pointers to such bodies
743           are decremented to point at the unused 'ghost' memory, knowing that
744           the pointers are used with offsets to the real memory.
745            
746            
747           =head1 SV-Body Allocation
748            
749           Allocation of SV-bodies is similar to SV-heads, differing as follows;
750           the allocation mechanism is used for many body types, so is somewhat
751           more complicated, it uses arena-sets, and has no need for still-live
752           SV detection.
753            
754           At the outermost level, (new|del)_X*V macros return bodies of the
755           appropriate type. These macros call either (new|del)_body_type or
756           (new|del)_body_allocated macro pairs, depending on specifics of the
757           type. Most body types use the former pair, the latter pair is used to
758           allocate body types with "ghost fields".
759            
760           "ghost fields" are fields that are unused in certain types, and
761           consequently don't need to actually exist. They are declared because
762           they're part of a "base type", which allows use of functions as
763           methods. The simplest examples are AVs and HVs, 2 aggregate types
764           which don't use the fields which support SCALAR semantics.
765            
766           For these types, the arenas are carved up into appropriately sized
767           chunks, we thus avoid wasted memory for those unaccessed members.
768           When bodies are allocated, we adjust the pointer back in memory by the
769           size of the part not allocated, so it's as if we allocated the full
770           structure. (But things will all go boom if you write to the part that
771           is "not there", because you'll be overwriting the last members of the
772           preceding structure in memory.)
773            
774           We calculate the correction using the STRUCT_OFFSET macro on the first
775           member present. If the allocated structure is smaller (no initial NV
776           actually allocated) then the net effect is to subtract the size of the NV
777           from the pointer, to return a new pointer as if an initial NV were actually
778           allocated. (We were using structures named *_allocated for this, but
779           this turned out to be a subtle bug, because a structure without an NV
780           could have a lower alignment constraint, but the compiler is allowed to
781           optimised accesses based on the alignment constraint of the actual pointer
782           to the full structure, for example, using a single 64 bit load instruction
783           because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
784            
785           This is the same trick as was used for NV and IV bodies. Ironically it
786           doesn't need to be used for NV bodies any more, because NV is now at
787           the start of the structure. IV bodies don't need it either, because
788           they are no longer allocated.
789            
790           In turn, the new_body_* allocators call S_new_body(), which invokes
791           new_body_inline macro, which takes a lock, and takes a body off the
792           linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
793           necessary to refresh an empty list. Then the lock is released, and
794           the body is returned.
795            
796           Perl_more_bodies allocates a new arena, and carves it up into an array of N
797           bodies, which it strings into a linked list. It looks up arena-size
798           and body-size from the body_details table described below, thus
799           supporting the multiple body-types.
800            
801           If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
802           the (new|del)_X*V macros are mapped directly to malloc/free.
803            
804           For each sv-type, struct body_details bodies_by_type[] carries
805           parameters which control these aspects of SV handling:
806            
807           Arena_size determines whether arenas are used for this body type, and if
808           so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
809           zero, forcing individual mallocs and frees.
810            
811           Body_size determines how big a body is, and therefore how many fit into
812           each arena. Offset carries the body-pointer adjustment needed for
813           "ghost fields", and is used in *_allocated macros.
814            
815           But its main purpose is to parameterize info needed in
816           Perl_sv_upgrade(). The info here dramatically simplifies the function
817           vs the implementation in 5.8.8, making it table-driven. All fields
818           are used for this, except for arena_size.
819            
820           For the sv-types that have no bodies, arenas are not used, so those
821           PL_body_roots[sv_type] are unused, and can be overloaded. In
822           something of a special case, SVt_NULL is borrowed for HE arenas;
823           PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
824           bodies_by_type[SVt_NULL] slot is not used, as the table is not
825           available in hv.c.
826            
827           */
828            
829           struct body_details {
830           U8 body_size; /* Size to allocate */
831           U8 copy; /* Size of structure to copy (may be shorter) */
832           U8 offset;
833           unsigned int type : 4; /* We have space for a sanity check. */
834           unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
835           unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
836           unsigned int arena : 1; /* Allocated from an arena */
837           size_t arena_size; /* Size of arena to allocate */
838           };
839            
840           #define HADNV FALSE
841           #define NONV TRUE
842            
843            
844           #ifdef PURIFY
845           /* With -DPURFIY we allocate everything directly, and don't use arenas.
846           This seems a rather elegant way to simplify some of the code below. */
847           #define HASARENA FALSE
848           #else
849           #define HASARENA TRUE
850           #endif
851           #define NOARENA FALSE
852            
853           /* Size the arenas to exactly fit a given number of bodies. A count
854           of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
855           simplifying the default. If count > 0, the arena is sized to fit
856           only that many bodies, allowing arenas to be used for large, rare
857           bodies (XPVFM, XPVIO) without undue waste. The arena size is
858           limited by PERL_ARENA_SIZE, so we can safely oversize the
859           declarations.
860           */
861           #define FIT_ARENA0(body_size) \
862           ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
863           #define FIT_ARENAn(count,body_size) \
864           ( count * body_size <= PERL_ARENA_SIZE) \
865           ? count * body_size \
866           : FIT_ARENA0 (body_size)
867           #define FIT_ARENA(count,body_size) \
868           count \
869           ? FIT_ARENAn (count, body_size) \
870           : FIT_ARENA0 (body_size)
871            
872           /* Calculate the length to copy. Specifically work out the length less any
873           final padding the compiler needed to add. See the comment in sv_upgrade
874           for why copying the padding proved to be a bug. */
875            
876           #define copy_length(type, last_member) \
877           STRUCT_OFFSET(type, last_member) \
878           + sizeof (((type*)SvANY((const SV *)0))->last_member)
879            
880           static const struct body_details bodies_by_type[] = {
881           /* HEs use this offset for their arena. */
882           { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
883            
884           /* IVs are in the head, so the allocation size is 0. */
885           { 0,
886           sizeof(IV), /* This is used to copy out the IV body. */
887           STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
888           NOARENA /* IVS don't need an arena */, 0
889           },
890            
891           { sizeof(NV), sizeof(NV),
892           STRUCT_OFFSET(XPVNV, xnv_u),
893           SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
894            
895           { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
896           copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
897           + STRUCT_OFFSET(XPV, xpv_cur),
898           SVt_PV, FALSE, NONV, HASARENA,
899           FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
900            
901           { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur),
902           copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur),
903           + STRUCT_OFFSET(XPV, xpv_cur),
904           SVt_INVLIST, TRUE, NONV, HASARENA,
905           FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) },
906            
907           { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
908           copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
909           + STRUCT_OFFSET(XPV, xpv_cur),
910           SVt_PVIV, FALSE, NONV, HASARENA,
911           FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
912            
913           { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
914           copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
915           + STRUCT_OFFSET(XPV, xpv_cur),
916           SVt_PVNV, FALSE, HADNV, HASARENA,
917           FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
918            
919           { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
920           HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
921            
922           { sizeof(regexp),
923           sizeof(regexp),
924           0,
925           SVt_REGEXP, TRUE, NONV, HASARENA,
926           FIT_ARENA(0, sizeof(regexp))
927           },
928            
929           { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
930           HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
931          
932           { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
933           HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
934            
935           { sizeof(XPVAV),
936           copy_length(XPVAV, xav_alloc),
937           0,
938           SVt_PVAV, TRUE, NONV, HASARENA,
939           FIT_ARENA(0, sizeof(XPVAV)) },
940            
941           { sizeof(XPVHV),
942           copy_length(XPVHV, xhv_max),
943           0,
944           SVt_PVHV, TRUE, NONV, HASARENA,
945           FIT_ARENA(0, sizeof(XPVHV)) },
946            
947           { sizeof(XPVCV),
948           sizeof(XPVCV),
949           0,
950           SVt_PVCV, TRUE, NONV, HASARENA,
951           FIT_ARENA(0, sizeof(XPVCV)) },
952            
953           { sizeof(XPVFM),
954           sizeof(XPVFM),
955           0,
956           SVt_PVFM, TRUE, NONV, NOARENA,
957           FIT_ARENA(20, sizeof(XPVFM)) },
958            
959           { sizeof(XPVIO),
960           sizeof(XPVIO),
961           0,
962           SVt_PVIO, TRUE, NONV, HASARENA,
963           FIT_ARENA(24, sizeof(XPVIO)) },
964           };
965            
966           #define new_body_allocated(sv_type) \
967           (void *)((char *)S_new_body(aTHX_ sv_type) \
968           - bodies_by_type[sv_type].offset)
969            
970           /* return a thing to the free list */
971            
972           #define del_body(thing, root) \
973           STMT_START { \
974           void ** const thing_copy = (void **)thing; \
975           *thing_copy = *root; \
976           *root = (void*)thing_copy; \
977           } STMT_END
978            
979           #ifdef PURIFY
980            
981           #define new_XNV() safemalloc(sizeof(XPVNV))
982           #define new_XPVNV() safemalloc(sizeof(XPVNV))
983           #define new_XPVMG() safemalloc(sizeof(XPVMG))
984            
985           #define del_XPVGV(p) safefree(p)
986            
987           #else /* !PURIFY */
988            
989           #define new_XNV() new_body_allocated(SVt_NV)
990           #define new_XPVNV() new_body_allocated(SVt_PVNV)
991           #define new_XPVMG() new_body_allocated(SVt_PVMG)
992            
993           #define del_XPVGV(p) del_body(p + bodies_by_type[SVt_PVGV].offset, \
994           &PL_body_roots[SVt_PVGV])
995            
996           #endif /* PURIFY */
997            
998           /* no arena for you! */
999            
1000           #define new_NOARENA(details) \
1001           safemalloc((details)->body_size + (details)->offset)
1002           #define new_NOARENAZ(details) \
1003           safecalloc((details)->body_size + (details)->offset, 1)
1004            
1005           void *
1006 4609978         Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
1007           const size_t arena_size)
1008           {
1009           dVAR;
1010 4609978         void ** const root = &PL_body_roots[sv_type];
1011           struct arena_desc *adesc;
1012 4609978         struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1013           unsigned int curr;
1014           char *start;
1015           const char *end;
1016           const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1017           #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1018           static bool done_sanity_check;
1019            
1020           /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1021           * variables like done_sanity_check. */
1022           if (!done_sanity_check) {
1023           unsigned int i = SVt_LAST;
1024            
1025           done_sanity_check = TRUE;
1026            
1027           while (i--)
1028           assert (bodies_by_type[i].type == i);
1029           }
1030           #endif
1031            
1032           assert(arena_size);
1033            
1034           /* may need new arena-set to hold new arena */
1035 4609978 100       if (!aroot || aroot->curr >= aroot->set_size) {
    100        
1036           struct arena_set *newroot;
1037 45172         Newxz(newroot, 1, struct arena_set);
1038 45172         newroot->set_size = ARENAS_PER_SET;
1039 45172         newroot->next = aroot;
1040           aroot = newroot;
1041 45172         PL_body_arenas = (void *) newroot;
1042           DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1043           }
1044            
1045           /* ok, now have arena-set with at least 1 empty/available arena-desc */
1046 4609978         curr = aroot->curr++;
1047 4609978         adesc = &(aroot->set[curr]);
1048           assert(!adesc->arena);
1049          
1050 4609978         Newx(adesc->arena, good_arena_size, char);
1051 4609978         adesc->size = good_arena_size;
1052 4609978         adesc->utype = sv_type;
1053           DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
1054           curr, (void*)adesc->arena, (UV)good_arena_size));
1055            
1056 4609978         start = (char *) adesc->arena;
1057            
1058           /* Get the address of the byte after the end of the last body we can fit.
1059           Remember, this is integer division: */
1060 4609978         end = start + good_arena_size / body_size * body_size;
1061            
1062           /* computed count doesn't reflect the 1st slot reservation */
1063           #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1064           DEBUG_m(PerlIO_printf(Perl_debug_log,
1065           "arena %p end %p arena-size %d (from %d) type %d "
1066           "size %d ct %d\n",
1067           (void*)start, (void*)end, (int)good_arena_size,
1068           (int)arena_size, sv_type, (int)body_size,
1069           (int)good_arena_size / (int)body_size));
1070           #else
1071           DEBUG_m(PerlIO_printf(Perl_debug_log,
1072           "arena %p end %p arena-size %d type %d size %d ct %d\n",
1073           (void*)start, (void*)end,
1074           (int)arena_size, sv_type, (int)body_size,
1075           (int)good_arena_size / (int)body_size));
1076           #endif
1077 4609978         *root = (void *)start;
1078            
1079           while (1) {
1080           /* Where the next body would start: */
1081 590962958         char * const next = start + body_size;
1082            
1083 590962958 100       if (next >= end) {
1084           /* This is the last body: */
1085           assert(next == end);
1086            
1087 4609978         *(void **)start = 0;
1088 4609978         return *root;
1089           }
1090            
1091 586352980         *(void**) start = (void *)next;
1092           start = next;
1093 586352980         }
1094           }
1095            
1096           /* grab a new thing from the free list, allocating more if necessary.
1097           The inline version is used for speed in hot routines, and the
1098           function using it serves the rest (unless PURIFY).
1099           */
1100           #define new_body_inline(xpv, sv_type) \
1101           STMT_START { \
1102           void ** const r3wt = &PL_body_roots[sv_type]; \
1103           xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
1104           ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1105           bodies_by_type[sv_type].body_size,\
1106           bodies_by_type[sv_type].arena_size)); \
1107           *(r3wt) = *(void**)(xpv); \
1108           } STMT_END
1109            
1110           #ifndef PURIFY
1111            
1112           STATIC void *
1113 35916050         S_new_body(pTHX_ const svtype sv_type)
1114           {
1115           dVAR;
1116           void *xpv;
1117 35916050 100       new_body_inline(xpv, sv_type);
1118 35916050         return xpv;
1119           }
1120            
1121           #endif
1122            
1123           static const struct body_details fake_rv =
1124           { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1125            
1126           /*
1127           =for apidoc sv_upgrade
1128            
1129           Upgrade an SV to a more complex form. Generally adds a new body type to the
1130           SV, then copies across as much information as possible from the old body.
1131           It croaks if the SV is already in a more complex form than requested. You
1132           generally want to use the C macro wrapper, which checks the type
1133           before calling C, and hence does not croak. See also
1134           C.
1135            
1136           =cut
1137           */
1138            
1139           void
1140 4246335395         Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
1141           {
1142           dVAR;
1143           void* old_body;
1144           void* new_body;
1145 4246335395         const svtype old_type = SvTYPE(sv);
1146           const struct body_details *new_type_details;
1147 4246335395         const struct body_details *old_type_details
1148 4246335395         = bodies_by_type + old_type;
1149           SV *referant = NULL;
1150            
1151           PERL_ARGS_ASSERT_SV_UPGRADE;
1152            
1153 4246335395 100       if (old_type == new_type)
1154           return;
1155            
1156           /* This clause was purposefully added ahead of the early return above to
1157           the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1158           inference by Nick I-S that it would fix other troublesome cases. See
1159           changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1160            
1161           Given that shared hash key scalars are no longer PVIV, but PV, there is
1162           no longer need to unshare so as to free up the IVX slot for its proper
1163           purpose. So it's safe to move the early return earlier. */
1164            
1165 4243940283 100       if (new_type > SVt_PVMG && SvIsCOW(sv)) {
    50        
1166 0         sv_force_normal_flags(sv, 0);
1167           }
1168            
1169 4243940283         old_body = SvANY(sv);
1170            
1171           /* Copying structures onto other structures that have been neatly zeroed
1172           has a subtle gotcha. Consider XPVMG
1173            
1174           +------+------+------+------+------+-------+-------+
1175           | NV | CUR | LEN | IV | MAGIC | STASH |
1176           +------+------+------+------+------+-------+-------+
1177           0 4 8 12 16 20 24 28
1178            
1179           where NVs are aligned to 8 bytes, so that sizeof that structure is
1180           actually 32 bytes long, with 4 bytes of padding at the end:
1181            
1182           +------+------+------+------+------+-------+-------+------+
1183           | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1184           +------+------+------+------+------+-------+-------+------+
1185           0 4 8 12 16 20 24 28 32
1186            
1187           so what happens if you allocate memory for this structure:
1188            
1189           +------+------+------+------+------+-------+-------+------+------+...
1190           | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1191           +------+------+------+------+------+-------+-------+------+------+...
1192           0 4 8 12 16 20 24 28 32 36
1193            
1194           zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1195           expect, because you copy the area marked ??? onto GP. Now, ??? may have
1196           started out as zero once, but it's quite possible that it isn't. So now,
1197           rather than a nicely zeroed GP, you have it pointing somewhere random.
1198           Bugs ensue.
1199            
1200           (In fact, GP ends up pointing at a previous GP structure, because the
1201           principle cause of the padding in XPVMG getting garbage is a copy of
1202           sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1203           this happens to be moot because XPVGV has been re-ordered, with GP
1204           no longer after STASH)
1205            
1206           So we are careful and work out the size of used parts of all the
1207           structures. */
1208            
1209 4243940283         switch (old_type) {
1210           case SVt_NULL:
1211           break;
1212           case SVt_IV:
1213 170477263 100       if (SvROK(sv)) {
1214 42598         referant = SvRV(sv);
1215           old_type_details = &fake_rv;
1216 42598 50       if (new_type == SVt_NV)
1217           new_type = SVt_PVNV;
1218           } else {
1219 170434665 100       if (new_type < SVt_PVIV) {
1220 2324856 100       new_type = (new_type == SVt_NV)
1221           ? SVt_PVNV : SVt_PVIV;
1222           }
1223           }
1224           break;
1225           case SVt_NV:
1226 2303163 100       if (new_type < SVt_PVNV) {
1227           new_type = SVt_PVNV;
1228           }
1229           break;
1230           case SVt_PV:
1231           assert(new_type > SVt_PV);
1232           assert(SVt_IV < SVt_PV);
1233           assert(SVt_NV < SVt_PV);
1234           break;
1235           case SVt_PVIV:
1236           break;
1237           case SVt_PVNV:
1238           break;
1239           case SVt_PVMG:
1240           /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1241           there's no way that it can be safely upgraded, because perl.c
1242           expects to Safefree(SvANY(PL_mess_sv)) */
1243           assert(sv != PL_mess_sv);
1244           /* This flag bit is used to mean other things in other scalar types.
1245           Given that it only has meaning inside the pad, it shouldn't be set
1246           on anything that can get upgraded. */
1247           assert(!SvPAD_TYPED(sv));
1248           break;
1249           default:
1250 0 0       if (UNLIKELY(old_type_details->cant_upgrade))
1251 0         Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1252           sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1253           }
1254            
1255 4243940283 50       if (UNLIKELY(old_type > new_type))
1256 0         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1257           (int)old_type, (int)new_type);
1258            
1259 4243940283         new_type_details = bodies_by_type + new_type;
1260            
1261 4243940283         SvFLAGS(sv) &= ~SVTYPEMASK;
1262 4243940283         SvFLAGS(sv) |= new_type;
1263            
1264           /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1265           the return statements above will have triggered. */
1266           assert (new_type != SVt_NULL);
1267 4243940283         switch (new_type) {
1268           case SVt_IV:
1269           assert(old_type == SVt_NULL);
1270 1904381913         SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1271 1904381913         SvIV_set(sv, 0);
1272 1904381913         return;
1273           case SVt_NV:
1274           assert(old_type == SVt_NULL);
1275 8784664         SvANY(sv) = new_XNV();
1276 8784664         SvNV_set(sv, 0);
1277 8784664         return;
1278           case SVt_PVHV:
1279           case SVt_PVAV:
1280           assert(new_type_details->body_size);
1281            
1282           #ifndef PURIFY
1283           assert(new_type_details->arena);
1284           assert(new_type_details->arena_size);
1285           /* This points to the start of the allocated area. */
1286 301470357 100       new_body_inline(new_body, new_type);
1287 301470357         Zero(new_body, new_type_details->body_size, char);
1288 301470357         new_body = ((char *)new_body) - new_type_details->offset;
1289           #else
1290           /* We always allocated the full length item with PURIFY. To do this
1291           we fake things so that arena is false for all 16 types.. */
1292           new_body = new_NOARENAZ(new_type_details);
1293           #endif
1294 301470357         SvANY(sv) = new_body;
1295 301470357 100       if (new_type == SVt_PVAV) {
1296 185822768         AvMAX(sv) = -1;
1297 185822768         AvFILLp(sv) = -1;
1298 185822768         AvREAL_only(sv);
1299 185822768 50       if (old_type_details->body_size) {
1300 0         AvALLOC(sv) = 0;
1301           } else {
1302           /* It will have been zeroed when the new body was allocated.
1303           Lets not write to it, in case it confuses a write-back
1304           cache. */
1305           }
1306           } else {
1307           assert(!SvOK(sv));
1308 115647589 50       SvOK_off(sv);
1309           #ifndef NODEFAULT_SHAREKEYS
1310 115647589         HvSHAREKEYS_on(sv); /* key-sharing on by default */
1311           #endif
1312           /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
1313 115647589         HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
1314           }
1315            
1316           /* SVt_NULL isn't the only thing upgraded to AV or HV.
1317           The target created by newSVrv also is, and it can have magic.
1318           However, it never has SvPVX set.
1319           */
1320           if (old_type == SVt_IV) {
1321           assert(!SvROK(sv));
1322           } else if (old_type >= SVt_PV) {
1323           assert(SvPVX_const(sv) == 0);
1324           }
1325            
1326 301470357 100       if (old_type >= SVt_PVMG) {
1327 1184416         SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1328 1184416         SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1329           } else {
1330 300285941         sv->sv_u.svu_array = NULL; /* or svu_hash */
1331           }
1332           break;
1333            
1334           case SVt_PVIV:
1335           /* XXX Is this still needed? Was it ever needed? Surely as there is
1336           no route from NV to PVIV, NOK can never be true */
1337           assert(!SvNOKp(sv));
1338           assert(!SvNOK(sv));
1339           case SVt_PVIO:
1340           case SVt_PVFM:
1341           case SVt_PVGV:
1342           case SVt_PVCV:
1343           case SVt_PVLV:
1344           case SVt_INVLIST:
1345           case SVt_REGEXP:
1346           case SVt_PVMG:
1347           case SVt_PVNV:
1348           case SVt_PV:
1349            
1350           assert(new_type_details->body_size);
1351           /* We always allocated the full length item with PURIFY. To do this
1352           we fake things so that arena is false for all 16 types.. */
1353 2029303349 100       if(new_type_details->arena) {
1354           /* This points to the start of the allocated area. */
1355 2029302717 100       new_body_inline(new_body, new_type);
1356 2029302717         Zero(new_body, new_type_details->body_size, char);
1357 2029302717         new_body = ((char *)new_body) - new_type_details->offset;
1358           } else {
1359 632         new_body = new_NOARENAZ(new_type_details);
1360           }
1361 2029303349         SvANY(sv) = new_body;
1362            
1363 2029303349 100       if (old_type_details->copy) {
1364           /* There is now the potential for an upgrade from something without
1365           an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1366 219765160         int offset = old_type_details->offset;
1367 219765160         int length = old_type_details->copy;
1368            
1369 219765160 50       if (new_type_details->offset > old_type_details->offset) {
1370 0         const int difference
1371 0         = new_type_details->offset - old_type_details->offset;
1372 0         offset += difference;
1373 0         length -= difference;
1374           }
1375           assert (length >= 0);
1376          
1377 219765160         Copy((char *)old_body + offset, (char *)new_body + offset, length,
1378           char);
1379           }
1380            
1381           #ifndef NV_ZERO_IS_ALLBITS_ZERO
1382           /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1383           * correct 0.0 for us. Otherwise, if the old body didn't have an
1384           * NV slot, but the new one does, then we need to initialise the
1385           * freshly created NV slot with whatever the correct bit pattern is
1386           * for 0.0 */
1387           if (old_type_details->zero_nv && !new_type_details->zero_nv
1388           && !isGV_with_GP(sv))
1389           SvNV_set(sv, 0);
1390           #endif
1391            
1392 2029303349 100       if (UNLIKELY(new_type == SVt_PVIO)) {
1393           IO * const io = MUTABLE_IO(sv);
1394 5097139         GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1395            
1396 5097139         SvOBJECT_on(io);
1397           /* Clear the stashcache because a new IO could overrule a package
1398           name */
1399           DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
1400 5097139         hv_clear(PL_stashcache);
1401            
1402 10194278         SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1403 5097139         IoPAGE_LEN(sv) = 60;
1404           }
1405 2029303349 100       if (UNLIKELY(new_type == SVt_REGEXP))
1406 24189608         sv->sv_u.svu_rx = (regexp *)new_body;
1407 2005113741 100       else if (old_type < SVt_PV) {
1408           /* referant will be NULL unless the old type was SVt_IV emulating
1409           SVt_RV */
1410 1958086435         sv->sv_u.svu_rv = referant;
1411           }
1412           break;
1413           default:
1414 0         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1415           (unsigned long)new_type);
1416           }
1417            
1418 2330773706 100       if (old_type > SVt_IV) {
1419           #ifdef PURIFY
1420           safefree(old_body);
1421           #else
1422           /* Note that there is an assumption that all bodies of types that
1423           can be upgraded came from arenas. Only the more complex non-
1424           upgradable types are allowed to be directly malloc()ed. */
1425           assert(old_type_details->arena);
1426 2158102480         del_body((void*)((char*)old_body + old_type_details->offset),
1427           &PL_body_roots[old_type]);
1428           #endif
1429           }
1430           }
1431            
1432           /*
1433           =for apidoc sv_backoff
1434            
1435           Remove any string offset. You should normally use the C macro
1436           wrapper instead.
1437            
1438           =cut
1439           */
1440            
1441           int
1442 77326         Perl_sv_backoff(pTHX_ SV *const sv)
1443           {
1444           STRLEN delta;
1445 77326         const char * const s = SvPVX_const(sv);
1446            
1447           PERL_ARGS_ASSERT_SV_BACKOFF;
1448           PERL_UNUSED_CONTEXT;
1449            
1450           assert(SvOOK(sv));
1451           assert(SvTYPE(sv) != SVt_PVHV);
1452           assert(SvTYPE(sv) != SVt_PVAV);
1453            
1454 77326 50       SvOOK_offset(sv, delta);
    100        
1455          
1456 77326         SvLEN_set(sv, SvLEN(sv) + delta);
1457 77326         SvPV_set(sv, SvPVX(sv) - delta);
1458 77326         Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1459 77326         SvFLAGS(sv) &= ~SVf_OOK;
1460 77326         return 0;
1461           }
1462            
1463           /*
1464           =for apidoc sv_grow
1465            
1466           Expands the character buffer in the SV. If necessary, uses C and
1467           upgrades the SV to C. Returns a pointer to the character buffer.
1468           Use the C wrapper instead.
1469            
1470           =cut
1471           */
1472            
1473           static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
1474            
1475           char *
1476 1046735576         Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
1477           {
1478           char *s;
1479            
1480           PERL_ARGS_ASSERT_SV_GROW;
1481            
1482           #ifdef HAS_64K_LIMIT
1483           if (newlen >= 0x10000) {
1484           PerlIO_printf(Perl_debug_log,
1485           "Allocation too large: %"UVxf"\n", (UV)newlen);
1486           my_exit(1);
1487           }
1488           #endif /* HAS_64K_LIMIT */
1489 1046735576 50       if (SvROK(sv))
1490 0         sv_unref(sv);
1491 1046735576 100       if (SvTYPE(sv) < SVt_PV) {
1492 24346         sv_upgrade(sv, SVt_PV);
1493 24346         s = SvPVX_mutable(sv);
1494           }
1495 1046711230 100       else if (SvOOK(sv)) { /* pv is offset? */
1496 14562         sv_backoff(sv);
1497 14562         s = SvPVX_mutable(sv);
1498 14562 100       if (newlen > SvLEN(sv))
1499 6344         newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1500           #ifdef HAS_64K_LIMIT
1501           if (newlen >= 0x10000)
1502           newlen = 0xFFFF;
1503           #endif
1504           }
1505           else
1506           {
1507 1046696668 100       if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0);
1508 1046696668         s = SvPVX_mutable(sv);
1509           }
1510            
1511           #ifdef PERL_NEW_COPY_ON_WRITE
1512           /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1513           * to store the COW count. So in general, allocate one more byte than
1514           * asked for, to make it likely this byte is always spare: and thus
1515           * make more strings COW-able.
1516           * If the new size is a big power of two, don't bother: we assume the
1517           * caller wanted a nice 2^N sized block and will be annoyed at getting
1518           * 2^N+1 */
1519 1046735576 100       if (newlen & 0xff)
1520 1046623352         newlen++;
1521           #endif
1522            
1523 1046735576 100       if (newlen > SvLEN(sv)) { /* need more room? */
1524 1037760184         STRLEN minlen = SvCUR(sv);
1525 1037760184         minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1526 1037760184 100       if (newlen < minlen)
1527           newlen = minlen;
1528           #ifndef Perl_safesysmalloc_size
1529 1037760184 50       newlen = PERL_STRLEN_ROUNDUP(newlen);
1530           #endif
1531 1037760184 100       if (SvLEN(sv) && s) {
1532 37573464         s = (char*)saferealloc(s, newlen);
1533           }
1534           else {
1535 1000186720         s = (char*)safemalloc(newlen);
1536 1000186720 100       if (SvPVX_const(sv) && SvCUR(sv)) {
    50        
1537 72         Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1538           }
1539           }
1540 1037760184         SvPV_set(sv, s);
1541           #ifdef Perl_safesysmalloc_size
1542           /* Do this here, do it once, do it right, and then we will never get
1543           called back into sv_grow() unless there really is some growing
1544           needed. */
1545           SvLEN_set(sv, Perl_safesysmalloc_size(s));
1546           #else
1547 1037760184         SvLEN_set(sv, newlen);
1548           #endif
1549           }
1550 1046735576         return s;
1551           }
1552            
1553           /*
1554           =for apidoc sv_setiv
1555            
1556           Copies an integer into the given SV, upgrading first if necessary.
1557           Does not handle 'set' magic. See also C.
1558            
1559           =cut
1560           */
1561            
1562           void
1563 1792820924         Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
1564           {
1565           dVAR;
1566            
1567           PERL_ARGS_ASSERT_SV_SETIV;
1568            
1569 1792820924 100       SV_CHECK_THINKFIRST_COW_DROP(sv);
1570 1792820922         switch (SvTYPE(sv)) {
1571           case SVt_NULL:
1572           case SVt_NV:
1573 770672422         sv_upgrade(sv, SVt_IV);
1574 770672422         break;
1575           case SVt_PV:
1576 8926         sv_upgrade(sv, SVt_PVIV);
1577 8926         break;
1578            
1579           case SVt_PVGV:
1580 2 50       if (!isGV_with_GP(sv))
    50        
1581           break;
1582           case SVt_PVAV:
1583           case SVt_PVHV:
1584           case SVt_PVCV:
1585           case SVt_PVFM:
1586           case SVt_PVIO:
1587           /* diag_listed_as: Can't coerce %s to %s in %s */
1588 3 50       Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1589 1 0       OP_DESC(PL_op));
1590           default: NOOP;
1591           }
1592 1792820920 50       (void)SvIOK_only(sv); /* validate number */
1593 1792820920         SvIV_set(sv, i);
1594 1792820920 100       SvTAINT(sv);
    100        
    50        
1595 1792820920         }
1596            
1597           /*
1598           =for apidoc sv_setiv_mg
1599            
1600           Like C, but also handles 'set' magic.
1601            
1602           =cut
1603           */
1604            
1605           void
1606 108         Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1607           {
1608           PERL_ARGS_ASSERT_SV_SETIV_MG;
1609            
1610 108         sv_setiv(sv,i);
1611 108 100       SvSETMAGIC(sv);
1612 108         }
1613            
1614           /*
1615           =for apidoc sv_setuv
1616            
1617           Copies an unsigned integer into the given SV, upgrading first if necessary.
1618           Does not handle 'set' magic. See also C.
1619            
1620           =cut
1621           */
1622            
1623           void
1624 250556095         Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1625           {
1626           PERL_ARGS_ASSERT_SV_SETUV;
1627            
1628           /* With the if statement to ensure that integers are stored as IVs whenever
1629           possible:
1630           u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1631            
1632           without
1633           u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1634            
1635           If you wish to remove the following if statement, so that this routine
1636           (and its callers) always return UVs, please benchmark to see what the
1637           effect is. Modern CPUs may be different. Or may not :-)
1638           */
1639 250556095 100       if (u <= (UV)IV_MAX) {
1640 249527411         sv_setiv(sv, (IV)u);
1641 374971525         return;
1642           }
1643 1028684         sv_setiv(sv, 0);
1644 1028684         SvIsUV_on(sv);
1645 1028684         SvUV_set(sv, u);
1646           }
1647            
1648           /*
1649           =for apidoc sv_setuv_mg
1650            
1651           Like C, but also handles 'set' magic.
1652            
1653           =cut
1654           */
1655            
1656           void
1657 12         Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1658           {
1659           PERL_ARGS_ASSERT_SV_SETUV_MG;
1660            
1661 12         sv_setuv(sv,u);
1662 10 100       SvSETMAGIC(sv);
1663 10         }
1664            
1665           /*
1666           =for apidoc sv_setnv
1667            
1668           Copies a double into the given SV, upgrading first if necessary.
1669           Does not handle 'set' magic. See also C.
1670            
1671           =cut
1672           */
1673            
1674           void
1675 106016696         Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1676           {
1677           dVAR;
1678            
1679           PERL_ARGS_ASSERT_SV_SETNV;
1680            
1681 106016696 100       SV_CHECK_THINKFIRST_COW_DROP(sv);
1682 106016696         switch (SvTYPE(sv)) {
1683           case SVt_NULL:
1684           case SVt_IV:
1685 4942782         sv_upgrade(sv, SVt_NV);
1686 4942782         break;
1687           case SVt_PV:
1688           case SVt_PVIV:
1689 36         sv_upgrade(sv, SVt_PVNV);
1690 36         break;
1691            
1692           case SVt_PVGV:
1693 2 50       if (!isGV_with_GP(sv))
    50        
1694           break;
1695           case SVt_PVAV:
1696           case SVt_PVHV:
1697           case SVt_PVCV:
1698           case SVt_PVFM:
1699           case SVt_PVIO:
1700           /* diag_listed_as: Can't coerce %s to %s in %s */
1701 3 50       Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1702 1 0       OP_DESC(PL_op));
1703           default: NOOP;
1704           }
1705 106016694         SvNV_set(sv, num);
1706 106016694 50       (void)SvNOK_only(sv); /* validate number */
1707 106016694 100       SvTAINT(sv);
    50        
    0        
1708 106016694         }
1709            
1710           /*
1711           =for apidoc sv_setnv_mg
1712            
1713           Like C, but also handles 'set' magic.
1714            
1715           =cut
1716           */
1717            
1718           void
1719 1536621         Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1720           {
1721           PERL_ARGS_ASSERT_SV_SETNV_MG;
1722            
1723 1536621         sv_setnv(sv,num);
1724 1536621 100       SvSETMAGIC(sv);
1725 1536621         }
1726            
1727           /* Return a cleaned-up, printable version of sv, for non-numeric, or
1728           * not incrementable warning display.
1729           * Originally part of S_not_a_number().
1730           * The return value may be != tmpbuf.
1731           */
1732            
1733           STATIC const char *
1734 92         S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1735           const char *pv;
1736            
1737           PERL_ARGS_ASSERT_SV_DISPLAY;
1738            
1739 110 100       if (DO_UTF8(sv)) {
    50        
1740 18         SV *dsv = newSVpvs_flags("", SVs_TEMP);
1741 18         pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
1742           } else {
1743           char *d = tmpbuf;
1744 74         const char * const limit = tmpbuf + tmpbuf_size - 8;
1745           /* each *s can expand to 4 chars + "...\0",
1746           i.e. need room for 8 chars */
1747          
1748 74         const char *s = SvPVX_const(sv);
1749 74         const char * const end = s + SvCUR(sv);
1750 522 100       for ( ; s < end && d < limit; s++ ) {
1751 448         int ch = *s & 0xFF;
1752 448 50       if (! isASCII(ch) && !isPRINT_LC(ch)) {
    0        
1753 0         *d++ = 'M';
1754 0         *d++ = '-';
1755            
1756           /* Map to ASCII "equivalent" of Latin1 */
1757 0         ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1758           }
1759 448 50       if (ch == '\n') {
1760 0         *d++ = '\\';
1761 0         *d++ = 'n';
1762           }
1763 448 50       else if (ch == '\r') {
1764 0         *d++ = '\\';
1765 0         *d++ = 'r';
1766           }
1767 448 50       else if (ch == '\f') {
1768 0         *d++ = '\\';
1769 0         *d++ = 'f';
1770           }
1771 448 50       else if (ch == '\\') {
1772 0         *d++ = '\\';
1773 0         *d++ = '\\';
1774           }
1775 448 100       else if (ch == '\0') {
1776 22         *d++ = '\\';
1777 22         *d++ = '0';
1778           }
1779 426 50       else if (isPRINT_LC(ch))
1780 426         *d++ = ch;
1781           else {
1782 0         *d++ = '^';
1783 0 0       *d++ = toCTRL(ch);
1784           }
1785           }
1786 74 50       if (s < end) {
1787 0         *d++ = '.';
1788 0         *d++ = '.';
1789 0         *d++ = '.';
1790           }
1791 74         *d = '\0';
1792           pv = tmpbuf;
1793           }
1794            
1795 92         return pv;
1796           }
1797            
1798           /* Print an "isn't numeric" warning, using a cleaned-up,
1799           * printable version of the offending string
1800           */
1801            
1802           STATIC void
1803 88         S_not_a_number(pTHX_ SV *const sv)
1804           {
1805           dVAR;
1806           char tmpbuf[64];
1807           const char *pv;
1808            
1809           PERL_ARGS_ASSERT_NOT_A_NUMBER;
1810            
1811 88         pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1812            
1813 88 50       if (PL_op)
1814 132 50       Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1815           /* diag_listed_as: Argument "%s" isn't numeric%s */
1816           "Argument \"%s\" isn't numeric in %s", pv,
1817 44 0       OP_DESC(PL_op));
1818           else
1819 0         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1820           /* diag_listed_as: Argument "%s" isn't numeric%s */
1821           "Argument \"%s\" isn't numeric", pv);
1822 74         }
1823            
1824           STATIC void
1825           S_not_incrementable(pTHX_ SV *const sv) {
1826           dVAR;
1827           char tmpbuf[64];
1828           const char *pv;
1829            
1830           PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1831            
1832 4         pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1833            
1834 4         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1835           "Argument \"%s\" treated as 0 in increment (++)", pv);
1836           }
1837            
1838           /*
1839           =for apidoc looks_like_number
1840            
1841           Test if the content of an SV looks like a number (or is a number).
1842           C and C are treated as numbers (so will not issue a
1843           non-numeric warning), even if your atof() doesn't grok them. Get-magic is
1844           ignored.
1845            
1846           =cut
1847           */
1848            
1849           I32
1850 3586         Perl_looks_like_number(pTHX_ SV *const sv)
1851           {
1852           const char *sbegin;
1853           STRLEN len;
1854            
1855           PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1856            
1857 3586 100       if (SvPOK(sv) || SvPOKp(sv)) {
1858 3518 100       sbegin = SvPV_nomg_const(sv, len);
1859           }
1860           else
1861 1827         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1862 3518         return grok_number(sbegin, len, NULL);
1863           }
1864            
1865           STATIC bool
1866 50         S_glob_2number(pTHX_ GV * const gv)
1867           {
1868           PERL_ARGS_ASSERT_GLOB_2NUMBER;
1869            
1870           /* We know that all GVs stringify to something that is not-a-number,
1871           so no need to test that. */
1872 50 100       if (ckWARN(WARN_NUMERIC))
1873           {
1874 28         SV *const buffer = sv_newmortal();
1875 28         gv_efullname3(buffer, gv, "*");
1876 28         not_a_number(buffer);
1877           }
1878           /* We just want something true to return, so that S_sv_2iuv_common
1879           can tail call us and return true. */
1880 50         return TRUE;
1881           }
1882            
1883           /* Actually, ISO C leaves conversion of UV to IV undefined, but
1884           until proven guilty, assume that things are not that bad... */
1885            
1886           /*
1887           NV_PRESERVES_UV:
1888            
1889           As 64 bit platforms often have an NV that doesn't preserve all bits of
1890           an IV (an assumption perl has been based on to date) it becomes necessary
1891           to remove the assumption that the NV always carries enough precision to
1892           recreate the IV whenever needed, and that the NV is the canonical form.
1893           Instead, IV/UV and NV need to be given equal rights. So as to not lose
1894           precision as a side effect of conversion (which would lead to insanity
1895           and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1896           1) to distinguish between IV/UV/NV slots that have cached a valid
1897           conversion where precision was lost and IV/UV/NV slots that have a
1898           valid conversion which has lost no precision
1899           2) to ensure that if a numeric conversion to one form is requested that
1900           would lose precision, the precise conversion (or differently
1901           imprecise conversion) is also performed and cached, to prevent
1902           requests for different numeric formats on the same SV causing
1903           lossy conversion chains. (lossless conversion chains are perfectly
1904           acceptable (still))
1905            
1906            
1907           flags are used:
1908           SvIOKp is true if the IV slot contains a valid value
1909           SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1910           SvNOKp is true if the NV slot contains a valid value
1911           SvNOK is true only if the NV value is accurate
1912            
1913           so
1914           while converting from PV to NV, check to see if converting that NV to an
1915           IV(or UV) would lose accuracy over a direct conversion from PV to
1916           IV(or UV). If it would, cache both conversions, return NV, but mark
1917           SV as IOK NOKp (ie not NOK).
1918            
1919           While converting from PV to IV, check to see if converting that IV to an
1920           NV would lose accuracy over a direct conversion from PV to NV. If it
1921           would, cache both conversions, flag similarly.
1922            
1923           Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1924           correctly because if IV & NV were set NV *always* overruled.
1925           Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1926           changes - now IV and NV together means that the two are interchangeable:
1927           SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1928            
1929           The benefit of this is that operations such as pp_add know that if
1930           SvIOK is true for both left and right operands, then integer addition
1931           can be used instead of floating point (for cases where the result won't
1932           overflow). Before, floating point was always used, which could lead to
1933           loss of precision compared with integer addition.
1934            
1935           * making IV and NV equal status should make maths accurate on 64 bit
1936           platforms
1937           * may speed up maths somewhat if pp_add and friends start to use
1938           integers when possible instead of fp. (Hopefully the overhead in
1939           looking for SvIOK and checking for overflow will not outweigh the
1940           fp to integer speedup)
1941           * will slow down integer operations (callers of SvIV) on "inaccurate"
1942           values, as the change from SvIOK to SvIOKp will cause a call into
1943           sv_2iv each time rather than a macro access direct to the IV slot
1944           * should speed up number->string conversion on integers as IV is
1945           favoured when IV and NV are equally accurate
1946            
1947           ####################################################################
1948           You had better be using SvIOK_notUV if you want an IV for arithmetic:
1949           SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1950           On the other hand, SvUOK is true iff UV.
1951           ####################################################################
1952            
1953           Your mileage will vary depending your CPU's relative fp to integer
1954           performance ratio.
1955           */
1956            
1957           #ifndef NV_PRESERVES_UV
1958           # define IS_NUMBER_UNDERFLOW_IV 1
1959           # define IS_NUMBER_UNDERFLOW_UV 2
1960           # define IS_NUMBER_IV_AND_UV 2
1961           # define IS_NUMBER_OVERFLOW_IV 4
1962           # define IS_NUMBER_OVERFLOW_UV 5
1963            
1964           /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1965            
1966           /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1967           STATIC int
1968 22976         S_sv_2iuv_non_preserve(pTHX_ SV *const sv
1969           # ifdef DEBUGGING
1970           , I32 numtype
1971           # endif
1972           )
1973           {
1974           dVAR;
1975            
1976           PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1977            
1978           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));
1979 22976 100       if (SvNVX(sv) < (NV)IV_MIN) {
1980 17118         (void)SvIOKp_on(sv);
1981 17118         (void)SvNOK_on(sv);
1982 17118         SvIV_set(sv, IV_MIN);
1983 17118         return IS_NUMBER_UNDERFLOW_IV;
1984           }
1985 5858 100       if (SvNVX(sv) > (NV)UV_MAX) {
1986 5744         (void)SvIOKp_on(sv);
1987 5744         (void)SvNOK_on(sv);
1988 5744         SvIsUV_on(sv);
1989 5744         SvUV_set(sv, UV_MAX);
1990 5744         return IS_NUMBER_OVERFLOW_UV;
1991           }
1992 114         (void)SvIOKp_on(sv);
1993 114         (void)SvNOK_on(sv);
1994           /* Can't use strtol etc to convert this string. (See truth table in
1995           sv_2iv */
1996 114 50       if (SvNVX(sv) <= (UV)IV_MAX) {
1997 0         SvIV_set(sv, I_V(SvNVX(sv)));
1998 0 0       if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1999 0         SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2000           } else {
2001           /* Integer is imprecise. NOK, IOKp */
2002           }
2003           return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2004           }
2005 114         SvIsUV_on(sv);
2006 114         SvUV_set(sv, U_V(SvNVX(sv)));
2007 114 50       if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2008 114 50       if (SvUVX(sv) == UV_MAX) {
2009           /* As we know that NVs don't preserve UVs, UV_MAX cannot
2010           possibly be preserved by NV. Hence, it must be overflow.
2011           NOK, IOKp */
2012           return IS_NUMBER_OVERFLOW_UV;
2013           }
2014 11488         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2015           } else {
2016           /* Integer is imprecise. NOK, IOKp */
2017           }
2018           return IS_NUMBER_OVERFLOW_IV;
2019           }
2020           #endif /* !NV_PRESERVES_UV*/
2021            
2022           STATIC bool
2023 28046981         S_sv_2iuv_common(pTHX_ SV *const sv)
2024           {
2025           dVAR;
2026            
2027           PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2028            
2029 28046981 100       if (SvNOKp(sv)) {
2030           /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2031           * without also getting a cached IV/UV from it at the same time
2032           * (ie PV->NV conversion should detect loss of accuracy and cache
2033           * IV or UV at same time to avoid this. */
2034           /* IV-over-UV optimisation - choose to cache IV if possible */
2035            
2036 16304457 100       if (SvTYPE(sv) == SVt_NV)
2037 714435         sv_upgrade(sv, SVt_PVNV);
2038            
2039 16304457         (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2040           /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2041           certainly cast into the IV range at IV_MAX, whereas the correct
2042           answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2043           cases go to UV */
2044           #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2045           if (Perl_isnan(SvNVX(sv))) {
2046           SvUV_set(sv, 0);
2047           SvIsUV_on(sv);
2048           return FALSE;
2049           }
2050           #endif
2051 16304457 100       if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2052 16289819         SvIV_set(sv, I_V(SvNVX(sv)));
2053 16289819 100       if (SvNVX(sv) == (NV) SvIVX(sv)
2054           #ifndef NV_PRESERVES_UV
2055 6386230 100       && (((UV)1 << NV_PRESERVES_UV_BITS) >
2056 6386230         (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2057           /* Don't flag it as "accurately an integer" if the number
2058           came from a (by definition imprecise) NV operation, and
2059           we're outside the range of NV integer precision */
2060           #endif
2061           ) {
2062 6384030 100       if (SvNOK(sv))
2063 6384022         SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2064           else {
2065           /* scalar has trailing garbage, eg "42a" */
2066           }
2067           DEBUG_c(PerlIO_printf(Perl_debug_log,
2068           "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2069           PTR2UV(sv),
2070           SvNVX(sv),
2071           SvIVX(sv)));
2072            
2073           } else {
2074           /* IV not precise. No need to convert from PV, as NV
2075           conversion would already have cached IV if it detected
2076           that PV->IV would be better than PV->NV->IV
2077           flags already correct - don't set public IOK. */
2078           DEBUG_c(PerlIO_printf(Perl_debug_log,
2079           "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2080           PTR2UV(sv),
2081           SvNVX(sv),
2082           SvIVX(sv)));
2083           }
2084           /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2085           but the cast (NV)IV_MIN rounds to a the value less (more
2086           negative) than IV_MIN which happens to be equal to SvNVX ??
2087           Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2088           NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2089           (NV)UVX == NVX are both true, but the values differ. :-(
2090           Hopefully for 2s complement IV_MIN is something like
2091           0x8000000000000000 which will be exact. NWC */
2092           }
2093           else {
2094 14638         SvUV_set(sv, U_V(SvNVX(sv)));
2095 14638 100       if (
2096 14638         (SvNVX(sv) == (NV) SvUVX(sv))
2097           #ifndef NV_PRESERVES_UV
2098           /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2099           /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2100 1160 50       && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2101           /* Don't flag it as "accurately an integer" if the number
2102           came from a (by definition imprecise) NV operation, and
2103           we're outside the range of NV integer precision */
2104           #endif
2105 0 0       && SvNOK(sv)
2106           )
2107 0         SvIOK_on(sv);
2108 14638         SvIsUV_on(sv);
2109           DEBUG_c(PerlIO_printf(Perl_debug_log,
2110           "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2111           PTR2UV(sv),
2112           SvUVX(sv),
2113           SvUVX(sv)));
2114           }
2115           }
2116 11742524 100       else if (SvPOKp(sv)) {
2117           UV value;
2118 3423444         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2119           /* We want to avoid a possible problem when we cache an IV/ a UV which
2120           may be later translated to an NV, and the resulting NV is not
2121           the same as the direct translation of the initial string
2122           (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2123           be careful to ensure that the value with the .456 is around if the
2124           NV value is requested in the future).
2125          
2126           This means that if we cache such an IV/a UV, we need to cache the
2127           NV as well. Moreover, we trade speed for space, and do not
2128           cache the NV if we are sure it's not needed.
2129           */
2130            
2131           /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2132 3423444 100       if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2133           == IS_NUMBER_IN_UV) {
2134           /* It's definitely an integer, only upgrade to PVIV */
2135 3348820 100       if (SvTYPE(sv) < SVt_PVIV)
2136 812452         sv_upgrade(sv, SVt_PVIV);
2137 3348820         (void)SvIOK_on(sv);
2138 74624 100       } else if (SvTYPE(sv) < SVt_PVNV)
2139 39240         sv_upgrade(sv, SVt_PVNV);
2140            
2141           /* If NVs preserve UVs then we only use the UV value if we know that
2142           we aren't going to call atof() below. If NVs don't preserve UVs
2143           then the value returned may have more precision than atof() will
2144           return, even though value isn't perfectly accurate. */
2145 3423444 100       if ((numtype & (IS_NUMBER_IN_UV
2146           #ifdef NV_PRESERVES_UV
2147           | IS_NUMBER_NOT_INT
2148           #endif
2149 3423444         )) == IS_NUMBER_IN_UV) {
2150           /* This won't turn off the public IOK flag if it was set above */
2151 3391576         (void)SvIOKp_on(sv);
2152            
2153 3391576 100       if (!(numtype & IS_NUMBER_NEG)) {
2154           /* positive */;
2155 3361862 100       if (value <= (UV)IV_MAX) {
2156 3343770         SvIV_set(sv, (IV)value);
2157           } else {
2158           /* it didn't overflow, and it was positive. */
2159 18092         SvUV_set(sv, value);
2160 18092         SvIsUV_on(sv);
2161           }
2162           } else {
2163           /* 2s complement assumption */
2164 29714 50       if (value <= (UV)IV_MIN) {
2165 29714         SvIV_set(sv, -(IV)value);
2166           } else {
2167           /* Too negative for an IV. This is a double upgrade, but
2168           I'm assuming it will be rare. */
2169 0 0       if (SvTYPE(sv) < SVt_PVNV)
2170 0         sv_upgrade(sv, SVt_PVNV);
2171 0         SvNOK_on(sv);
2172 0         SvIOK_off(sv);
2173 0         SvIOKp_on(sv);
2174 0         SvNV_set(sv, -(NV)value);
2175 0         SvIV_set(sv, IV_MIN);
2176           }
2177           }
2178           }
2179           /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2180           will be in the previous block to set the IV slot, and the next
2181           block to set the NV slot. So no else here. */
2182          
2183 3423444 100       if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2184           != IS_NUMBER_IN_UV) {
2185           /* It wasn't an (integer that doesn't overflow the UV). */
2186 74624         SvNV_set(sv, Atof(SvPVX_const(sv)));
2187            
2188 74624 100       if (! numtype && ckWARN(WARN_NUMERIC))
    100        
2189 54         not_a_number(sv);
2190            
2191           #if defined(USE_LONG_DOUBLE)
2192           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2193           PTR2UV(sv), SvNVX(sv)));
2194           #else
2195           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2196           PTR2UV(sv), SvNVX(sv)));
2197           #endif
2198            
2199           #ifdef NV_PRESERVES_UV
2200           (void)SvIOKp_on(sv);
2201           (void)SvNOK_on(sv);
2202           if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2203           SvIV_set(sv, I_V(SvNVX(sv)));
2204           if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2205           SvIOK_on(sv);
2206           } else {
2207           NOOP; /* Integer is imprecise. NOK, IOKp */
2208           }
2209           /* UV will not work better than IV */
2210           } else {
2211           if (SvNVX(sv) > (NV)UV_MAX) {
2212           SvIsUV_on(sv);
2213           /* Integer is inaccurate. NOK, IOKp, is UV */
2214           SvUV_set(sv, UV_MAX);
2215           } else {
2216           SvUV_set(sv, U_V(SvNVX(sv)));
2217           /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2218           NV preservse UV so can do correct comparison. */
2219           if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2220           SvIOK_on(sv);
2221           } else {
2222           NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
2223           }
2224           }
2225           SvIsUV_on(sv);
2226           }
2227           #else /* NV_PRESERVES_UV */
2228 74612 100       if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2229           == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2230           /* The IV/UV slot will have been set from value returned by
2231           grok_number above. The NV slot has just been set using
2232           Atof. */
2233 42756         SvNOK_on(sv);
2234           assert (SvIOKp(sv));
2235           } else {
2236 31856 100       if (((UV)1 << NV_PRESERVES_UV_BITS) >
2237 31856 100       U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2238           /* Small enough to preserve all bits. */
2239 8880         (void)SvIOKp_on(sv);
2240 8880         SvNOK_on(sv);
2241 8880         SvIV_set(sv, I_V(SvNVX(sv)));
2242 8880 100       if ((NV)(SvIVX(sv)) == SvNVX(sv))
2243 8374         SvIOK_on(sv);
2244           /* Assumption: first non-preserved integer is < IV_MAX,
2245           this NV is in the preserved range, therefore: */
2246 8880 100       if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
    50        
2247           < (UV)IV_MAX)) {
2248 0         Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2249           }
2250           } else {
2251           /* IN_UV NOT_INT
2252           0 0 already failed to read UV.
2253           0 1 already failed to read UV.
2254           1 0 you won't get here in this case. IV/UV
2255           slot set, public IOK, Atof() unneeded.
2256           1 1 already read UV.
2257           so there's no point in sv_2iuv_non_preserve() attempting
2258           to use atol, strtol, strtoul etc. */
2259           # ifdef DEBUGGING
2260           sv_2iuv_non_preserve (sv, numtype);
2261           # else
2262 22976         sv_2iuv_non_preserve (sv);
2263           # endif
2264           }
2265           }
2266           #endif /* NV_PRESERVES_UV */
2267           /* It might be more code efficient to go through the entire logic above
2268           and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2269           gets complex and potentially buggy, so more programmer efficient
2270           to do it this way, by turning off the public flags: */
2271 74612 100       if (!numtype)
2272 6720         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2273           }
2274           }
2275           else {
2276 8319080 100       if (isGV_with_GP(sv))
    50        
2277 18         return glob_2number(MUTABLE_GV(sv));
2278            
2279 8319062 100       if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
    100        
2280 274         report_uninit(sv);
2281 8319062 100       if (SvTYPE(sv) < SVt_IV)
2282           /* Typically the caller expects that sv_any is not NULL now. */
2283 14047762         sv_upgrade(sv, SVt_IV);
2284           /* Return 0 from the caller. */
2285           return TRUE;
2286           }
2287           return FALSE;
2288           }
2289            
2290           /*
2291           =for apidoc sv_2iv_flags
2292            
2293           Return the integer value of an SV, doing any necessary string
2294           conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2295           Normally used via the C and C macros.
2296            
2297           =cut
2298           */
2299            
2300           IV
2301 27762857         Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2302           {
2303           dVAR;
2304            
2305 27762857 50       if (!sv)
2306           return 0;
2307            
2308           assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2309           && SvTYPE(sv) != SVt_PVFM);
2310            
2311 27762857 100       if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
    100        
2312 23688         mg_get(sv);
2313            
2314 27762857 100       if (SvROK(sv)) {
2315 70282 50       if (SvAMAGIC(sv)) {
    100        
    50        
2316           SV * tmpstr;
2317 498 50       if (flags & SV_SKIP_OVERLOAD)
2318           return 0;
2319 498         tmpstr = AMG_CALLunary(sv, numer_amg);
2320 498 50       if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
    50        
    0        
2321 498 100       return SvIV(tmpstr);
2322           }
2323           }
2324 69784         return PTR2IV(SvRV(sv));
2325           }
2326            
2327 27692575 50       if (SvVALID(sv) || isREGEXP(sv)) {
    100        
    50        
2328           /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2329           the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2330           In practice they are extremely unlikely to actually get anywhere
2331           accessible by user Perl code - the only way that I'm aware of is when
2332           a constant subroutine which is used as the second argument to index.
2333            
2334           Regexps have no SvIVX and SvNVX fields.
2335           */
2336           assert(isREGEXP(sv) || SvPOKp(sv));
2337           {
2338           UV value;
2339           const char * const ptr =
2340 3 50       isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
    0        
2341 2         const int numtype
2342 2         = grok_number(ptr, SvCUR(sv), &value);
2343            
2344 2 50       if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2345           == IS_NUMBER_IN_UV) {
2346           /* It's definitely an integer */
2347 0 0       if (numtype & IS_NUMBER_NEG) {
2348 0 0       if (value < (UV)IV_MIN)
2349 0         return -(IV)value;
2350           } else {
2351 0 0       if (value < (UV)IV_MAX)
2352 0         return (IV)value;
2353           }
2354           }
2355 2 50       if (!numtype) {
2356 2 50       if (ckWARN(WARN_NUMERIC))
2357 0         not_a_number(sv);
2358           }
2359 2         return I_V(Atof(ptr));
2360           }
2361           }
2362            
2363 27692573 100       if (SvTHINKFIRST(sv)) {
2364           #ifdef PERL_OLD_COPY_ON_WRITE
2365           if (SvIsCOW(sv)) {
2366           sv_force_normal_flags(sv, 0);
2367           }
2368           #endif
2369 2097016 100       if (SvREADONLY(sv) && !SvOK(sv)) {
    100        
    50        
    50        
2370 74 100       if (ckWARN(WARN_UNINITIALIZED))
2371 32         report_uninit(sv);
2372           return 0;
2373           }
2374           }
2375            
2376 27692499 100       if (!SvIOKp(sv)) {
2377 27668001 100       if (S_sv_2iuv_common(aTHX_ sv))
2378           return 0;
2379           }
2380            
2381           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2382           PTR2UV(sv),SvIVX(sv)));
2383 23569127 100       return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2384           }
2385            
2386           /*
2387           =for apidoc sv_2uv_flags
2388            
2389           Return the unsigned integer value of an SV, doing any necessary string
2390           conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2391           Normally used via the C and C macros.
2392            
2393           =cut
2394           */
2395            
2396           UV
2397 28676011         Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2398           {
2399           dVAR;
2400            
2401 28676011 50       if (!sv)
2402           return 0;
2403            
2404 28676011 100       if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
    100        
2405 12         mg_get(sv);
2406            
2407 28676011 100       if (SvROK(sv)) {
2408 12498064 50       if (SvAMAGIC(sv)) {
    100        
    100        
2409           SV *tmpstr;
2410 12495574 50       if (flags & SV_SKIP_OVERLOAD)
2411           return 0;
2412 12495574         tmpstr = AMG_CALLunary(sv, numer_amg);
2413 12495574 100       if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
    50        
    0        
2414 6 50       return SvUV(tmpstr);
2415           }
2416           }
2417 12498058         return PTR2UV(SvRV(sv));
2418           }
2419            
2420 16177947 50       if (SvVALID(sv) || isREGEXP(sv)) {
    100        
    50        
2421           /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2422           the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2423           Regexps have no SvIVX and SvNVX fields. */
2424           assert(isREGEXP(sv) || SvPOKp(sv));
2425           {
2426           UV value;
2427           const char * const ptr =
2428 3 50       isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
    0        
2429 2         const int numtype
2430 2         = grok_number(ptr, SvCUR(sv), &value);
2431            
2432 2 50       if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2433           == IS_NUMBER_IN_UV) {
2434           /* It's definitely an integer */
2435 0 0       if (!(numtype & IS_NUMBER_NEG))
2436 0         return value;
2437           }
2438 2 50       if (!numtype) {
2439 2 50       if (ckWARN(WARN_NUMERIC))
2440 0         not_a_number(sv);
2441           }
2442 2         return U_V(Atof(ptr));
2443           }
2444           }
2445            
2446 16177945 100       if (SvTHINKFIRST(sv)) {
2447           #ifdef PERL_OLD_COPY_ON_WRITE
2448           if (SvIsCOW(sv)) {
2449           sv_force_normal_flags(sv, 0);
2450           }
2451           #endif
2452 2978976 100       if (SvREADONLY(sv) && !SvOK(sv)) {
    100        
    50        
    50        
2453 12 100       if (ckWARN(WARN_UNINITIALIZED))
2454 8         report_uninit(sv);
2455           return 0;
2456           }
2457           }
2458            
2459 16177933 100       if (!SvIOKp(sv)) {
2460 378980 100       if (S_sv_2iuv_common(aTHX_ sv))
2461           return 0;
2462           }
2463            
2464           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2465           PTR2UV(sv),SvUVX(sv)));
2466 22425969 100       return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2467           }
2468            
2469           /*
2470           =for apidoc sv_2nv_flags
2471            
2472           Return the num value of an SV, doing any necessary string or integer
2473           conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2474           Normally used via the C and C macros.
2475            
2476           =cut
2477           */
2478            
2479           NV
2480 8993530         Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2481           {
2482           dVAR;
2483 8993530 50       if (!sv)
2484           return 0.0;
2485           assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2486           && SvTYPE(sv) != SVt_PVFM);
2487 8993530 100       if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
    100        
    50        
2488           /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2489           the same flag bit as SVf_IVisUV, so must not let them cache NVs.
2490           Regexps have no SvIVX and SvNVX fields. */
2491           const char *ptr;
2492 696 100       if (flags & SV_GMAGIC)
2493 460         mg_get(sv);
2494 696 100       if (SvNOKp(sv))
2495 8         return SvNVX(sv);
2496 688 100       if (SvPOKp(sv) && !SvIOKp(sv)) {
2497 32         ptr = SvPVX_const(sv);
2498           grokpv:
2499 54 50       if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2500 12         !grok_number(ptr, SvCUR(sv), NULL))
2501 4         not_a_number(sv);
2502 42         return Atof(ptr);
2503           }
2504 656 100       if (SvIOKp(sv)) {
2505 602 50       if (SvIsUV(sv))
2506 0         return (NV)SvUVX(sv);
2507           else
2508 602         return (NV)SvIVX(sv);
2509           }
2510 54 50       if (SvROK(sv)) {
2511           goto return_rok;
2512           }
2513 54 100       if (isREGEXP(sv)) {
    50        
2514 10         ptr = RX_WRAPPED((REGEXP *)sv);
2515 10         goto grokpv;
2516           }
2517           assert(SvTYPE(sv) >= SVt_PVMG);
2518           /* This falls through to the report_uninit near the end of the
2519           function. */
2520 8992834 100       } else if (SvTHINKFIRST(sv)) {
2521 893742 100       if (SvROK(sv)) {
2522           return_rok:
2523 52 50       if (SvAMAGIC(sv)) {
    50        
    50        
2524           SV *tmpstr;
2525 52 50       if (flags & SV_SKIP_OVERLOAD)
2526           return 0;
2527 52         tmpstr = AMG_CALLunary(sv, numer_amg);
2528 52 100       if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
    50        
    0        
2529 44 100       return SvNV(tmpstr);
2530           }
2531           }
2532 8         return PTR2NV(SvRV(sv));
2533           }
2534           #ifdef PERL_OLD_COPY_ON_WRITE
2535           if (SvIsCOW(sv)) {
2536           sv_force_normal_flags(sv, 0);
2537           }
2538           #endif
2539 893690 100       if (SvREADONLY(sv) && !SvOK(sv)) {
    100        
    50        
    50        
2540 405766 100       if (ckWARN(WARN_UNINITIALIZED))
2541 174         report_uninit(sv);
2542           return 0.0;
2543           }
2544           }
2545 8587060 100       if (SvTYPE(sv) < SVt_NV) {
2546           /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2547 1934284         sv_upgrade(sv, SVt_NV);
2548           #ifdef USE_LONG_DOUBLE
2549           DEBUG_c({
2550           STORE_NUMERIC_LOCAL_SET_STANDARD();
2551           PerlIO_printf(Perl_debug_log,
2552           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2553           PTR2UV(sv), SvNVX(sv));
2554           RESTORE_NUMERIC_LOCAL();
2555           });
2556           #else
2557           DEBUG_c({
2558           STORE_NUMERIC_LOCAL_SET_STANDARD();
2559           PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2560           PTR2UV(sv), SvNVX(sv));
2561           RESTORE_NUMERIC_LOCAL();
2562           });
2563           #endif
2564           }
2565 6652776 100       else if (SvTYPE(sv) < SVt_PVNV)
2566 3070706         sv_upgrade(sv, SVt_PVNV);
2567 8587060 100       if (SvNOKp(sv)) {
2568 23814         return SvNVX(sv);
2569           }
2570 8563246 100       if (SvIOKp(sv)) {
2571 8222466 100       SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2572           #ifdef NV_PRESERVES_UV
2573           if (SvIOK(sv))
2574           SvNOK_on(sv);
2575           else
2576           SvNOKp_on(sv);
2577           #else
2578           /* Only set the public NV OK flag if this NV preserves the IV */
2579           /* Check it's not 0xFFFFFFFFFFFFFFFF */
2580 20511392 50       if (SvIOK(sv) &&
    100        
    100        
    100        
2581 4072435 100       SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2582 8215650         : (SvIVX(sv) == I_V(SvNVX(sv))))
2583 8211708         SvNOK_on(sv);
2584           else
2585 10758         SvNOKp_on(sv);
2586           #endif
2587           }
2588 340780 100       else if (SvPOKp(sv)) {
2589           UV value;
2590 336584         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2591 336584 100       if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
    100        
2592 2         not_a_number(sv);
2593           #ifdef NV_PRESERVES_UV
2594           if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2595           == IS_NUMBER_IN_UV) {
2596           /* It's definitely an integer */
2597           SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2598           } else
2599           SvNV_set(sv, Atof(SvPVX_const(sv)));
2600           if (numtype)
2601           SvNOK_on(sv);
2602           else
2603           SvNOKp_on(sv);
2604           #else
2605 336582         SvNV_set(sv, Atof(SvPVX_const(sv)));
2606           /* Only set the public NV OK flag if this NV preserves the value in
2607           the PV at least as well as an IV/UV would.
2608           Not sure how to do this 100% reliably. */
2609           /* if that shift count is out of range then Configure's test is
2610           wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2611           UV_BITS */
2612 336582 100       if (((UV)1 << NV_PRESERVES_UV_BITS) >
2613 336582 100       U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2614 334058         SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2615 2524 100       } else if (!(numtype & IS_NUMBER_IN_UV)) {
2616           /* Can't use strtol etc to convert this string, so don't try.
2617           sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2618 718         SvNOK_on(sv);
2619           } else {
2620           /* value has been set. It may not be precise. */
2621 1806 100       if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
    50        
2622           /* 2s complement assumption for (UV)IV_MIN */
2623 0         SvNOK_on(sv); /* Integer is too negative. */
2624           } else {
2625 1806         SvNOKp_on(sv);
2626 1806         SvIOKp_on(sv);
2627            
2628 1806 100       if (numtype & IS_NUMBER_NEG) {
2629 594         SvIV_set(sv, -(IV)value);
2630 1212 100       } else if (value <= (UV)IV_MAX) {
2631 462         SvIV_set(sv, (IV)value);
2632           } else {
2633 750         SvUV_set(sv, value);
2634 750         SvIsUV_on(sv);
2635           }
2636            
2637 1806 50       if (numtype & IS_NUMBER_NOT_INT) {
2638           /* I believe that even if the original PV had decimals,
2639           they are lost beyond the limit of the FP precision.
2640           However, neither is canonical, so both only get p
2641           flags. NWC, 2000/11/25 */
2642           /* Both already have p flags, so do nothing */
2643           } else {
2644 1806         const NV nv = SvNVX(sv);
2645 1806 100       if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2646 1042 100       if (SvIVX(sv) == I_V(nv)) {
2647 246         SvNOK_on(sv);
2648           } else {
2649           /* It had no "." so it must be integer. */
2650           }
2651 1042         SvIOK_on(sv);
2652           } else {
2653           /* between IV_MAX and NV(UV_MAX).
2654           Could be slightly > UV_MAX */
2655            
2656 764 50       if (numtype & IS_NUMBER_NOT_INT) {
2657           /* UV and NV both imprecise. */
2658           } else {
2659 764         const UV nv_as_uv = U_V(nv);
2660            
2661 764 100       if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
    100        
2662 246         SvNOK_on(sv);
2663           }
2664 764         SvIOK_on(sv);
2665           }
2666           }
2667           }
2668           }
2669           }
2670           /* It might be more code efficient to go through the entire logic above
2671           and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2672           gets complex and potentially buggy, so more programmer efficient
2673           to do it this way, by turning off the public flags: */
2674 336582 100       if (!numtype)
2675 1656         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2676           #endif /* NV_PRESERVES_UV */
2677           }
2678           else {
2679 4196 100       if (isGV_with_GP(sv)) {
    50        
2680 32         glob_2number(MUTABLE_GV(sv));
2681 32         return 0.0;
2682           }
2683            
2684 4164 50       if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
    100        
2685 306         report_uninit(sv);
2686           assert (SvTYPE(sv) >= SVt_NV);
2687           /* Typically the caller expects that sv_any is not NULL now. */
2688           /* XXX Ilya implies that this is a bug in callers that assume this
2689           and ideally should be fixed. */
2690           return 0.0;
2691           }
2692           #if defined(USE_LONG_DOUBLE)
2693           DEBUG_c({
2694           STORE_NUMERIC_LOCAL_SET_STANDARD();
2695           PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2696           PTR2UV(sv), SvNVX(sv));
2697           RESTORE_NUMERIC_LOCAL();
2698           });
2699           #else
2700           DEBUG_c({
2701           STORE_NUMERIC_LOCAL_SET_STANDARD();
2702           PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2703           PTR2UV(sv), SvNVX(sv));
2704           RESTORE_NUMERIC_LOCAL();
2705           });
2706           #endif
2707 8776288         return SvNVX(sv);
2708           }
2709            
2710           /*
2711           =for apidoc sv_2num
2712            
2713           Return an SV with the numeric value of the source SV, doing any necessary
2714           reference or overload conversion. You must use the C macro to
2715           access this function.
2716            
2717           =cut
2718           */
2719            
2720           SV *
2721 4668699         Perl_sv_2num(pTHX_ SV *const sv)
2722           {
2723           PERL_ARGS_ASSERT_SV_2NUM;
2724            
2725 4669624 100       if (!SvROK(sv))
2726           return sv;
2727 4667774 50       if (SvAMAGIC(sv)) {
    100        
    100        
2728 563436         SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2729 563436 100       TAINT_IF(tmpsv && SvTAINTED(tmpsv));
    50        
    0        
    50        
2730 563436 100       if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
    50        
    0        
2731           return sv_2num(tmpsv);
2732           }
2733 4666849         return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2734           }
2735            
2736           /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2737           * UV as a string towards the end of buf, and return pointers to start and
2738           * end of it.
2739           *
2740           * We assume that buf is at least TYPE_CHARS(UV) long.
2741           */
2742            
2743           static char *
2744           S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2745           {
2746           char *ptr = buf + TYPE_CHARS(UV);
2747           char * const ebuf = ptr;
2748           int sign;
2749            
2750           PERL_ARGS_ASSERT_UIV_2BUF;
2751            
2752 190248255 100       if (is_uv)
2753           sign = 0;
2754 190230923 0       else if (iv >= 0) {
    100        
2755 190132539         uv = iv;
2756           sign = 0;
2757           } else {
2758 95213454         uv = -iv;
2759           sign = 1;
2760           }
2761           do {
2762 1429742796         *--ptr = '0' + (char)(uv % 10);
2763 1429742796 0       } while (uv /= 10);
    100        
2764 190248255 0       if (sign)
    100        
2765 98384         *--ptr = '-';
2766           *peob = ebuf;
2767           return ptr;
2768           }
2769            
2770           /*
2771           =for apidoc sv_2pv_flags
2772            
2773           Returns a pointer to the string value of an SV, and sets *lp to its length.
2774           If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a
2775           string if necessary. Normally invoked via the C macro.
2776           C and C usually end up here too.
2777            
2778           =cut
2779           */
2780            
2781           char *
2782 223911065         Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
2783           {
2784           dVAR;
2785           char *s;
2786            
2787 223911065 50       if (!sv) {
2788 0 0       if (lp)
2789 0         *lp = 0;
2790           return (char *)"";
2791           }
2792           assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2793           && SvTYPE(sv) != SVt_PVFM);
2794 223911065 100       if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
    100        
2795 14085628         mg_get(sv);
2796 223911059 100       if (SvROK(sv)) {
2797 4191280 50       if (SvAMAGIC(sv)) {
    100        
    100        
2798           SV *tmpstr;
2799 2008748 100       if (flags & SV_SKIP_OVERLOAD)
2800           return NULL;
2801 2008516         tmpstr = AMG_CALLunary(sv, string_amg);
2802 2008516 100       TAINT_IF(tmpstr && SvTAINTED(tmpstr));
    50        
    0        
    50        
2803 2008516 100       if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
    100        
    50        
2804           /* Unwrap this: */
2805           /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2806           */
2807            
2808           char *pv;
2809 68268 100       if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2810 65352 100       if (flags & SV_CONST_RETURN) {
2811 61848         pv = (char *) SvPVX_const(tmpstr);
2812           } else {
2813 3504         pv = (flags & SV_MUTABLE_RETURN)
2814           ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2815           }
2816 65352 100       if (lp)
2817 65312         *lp = SvCUR(tmpstr);
2818           } else {
2819 2916         pv = sv_2pv_flags(tmpstr, lp, flags);
2820           }
2821 68268 100       if (SvUTF8(tmpstr))
2822 334         SvUTF8_on(sv);
2823           else
2824 67934         SvUTF8_off(sv);
2825           return pv;
2826           }
2827           }
2828           {
2829           STRLEN len;
2830           char *retval;
2831           char *buffer;
2832 4122780         SV *const referent = SvRV(sv);
2833            
2834 4122780 50       if (!referent) {
2835           len = 7;
2836 0         retval = buffer = savepvn("NULLREF", len);
2837 4329372 100       } else if (SvTYPE(referent) == SVt_REGEXP &&
    100        
2838 206620 100       (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
2839 28         amagic_is_enabled(string_amg))) {
2840           REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2841            
2842           assert(re);
2843          
2844           /* If the regex is UTF-8 we want the containing scalar to
2845           have an UTF-8 flag too */
2846 413162 100       if (RX_UTF8(re))
2847 40         SvUTF8_on(sv);
2848           else
2849 413122         SvUTF8_off(sv);
2850            
2851 413162 50       if (lp)
2852 413162         *lp = RX_WRAPLEN(re);
2853          
2854 413162         return RX_WRAPPED(re);
2855           } else {
2856 3709618         const char *const typestr = sv_reftype(referent, 0);
2857 3709618         const STRLEN typelen = strlen(typestr);
2858 3709618         UV addr = PTR2UV(referent);
2859           const char *stashname = NULL;
2860           STRLEN stashnamelen = 0; /* hush, gcc */
2861           const char *buffer_end;
2862            
2863 3709618 100       if (SvOBJECT(referent)) {
2864 2624002 50       const HEK *const name = HvNAME_HEK(SvSTASH(referent));
    50        
    100        
2865            
2866 2624002 100       if (name) {
2867 2623998         stashname = HEK_KEY(name);
2868 2623998         stashnamelen = HEK_LEN(name);
2869            
2870 2623998 100       if (HEK_UTF8(name)) {
2871 174         SvUTF8_on(sv);
2872           } else {
2873 2623824         SvUTF8_off(sv);
2874           }
2875           } else {
2876           stashname = "__ANON__";
2877           stashnamelen = 8;
2878           }
2879 2624002         len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2880           + 2 * sizeof(UV) + 2 /* )\0 */;
2881           } else {
2882 1085616         len = typelen + 3 /* (0x */
2883           + 2 * sizeof(UV) + 2 /* )\0 */;
2884           }
2885            
2886 3709618         Newx(buffer, len, char);
2887 3709618         buffer_end = retval = buffer + len;
2888            
2889           /* Working backwards */
2890 3709618         *--retval = '\0';
2891 3709618         *--retval = ')';
2892           do {
2893 25961388         *--retval = PL_hexdigit[addr & 15];
2894 25961388 100       } while (addr >>= 4);
2895 3709618         *--retval = 'x';
2896 3709618         *--retval = '0';
2897 3709618         *--retval = '(';
2898            
2899 3709618         retval -= typelen;
2900 3709618         memcpy(retval, typestr, typelen);
2901            
2902 3709618 100       if (stashname) {
2903 2624002         *--retval = '=';
2904 2624002         retval -= stashnamelen;
2905 2624002         memcpy(retval, stashname, stashnamelen);
2906           }
2907           /* retval may not necessarily have reached the start of the
2908           buffer here. */
2909           assert (retval >= buffer);
2910            
2911 3709618         len = buffer_end - retval - 1; /* -1 for that \0 */
2912           }
2913 3709618 100       if (lp)
2914 3683200         *lp = len;
2915 3709618         SAVEFREEPV(buffer);
2916 3709618         return retval;
2917           }
2918           }
2919            
2920 219719779 100       if (SvPOKp(sv)) {
2921 27682226 100       if (lp)
2922 27680776         *lp = SvCUR(sv);
2923 27682226 100       if (flags & SV_MUTABLE_RETURN)
2924 650         return SvPVX_mutable(sv);
2925 27681576 100       if (flags & SV_CONST_RETURN)
2926 27656214         return (char *)SvPVX_const(sv);
2927 25362         return SvPVX(sv);
2928           }
2929            
2930 192037553 100       if (SvIOK(sv)) {
2931           /* I'm assuming that if both IV and NV are equally valid then
2932           converting the IV is going to be more efficient */
2933 190248255         const U32 isUIOK = SvIsUV(sv);
2934           char buf[TYPE_CHARS(UV)];
2935           char *ebuf, *ptr;
2936           STRLEN len;
2937            
2938 190248255 100       if (SvTYPE(sv) < SVt_PVIV)
2939 162469671         sv_upgrade(sv, SVt_PVIV);
2940 190248255         ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2941 190248255         len = ebuf - ptr;
2942           /* inlined from sv_setpvn */
2943 190248255 100       s = SvGROW_mutable(sv, len + 1);
2944           Move(ptr, s, len, char);
2945 190248255         s += len;
2946 190248255         *s = '\0';
2947 190248255         SvPOK_on(sv);
2948           }
2949 1789298 100       else if (SvNOK(sv)) {
2950 125340 100       if (SvTYPE(sv) < SVt_PVNV)
2951 15410         sv_upgrade(sv, SVt_PVNV);
2952 125340 100       if (SvNVX(sv) == 0.0) {
2953 4042 100       s = SvGROW_mutable(sv, 2);
2954 4042         *s++ = '0';
2955 4042         *s = '\0';
2956           } else {
2957 121298         dSAVE_ERRNO;
2958           /* The +20 is pure guesswork. Configure test needed. --jhi */
2959 121298 100       s = SvGROW_mutable(sv, NV_DIG + 20);
2960           /* some Xenix systems wipe out errno here */
2961            
2962           #ifndef USE_LOCALE_NUMERIC
2963           Gconvert(SvNVX(sv), NV_DIG, 0, s);
2964           SvPOK_on(sv);
2965           #else
2966           /* Gconvert always uses the current locale. That's the right thing
2967           * to do if we're supposed to be using locales. But otherwise, we
2968           * want the result to be based on the C locale, so we need to
2969           * change to the C locale during the Gconvert and then change back.
2970           * But if we're already in the C locale (PL_numeric_standard is
2971           * TRUE in that case), no need to do any changing */
2972 121298 100       if (PL_numeric_standard || IN_SOME_LOCALE_FORM_RUNTIME) {
    50        
2973 121294         Gconvert(SvNVX(sv), NV_DIG, 0, s);
2974            
2975           /* If the radix character is UTF-8, and actually is in the
2976           * output, turn on the UTF-8 flag for the scalar */
2977 121294 50       if (! PL_numeric_standard
2978 0 0       && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
    0        
2979 0 0       && instr(s, SvPVX_const(PL_numeric_radix_sv)))
2980           {
2981 0         SvUTF8_on(sv);
2982           }
2983           }
2984           else {
2985 4         char *loc = savepv(setlocale(LC_NUMERIC, NULL));
2986 4         setlocale(LC_NUMERIC, "C");
2987 4         Gconvert(SvNVX(sv), NV_DIG, 0, s);
2988 4         setlocale(LC_NUMERIC, loc);
2989 4         Safefree(loc);
2990            
2991           }
2992            
2993           /* We don't call SvPOK_on(), because it may come to pass that the
2994           * locale changes so that the stringification we just did is no
2995           * longer correct. We will have to re-stringify every time it is
2996           * needed */
2997           #endif
2998 121298         RESTORE_ERRNO;
2999 821082 100       while (*s) s++;
3000           }
3001           #ifdef hcx
3002           if (s[-1] == '.')
3003           *--s = '\0';
3004           #endif
3005           }
3006 1663958 100       else if (isGV_with_GP(sv)) {
    50        
3007           GV *const gv = MUTABLE_GV(sv);
3008 1666         SV *const buffer = sv_newmortal();
3009            
3010 1666         gv_efullname3(buffer, gv, "*");
3011            
3012           assert(SvPOK(buffer));
3013 1666 100       if (SvUTF8(buffer))
3014 134         SvUTF8_on(sv);
3015 1666 100       if (lp)
3016 1646         *lp = SvCUR(buffer);
3017 1666         return SvPVX(buffer);
3018           }
3019 1662292 100       else if (isREGEXP(sv)) {
    100        
3020 1593132 50       if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
3021 1593132         return RX_WRAPPED((REGEXP *)sv);
3022           }
3023           else {
3024 69160 100       if (lp)
3025 69092         *lp = 0;
3026 69160 100       if (flags & SV_UNDEF_RETURNS_NULL)
3027           return NULL;
3028 69136 100       if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
    100        
3029 2264         report_uninit(sv);
3030           /* Typically the caller expects that sv_any is not NULL now. */
3031 69098 100       if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
    100        
3032 2092         sv_upgrade(sv, SVt_PV);
3033           return (char *)"";
3034           }
3035            
3036           {
3037 190373595         const STRLEN len = s - SvPVX_const(sv);
3038 190373595 100       if (lp)
3039 190371357         *lp = len;
3040 190373595         SvCUR_set(sv, len);
3041           }
3042           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3043           PTR2UV(sv),SvPVX_const(sv)));
3044 190373595 100       if (flags & SV_CONST_RETURN)
3045 190085597         return (char *)SvPVX_const(sv);
3046 287998 100       if (flags & SV_MUTABLE_RETURN)
3047 8         return SvPVX_mutable(sv);
3048 112144318         return SvPVX(sv);
3049           }
3050            
3051           /*
3052           =for apidoc sv_copypv
3053            
3054           Copies a stringified representation of the source SV into the
3055           destination SV. Automatically performs any necessary mg_get and
3056           coercion of numeric values into strings. Guaranteed to preserve
3057           UTF8 flag even from overloaded objects. Similar in nature to
3058           sv_2pv[_flags] but operates directly on an SV instead of just the
3059           string. Mostly uses sv_2pv_flags to do its work, except when that
3060           would lose the UTF-8'ness of the PV.
3061            
3062           =for apidoc sv_copypv_nomg
3063            
3064           Like sv_copypv, but doesn't invoke get magic first.
3065            
3066           =for apidoc sv_copypv_flags
3067            
3068           Implementation of sv_copypv and sv_copypv_nomg. Calls get magic iff flags
3069           include SV_GMAGIC.
3070            
3071           =cut
3072           */
3073            
3074           void
3075 0         Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
3076           {
3077           PERL_ARGS_ASSERT_SV_COPYPV;
3078            
3079 0         sv_copypv_flags(dsv, ssv, 0);
3080 0         }
3081            
3082           void
3083 6811770         Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3084           {
3085           STRLEN len;
3086           const char *s;
3087            
3088           PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3089            
3090 6811770 100       if ((flags & SV_GMAGIC) && SvGMAGICAL(ssv))
    100        
3091 40500         mg_get(ssv);
3092 6811768 100       s = SvPV_nomg_const(ssv,len);
3093 6811768         sv_setpvn(dsv,s,len);
3094 6811768 100       if (SvUTF8(ssv))
3095 361862         SvUTF8_on(dsv);
3096           else
3097 6449906         SvUTF8_off(dsv);
3098 6811768         }
3099            
3100           /*
3101           =for apidoc sv_2pvbyte
3102            
3103           Return a pointer to the byte-encoded representation of the SV, and set *lp
3104           to its length. May cause the SV to be downgraded from UTF-8 as a
3105           side-effect.
3106            
3107           Usually accessed via the C macro.
3108            
3109           =cut
3110           */
3111            
3112           char *
3113 1780         Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
3114 1780 100       {
3115           PERL_ARGS_ASSERT_SV_2PVBYTE;
3116            
3117 904         SvGETMAGIC(sv);
3118 1780 100       if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
    50        
3119 1768 100       || isGV_with_GP(sv) || SvROK(sv)) {
    50        
    100        
3120 22         SV *sv2 = sv_newmortal();
3121 22         sv_copypv_nomg(sv2,sv);
3122           sv = sv2;
3123           }
3124 1780         sv_utf8_downgrade(sv,0);
3125 1772 100       return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
    100        
    100        
3126           }
3127            
3128           /*
3129           =for apidoc sv_2pvutf8
3130            
3131           Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3132           to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3133            
3134           Usually accessed via the C macro.
3135            
3136           =cut
3137           */
3138            
3139           char *
3140 392         Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
3141           {
3142           PERL_ARGS_ASSERT_SV_2PVUTF8;
3143            
3144 776 100       if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
    50        
    100        
3145 388 100       || isGV_with_GP(sv) || SvROK(sv))
    50        
    100        
3146 8         sv = sv_mortalcopy(sv);
3147           else
3148 198         SvGETMAGIC(sv);
3149 392         sv_utf8_upgrade_nomg(sv);
3150 392 100       return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
    100        
    100        
3151           }
3152            
3153            
3154           /*
3155           =for apidoc sv_2bool
3156            
3157           This macro is only used by sv_true() or its macro equivalent, and only if
3158           the latter's argument is neither SvPOK, SvIOK nor SvNOK.
3159           It calls sv_2bool_flags with the SV_GMAGIC flag.
3160            
3161           =for apidoc sv_2bool_flags
3162            
3163           This function is only used by sv_true() and friends, and only if
3164           the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags
3165           contain SV_GMAGIC, then it does an mg_get() first.
3166            
3167            
3168           =cut
3169           */
3170            
3171           bool
3172 117332049         Perl_sv_2bool_flags(pTHX_ SV *const sv, const I32 flags)
3173           {
3174           dVAR;
3175            
3176           PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3177            
3178 117332049 100       if(flags & SV_GMAGIC) SvGETMAGIC(sv);
    50        
3179            
3180 117332049 100       if (!SvOK(sv))
    100        
    50        
3181           return 0;
3182 116897113 100       if (SvROK(sv)) {
3183 114118443 50       if (SvAMAGIC(sv)) {
    100        
    100        
3184 122850         SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3185 122850 100       if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
    50        
    0        
3186 23542 50       return cBOOL(SvTRUE(tmpsv));
    50        
    0        
    50        
    0        
    0        
    100        
    50        
    100        
    100        
    50        
    100        
    50        
    100        
    50        
    50        
    50        
    50        
    0        
3187           }
3188 114094901         return SvRV(sv) != 0;
3189           }
3190 2778670 100       if (isREGEXP(sv))
    50        
3191 2         return
3192 2 50       RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
    0        
    0        
3193 60072277 50       return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
    0        
    0        
    100        
    50        
    100        
    100        
    100        
    100        
    50        
    100        
    50        
    0        
    50        
    50        
3194           }
3195            
3196           /*
3197           =for apidoc sv_utf8_upgrade
3198            
3199           Converts the PV of an SV to its UTF-8-encoded form.
3200           Forces the SV to string form if it is not already.
3201           Will C on C if appropriate.
3202           Always sets the SvUTF8 flag to avoid future validity checks even
3203           if the whole string is the same in UTF-8 as not.
3204           Returns the number of bytes in the converted string
3205            
3206           This is not a general purpose byte encoding to Unicode interface:
3207           use the Encode extension for that.
3208            
3209           =for apidoc sv_utf8_upgrade_nomg
3210            
3211           Like sv_utf8_upgrade, but doesn't do magic on C.
3212            
3213           =for apidoc sv_utf8_upgrade_flags
3214            
3215           Converts the PV of an SV to its UTF-8-encoded form.
3216           Forces the SV to string form if it is not already.
3217           Always sets the SvUTF8 flag to avoid future validity checks even
3218           if all the bytes are invariant in UTF-8.
3219           If C has C bit set,
3220           will C on C if appropriate, else not.
3221           Returns the number of bytes in the converted string
3222           C and
3223           C are implemented in terms of this function.
3224            
3225           This is not a general purpose byte encoding to Unicode interface:
3226           use the Encode extension for that.
3227            
3228           =cut
3229            
3230           The grow version is currently not externally documented. It adds a parameter,
3231           extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3232           have free after it upon return. This allows the caller to reserve extra space
3233           that it intends to fill, to avoid extra grows.
3234            
3235           Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3236           which can be used to tell this function to not first check to see if there are
3237           any characters that are different in UTF-8 (variant characters) which would
3238           force it to allocate a new string to sv, but to assume there are. Typically
3239           this flag is used by a routine that has already parsed the string to find that
3240           there are such characters, and passes this information on so that the work
3241           doesn't have to be repeated.
3242            
3243           (One might think that the calling routine could pass in the position of the
3244           first such variant, so it wouldn't have to be found again. But that is not the
3245           case, because typically when the caller is likely to use this flag, it won't be
3246           calling this routine unless it finds something that won't fit into a byte.
3247           Otherwise it tries to not upgrade and just use bytes. But some things that
3248           do fit into a byte are variants in utf8, and the caller may not have been
3249           keeping track of these.)
3250            
3251           If the routine itself changes the string, it adds a trailing NUL. Such a NUL
3252           isn't guaranteed due to having other routines do the work in some input cases,
3253           or if the input is already flagged as being in utf8.
3254            
3255           The speed of this could perhaps be improved for many cases if someone wanted to
3256           write a fast function that counts the number of variant characters in a string,
3257           especially if it could return the position of the first one.
3258            
3259           */
3260            
3261           STRLEN
3262 5384668         Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3263           {
3264           dVAR;
3265            
3266           PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3267            
3268 5384668 50       if (sv == &PL_sv_undef)
3269           return 0;
3270 5384668 100       if (!SvPOK_nog(sv)) {
3271 350202         STRLEN len = 0;
3272 350202 50       if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
    0        
3273 0         (void) sv_2pv_flags(sv,&len, flags);
3274 0 0       if (SvUTF8(sv)) {
3275 0 0       if (extra) SvGROW(sv, SvCUR(sv) + extra);
    0        
    0        
3276 0         return len;
3277           }
3278           } else {
3279 350202 50       (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3280           }
3281           }
3282            
3283 5384668 100       if (SvUTF8(sv)) {
3284 855316 50       if (extra) SvGROW(sv, SvCUR(sv) + extra);
    0        
    0        
3285 855316         return SvCUR(sv);
3286           }
3287            
3288 4529352 100       if (SvIsCOW(sv)) {
3289 517012         S_sv_uncow(aTHX_ sv, 0);
3290           }
3291            
3292 4529352 100       if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
    50        
3293 55058         sv_recode_to_utf8(sv, PL_encoding);
3294 55054 100       if (extra) SvGROW(sv, SvCUR(sv) + extra);
    50        
    100        
3295 55054         return SvCUR(sv);
3296           }
3297            
3298 4474294 100       if (SvCUR(sv) == 0) {
3299 947628 100       if (extra) SvGROW(sv, extra);
    50        
    100        
3300           } else { /* Assume Latin-1/EBCDIC */
3301           /* This function could be much more efficient if we
3302           * had a FLAG in SVs to signal if there are any variant
3303           * chars in the PV. Given that there isn't such a flag
3304           * make the loop as fast as possible (although there are certainly ways
3305           * to speed this up, eg. through vectorization) */
3306 3526666         U8 * s = (U8 *) SvPVX_const(sv);
3307 3526666         U8 * e = (U8 *) SvEND(sv);
3308           U8 *t = s;
3309           STRLEN two_byte_count = 0;
3310          
3311 3526666 100       if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3312            
3313           /* See if really will need to convert to utf8. We mustn't rely on our
3314           * incoming SV being well formed and having a trailing '\0', as certain
3315           * code in pp_formline can send us partially built SVs. */
3316            
3317 40563332 100       while (t < e) {
3318 37381256         const U8 ch = *t++;
3319 37381256 100       if (NATIVE_IS_INVARIANT(ch)) continue;
3320            
3321           t--; /* t already incremented; re-point to first variant */
3322           two_byte_count = 1;
3323           goto must_be_utf8;
3324           }
3325            
3326           /* utf8 conversion not needed because all are invariants. Mark as
3327           * UTF-8 even if no variant - saves scanning loop */
3328 3182076         SvUTF8_on(sv);
3329 3182076 100       if (extra) SvGROW(sv, SvCUR(sv) + extra);
    50        
    100        
3330 3182076         return SvCUR(sv);
3331            
3332           must_be_utf8:
3333            
3334           /* Here, the string should be converted to utf8, either because of an
3335           * input flag (two_byte_count = 0), or because a character that
3336           * requires 2 bytes was found (two_byte_count = 1). t points either to
3337           * the beginning of the string (if we didn't examine anything), or to
3338           * the first variant. In either case, everything from s to t - 1 will
3339           * occupy only 1 byte each on output.
3340           *
3341           * There are two main ways to convert. One is to create a new string
3342           * and go through the input starting from the beginning, appending each
3343           * converted value onto the new string as we go along. It's probably
3344           * best to allocate enough space in the string for the worst possible
3345           * case rather than possibly running out of space and having to
3346           * reallocate and then copy what we've done so far. Since everything
3347           * from s to t - 1 is invariant, the destination can be initialized
3348           * with these using a fast memory copy
3349           *
3350           * The other way is to figure out exactly how big the string should be
3351           * by parsing the entire input. Then you don't have to make it big
3352           * enough to handle the worst possible case, and more importantly, if
3353           * the string you already have is large enough, you don't have to
3354           * allocate a new string, you can copy the last character in the input
3355           * string to the final position(s) that will be occupied by the
3356           * converted string and go backwards, stopping at t, since everything
3357           * before that is invariant.
3358           *
3359           * There are advantages and disadvantages to each method.
3360           *
3361           * In the first method, we can allocate a new string, do the memory
3362           * copy from the s to t - 1, and then proceed through the rest of the
3363           * string byte-by-byte.
3364           *
3365           * In the second method, we proceed through the rest of the input
3366           * string just calculating how big the converted string will be. Then
3367           * there are two cases:
3368           * 1) if the string has enough extra space to handle the converted
3369           * value. We go backwards through the string, converting until we
3370           * get to the position we are at now, and then stop. If this
3371           * position is far enough along in the string, this method is
3372           * faster than the other method. If the memory copy were the same
3373           * speed as the byte-by-byte loop, that position would be about
3374           * half-way, as at the half-way mark, parsing to the end and back
3375           * is one complete string's parse, the same amount as starting
3376           * over and going all the way through. Actually, it would be
3377           * somewhat less than half-way, as it's faster to just count bytes
3378           * than to also copy, and we don't have the overhead of allocating
3379           * a new string, changing the scalar to use it, and freeing the
3380           * existing one. But if the memory copy is fast, the break-even
3381           * point is somewhere after half way. The counting loop could be
3382           * sped up by vectorization, etc, to move the break-even point
3383           * further towards the beginning.
3384           * 2) if the string doesn't have enough space to handle the converted
3385           * value. A new string will have to be allocated, and one might
3386           * as well, given that, start from the beginning doing the first
3387           * method. We've spent extra time parsing the string and in
3388           * exchange all we've gotten is that we know precisely how big to
3389           * make the new one. Perl is more optimized for time than space,
3390           * so this case is a loser.
3391           * So what I've decided to do is not use the 2nd method unless it is
3392           * guaranteed that a new string won't have to be allocated, assuming
3393           * the worst case. I also decided not to put any more conditions on it
3394           * than this, for now. It seems likely that, since the worst case is
3395           * twice as big as the unknown portion of the string (plus 1), we won't
3396           * be guaranteed enough space, causing us to go to the first method,
3397           * unless the string is short, or the first variant character is near
3398           * the end of it. In either of these cases, it seems best to use the
3399           * 2nd method. The only circumstance I can think of where this would
3400           * be really slower is if the string had once had much more data in it
3401           * than it does now, but there is still a substantial amount in it */
3402            
3403           {
3404 344590         STRLEN invariant_head = t - s;
3405 344590         STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3406 344590 100       if (SvLEN(sv) < size) {
3407            
3408           /* Here, have decided to allocate a new string */
3409            
3410           U8 *dst;
3411           U8 *d;
3412            
3413 4134         Newx(dst, size, U8);
3414            
3415           /* If no known invariants at the beginning of the input string,
3416           * set so starts from there. Otherwise, can use memory copy to
3417           * get up to where we are now, and then start from here */
3418            
3419 4404 100       if (invariant_head <= 0) {
3420           d = dst;
3421           } else {
3422 540         Copy(s, dst, invariant_head, char);
3423 540         d = dst + invariant_head;
3424           }
3425            
3426 205176 100       while (t < e) {
3427 201042         append_utf8_from_native_byte(*t, &d);
3428 201042         t++;
3429           }
3430 4134         *d = '\0';
3431 4134 50       SvPV_free(sv); /* No longer using pre-existing string */
    50        
    0        
    0        
3432 4134         SvPV_set(sv, (char*)dst);
3433 4134         SvCUR_set(sv, d - dst);
3434 4134         SvLEN_set(sv, size);
3435           } else {
3436            
3437           /* Here, have decided to get the exact size of the string.
3438           * Currently this happens only when we know that there is
3439           * guaranteed enough space to fit the converted string, so
3440           * don't have to worry about growing. If two_byte_count is 0,
3441           * then t points to the first byte of the string which hasn't
3442           * been examined yet. Otherwise two_byte_count is 1, and t
3443           * points to the first byte in the string that will expand to
3444           * two. Depending on this, start examining at t or 1 after t.
3445           * */
3446            
3447 340456         U8 *d = t + two_byte_count;
3448            
3449            
3450           /* Count up the remaining bytes that expand to two */
3451            
3452 871014 100       while (d < e) {
3453 360330         const U8 chr = *d++;
3454 360330 100       if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
3455           }
3456            
3457           /* The string will expand by just the number of bytes that
3458           * occupy two positions. But we are one afterwards because of
3459           * the increment just above. This is the place to put the
3460           * trailing NUL, and to set the length before we decrement */
3461            
3462 340456         d += two_byte_count;
3463 340456         SvCUR_set(sv, d - s);
3464 340456         *d-- = '\0';
3465            
3466            
3467           /* Having decremented d, it points to the position to put the
3468           * very last byte of the expanded string. Go backwards through
3469           * the string, copying and expanding as we go, stopping when we
3470           * get to the part that is invariant the rest of the way down */
3471            
3472 340456         e--;
3473 1138618 100       while (e >= t) {
3474 627934 100       if (NATIVE_IS_INVARIANT(*e)) {
3475 218304         *d-- = *e;
3476           } else {
3477 409630         *d-- = UTF8_EIGHT_BIT_LO(*e);
3478 409630         *d-- = UTF8_EIGHT_BIT_HI(*e);
3479           }
3480 627934         e--;
3481           }
3482           }
3483            
3484 344590 100       if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
    100        
3485           /* Update pos. We do it at the end rather than during
3486           * the upgrade, to avoid slowing down the common case
3487           * (upgrade without pos).
3488           * pos can be stored as either bytes or characters. Since
3489           * this was previously a byte string we can just turn off
3490           * the bytes flag. */
3491 540         MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3492 540 100       if (mg) {
3493 328         mg->mg_flags &= ~MGf_BYTES;
3494           }
3495 540 100       if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3496 220         magic_setutf8(sv,mg); /* clear UTF8 cache */
3497           }
3498           }
3499           }
3500            
3501           /* Mark as UTF-8 even if no variant - saves scanning loop */
3502 1292218         SvUTF8_on(sv);
3503 3338441         return SvCUR(sv);
3504           }
3505            
3506           /*
3507           =for apidoc sv_utf8_downgrade
3508            
3509           Attempts to convert the PV of an SV from characters to bytes.
3510           If the PV contains a character that cannot fit
3511           in a byte, this conversion will fail;
3512           in this case, either returns false or, if C is not
3513           true, croaks.
3514            
3515           This is not a general purpose Unicode to byte encoding interface:
3516           use the Encode extension for that.
3517            
3518           =cut
3519           */
3520            
3521           bool
3522 877692         Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
3523           {
3524           dVAR;
3525            
3526           PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3527            
3528 877692 100       if (SvPOKp(sv) && SvUTF8(sv)) {
3529 170456 100       if (SvCUR(sv)) {
3530           U8 *s;
3531           STRLEN len;
3532           int mg_flags = SV_GMAGIC;
3533            
3534 170454 100       if (SvIsCOW(sv)) {
3535 860         S_sv_uncow(aTHX_ sv, 0);
3536           }
3537 170454 100       if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
    100        
3538           /* update pos */
3539 416         MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3540 416 100       if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
    100        
    50        
3541 0         mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
3542           SV_GMAGIC|SV_CONST_RETURN);
3543           mg_flags = 0; /* sv_pos_b2u does get magic */
3544           }
3545 416 100       if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3546 380         magic_setutf8(sv,mg); /* clear UTF8 cache */
3547            
3548           }
3549 170454 50       s = (U8 *) SvPV_flags(sv, len, mg_flags);
3550            
3551 170454 100       if (!utf8_to_bytes(s, &len)) {
3552 766 100       if (fail_ok)
3553           return FALSE;
3554           else {
3555 30 50       if (PL_op)
3556 45 50       Perl_croak(aTHX_ "Wide character in %s",
3557 15 0       OP_DESC(PL_op));
3558           else
3559 0         Perl_croak(aTHX_ "Wide character");
3560           }
3561           }
3562 169688         SvCUR_set(sv, len);
3563           }
3564           }
3565 876926         SvUTF8_off(sv);
3566 877294         return TRUE;
3567           }
3568            
3569           /*
3570           =for apidoc sv_utf8_encode
3571            
3572           Converts the PV of an SV to UTF-8, but then turns the C
3573           flag off so that it looks like octets again.
3574            
3575           =cut
3576           */
3577            
3578           void
3579 931500         Perl_sv_utf8_encode(pTHX_ SV *const sv)
3580           {
3581           PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3582            
3583 931500 100       if (SvREADONLY(sv)) {
3584 2         sv_force_normal_flags(sv, 0);
3585           }
3586 931498         (void) sv_utf8_upgrade(sv);
3587 931498         SvUTF8_off(sv);
3588 931498         }
3589            
3590           /*
3591           =for apidoc sv_utf8_decode
3592            
3593           If the PV of the SV is an octet sequence in UTF-8
3594           and contains a multiple-byte character, the C flag is turned on
3595           so that it looks like a character. If the PV contains only single-byte
3596           characters, the C flag stays off.
3597           Scans PV for validity and returns false if the PV is invalid UTF-8.
3598            
3599           =cut
3600           */
3601            
3602           bool
3603 4930         Perl_sv_utf8_decode(pTHX_ SV *const sv)
3604           {
3605           PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3606            
3607 4930 50       if (SvPOKp(sv)) {
3608           const U8 *start, *c;
3609           const U8 *e;
3610            
3611           /* The octets may have got themselves encoded - get them back as
3612           * bytes
3613           */
3614 4930 100       if (!sv_utf8_downgrade(sv, TRUE))
3615           return FALSE;
3616            
3617           /* it is actually just a matter of turning the utf8 flag on, but
3618           * we want to make sure everything inside is valid utf8 first.
3619           */
3620 4926         c = start = (const U8 *) SvPVX_const(sv);
3621 4926 100       if (!is_utf8_string(c, SvCUR(sv)))
3622           return FALSE;
3623 4920         e = (const U8 *) SvEND(sv);
3624 350950 100       while (c < e) {
3625 347834         const U8 ch = *c++;
3626 347834 100       if (!UTF8_IS_INVARIANT(ch)) {
3627 4264         SvUTF8_on(sv);
3628 4264         break;
3629           }
3630           }
3631 4920 100       if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
    50        
3632           /* XXX Is this dead code? XS_utf8_decode calls SvSETMAGIC
3633           after this, clearing pos. Does anything on CPAN
3634           need this? */
3635           /* adjust pos to the start of a UTF8 char sequence */
3636 26         MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3637 26 100       if (mg) {
3638 24         I32 pos = mg->mg_len;
3639 24 100       if (pos > 0) {
3640 36 50       for (c = start + pos; c > start; c--) {
3641 36 100       if (UTF8_IS_START(*c))
3642           break;
3643           }
3644 20         mg->mg_len = c - start;
3645           }
3646           }
3647 26 100       if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3648 2477         magic_setutf8(sv,mg); /* clear UTF8 cache */
3649           }
3650           }
3651           return TRUE;
3652           }
3653            
3654           /*
3655           =for apidoc sv_setsv
3656            
3657           Copies the contents of the source SV C into the destination SV
3658           C. The source SV may be destroyed if it is mortal, so don't use this
3659           function if the source SV needs to be reused. Does not handle 'set' magic.
3660           Loosely speaking, it performs a copy-by-value, obliterating any previous
3661           content of the destination.
3662            
3663           You probably want to use one of the assortment of wrappers, such as
3664           C, C, C and
3665           C.
3666            
3667           =for apidoc sv_setsv_flags
3668            
3669           Copies the contents of the source SV C into the destination SV
3670           C. The source SV may be destroyed if it is mortal, so don't use this
3671           function if the source SV needs to be reused. Does not handle 'set' magic.
3672           Loosely speaking, it performs a copy-by-value, obliterating any previous
3673           content of the destination.
3674           If the C parameter has the C bit set, will C on
3675           C if appropriate, else not. If the C
3676           parameter has the C bit set then the
3677           buffers of temps will not be stolen.
3678           and C are implemented in terms of this function.
3679            
3680           You probably want to use one of the assortment of wrappers, such as
3681           C, C, C and
3682           C.
3683            
3684           This is the primary function for copying scalars, and most other
3685           copy-ish functions and macros use this underneath.
3686            
3687           =cut
3688           */
3689            
3690           static void
3691 27508108         S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3692           {
3693           I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3694           HV *old_stash = NULL;
3695            
3696           PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3697            
3698 54919784 100       if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
    50        
    0        
    100        
3699 27411676         const char * const name = GvNAME(sstr);
3700 27411676         const STRLEN len = GvNAMELEN(sstr);
3701           {
3702 27411676 100       if (dtype >= SVt_PV) {
3703 27054806 100       SvPV_free(dstr);
    50        
    0        
    0        
3704 27054806         SvPV_set(dstr, 0);
3705 27054806         SvLEN_set(dstr, 0);
3706 27054806         SvCUR_set(dstr, 0);
3707           }
3708 41117378         SvUPGRADE(dstr, SVt_PVGV);
3709 27411676 50       (void)SvOK_off(dstr);
3710           /* We have to turn this on here, even though we turn it off
3711           below, as GvSTASH will fail an assertion otherwise. */
3712 27411676         isGV_with_GP_on(dstr);
3713           }
3714 27411676         GvSTASH(dstr) = GvSTASH(sstr);
3715 27411676 100       if (GvSTASH(dstr))
3716 27411624         Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3717 27411676 100       gv_name_set(MUTABLE_GV(dstr), name, len,
3718           GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
3719 27411676         SvFAKE_on(dstr); /* can coerce to non-glob */
3720           }
3721            
3722 27508108 50       if(GvGP(MUTABLE_GV(sstr))) {
3723           /* If source has method cache entry, clear it */
3724 27508108 100       if(GvCVGEN(sstr)) {
3725 749856         SvREFCNT_dec(GvCV(sstr));
3726 749856         GvCV_set(sstr, NULL);
3727 749856         GvCVGEN(sstr) = 0;
3728           }
3729           /* If source has a real method, then a method is
3730           going to change */
3731 26758252 100       else if(
3732 32982001 100       GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
    50        
    50        
    50        
    100        
    100        
    50        
    50        
3733           ) {
3734           mro_changes = 1;
3735           }
3736           }
3737            
3738           /* If dest already had a real method, that's a change as well */
3739 27508108 100       if(
3740 7904170 100       !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
    50        
    100        
3741 46 100       && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
    50        
    50        
    50        
    50        
    50        
    50        
    50        
3742           ) {
3743           mro_changes = 1;
3744           }
3745            
3746           /* We don't need to check the name of the destination if it was not a
3747           glob to begin with. */
3748 27508108 100       if(dtype == SVt_PVGV) {
3749 96432         const char * const name = GvNAME((const GV *)dstr);
3750 96432 100       if(
3751 96432 100       strEQ(name,"ISA")
    50        
    50        
3752           /* The stash may have been detached from the symbol table, so
3753           check its name. */
3754 16 100       && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
    50        
    50        
    50        
    50        
    50        
    50        
    50        
3755           )
3756           mro_changes = 2;
3757           else {
3758 96420         const STRLEN len = GvNAMELEN(dstr);
3759 96420 100       if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
    100        
    50        
3760 96288 100       || (len == 1 && name[0] == ':')) {
    50        
3761           mro_changes = 3;
3762            
3763           /* Set aside the old stash, so we can reset isa caches on
3764           its subclasses. */
3765 132 50       if((old_stash = GvHV(dstr)))
3766           /* Make sure we do not lose it early. */
3767 132         SvREFCNT_inc_simple_void_NN(
3768           sv_2mortal((SV *)old_stash)
3769           );
3770           }
3771           }
3772           }
3773            
3774 27508108         gp_free(MUTABLE_GV(dstr));
3775 27508108         isGV_with_GP_off(dstr); /* SvOK_off does not like globs. */
3776 27508108 50       (void)SvOK_off(dstr);
3777 27508108         isGV_with_GP_on(dstr);
3778 27508108         GvINTRO_off(dstr); /* one-shot flag */
3779 27508108         GvGP_set(dstr, gp_ref(GvGP(sstr)));
3780 27508108 100       if (SvTAINTED(sstr))
    50        
3781 0 0       SvTAINT(dstr);
    0        
    0        
3782 27508108 100       if (GvIMPORTED(dstr) != GVf_IMPORTED
3783 27507988 100       && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3784           {
3785 24987980         GvIMPORTED_on(dstr);
3786           }
3787 27508108         GvMULTI_on(dstr);
3788 27508108 100       if(mro_changes == 2) {
3789 12 100       if (GvAV((const GV *)sstr)) {
3790           MAGIC *mg;
3791 10         SV * const sref = (SV *)GvAV((const GV *)dstr);
3792 10 50       if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
    50        
3793 10 50       if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3794 10         AV * const ary = newAV();
3795 10         av_push(ary, mg->mg_obj); /* takes the refcount */
3796 10         mg->mg_obj = (SV *)ary;
3797           }
3798 10         av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3799           }
3800 0         else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3801           }
3802 12         mro_isa_changed_in(GvSTASH(dstr));
3803           }
3804 27508096 100       else if(mro_changes == 3) {
3805 132         HV * const stash = GvHV(dstr);
3806 132 50       if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
    50        
    50        
    50        
    100        
    100        
    50        
    50        
    50        
3807 132         mro_package_moved(
3808           stash, old_stash,
3809           (GV *)dstr, 0
3810           );
3811           }
3812 27507964 100       else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3813 27508108 50       if (GvIO(dstr) && dtype == SVt_PVGV) {
    50        
    50        
    100        
3814           DEBUG_o(Perl_deb(aTHX_
3815           "glob_assign_glob clearing PL_stashcache\n"));
3816           /* It's a cache. It will rebuild itself quite happily.
3817           It's a lot of effort to work out exactly which key (or keys)
3818           might be invalidated by the creation of the this file handle.
3819           */
3820 6480         hv_clear(PL_stashcache);
3821           }
3822 27508108         return;
3823           }
3824            
3825           static void
3826 2270345         S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3827           {
3828 2270345         SV * const sref = SvRV(sstr);
3829           SV *dref;
3830 2270345         const int intro = GvINTRO(dstr);
3831           SV **location;
3832           U8 import_flag = 0;
3833 2270345         const U32 stype = SvTYPE(sref);
3834            
3835           PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3836            
3837 2270345 100       if (intro) {
3838 311899         GvINTRO_off(dstr); /* one-shot flag */
3839 311899         GvLINE(dstr) = CopLINE(PL_curcop);
3840 311899         GvEGV(dstr) = MUTABLE_GV(dstr);
3841           }
3842 2270345         GvMULTI_on(dstr);
3843 2270345         switch (stype) {
3844           case SVt_PVCV:
3845 1768343         location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
3846           import_flag = GVf_IMPORTED_CV;
3847 1768343         goto common;
3848           case SVt_PVHV:
3849 101700         location = (SV **) &GvHV(dstr);
3850           import_flag = GVf_IMPORTED_HV;
3851 101700         goto common;
3852           case SVt_PVAV:
3853 125240         location = (SV **) &GvAV(dstr);
3854           import_flag = GVf_IMPORTED_AV;
3855 125240         goto common;
3856           case SVt_PVIO:
3857 20         location = (SV **) &GvIOp(dstr);
3858 20         goto common;
3859           case SVt_PVFM:
3860 24         location = (SV **) &GvFORM(dstr);
3861 24         goto common;
3862           default:
3863 275018         location = &GvSV(dstr);
3864           import_flag = GVf_IMPORTED_SV;
3865           common:
3866 2270345 100       if (intro) {
3867 311899 100       if (stype == SVt_PVCV) {
3868           /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3869 297598 100       if (GvCVGEN(dstr)) {
3870 18         SvREFCNT_dec(GvCV(dstr));
3871 18         GvCV_set(dstr, NULL);
3872 18         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3873           }
3874           }
3875           /* SAVEt_GVSLOT takes more room on the savestack and has more
3876           overhead in leave_scope than SAVEt_GENERIC_SV. But for CVs
3877           leave_scope needs access to the GV so it can reset method
3878           caches. We must use SAVEt_GVSLOT whenever the type is
3879           SVt_PVCV, even if the stash is anonymous, as the stash may
3880           gain a name somehow before leave_scope. */
3881 311899 100       if (stype == SVt_PVCV) {
3882           /* There is no save_pushptrptrptr. Creating it for this
3883           one call site would be overkill. So inline the ss add
3884           routines here. */
3885 297598         dSS_ADD;
3886 297598         SS_ADD_PTR(dstr);
3887 297598         SS_ADD_PTR(location);
3888 595196         SS_ADD_PTR(SvREFCNT_inc(*location));
3889 297598         SS_ADD_UV(SAVEt_GVSLOT);
3890 297598 50       SS_ADD_END(4);
3891           }
3892 14301         else SAVEGENERICSV(*location);
3893           }
3894 2270345         dref = *location;
3895 2270345 100       if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
    100        
    100        
3896 1738169         CV* const cv = MUTABLE_CV(*location);
3897 1738169 100       if (cv) {
3898 476808 100       if (!GvCVGEN((const GV *)dstr) &&
    100        
3899 476802 50       (CvROOT(cv) || CvXSUB(cv)) &&
    100        
3900           /* redundant check that avoids creating the extra SV
3901           most of the time: */
3902 446446 100       (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
3903           {
3904 18574         SV * const new_const_sv =
3905 18574         CvCONST((const CV *)sref)
3906           ? cv_const_sv((const CV *)sref)
3907 18574 100       : NULL;
3908 18574 100       report_redefined_cv(
    50        
    50        
    50        
    50        
3909           sv_2mortal(Perl_newSVpvf(aTHX_
3910           "%"HEKf"::%"HEKf,
3911           HEKfARG(
3912           HvNAME_HEK(GvSTASH((const GV *)dstr))
3913           ),
3914           HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
3915           )),
3916           cv,
3917           CvCONST((const CV *)sref) ? &new_const_sv : NULL
3918           );
3919           }
3920 317868 100       if (!intro)
3921 27352 100       cv_ckproto_len_flags(cv, (const GV *)dstr,
    100        
    50        
    50        
    100        
    100        
    50        
    50        
    100        
3922           SvPOK(sref) ? CvPROTO(sref) : NULL,
3923           SvPOK(sref) ? CvPROTOLEN(sref) : 0,
3924           SvPOK(sref) ? SvUTF8(sref) : 0);
3925           }
3926 1738163         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3927 1738163         GvASSUMECV_on(dstr);
3928 1738163 50       if(GvSTASH(dstr)) gv_method_changed(dstr); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
    100        
3929           }
3930 2270339         *location = SvREFCNT_inc_simple_NN(sref);
3931 2270339 100       if (import_flag && !(GvFLAGS(dstr) & import_flag)
    100        
3932 1927310 100       && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3933 1503927         GvFLAGS(dstr) |= import_flag;
3934           }
3935 2270339 100       if (stype == SVt_PVHV) {
3936 101700         const char * const name = GvNAME((GV*)dstr);
3937 101700         const STRLEN len = GvNAMELEN(dstr);
3938 101700 100       if (
3939           (
3940 101694 100       (len > 1 && name[len-2] == ':' && name[len-1] == ':')
    50        
3941 101652 100       || (len == 1 && name[0] == ':')
    50        
3942           )
3943 48 50       && (!dref || HvENAME_get(dref))
    50        
    50        
    50        
    50        
    100        
    50        
    50        
3944           ) {
3945 48         mro_package_moved(
3946           (HV *)sref, (HV *)dref,
3947           (GV *)dstr, 0
3948           );
3949           }
3950           }
3951 2168639 100       else if (
3952 2168639         stype == SVt_PVAV && sref != dref
3953 9944 100       && strEQ(GvNAME((GV*)dstr), "ISA")
    50        
    50        
    100        
3954           /* The stash may have been detached from the symbol table, so
3955           check its name before doing anything. */
3956 78 100       && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
    50        
    50        
    50        
    50        
    50        
    50        
    50        
3957 74         ) {
3958           MAGIC *mg;
3959 74 50       MAGIC * const omg = dref && SvSMAGICAL(dref)
3960           ? mg_find(dref, PERL_MAGIC_isa)
3961 148 50       : NULL;
3962 74 100       if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
    50        
3963 54 100       if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3964 24         AV * const ary = newAV();
3965 24         av_push(ary, mg->mg_obj); /* takes the refcount */
3966 24         mg->mg_obj = (SV *)ary;
3967           }
3968 54 50       if (omg) {
3969 54 50       if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
3970 0         SV **svp = AvARRAY((AV *)omg->mg_obj);
3971 0         I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
3972 0 0       while (items--)
3973 0         av_push(
3974           (AV *)mg->mg_obj,
3975           SvREFCNT_inc_simple_NN(*svp++)
3976           );
3977           }
3978           else
3979 54         av_push(
3980           (AV *)mg->mg_obj,
3981           SvREFCNT_inc_simple_NN(omg->mg_obj)
3982           );
3983           }
3984           else
3985 0         av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
3986           }
3987           else
3988           {
3989 20 50       sv_magic(
3990           sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
3991           );
3992 20         mg = mg_find(sref, PERL_MAGIC_isa);
3993           }
3994           /* Since the *ISA assignment could have affected more than
3995           one stash, don't call mro_isa_changed_in directly, but let
3996           magic_clearisa do it for us, as it already has the logic for
3997           dealing with globs vs arrays of globs. */
3998           assert(mg);
3999 74         Perl_magic_clearisa(aTHX_ NULL, mg);
4000           }
4001 2168565 100       else if (stype == SVt_PVIO) {
4002           DEBUG_o(Perl_deb(aTHX_ "glob_assign_ref clearing PL_stashcache\n"));
4003           /* It's a cache. It will rebuild itself quite happily.
4004           It's a lot of effort to work out exactly which key (or keys)
4005           might be invalidated by the creation of the this file handle.
4006           */
4007 20         hv_clear(PL_stashcache);
4008           }
4009           break;
4010           }
4011 2270339 100       if (!intro) SvREFCNT_dec(dref);
4012 2270339 50       if (SvTAINTED(sstr))
    0        
4013 0 0       SvTAINT(dstr);
    0        
    0        
4014 2270339         return;
4015           }
4016            
4017           /* Work around compiler warnings about unsigned >= THRESHOLD when thres-
4018           hold is 0. */
4019           #if SV_COW_THRESHOLD
4020           # define GE_COW_THRESHOLD(len) ((len) >= SV_COW_THRESHOLD)
4021           #else
4022           # define GE_COW_THRESHOLD(len) 1
4023           #endif
4024           #if SV_COWBUF_THRESHOLD
4025           # define GE_COWBUF_THRESHOLD(len) ((len) >= SV_COWBUF_THRESHOLD)
4026           #else
4027           # define GE_COWBUF_THRESHOLD(len) 1
4028           #endif
4029            
4030           void
4031 2006120706         Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
4032           {
4033           dVAR;
4034           U32 sflags;
4035           int dtype;
4036           svtype stype;
4037            
4038           PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
4039            
4040 2006120706 100       if (sstr == dstr)
4041           return;
4042            
4043 2006118310 50       if (SvIS_FREED(dstr)) {
4044 0         Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
4045           " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
4046           }
4047 2006118310 100       SV_CHECK_THINKFIRST_COW_DROP(dstr);
4048 2006118248 100       if (!sstr)
4049           sstr = &PL_sv_undef;
4050 2006118248 100       if (SvIS_FREED(sstr)) {
4051 2         Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
4052           (void*)sstr, (void*)dstr);
4053           }
4054 2006118246         stype = SvTYPE(sstr);
4055 2006118246         dtype = SvTYPE(dstr);
4056            
4057           /* There's a lot of redundancy below but we're going for speed here */
4058            
4059 2006118246         switch (stype) {
4060           case SVt_NULL:
4061           undef_sstr:
4062 100088469 100       if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
4063 99946025 50       (void)SvOK_off(dstr);
4064           return;
4065           }
4066           break;
4067           case SVt_IV:
4068 943707383 100       if (SvIOK(sstr)) {
4069 444678728         switch (dtype) {
4070           case SVt_NULL:
4071 234767721         sv_upgrade(dstr, SVt_IV);
4072 234767721         break;
4073           case SVt_NV:
4074           case SVt_PV:
4075 321834         sv_upgrade(dstr, SVt_PVIV);
4076 321834         break;
4077           case SVt_PVGV:
4078           case SVt_PVLV:
4079           goto end_of_first_switch;
4080           }
4081 439777188 50       (void)SvIOK_only(dstr);
4082 439777188         SvIV_set(dstr, SvIVX(sstr));
4083 439777188 100       if (SvIsUV(sstr))
4084 53936         SvIsUV_on(dstr);
4085           /* SvTAINTED can only be true if the SV has taint magic, which in
4086           turn means that the SV type is PVMG (or greater). This is the
4087           case statement for SVt_IV, so this cannot be true (whatever gcov
4088           may say). */
4089           assert(!SvTAINTED(sstr));
4090           return;
4091           }
4092 499028655 100       if (!SvROK(sstr))
4093           goto undef_sstr;
4094 487511553 100       if (dtype < SVt_PV && dtype != SVt_IV)
4095 83497489         sv_upgrade(dstr, SVt_IV);
4096           break;
4097            
4098           case SVt_NV:
4099 9360370 100       if (SvNOK(sstr)) {
4100 9360368         switch (dtype) {
4101           case SVt_NULL:
4102           case SVt_IV:
4103 3905078         sv_upgrade(dstr, SVt_NV);
4104 3905078         break;
4105           case SVt_PV:
4106           case SVt_PVIV:
4107 49314         sv_upgrade(dstr, SVt_PVNV);
4108 49314         break;
4109           case SVt_PVGV:
4110           case SVt_PVLV:
4111           goto end_of_first_switch;
4112           }
4113 9342822         SvNV_set(dstr, SvNVX(sstr));
4114 9342822 50       (void)SvNOK_only(dstr);
4115           /* SvTAINTED can only be true if the SV has taint magic, which in
4116           turn means that the SV type is PVMG (or greater). This is the
4117           case statement for SVt_NV, so this cannot be true (whatever gcov
4118           may say). */
4119           assert(!SvTAINTED(sstr));
4120 9342822         return;
4121           }
4122           goto undef_sstr;
4123            
4124           case SVt_PV:
4125 607288604 100       if (dtype < SVt_PV)
4126 241946151         sv_upgrade(dstr, SVt_PV);
4127           break;
4128           case SVt_PVIV:
4129 42444802 100       if (dtype < SVt_PVIV)
4130 14761326         sv_upgrade(dstr, SVt_PVIV);
4131           break;
4132           case SVt_PVNV:
4133 131918240 100       if (dtype < SVt_PVNV)
4134 81943090         sv_upgrade(dstr, SVt_PVNV);
4135           break;
4136           default:
4137           {
4138 0         const char * const type = sv_reftype(sstr,0);
4139 0 0       if (PL_op)
4140           /* diag_listed_as: Bizarre copy of %s */
4141 0 0       Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
    0        
4142           else
4143 0         Perl_croak(aTHX_ "Bizarre copy of %s", type);
4144           }
4145           break;
4146            
4147           case SVt_REGEXP:
4148           upgregexp:
4149 66 100       if (dtype < SVt_REGEXP)
4150           {
4151 56 100       if (dtype >= SVt_PV) {
4152 26 100       SvPV_free(dstr);
    50        
    0        
    0        
4153 26         SvPV_set(dstr, 0);
4154 26         SvLEN_set(dstr, 0);
4155 26         SvCUR_set(dstr, 0);
4156           }
4157 56         sv_upgrade(dstr, SVt_REGEXP);
4158           }
4159           break;
4160            
4161           case SVt_INVLIST:
4162           case SVt_PVLV:
4163           case SVt_PVGV:
4164           case SVt_PVMG:
4165 182827422 100       if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
    100        
4166 16885509         mg_get(sstr);
4167 16885507 100       if (SvTYPE(sstr) != stype)
4168 4         stype = SvTYPE(sstr);
4169           }
4170 182827420 100       if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
    50        
4171 27476775         glob_assign_glob(dstr, sstr, dtype);
4172 27476775         return;
4173           }
4174 232551168 100       if (stype == SVt_PVLV)
    100        
    100        
4175           {
4176 450119 50       if (isREGEXP(sstr)) goto upgregexp;
    100        
4177 464056         SvUPGRADE(dstr, SVt_PVNV);
4178           }
4179           else
4180 146750178         SvUPGRADE(dstr, (svtype)stype);
4181           }
4182           end_of_first_switch:
4183            
4184           /* dstr may have been upgraded. */
4185 1429575434         dtype = SvTYPE(dstr);
4186 1429575434         sflags = SvFLAGS(sstr);
4187            
4188 1429575434 100       if (dtype == SVt_PVCV) {
4189           /* Assigning to a subroutine sets the prototype. */
4190 32 50       if (SvOK(sstr)) {
    0        
    0        
4191           STRLEN len;
4192 16 50       const char *const ptr = SvPV_const(sstr, len);
4193            
4194 16 50       SvGROW(dstr, len + 1);
    100        
4195 16         Copy(ptr, SvPVX(dstr), len + 1, char);
4196 16         SvCUR_set(dstr, len);
4197 16         SvPOK_only(dstr);
4198 16         SvFLAGS(dstr) |= sflags & SVf_UTF8;
4199 16         CvAUTOLOAD_off(dstr);
4200           } else {
4201 0 0       SvOK_off(dstr);
4202           }
4203           }
4204 1429575418 50       else if (dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM) {
4205 0         const char * const type = sv_reftype(dstr,0);
4206 0 0       if (PL_op)
4207           /* diag_listed_as: Cannot copy to %s */
4208 0 0       Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
    0        
4209           else
4210 0         Perl_croak(aTHX_ "Cannot copy to %s", type);
4211 1429575418 100       } else if (sflags & SVf_ROK) {
4212 548545323 100       if (isGV_with_GP(dstr)
    50        
4213 2304772 100       && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
    50        
    50        
4214 34427         sstr = SvRV(sstr);
4215 34427 100       if (sstr == dstr) {
4216 3094 50       if (GvIMPORTED(dstr) != GVf_IMPORTED
4217 3094 50       && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4218           {
4219 3094         GvIMPORTED_on(dstr);
4220           }
4221 3094         GvMULTI_on(dstr);
4222 3094         return;
4223           }
4224 31333         glob_assign_glob(dstr, sstr, dtype);
4225 31333         return;
4226           }
4227            
4228 548510896 100       if (dtype >= SVt_PV) {
4229 118957336 100       if (isGV_with_GP(dstr)) {
    50        
4230 2270345         glob_assign_ref(dstr, sstr);
4231 2270339         return;
4232           }
4233 116686991 100       if (SvPVX_const(dstr)) {
4234 1667224 50       SvPV_free(dstr);
    100        
    50        
    50        
4235 1667224         SvLEN_set(dstr, 0);
4236 1667224         SvCUR_set(dstr, 0);
4237           }
4238           }
4239 546240551 50       (void)SvOK_off(dstr);
4240 1092481102         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4241 546240551         SvFLAGS(dstr) |= sflags & SVf_ROK;
4242           assert(!(sflags & SVp_NOK));
4243           assert(!(sflags & SVp_IOK));
4244           assert(!(sflags & SVf_NOK));
4245           assert(!(sflags & SVf_IOK));
4246           }
4247 881030095 100       else if (isGV_with_GP(dstr)) {
    50        
4248 106 100       if (!(sflags & SVf_OK)) {
4249 28         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4250           "Undefined value assigned to typeglob");
4251           }
4252           else {
4253 78         GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
4254 78 50       if (dstr != (const SV *)gv) {
4255 78         const char * const name = GvNAME((const GV *)dstr);
4256 78         const STRLEN len = GvNAMELEN(dstr);
4257           HV *old_stash = NULL;
4258           bool reset_isa = FALSE;
4259 78 100       if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
    100        
    50        
4260 34 100       || (len == 1 && name[0] == ':')) {
    50        
4261           /* Set aside the old stash, so we can reset isa caches
4262           on its subclasses. */
4263 44 50       if((old_stash = GvHV(dstr))) {
4264           /* Make sure we do not lose it early. */
4265 44         SvREFCNT_inc_simple_void_NN(
4266           sv_2mortal((SV *)old_stash)
4267           );
4268           }
4269           reset_isa = TRUE;
4270           }
4271            
4272 78 50       if (GvGP(dstr))
4273 78         gp_free(MUTABLE_GV(dstr));
4274 76         GvGP_set(dstr, gp_ref(GvGP(gv)));
4275            
4276 76 100       if (reset_isa) {
4277 44         HV * const stash = GvHV(dstr);
4278 44 50       if(
4279 44 50       old_stash ? (HV *)HvENAME_get(old_stash) : stash
    50        
    50        
    50        
    50        
    50        
    50        
    50        
4280           )
4281 44         mro_package_moved(
4282           stash, old_stash,
4283           (GV *)dstr, 0
4284           );
4285           }
4286           }
4287           }
4288           }
4289 881029989 100       else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4290 5653373 100       && (stype == SVt_REGEXP || isREGEXP(sstr))) {
    50        
    100        
4291 66         reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4292           }
4293 881029923 100       else if (sflags & SVp_POK) {
4294           bool isSwipe = 0;
4295 817703680         const STRLEN cur = SvCUR(sstr);
4296 817703680         const STRLEN len = SvLEN(sstr);
4297            
4298           /*
4299           * Check to see if we can just swipe the string. If so, it's a
4300           * possible small lose on short strings, but a big win on long ones.
4301           * It might even be a win on short strings if SvPVX_const(dstr)
4302           * has to be allocated and SvPVX_const(sstr) has to be freed.
4303           * Likewise if we can set up COW rather than doing an actual copy, we
4304           * drop to the else clause, as the swipe code and the COW setup code
4305           * have much in common.
4306           */
4307            
4308           /* Whichever path we take through the next code, we want this true,
4309           and doing it now facilitates the COW check. */
4310 817703680         (void)SvPOK_only(dstr);
4311            
4312 817703680 100       if (
4313           /* If we're already COW then this clause is not true, and if COW
4314           is allowed then we drop down to the else and make dest COW
4315           with us. If caller hasn't said that we're allowed to COW
4316           shared hash keys then we don't do the COW setup, even if the
4317           source scalar is a shared hash key scalar. */
4318 817703680         (((flags & SV_COW_SHARED_HASH_KEYS)
4319 778547945         ? !(sflags & SVf_IsCOW)
4320           #ifdef PERL_NEW_COPY_ON_WRITE
4321 354552683 100       || (len &&
    100        
4322 258440152 100       ((!GE_COWBUF_THRESHOLD(cur) && SvLEN(dstr) > cur)
4323           /* If this is a regular (non-hek) COW, only so many COW
4324           "copies" are possible. */
4325 229232425 100       || CowREFCNT(sstr) == SV_COW_REFCNT_MAX))
4326           #endif
4327           : 1 /* If making a COW copy is forbidden then the behaviour we
4328           desire is as if the source SV isn't actually already
4329           COW, even if it is. So we act as if the source flags
4330           are not COW, rather than actually testing them. */
4331           )
4332           #ifndef PERL_ANY_COW
4333           /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4334           when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4335           Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4336           override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4337           but in turn, it's somewhat dead code, never expected to go
4338           live, but more kept as a placeholder on how to do it better
4339           in a newer implementation. */
4340           /* If we are COW and dstr is a suitable target then we drop down
4341           into the else and make dest a COW of us. */
4342           || (SvFLAGS(dstr) & SVf_BREAK)
4343           #endif
4344           )
4345 1273974723 100       &&
    100        
4346 495426778         !(isSwipe =
4347           #ifdef PERL_NEW_COPY_ON_WRITE
4348           /* slated for free anyway (and not COW)? */
4349 495426778         (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP &&
4350           #else
4351           (sflags & SVs_TEMP) && /* slated for free anyway? */
4352           #endif
4353 93339748 100       !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4354 93339748         (!(flags & SV_NOSTEAL)) &&
4355           /* and we're allowed to steal temps */
4356 587302430 100       SvREFCNT(sstr) == 1 && /* and no other references to it? */
    100        
4357           len) /* and really is a string */
4358           #ifdef PERL_ANY_COW
4359 587165357 100       && ((flags & SV_COW_SHARED_HASH_KEYS)
    100        
4360 425116316 100       ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4361           # ifdef PERL_OLD_COPY_ON_WRITE
4362           && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4363           && SvTYPE(sstr) >= SVt_PVIV && len
4364           # else
4365 266031612 50       && !(SvFLAGS(dstr) & SVf_BREAK)
4366 266031612         && !(sflags & SVf_IsCOW)
4367 266031612 100       && GE_COW_THRESHOLD(cur) && cur+1 < len
    100        
4368 242506690 100       && (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1)
4369           # endif
4370           ))
4371           : 1)
4372           #endif
4373           ) {
4374           /* Failed the swipe test, and it's not a shared hash key either.
4375           Have to copy the string. */
4376 228699921 50       SvGROW(dstr, cur + 1); /* inlined from sv_setpvn */
    100        
4377 228699921         Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
4378 228699921         SvCUR_set(dstr, cur);
4379 228699921         *SvEND(dstr) = '\0';
4380           } else {
4381           /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4382           be true in here. */
4383           /* Either it's a shared hash key, or it's suitable for
4384           copy-on-write or we can swipe the string. */
4385           if (DEBUG_C_TEST) {
4386           PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4387           sv_dump(sstr);
4388           sv_dump(dstr);
4389           }
4390           #ifdef PERL_ANY_COW
4391 589003759 100       if (!isSwipe) {
4392 498747387 100       if (!(sflags & SVf_IsCOW)) {
4393 176470485         SvIsCOW_on(sstr);
4394           # ifdef PERL_OLD_COPY_ON_WRITE
4395           /* Make the source SV into a loop of 1.
4396           (about to become 2) */
4397           SV_COW_NEXT_SV_SET(sstr, sstr);
4398           # else
4399 176470485         CowREFCNT(sstr) = 0;
4400           # endif
4401           }
4402           }
4403           #endif
4404           /* Initial code is common. */
4405 589003759 100       if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4406 62494203 100       SvPV_free(dstr);
    100        
    50        
    100        
4407           }
4408            
4409 589003759 100       if (!isSwipe) {
4410           /* making another shared SV. */
4411           #ifdef PERL_ANY_COW
4412 498747387 100       if (len) {
4413           # ifdef PERL_OLD_COPY_ON_WRITE
4414           assert (SvTYPE(dstr) >= SVt_PVIV);
4415           /* SvIsCOW_normal */
4416           /* splice us in between source and next-after-source. */
4417           SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4418           SV_COW_NEXT_SV_SET(sstr, dstr);
4419           # else
4420 402757514         CowREFCNT(sstr)++;
4421           # endif
4422 402757514         SvPV_set(dstr, SvPVX_mutable(sstr));
4423           } else
4424           #endif
4425           {
4426           /* SvIsCOW_shared_hash */
4427           DEBUG_C(PerlIO_printf(Perl_debug_log,
4428           "Copy on write: Sharing hash\n"));
4429            
4430           assert (SvTYPE(dstr) >= SVt_PV);
4431 95989873         SvPV_set(dstr,
4432           HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4433           }
4434 498747387         SvLEN_set(dstr, len);
4435 498747387         SvCUR_set(dstr, cur);
4436 498747387         SvIsCOW_on(dstr);
4437           }
4438           else
4439           { /* Passes the swipe test. */
4440 90256372         SvPV_set(dstr, SvPVX_mutable(sstr));
4441 90256372         SvLEN_set(dstr, SvLEN(sstr));
4442 90256372         SvCUR_set(dstr, SvCUR(sstr));
4443            
4444 90256372         SvTEMP_off(dstr);
4445 90256372 50       (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4446 90256372         SvPV_set(sstr, NULL);
4447 90256372         SvLEN_set(sstr, 0);
4448 90256372         SvCUR_set(sstr, 0);
4449 90256372         SvTEMP_off(sstr);
4450           }
4451           }
4452 817703680 100       if (sflags & SVp_NOK) {
4453 98888985         SvNV_set(dstr, SvNVX(sstr));
4454           }
4455 817703680 100       if (sflags & SVp_IOK) {
4456 105167063         SvIV_set(dstr, SvIVX(sstr));
4457           /* Must do this otherwise some other overloaded use of 0x80000000
4458           gets confused. I guess SVpbm_VALID */
4459 105167063 100       if (sflags & SVf_IVisUV)
4460 260         SvIsUV_on(dstr);
4461           }
4462 817703680         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4463           {
4464 817703680 100       const MAGIC * const smg = SvVSTRING_mg(sstr);
4465 817703680 100       if (smg) {
4466 690         sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4467           smg->mg_ptr, smg->mg_len);
4468 690         SvRMAGICAL_on(dstr);
4469           }
4470           }
4471           }
4472 63326243 100       else if (sflags & (SVp_IOK|SVp_NOK)) {
4473 55718483 50       (void)SvOK_off(dstr);
4474 55718483         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4475 55718483 100       if (sflags & SVp_IOK) {
4476           /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4477 50039455         SvIV_set(dstr, SvIVX(sstr));
4478           }
4479 55718483 100       if (sflags & SVp_NOK) {
4480 6100894         SvNV_set(dstr, SvNVX(sstr));
4481           }
4482           }
4483           else {
4484 7607760 50       if (isGV_with_GP(sstr)) {
    0        
4485 0         gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4486           }
4487           else
4488 7607760 50       (void)SvOK_off(dstr);
4489           }
4490 1427270660 100       if (SvTAINTED(sstr))
    100        
4491 1005702010 50       SvTAINT(dstr);
    50        
    50        
4492           }
4493            
4494           /*
4495           =for apidoc sv_setsv_mg
4496            
4497           Like C, but also handles 'set' magic.
4498            
4499           =cut
4500           */
4501            
4502           void
4503 44         Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr)
4504           {
4505           PERL_ARGS_ASSERT_SV_SETSV_MG;
4506            
4507 44         sv_setsv(dstr,sstr);
4508 44 100       SvSETMAGIC(dstr);
4509 44         }
4510            
4511           #ifdef PERL_ANY_COW
4512           # ifdef PERL_OLD_COPY_ON_WRITE
4513           # define SVt_COW SVt_PVIV
4514           # else
4515           # define SVt_COW SVt_PV
4516           # endif
4517           SV *
4518 60628184         Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4519 60628184 100       {
4520 60628184         STRLEN cur = SvCUR(sstr);
4521 60628184         STRLEN len = SvLEN(sstr);
4522           char *new_pv;
4523            
4524           PERL_ARGS_ASSERT_SV_SETSV_COW;
4525            
4526           if (DEBUG_C_TEST) {
4527           PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4528           (void*)sstr, (void*)dstr);
4529           sv_dump(sstr);
4530           if (dstr)
4531           sv_dump(dstr);
4532           }
4533            
4534 60628184 100       if (dstr) {
4535 55163380 50       if (SvTHINKFIRST(dstr))
4536 0         sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4537 55163380 100       else if (SvPVX_const(dstr))
4538 22283121         Safefree(SvPVX_mutable(dstr));
4539           }
4540           else
4541 5464804 100       new_SV(dstr);
4542 35565095         SvUPGRADE(dstr, SVt_COW);
4543            
4544           assert (SvPOK(sstr));
4545           assert (SvPOKp(sstr));
4546           # ifdef PERL_OLD_COPY_ON_WRITE
4547           assert (!SvIOK(sstr));
4548           assert (!SvIOKp(sstr));
4549           assert (!SvNOK(sstr));
4550           assert (!SvNOKp(sstr));
4551           # endif
4552            
4553 69208094 100       if (SvIsCOW(sstr)) {
    50        
4554            
4555 43101406 100       if (SvLEN(sstr) == 0) {
4556           /* source is a COW shared hash key. */
4557           DEBUG_C(PerlIO_printf(Perl_debug_log,
4558           "Fast copy on write: Sharing hash\n"));
4559 29230252         new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4560 29230252         goto common_exit;
4561           }
4562           # ifdef PERL_OLD_COPY_ON_WRITE
4563           SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4564           # else
4565           assert(SvCUR(sstr)+1 < SvLEN(sstr));
4566           assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX);
4567           # endif
4568           } else {
4569           assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4570 8579910         SvUPGRADE(sstr, SVt_COW);
4571 17526778         SvIsCOW_on(sstr);
4572           DEBUG_C(PerlIO_printf(Perl_debug_log,
4573           "Fast copy on write: Converting sstr to COW\n"));
4574           # ifdef PERL_OLD_COPY_ON_WRITE
4575           SV_COW_NEXT_SV_SET(dstr, sstr);
4576           # else
4577 17526778         CowREFCNT(sstr) = 0;
4578           # endif
4579           }
4580           # ifdef PERL_OLD_COPY_ON_WRITE
4581           SV_COW_NEXT_SV_SET(sstr, dstr);
4582           # else
4583 31397932         CowREFCNT(sstr)++;
4584           # endif
4585 31397932         new_pv = SvPVX_mutable(sstr);
4586            
4587           common_exit:
4588 60628184         SvPV_set(dstr, new_pv);
4589 60628184         SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
4590 60628184 100       if (SvUTF8(sstr))
4591 1099562         SvUTF8_on(dstr);
4592 60628184         SvLEN_set(dstr, len);
4593 60628184         SvCUR_set(dstr, cur);
4594           if (DEBUG_C_TEST) {
4595           sv_dump(dstr);
4596           }
4597 60628184         return dstr;
4598           }
4599           #endif
4600            
4601           /*
4602           =for apidoc sv_setpvn
4603            
4604           Copies a string into an SV. The C parameter indicates the number of
4605           bytes to be copied. If the C argument is NULL the SV will become
4606           undefined. Does not handle 'set' magic. See C.
4607            
4608           =cut
4609           */
4610            
4611           void
4612 659470505         Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4613 658315909 100       {
4614           dVAR;
4615           char *dptr;
4616            
4617           PERL_ARGS_ASSERT_SV_SETPVN;
4618            
4619 659470505 100       SV_CHECK_THINKFIRST_COW_DROP(sv);
4620 659470505 100       if (!ptr) {
4621 1154596 50       (void)SvOK_off(sv);
4622 659470505         return;
4623           }
4624           else {
4625           /* len is STRLEN which is unsigned, need to copy to signed */
4626 658315909         const IV iv = len;
4627 658315909 50       if (iv < 0)
4628 0         Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
4629           IVdf, iv);
4630           }
4631 712136246         SvUPGRADE(sv, SVt_PV);
4632            
4633 658315909 50       dptr = SvGROW(sv, len + 1);
    100        
4634           Move(ptr,dptr,len,char);
4635 658315909         dptr[len] = '\0';
4636 658315909         SvCUR_set(sv, len);
4637 658315909         (void)SvPOK_only_UTF8(sv); /* validate pointer */
4638 658315909 100       SvTAINT(sv);
    100        
    50        
4639 658315909 100       if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4640           }
4641            
4642           /*
4643           =for apidoc sv_setpvn_mg
4644            
4645           Like C, but also handles 'set' magic.
4646            
4647           =cut
4648           */
4649            
4650           void
4651 2         Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4652           {
4653           PERL_ARGS_ASSERT_SV_SETPVN_MG;
4654            
4655 2         sv_setpvn(sv,ptr,len);
4656 2 50       SvSETMAGIC(sv);
4657 2         }
4658            
4659           /*
4660           =for apidoc sv_setpv
4661            
4662           Copies a string into an SV. The string must be null-terminated. Does not
4663           handle 'set' magic. See C.
4664            
4665           =cut
4666           */
4667            
4668           void
4669 48726902         Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
4670 45973750 100       {
4671           dVAR;
4672           STRLEN len;
4673            
4674           PERL_ARGS_ASSERT_SV_SETPV;
4675            
4676 48726902 100       SV_CHECK_THINKFIRST_COW_DROP(sv);
4677 48726902 100       if (!ptr) {
4678 2753152 50       (void)SvOK_off(sv);
4679 48726902         return;
4680           }
4681 45973750         len = strlen(ptr);
4682 29104202         SvUPGRADE(sv, SVt_PV);
4683            
4684 45973750 50       SvGROW(sv, len + 1);
    100        
4685 45973750         Move(ptr,SvPVX(sv),len+1,char);
4686 45973750         SvCUR_set(sv, len);
4687 45973750         (void)SvPOK_only_UTF8(sv); /* validate pointer */
4688 45973750 100       SvTAINT(sv);
    100        
    50        
4689 45973750 100       if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4690           }
4691            
4692           /*
4693           =for apidoc sv_setpv_mg
4694            
4695           Like C, but also handles 'set' magic.
4696            
4697           =cut
4698           */
4699            
4700           void
4701 454022         Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
4702           {
4703           PERL_ARGS_ASSERT_SV_SETPV_MG;
4704            
4705 454022         sv_setpv(sv,ptr);
4706 454022 100       SvSETMAGIC(sv);
4707 454022         }
4708            
4709           void
4710 261753296         Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
4711           {
4712           dVAR;
4713            
4714           PERL_ARGS_ASSERT_SV_SETHEK;
4715            
4716 261753296 50       if (!hek) {
4717           return;
4718           }
4719            
4720 261753296 50       if (HEK_LEN(hek) == HEf_SVKEY) {
4721 0         sv_setsv(sv, *(SV**)HEK_KEY(hek));
4722 0         return;
4723 261753212 100       } else {
4724 261753296         const int flags = HEK_FLAGS(hek);
4725 261753296 100       if (flags & HVhek_WASUTF8) {
4726 84         STRLEN utf8_len = HEK_LEN(hek);
4727 84         char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
4728 84         sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
4729 84         SvUTF8_on(sv);
4730 84         return;
4731 261753212 50       } else if (flags & HVhek_UNSHARED) {
4732 0         sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
4733 0 0       if (HEK_UTF8(hek))
4734 0         SvUTF8_on(sv);
4735 0         else SvUTF8_off(sv);
4736           return;
4737           }
4738           {
4739 261753212 100       SV_CHECK_THINKFIRST_COW_DROP(sv);
4740 131130896         SvUPGRADE(sv, SVt_PV);
4741 261753212 100       SvPV_free(sv);
    50        
    0        
    0        
4742 261753212         SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
4743 261753212         SvCUR_set(sv, HEK_LEN(hek));
4744 261753212         SvLEN_set(sv, 0);
4745 261753212         SvIsCOW_on(sv);
4746 261753212         SvPOK_on(sv);
4747 261753212 100       if (HEK_UTF8(hek))
4748 1298         SvUTF8_on(sv);
4749 261752605         else SvUTF8_off(sv);
4750           return;
4751           }
4752           }
4753           }
4754            
4755            
4756           /*
4757           =for apidoc sv_usepvn_flags
4758            
4759           Tells an SV to use C to find its string value. Normally the
4760           string is stored inside the SV but sv_usepvn allows the SV to use an
4761           outside string. The C should point to memory that was allocated
4762           by C. It must be the start of a mallocked block
4763           of memory, and not a pointer to the middle of it. The
4764           string length, C, must be supplied. By default
4765           this function will realloc (i.e. move) the memory pointed to by C,
4766           so that pointer should not be freed or used by the programmer after
4767           giving it to sv_usepvn, and neither should any pointers from "behind"
4768           that pointer (e.g. ptr + 1) be used.
4769            
4770           If C & SV_SMAGIC is true, will call SvSETMAGIC. If C &
4771           SV_HAS_TRAILING_NUL is true, then C must be NUL, and the realloc
4772           will be skipped (i.e. the buffer is actually at least 1 byte longer than
4773           C, and already meets the requirements for storing in C).
4774            
4775           =cut
4776           */
4777            
4778           void
4779 334644         Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4780 334644 100       {
4781           dVAR;
4782           STRLEN allocate;
4783            
4784           PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4785            
4786 334644 100       SV_CHECK_THINKFIRST_COW_DROP(sv);
4787 165296         SvUPGRADE(sv, SVt_PV);
4788 334644 50       if (!ptr) {
4789 0 0       (void)SvOK_off(sv);
4790 0 0       if (flags & SV_SMAGIC)
4791 0 0       SvSETMAGIC(sv);
4792 334644         return;
4793           }
4794 334644 100       if (SvPVX_const(sv))
4795 50510 50       SvPV_free(sv);
    50        
    0        
    0        
4796            
4797           #ifdef DEBUGGING
4798           if (flags & SV_HAS_TRAILING_NUL)
4799           assert(ptr[len] == '\0');
4800           #endif
4801            
4802 334644         allocate = (flags & SV_HAS_TRAILING_NUL)
4803 334764 100       ? len + 1 :
4804           #ifdef Perl_safesysmalloc_size
4805           len + 1;
4806           #else
4807 120 50       PERL_STRLEN_ROUNDUP(len + 1);
4808           #endif
4809 334644 100       if (flags & SV_HAS_TRAILING_NUL) {
4810           /* It's long enough - do nothing.
4811           Specifically Perl_newCONSTSUB is relying on this. */
4812           } else {
4813           #ifdef DEBUGGING
4814           /* Force a move to shake out bugs in callers. */
4815           char *new_ptr = (char*)safemalloc(allocate);
4816           Copy(ptr, new_ptr, len, char);
4817           PoisonFree(ptr,len,char);
4818           Safefree(ptr);
4819           ptr = new_ptr;
4820           #else
4821 120         ptr = (char*) saferealloc (ptr, allocate);
4822           #endif
4823           }
4824           #ifdef Perl_safesysmalloc_size
4825           SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4826           #else
4827 334644         SvLEN_set(sv, allocate);
4828           #endif
4829 334644         SvCUR_set(sv, len);
4830 334644         SvPV_set(sv, ptr);
4831 334644 100       if (!(flags & SV_HAS_TRAILING_NUL)) {
4832 120         ptr[len] = '\0';
4833           }
4834 334644         (void)SvPOK_only_UTF8(sv); /* validate pointer */
4835 334644 100       SvTAINT(sv);
    50        
    0        
4836 334644 100       if (flags & SV_SMAGIC)
4837 2 50       SvSETMAGIC(sv);
4838           }
4839            
4840           #ifdef PERL_OLD_COPY_ON_WRITE
4841           /* Need to do this *after* making the SV normal, as we need the buffer
4842           pointer to remain valid until after we've copied it. If we let go too early,
4843           another thread could invalidate it by unsharing last of the same hash key
4844           (which it can do by means other than releasing copy-on-write Svs)
4845           or by changing the other copy-on-write SVs in the loop. */
4846           STATIC void
4847           S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after)
4848           {
4849           PERL_ARGS_ASSERT_SV_RELEASE_COW;
4850            
4851           { /* this SV was SvIsCOW_normal(sv) */
4852           /* we need to find the SV pointing to us. */
4853           SV *current = SV_COW_NEXT_SV(after);
4854            
4855           if (current == sv) {
4856           /* The SV we point to points back to us (there were only two of us
4857           in the loop.)
4858           Hence other SV is no longer copy on write either. */
4859           SvIsCOW_off(after);
4860           } else {
4861           /* We need to follow the pointers around the loop. */
4862           SV *next;
4863           while ((next = SV_COW_NEXT_SV(current)) != sv) {
4864           assert (next);
4865           current = next;
4866           /* don't loop forever if the structure is bust, and we have
4867           a pointer into a closed loop. */
4868           assert (current != after);
4869           assert (SvPVX_const(current) == pvx);
4870           }
4871           /* Make the SV before us point to the SV after us. */
4872           SV_COW_NEXT_SV_SET(current, after);
4873           }
4874           }
4875           }
4876           #endif
4877           /*
4878           =for apidoc sv_force_normal_flags
4879            
4880           Undo various types of fakery on an SV, where fakery means
4881           "more than" a string: if the PV is a shared string, make
4882           a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4883           an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4884           we do the copy, and is also used locally; if this is a
4885           vstring, drop the vstring magic. If C is set
4886           then a copy-on-write scalar drops its PV buffer (if any) and becomes
4887           SvPOK_off rather than making a copy. (Used where this
4888           scalar is about to be set to some other value.) In addition,
4889           the C parameter gets passed to C
4890           when unreffing. C calls this function
4891           with flags set to 0.
4892            
4893           =cut
4894           */
4895            
4896           static void
4897 767424465         S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
4898           {
4899           dVAR;
4900            
4901           assert(SvIsCOW(sv));
4902           {
4903           #ifdef PERL_ANY_COW
4904 767424465         const char * const pvx = SvPVX_const(sv);
4905 767424465         const STRLEN len = SvLEN(sv);
4906 767424465         const STRLEN cur = SvCUR(sv);
4907           # ifdef PERL_OLD_COPY_ON_WRITE
4908           /* next COW sv in the loop. If len is 0 then this is a shared-hash
4909           key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4910           we'll fail an assertion. */
4911           SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4912           # endif
4913            
4914           if (DEBUG_C_TEST) {
4915           PerlIO_printf(Perl_debug_log,
4916           "Copy on write: Force normal %ld\n",
4917           (long) flags);
4918           sv_dump(sv);
4919           }
4920 767424465         SvIsCOW_off(sv);
4921           # ifdef PERL_NEW_COPY_ON_WRITE
4922 767424465 100       if (len && CowREFCNT(sv) == 0)
    100        
4923           /* We own the buffer ourselves. */
4924           NOOP;
4925           else
4926           # endif
4927           {
4928          
4929           /* This SV doesn't own the buffer, so need to Newx() a new one: */
4930           # ifdef PERL_NEW_COPY_ON_WRITE
4931           /* Must do this first, since the macro uses SvPVX. */
4932 653693286 100       if (len) CowREFCNT(sv)--;
4933           # endif
4934 653693286         SvPV_set(sv, NULL);
4935 653693286         SvLEN_set(sv, 0);
4936 653693286 100       if (flags & SV_COW_DROP_PV) {
4937           /* OK, so we don't need to copy our buffer. */
4938 640364794         SvPOK_off(sv);
4939           } else {
4940 13328492 50       SvGROW(sv, cur + 1);
    50        
4941 13328492         Move(pvx,SvPVX(sv),cur,char);
4942 13328492         SvCUR_set(sv, cur);
4943 13328492         *SvEND(sv) = '\0';
4944           }
4945 653693286 100       if (len) {
4946           # ifdef PERL_OLD_COPY_ON_WRITE
4947           sv_release_COW(sv, pvx, next);
4948           # endif
4949           } else {
4950 366171262         unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4951           }
4952           if (DEBUG_C_TEST) {
4953           sv_dump(sv);
4954           }
4955           }
4956           #else
4957           const char * const pvx = SvPVX_const(sv);
4958           const STRLEN len = SvCUR(sv);
4959           SvIsCOW_off(sv);
4960           SvPV_set(sv, NULL);
4961           SvLEN_set(sv, 0);
4962           if (flags & SV_COW_DROP_PV) {
4963           /* OK, so we don't need to copy our buffer. */
4964           SvPOK_off(sv);
4965           } else {
4966           SvGROW(sv, len + 1);
4967           Move(pvx,SvPVX(sv),len,char);
4968           *SvEND(sv) = '\0';
4969           }
4970           unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4971           #endif
4972           }
4973 767424465         }
4974            
4975           void
4976 1252285707         Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
4977           {
4978           PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4979            
4980 1252285707 100       if (SvREADONLY(sv))
4981 78         Perl_croak_no_modify();
4982 1252285629 100       else if (SvIsCOW(sv))
4983 757655483         S_sv_uncow(aTHX_ sv, flags);
4984 1252285629 100       if (SvROK(sv))
4985 465097065         sv_unref_flags(sv, flags);
4986 787188564 100       else if (SvFAKE(sv) && isGV_with_GP(sv))
    100        
    50        
4987           sv_unglob(sv, flags);
4988 760105808 100       else if (SvFAKE(sv) && isREGEXP(sv)) {
    100        
    50        
4989           /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
4990           to sv_unglob. We only need it here, so inline it. */
4991 52         const bool islv = SvTYPE(sv) == SVt_PVLV;
4992 73 100       const svtype new_type =
    100        
4993 62 100       islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
4994 52         SV *const temp = newSV_type(new_type);
4995           regexp *const temp_p = ReANY((REGEXP *)sv);
4996            
4997 52 100       if (new_type == SVt_PVMG) {
4998 6         SvMAGIC_set(temp, SvMAGIC(sv));
4999 6         SvMAGIC_set(sv, NULL);
5000 6         SvSTASH_set(temp, SvSTASH(sv));
5001 6         SvSTASH_set(sv, NULL);
5002           }
5003 52 100       if (!islv) SvCUR_set(temp, SvCUR(sv));
5004           /* Remember that SvPVX is in the head, not the body. But
5005           RX_WRAPPED is in the body. */
5006           assert(ReANY((REGEXP *)sv)->mother_re);
5007           /* Their buffer is already owned by someone else. */
5008 52 100       if (flags & SV_COW_DROP_PV) {
5009           /* SvLEN is already 0. For SVt_REGEXP, we have a brand new
5010           zeroed body. For SVt_PVLV, it should have been set to 0
5011           before turning into a regexp. */
5012           assert(!SvLEN(islv ? sv : temp));
5013 44         sv->sv_u.svu_pv = 0;
5014           }
5015           else {
5016 12         sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
5017 8 100       SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
5018 8         SvPOK_on(sv);
5019           }
5020            
5021           /* Now swap the rest of the bodies. */
5022            
5023 52         SvFAKE_off(sv);
5024 52 100       if (!islv) {
5025 42         SvFLAGS(sv) &= ~SVTYPEMASK;
5026 42         SvFLAGS(sv) |= new_type;
5027 42         SvANY(sv) = SvANY(temp);
5028           }
5029            
5030 52         SvFLAGS(temp) &= ~(SVTYPEMASK);
5031 52         SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
5032 52         SvANY(temp) = temp_p;
5033 52         temp->sv_u.svu_rx = (regexp *)temp_p;
5034            
5035 52         SvREFCNT_dec_NN(temp);
5036           }
5037 760105704 100       else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
    100        
5038 1252285627         }
5039            
5040           /*
5041           =for apidoc sv_chop
5042            
5043           Efficient removal of characters from the beginning of the string buffer.
5044           SvPOK(sv), or at least SvPOKp(sv), must be true and the C must be a
5045           pointer to somewhere inside the string buffer. The C becomes the first
5046           character of the adjusted string. Uses the "OOK hack". On return, only
5047           SvPOK(sv) and SvPOKp(sv) among the OK flags will be true.
5048            
5049           Beware: after this function returns, C and SvPVX_const(sv) may no longer
5050           refer to the same chunk of data.
5051            
5052           The unfortunate similarity of this function's name to that of Perl's C
5053           operator is strictly coincidental. This function works from the left;
5054           C works from the right.
5055            
5056           =cut
5057           */
5058            
5059           void
5060 1277240         Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
5061           {
5062           STRLEN delta;
5063           STRLEN old_delta;
5064           U8 *p;
5065           #ifdef DEBUGGING
5066           const U8 *evacp;
5067           STRLEN evacn;
5068           #endif
5069           STRLEN max_delta;
5070            
5071           PERL_ARGS_ASSERT_SV_CHOP;
5072            
5073 1277240 100       if (!ptr || !SvPOKp(sv))
    100        
5074           return;
5075 1277044         delta = ptr - SvPVX_const(sv);
5076 1277044 100       if (!delta) {
5077           /* Nothing to do. */
5078           return;
5079           }
5080 1267350 100       max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
5081 1267350 50       if (delta > max_delta)
5082 0         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
5083 0         ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
5084           /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
5085 1267350 100       SV_CHECK_THINKFIRST(sv);
5086 1267350         SvPOK_only_UTF8(sv);
5087            
5088 1267350 100       if (!SvOOK(sv)) {
5089 591426 50       if (!SvLEN(sv)) { /* make copy of shared string */
5090 0         const char *pvx = SvPVX_const(sv);
5091 0         const STRLEN len = SvCUR(sv);
5092 0 0       SvGROW(sv, len + 1);
    0        
5093 0         Move(pvx,SvPVX(sv),len,char);
5094 0         *SvEND(sv) = '\0';
5095           }
5096 591426         SvOOK_on(sv);
5097 591426         old_delta = 0;
5098           } else {
5099 675924 50       SvOOK_offset(sv, old_delta);
    100        
5100           }
5101 1267350         SvLEN_set(sv, SvLEN(sv) - delta);
5102 1267350         SvCUR_set(sv, SvCUR(sv) - delta);
5103 1267350         SvPV_set(sv, SvPVX(sv) + delta);
5104            
5105 1267350         p = (U8 *)SvPVX_const(sv);
5106            
5107           #ifdef DEBUGGING
5108           /* how many bytes were evacuated? we will fill them with sentinel
5109           bytes, except for the part holding the new offset of course. */
5110           evacn = delta;
5111           if (old_delta)
5112           evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
5113           assert(evacn);
5114           assert(evacn <= delta + old_delta);
5115           evacp = p - evacn;
5116           #endif
5117            
5118           /* This sets 'delta' to the accumulated value of all deltas so far */
5119 1267350         delta += old_delta;
5120           assert(delta);
5121            
5122           /* If 'delta' fits in a byte, store it just prior to the new beginning of
5123           * the string; otherwise store a 0 byte there and store 'delta' just prior
5124           * to that, using as many bytes as a STRLEN occupies. Thus it overwrites a
5125           * portion of the chopped part of the string */
5126 1267350 100       if (delta < 0x100) {
5127 886110         *--p = (U8) delta;
5128           } else {
5129 381240         *--p = 0;
5130 381240         p -= sizeof(STRLEN);
5131 381240         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
5132           }
5133            
5134           #ifdef DEBUGGING
5135           /* Fill the preceding buffer with sentinals to verify that no-one is
5136           using it. */
5137           while (p > evacp) {
5138           --p;
5139           *p = (U8)PTR2UV(p);
5140           }
5141           #endif
5142           }
5143            
5144           /*
5145           =for apidoc sv_catpvn
5146            
5147           Concatenates the string onto the end of the string which is in the SV. The
5148           C indicates number of bytes to copy. If the SV has the UTF-8
5149           status set, then the bytes appended should be valid UTF-8.
5150           Handles 'get' magic, but not 'set' magic. See C.
5151            
5152           =for apidoc sv_catpvn_flags
5153            
5154           Concatenates the string onto the end of the string which is in the SV. The
5155           C indicates number of bytes to copy. If the SV has the UTF-8
5156           status set, then the bytes appended should be valid UTF-8.
5157           If C has the C bit set, will
5158           C on C afterwards if appropriate.
5159           C and C are implemented
5160           in terms of this function.
5161            
5162           =cut
5163           */
5164            
5165           void
5166 489230917         Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
5167           {
5168           dVAR;
5169           STRLEN dlen;
5170 489230917 100       const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5171            
5172           PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5173           assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5174            
5175 489230917 100       if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
    100        
5176 489002249 100       if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
    100        
5177 73922         sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5178 73922         dlen = SvCUR(dsv);
5179           }
5180 488928327 50       else SvGROW(dsv, dlen + slen + 1);
    100        
5181 489002249 100       if (sstr == dstr)
5182 32         sstr = SvPVX_const(dsv);
5183 489002249         Move(sstr, SvPVX(dsv) + dlen, slen, char);
5184 489002249         SvCUR_set(dsv, SvCUR(dsv) + slen);
5185           }
5186           else {
5187           /* We inline bytes_to_utf8, to avoid an extra malloc. */
5188 228668         const char * const send = sstr + slen;
5189           U8 *d;
5190            
5191           /* Something this code does not account for, which I think is
5192           impossible; it would require the same pv to be treated as
5193           bytes *and* utf8, which would indicate a bug elsewhere. */
5194           assert(sstr != dstr);
5195            
5196 228668 50       SvGROW(dsv, dlen + slen * 2 + 1);
    100        
5197 228668         d = (U8 *)SvPVX(dsv) + dlen;
5198            
5199 3680454 100       while (sstr < send) {
5200 3337452         append_utf8_from_native_byte(*sstr, &d);
5201 3337452         sstr++;
5202           }
5203 228668         SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5204           }
5205 489230917         *SvEND(dsv) = '\0';
5206 489230917         (void)SvPOK_only_UTF8(dsv); /* validate pointer */
5207 489230917 100       SvTAINT(dsv);
    100        
    50        
5208 489230917 100       if (flags & SV_SMAGIC)
5209 38110 100       SvSETMAGIC(dsv);
5210 489230917         }
5211            
5212           /*
5213           =for apidoc sv_catsv
5214            
5215           Concatenates the string from SV C onto the end of the string in SV
5216           C. If C is null, does nothing; otherwise modifies only C.
5217           Handles 'get' magic on both SVs, but no 'set' magic. See C and
5218           C.
5219            
5220           =for apidoc sv_catsv_flags
5221            
5222           Concatenates the string from SV C onto the end of the string in SV
5223           C. If C is null, does nothing; otherwise modifies only C.
5224           If C include C bit set, will call C on both SVs if
5225           appropriate. If C include C, C will be called on
5226           the modified SV afterward, if appropriate. C, C,
5227           and C are implemented in terms of this function.
5228            
5229           =cut */
5230            
5231           void
5232 84306832         Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
5233           {
5234           dVAR;
5235          
5236           PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5237            
5238 84306832 50       if (ssv) {
5239           STRLEN slen;
5240 84306832 100       const char *spv = SvPV_flags_const(ssv, slen, flags);
5241 84306832 50       if (spv) {
5242 104740130 100       if (flags & SV_GMAGIC)
    100        
5243 20433302         SvGETMAGIC(dsv);
5244 84306832 100       sv_catpvn_flags(dsv, spv, slen,
    50        
5245           DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
5246 84306832 100       if (flags & SV_SMAGIC)
5247 2 50       SvSETMAGIC(dsv);
5248           }
5249           }
5250 84306832         }
5251            
5252           /*
5253           =for apidoc sv_catpv
5254            
5255           Concatenates the string onto the end of the string which is in the SV.
5256           If the SV has the UTF-8 status set, then the bytes appended should be
5257           valid UTF-8. Handles 'get' magic, but not 'set' magic. See C.
5258            
5259           =cut */
5260            
5261           void
5262 1678538         Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
5263           {
5264           dVAR;
5265           STRLEN len;
5266           STRLEN tlen;
5267           char *junk;
5268            
5269           PERL_ARGS_ASSERT_SV_CATPV;
5270            
5271 1678538 50       if (!ptr)
5272 1678538         return;
5273 1678538 100       junk = SvPV_force(sv, tlen);
5274 1678538         len = strlen(ptr);
5275 1678538 50       SvGROW(sv, tlen + len + 1);
    100        
5276 1678538 50       if (ptr == junk)
5277 0         ptr = SvPVX_const(sv);
5278 1678538         Move(ptr,SvPVX(sv)+tlen,len+1,char);
5279 1678538         SvCUR_set(sv, SvCUR(sv) + len);
5280 1678538         (void)SvPOK_only_UTF8(sv); /* validate pointer */
5281 1678538 100       SvTAINT(sv);
    50        
    0        
5282           }
5283            
5284           /*
5285           =for apidoc sv_catpv_flags
5286            
5287           Concatenates the string onto the end of the string which is in the SV.
5288           If the SV has the UTF-8 status set, then the bytes appended should
5289           be valid UTF-8. If C has the C bit set, will C
5290           on the modified SV if appropriate.
5291            
5292           =cut
5293           */
5294            
5295           void
5296 1196         Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
5297           {
5298           PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5299 1196         sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
5300 1196         }
5301            
5302           /*
5303           =for apidoc sv_catpv_mg
5304            
5305           Like C, but also handles 'set' magic.
5306            
5307           =cut
5308           */
5309            
5310           void
5311 2         Perl_sv_catpv_mg(pTHX_ SV *const sv, const char *const ptr)
5312           {
5313           PERL_ARGS_ASSERT_SV_CATPV_MG;
5314            
5315 2         sv_catpv(sv,ptr);
5316 2 50       SvSETMAGIC(sv);
5317 2         }
5318            
5319           /*
5320           =for apidoc newSV
5321            
5322           Creates a new SV. A non-zero C parameter indicates the number of
5323           bytes of preallocated string space the SV should have. An extra byte for a
5324           trailing NUL is also reserved. (SvPOK is not set for the SV even if string
5325           space is allocated.) The reference count for the new SV is set to 1.
5326            
5327           In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
5328           parameter, I, a debug aid which allowed callers to identify themselves.
5329           This aid has been superseded by a new build option, PERL_MEM_LOG (see
5330           L). The older API is still there for use in XS
5331           modules supporting older perls.
5332            
5333           =cut
5334           */
5335            
5336           SV *
5337 1007187639         Perl_newSV(pTHX_ const STRLEN len)
5338           {
5339           dVAR;
5340           SV *sv;
5341            
5342 1007187639 100       new_SV(sv);
5343 1007187639 100       if (len) {
5344 175817824         sv_upgrade(sv, SVt_PV);
5345 175817824 50       SvGROW(sv, len + 1);
    50        
5346           }
5347 1007187639         return sv;
5348           }
5349           /*
5350           =for apidoc sv_magicext
5351            
5352           Adds magic to an SV, upgrading it if necessary. Applies the
5353           supplied vtable and returns a pointer to the magic added.
5354            
5355           Note that C will allow things that C will not.
5356           In particular, you can add magic to SvREADONLY SVs, and add more than
5357           one instance of the same 'how'.
5358            
5359           If C is greater than zero then a C I of C is
5360           stored, if C is zero then C is stored as-is and - as another
5361           special case - if C<(name && namlen == HEf_SVKEY)> then C is assumed
5362           to contain an C and is stored as-is with its REFCNT incremented.
5363            
5364           (This is now used as a subroutine by C.)
5365            
5366           =cut
5367           */
5368           MAGIC *
5369 68366284         Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
5370           const MGVTBL *const vtable, const char *const name, const I32 namlen)
5371 68366284 100       {
5372           dVAR;
5373           MAGIC* mg;
5374            
5375           PERL_ARGS_ASSERT_SV_MAGICEXT;
5376            
5377           if (SvTYPE(sv)==SVt_PVAV) { assert (!AvPAD_NAMELIST(sv)); }
5378            
5379 56464578         SvUPGRADE(sv, SVt_PVMG);
5380 68366284         Newxz(mg, 1, MAGIC);
5381 68366284         mg->mg_moremagic = SvMAGIC(sv);
5382 68366284         SvMAGIC_set(sv, mg);
5383            
5384           /* Sometimes a magic contains a reference loop, where the sv and
5385           object refer to each other. To prevent a reference loop that
5386           would prevent such objects being freed, we look for such loops
5387           and if we find one we avoid incrementing the object refcount.
5388            
5389           Note we cannot do this to avoid self-tie loops as intervening RV must
5390           have its REFCNT incremented to keep it in existence.
5391            
5392           */
5393 68366284 100       if (!obj || obj == sv ||
5394 25357114 100       how == PERL_MAGIC_arylen ||
5395 25341630 100       how == PERL_MAGIC_symtab ||
5396 22107459 100       (SvTYPE(obj) == SVt_PVGV &&
5397 7277245 50       (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5398 452070 50       || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
    0        
5399 0 0       || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
    0        
5400           {
5401 65139855         mg->mg_obj = obj;
5402           }
5403           else {
5404 3226429         mg->mg_obj = SvREFCNT_inc_simple(obj);
5405 3226429         mg->mg_flags |= MGf_REFCOUNTED;
5406           }
5407            
5408           /* Normal self-ties simply pass a null object, and instead of
5409           using mg_obj directly, use the SvTIED_obj macro to produce a
5410           new RV as needed. For glob "self-ties", we are tieing the PVIO
5411           with an RV obj pointing to the glob containing the PVIO. In
5412           this case, to avoid a reference loop, we need to weaken the
5413           reference.
5414           */
5415            
5416 68366284 100       if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
    100        
5417 32280 50       obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
    50        
    100        
    50        
    100        
5418           {
5419 29666         sv_rvweaken(obj);
5420           }
5421            
5422 68366284         mg->mg_type = how;
5423 68366284         mg->mg_len = namlen;
5424 68366284 100       if (name) {
5425 29783903 100       if (namlen > 0)
5426 16666191         mg->mg_ptr = savepvn(name, namlen);
5427 13117712 100       else if (namlen == HEf_SVKEY) {
5428           /* Yes, this is casting away const. This is only for the case of
5429           HEf_SVKEY. I think we need to document this aberation of the
5430           constness of the API, rather than making name non-const, as
5431           that change propagating outwards a long way. */
5432 12406639         mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5433           } else
5434 711073         mg->mg_ptr = (char *) name;
5435           }
5436 68366284         mg->mg_virtual = (MGVTBL *) vtable;
5437            
5438 68366284         mg_magical(sv);
5439 68366284         return mg;
5440           }
5441            
5442           MAGIC *
5443 2005931         Perl_sv_magicext_mglob(pTHX_ SV *sv)
5444           {
5445           PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB;
5446 2005931 100       if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
    100        
5447           /* This sv is only a delegate. //g magic must be attached to
5448           its target. */
5449 6         vivify_defelem(sv);
5450 6         sv = LvTARG(sv);
5451           }
5452           #ifdef PERL_OLD_COPY_ON_WRITE
5453           if (SvIsCOW(sv))
5454           sv_force_normal_flags(sv, 0);
5455           #endif
5456 2005931         return sv_magicext(sv, NULL, PERL_MAGIC_regex_global,
5457           &PL_vtbl_mglob, 0, 0);
5458           }
5459            
5460           /*
5461           =for apidoc sv_magic
5462            
5463           Adds magic to an SV. First upgrades C to type C if
5464           necessary, then adds a new magic item of type C to the head of the
5465           magic list.
5466            
5467           See C (which C now calls) for a description of the
5468           handling of the C and C arguments.
5469            
5470           You need to use C to add magic to SvREADONLY SVs and also
5471           to add more than one instance of the same 'how'.
5472            
5473           =cut
5474           */
5475            
5476           void
5477 42044472         Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
5478           const char *const name, const I32 namlen)
5479           {
5480           dVAR;
5481           const MGVTBL *vtable;
5482           MAGIC* mg;
5483           unsigned int flags;
5484           unsigned int vtable_index;
5485            
5486           PERL_ARGS_ASSERT_SV_MAGIC;
5487            
5488 42044472 50       if (how < 0 || (unsigned)how > C_ARRAY_LENGTH(PL_magic_data)
5489 62725472 50       || ((flags = PL_magic_data[how]),
5490 42044472         (vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
5491           > magic_vtable_max))
5492 0         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5493            
5494           /* PERL_MAGIC_ext is reserved for use by extensions not perl internals.
5495           Useful for attaching extension internal data to perl vars.
5496           Note that multiple extensions may clash if magical scalars
5497           etc holding private data from one are passed to another. */
5498            
5499           vtable = (vtable_index == magic_vtable_max)
5500 42044472 100       ? NULL : PL_magic_vtables + vtable_index;
5501            
5502           #ifdef PERL_OLD_COPY_ON_WRITE
5503           if (SvIsCOW(sv))
5504           sv_force_normal_flags(sv, 0);
5505           #endif
5506 42044472 100       if (SvREADONLY(sv)) {
5507 10852 100       if (
5508 10852         !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
5509           )
5510           {
5511 6         Perl_croak_no_modify();
5512           }
5513           }
5514 42044466 100       if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
    100        
    100        
5515 540272 100       if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
    100        
5516           /* sv_magic() refuses to add a magic of the same 'how' as an
5517           existing one
5518           */
5519 458912 100       if (how == PERL_MAGIC_taint)
5520 11748         mg->mg_len |= 1;
5521 42044466         return;
5522           }
5523           }
5524            
5525           /* Force pos to be stored as characters, not bytes. */
5526 41585554 100       if (SvMAGICAL(sv) && DO_UTF8(sv)
    100        
    50        
5527 30 50       && (mg = mg_find(sv, PERL_MAGIC_regex_global))
5528 0 0       && mg->mg_len != -1
5529 0 0       && mg->mg_flags & MGf_BYTES) {
5530 0         mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len,
5531           SV_CONST_RETURN);
5532 0         mg->mg_flags &= ~MGf_BYTES;
5533           }
5534            
5535           /* Rest of work is done else where */
5536 41585554         mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5537            
5538 41585554         switch (how) {
5539           case PERL_MAGIC_taint:
5540 111660         mg->mg_len = 1;
5541 111660         break;
5542           case PERL_MAGIC_ext:
5543           case PERL_MAGIC_dbfile:
5544 7342         SvRMAGICAL_on(sv);
5545 7342         break;
5546           }
5547           }
5548            
5549           static int
5550 71755084         S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
5551           {
5552           MAGIC* mg;
5553           MAGIC** mgp;
5554            
5555           assert(flags <= 1);
5556            
5557 71755084 100       if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
    100        
5558           return 0;
5559 42431063         mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5560 85749056 100       for (mg = *mgp; mg; mg = *mgp) {
5561 43317993         const MGVTBL* const virt = mg->mg_virtual;
5562 43317993 100       if (mg->mg_type == type && (!flags || virt == vtbl)) {
    100        
5563 4871794         *mgp = mg->mg_moremagic;
5564 4871794 100       if (virt && virt->svt_free)
    100        
5565 1914540         virt->svt_free(aTHX_ sv, mg);
5566 4871794 100       if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
    50        
5567 3290388 100       if (mg->mg_len > 0)
5568 364754         Safefree(mg->mg_ptr);
5569 2925634 100       else if (mg->mg_len == HEf_SVKEY)
5570 2925626         SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5571 8 50       else if (mg->mg_type == PERL_MAGIC_utf8)
5572 0         Safefree(mg->mg_ptr);
5573           }
5574 4871794 100       if (mg->mg_flags & MGf_REFCOUNTED)
5575 32796         SvREFCNT_dec(mg->mg_obj);
5576 4871794         Safefree(mg);
5577           }
5578           else
5579 38446199         mgp = &mg->mg_moremagic;
5580           }
5581 42431063 100       if (SvMAGIC(sv)) {
5582 37599393 50       if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */
5583 37599393         mg_magical(sv); /* else fix the flags now */
5584           }
5585           else {
5586 4831670         SvMAGICAL_off(sv);
5587 38445099         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5588           }
5589           return 0;
5590           }
5591            
5592           /*
5593           =for apidoc sv_unmagic
5594            
5595           Removes all magic of type C from an SV.
5596            
5597           =cut
5598           */
5599            
5600           int
5601 71755080         Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5602           {
5603           PERL_ARGS_ASSERT_SV_UNMAGIC;
5604 71755080         return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
5605           }
5606            
5607           /*
5608           =for apidoc sv_unmagicext
5609            
5610           Removes all magic of type C with the specified C from an SV.
5611            
5612           =cut
5613           */
5614            
5615           int
5616 4         Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
5617           {
5618           PERL_ARGS_ASSERT_SV_UNMAGICEXT;
5619 4         return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
5620           }
5621            
5622           /*
5623           =for apidoc sv_rvweaken
5624            
5625           Weaken a reference: set the C flag on this RV; give the
5626           referred-to SV C magic if it hasn't already; and
5627           push a back-reference to this RV onto the array of backreferences
5628           associated with that magic. If the RV is magical, set magic will be
5629           called after the RV is cleared.
5630            
5631           =cut
5632           */
5633            
5634           SV *
5635 69932         Perl_sv_rvweaken(pTHX_ SV *const sv)
5636           {
5637           SV *tsv;
5638            
5639           PERL_ARGS_ASSERT_SV_RVWEAKEN;
5640            
5641 69932 50       if (!SvOK(sv)) /* let undefs pass */
    0        
    0        
5642           return sv;
5643 69932 50       if (!SvROK(sv))
5644 0         Perl_croak(aTHX_ "Can't weaken a nonreference");
5645 69932 50       else if (SvWEAKREF(sv)) {
5646 0         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5647 0         return sv;
5648           }
5649 69932 100       else if (SvREADONLY(sv)) croak_no_modify();
5650 69930         tsv = SvRV(sv);
5651 69930         Perl_sv_add_backref(aTHX_ tsv, sv);
5652 69930         SvWEAKREF_on(sv);
5653 69930         SvREFCNT_dec_NN(tsv);
5654 69930         return sv;
5655           }
5656            
5657           /* Give tsv backref magic if it hasn't already got it, then push a
5658           * back-reference to sv onto the array associated with the backref magic.
5659           *
5660           * As an optimisation, if there's only one backref and it's not an AV,
5661           * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5662           * allocate an AV. (Whether the slot holds an AV tells us whether this is
5663           * active.)
5664           */
5665            
5666           /* A discussion about the backreferences array and its refcount:
5667           *
5668           * The AV holding the backreferences is pointed to either as the mg_obj of
5669           * PERL_MAGIC_backref, or in the specific case of a HV, from the
5670           * xhv_backreferences field. The array is created with a refcount
5671           * of 2. This means that if during global destruction the array gets
5672           * picked on before its parent to have its refcount decremented by the
5673           * random zapper, it won't actually be freed, meaning it's still there for
5674           * when its parent gets freed.
5675           *
5676           * When the parent SV is freed, the extra ref is killed by
5677           * Perl_sv_kill_backrefs. The other ref is killed, in the case of magic,
5678           * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5679           *
5680           * When a single backref SV is stored directly, it is not reference
5681           * counted.
5682           */
5683            
5684           void
5685 107122203         Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5686           {
5687           dVAR;
5688           SV **svp;
5689           AV *av = NULL;
5690           MAGIC *mg = NULL;
5691            
5692           PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5693            
5694           /* find slot to store array or singleton backref */
5695            
5696 107122203 100       if (SvTYPE(tsv) == SVt_PVHV) {
5697 85119467         svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5698           } else {
5699 22002736 100       if (! ((mg =
5700 22002736 100       (SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL))))
5701           {
5702 17488666         sv_magic(tsv, NULL, PERL_MAGIC_backref, NULL, 0);
5703 17488666         mg = mg_find(tsv, PERL_MAGIC_backref);
5704           }
5705 22002736         svp = &(mg->mg_obj);
5706           }
5707            
5708           /* create or retrieve the array */
5709            
5710 107122203 100       if ( (!*svp && SvTYPE(sv) == SVt_PVAV)
    50        
5711 107122203 100       || (*svp && SvTYPE(*svp) != SVt_PVAV)
    100        
5712           ) {
5713           /* create array */
5714 1406124         av = newAV();
5715 1406124         AvREAL_off(av);
5716 1406124 50       SvREFCNT_inc_simple_void(av);
5717           /* av now has a refcnt of 2; see discussion above */
5718 1406124 50       if (*svp) {
5719           /* move single existing backref to the array */
5720 1406124         av_extend(av, 1);
5721 1406124         AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5722           }
5723 1406124         *svp = (SV*)av;
5724 1406124 100       if (mg)
5725 91292         mg->mg_flags |= MGf_REFCOUNTED;
5726           }
5727           else
5728 105716079         av = MUTABLE_AV(*svp);
5729            
5730 107122203 100       if (!av) {
5731           /* optimisation: store single backref directly in HvAUX or mg_obj */
5732 20882494         *svp = sv;
5733 117259114         return;
5734           }
5735           /* push new backref */
5736           assert(SvTYPE(av) == SVt_PVAV);
5737 86239709 100       if (AvFILLp(av) >= AvMAX(av)) {
5738 6912012         av_extend(av, AvFILLp(av)+1);
5739           }
5740 86239709         AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5741           }
5742            
5743           /* delete a back-reference to ourselves from the backref magic associated
5744           * with the SV we point to.
5745           */
5746            
5747           void
5748 44350633         Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5749           {
5750           dVAR;
5751           SV **svp = NULL;
5752            
5753           PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5754            
5755 44350633 100       if (SvTYPE(tsv) == SVt_PVHV) {
5756 42039604 50       if (SvOOK(tsv))
5757 42039604         svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5758           }
5759 2311029 50       else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) {
    0        
5760           /* It's possible for the the last (strong) reference to tsv to have
5761           become freed *before* the last thing holding a weak reference.
5762           If both survive longer than the backreferences array, then when
5763           the referent's reference count drops to 0 and it is freed, it's
5764           not able to chase the backreferences, so they aren't NULLed.
5765            
5766           For example, a CV holds a weak reference to its stash. If both the
5767           CV and the stash survive longer than the backreferences array,
5768           and the CV gets picked for the SvBREAK() treatment first,
5769           *and* it turns out that the stash is only being kept alive because
5770           of an our variable in the pad of the CV, then midway during CV
5771           destruction the stash gets freed, but CvSTASH() isn't set to NULL.
5772           It ends up pointing to the freed HV. Hence it's chased in here, and
5773           if this block wasn't here, it would hit the !svp panic just below.
5774            
5775           I don't believe that "better" destruction ordering is going to help
5776           here - during global destruction there's always going to be the
5777           chance that something goes out of order. We've tried to make it
5778           foolproof before, and it only resulted in evolutionary pressure on
5779           fools. Which made us look foolish for our hubris. :-(
5780           */
5781           return;
5782           }
5783           else {
5784           MAGIC *const mg
5785 2311029 100       = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5786 2311029 100       svp = mg ? &(mg->mg_obj) : NULL;
5787           }
5788            
5789 44350633 100       if (!svp)
5790 2         Perl_croak(aTHX_ "panic: del_backref, svp=0");
5791 44350631 50       if (!*svp) {
5792           /* It's possible that sv is being freed recursively part way through the
5793           freeing of tsv. If this happens, the backreferences array of tsv has
5794           already been freed, and so svp will be NULL. If this is the case,
5795           we should not panic. Instead, nothing needs doing, so return. */
5796 0 0       if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
    0        
5797           return;
5798 0         Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
5799 0         *svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
5800           }
5801            
5802 44350631 100       if (SvTYPE(*svp) == SVt_PVAV) {
5803           #ifdef DEBUGGING
5804           int count = 1;
5805           #endif
5806 42002502         AV * const av = (AV*)*svp;
5807           SSize_t fill;
5808           assert(!SvIS_FREED(av));
5809 42002502         fill = AvFILLp(av);
5810           assert(fill > -1);
5811 42002502         svp = AvARRAY(av);
5812           /* for an SV with N weak references to it, if all those
5813           * weak refs are deleted, then sv_del_backref will be called
5814           * N times and O(N^2) compares will be done within the backref
5815           * array. To ameliorate this potential slowness, we:
5816           * 1) make sure this code is as tight as possible;
5817           * 2) when looking for SV, look for it at both the head and tail of the
5818           * array first before searching the rest, since some create/destroy
5819           * patterns will cause the backrefs to be freed in order.
5820           */
5821 42002502 100       if (*svp == sv) {
5822 108922         AvARRAY(av)++;
5823 108922         AvMAX(av)--;
5824           }
5825           else {
5826 41893580         SV **p = &svp[fill];
5827 41893580         SV *const topsv = *p;
5828 41893580 100       if (topsv != sv) {
5829           #ifdef DEBUGGING
5830           count = 0;
5831           #endif
5832 88427380 50       while (--p > svp) {
5833 88427380 100       if (*p == sv) {
5834           /* We weren't the last entry.
5835           An unordered list has this property that you
5836           can take the last element off the end to fill
5837           the hole, and it's still an unordered list :-)
5838           */
5839 981156         *p = topsv;
5840           #ifdef DEBUGGING
5841           count++;
5842           #else
5843 1487212         break; /* should only be one */
5844           #endif
5845           }
5846           }
5847           }
5848           }
5849           assert(count ==1);
5850 42002502         AvFILLp(av) = fill-1;
5851           }
5852 2348129 50       else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) {
    0        
5853           /* freed AV; skip */
5854           }
5855           else {
5856           /* optimisation: only a single backref, stored directly */
5857 2348129 50       if (*svp != sv)
5858 0         Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p", *svp, sv);
5859 23518380         *svp = NULL;
5860           }
5861            
5862           }
5863            
5864           void
5865 1551076         Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5866           {
5867           SV **svp;
5868           SV **last;
5869           bool is_array;
5870            
5871           PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5872            
5873 1551076 100       if (!av)
5874           return;
5875            
5876           /* after multiple passes through Perl_sv_clean_all() for a thingy
5877           * that has badly leaked, the backref array may have gotten freed,
5878           * since we only protect it against 1 round of cleanup */
5879 1526670 50       if (SvIS_FREED(av)) {
5880 0 0       if (PL_in_clean_all) /* All is fair */
5881           return;
5882 0         Perl_croak(aTHX_
5883           "panic: magic_killbackrefs (freed backref AV/SV)");
5884           }
5885            
5886            
5887 1526670         is_array = (SvTYPE(av) == SVt_PVAV);
5888 1526670 100       if (is_array) {
5889           assert(!SvIS_FREED(av));
5890 518         svp = AvARRAY(av);
5891 518 50       if (svp)
5892 518         last = svp + AvFILLp(av);
5893           }
5894           else {
5895           /* optimisation: only a single backref, stored directly */
5896           svp = (SV**)&av;
5897           last = svp;
5898           }
5899            
5900 1526670 50       if (svp) {
5901 3058746 100       while (svp <= last) {
5902 1532076 50       if (*svp) {
5903 1532076         SV *const referrer = *svp;
5904 1532076 100       if (SvWEAKREF(referrer)) {
5905           /* XXX Should we check that it hasn't changed? */
5906           assert(SvROK(referrer));
5907 45454         SvRV_set(referrer, 0);
5908 45454 50       SvOK_off(referrer);
5909 45454         SvWEAKREF_off(referrer);
5910 45454 100       SvSETMAGIC(referrer);
5911 1486622 100       } else if (SvTYPE(referrer) == SVt_PVGV ||
5912           SvTYPE(referrer) == SVt_PVLV) {
5913           assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
5914           /* You lookin' at me? */
5915           assert(GvSTASH(referrer));
5916           assert(GvSTASH(referrer) == (const HV *)sv);
5917 4834         GvSTASH(referrer) = 0;
5918 1481788 50       } else if (SvTYPE(referrer) == SVt_PVCV ||
5919           SvTYPE(referrer) == SVt_PVFM) {
5920 1481788 100       if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
5921           /* You lookin' at me? */
5922           assert(CvSTASH(referrer));
5923           assert(CvSTASH(referrer) == (const HV *)sv);
5924 1074         SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
5925           }
5926           else {
5927           assert(SvTYPE(sv) == SVt_PVGV);
5928           /* You lookin' at me? */
5929           assert(CvGV(referrer));
5930           assert(CvGV(referrer) == (const GV *)sv);
5931 1480714         anonymise_cv_maybe(MUTABLE_GV(sv),
5932           MUTABLE_CV(referrer));
5933           }
5934            
5935           } else {
5936 0         Perl_croak(aTHX_
5937           "panic: magic_killbackrefs (flags=%"UVxf")",
5938 0         (UV)SvFLAGS(referrer));
5939           }
5940            
5941 1532076 100       if (is_array)
5942 5924         *svp = NULL;
5943           }
5944 1532076         svp++;
5945           }
5946           }
5947 1526670 100       if (is_array) {
5948 518         AvFILLp(av) = -1;
5949 811616         SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */
5950           }
5951           return;
5952           }
5953            
5954           /*
5955           =for apidoc sv_insert
5956            
5957           Inserts a string at the specified offset/length within the SV. Similar to
5958           the Perl substr() function. Handles get magic.
5959            
5960           =for apidoc sv_insert_flags
5961            
5962           Same as C, but the extra C are passed to the
5963           C that applies to C.
5964            
5965           =cut
5966           */
5967            
5968           void
5969 3014032         Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5970           {
5971           dVAR;
5972           char *big;
5973           char *mid;
5974           char *midend;
5975           char *bigend;
5976           SSize_t i; /* better be sizeof(STRLEN) or bad things happen */
5977           STRLEN curlen;
5978            
5979           PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5980            
5981 3014032 50       if (!bigstr)
5982 0         Perl_croak(aTHX_ "Can't modify nonexistent substring");
5983 3014032 100       SvPV_force_flags(bigstr, curlen, flags);
5984 3014032         (void)SvPOK_only_UTF8(bigstr);
5985 3014032 50       if (offset + len > curlen) {
5986 0 0       SvGROW(bigstr, offset+len+1);
    0        
5987 0         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5988 0         SvCUR_set(bigstr, offset+len);
5989           }
5990            
5991 3014032 100       SvTAINT(bigstr);
    50        
    0        
5992 3014032         i = littlelen - len;
5993 3014032 100       if (i > 0) { /* string might grow */
5994 1927566 50       big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
    100        
5995 1927566         mid = big + offset + len;
5996 1927566         midend = bigend = big + SvCUR(bigstr);
5997 1927566         bigend += i;
5998 1927566         *bigend = '\0';
5999 50493219 100       while (midend > mid) /* shove everything down */
6000 47602230         *--bigend = *--midend;
6001 1927566         Move(little,big+offset,littlelen,char);
6002 1927566         SvCUR_set(bigstr, SvCUR(bigstr) + i);
6003 1927566 100       SvSETMAGIC(bigstr);
6004           return;
6005           }
6006 1086466 100       else if (i == 0) {
6007 64320         Move(little,SvPVX(bigstr)+offset,len,char);
6008 64320 100       SvSETMAGIC(bigstr);
6009           return;
6010           }
6011            
6012 1022146         big = SvPVX(bigstr);
6013 1022146         mid = big + offset;
6014 1022146         midend = mid + len;
6015 1022146         bigend = big + SvCUR(bigstr);
6016            
6017 1022146 50       if (midend > bigend)
6018 0         Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p",
6019           midend, bigend);
6020            
6021 1022146 100       if (mid - big > bigend - midend) { /* faster to shorten from end */
6022 16960 100       if (littlelen) {
6023           Move(little, mid, littlelen,char);
6024 1450         mid += littlelen;
6025           }
6026 16960         i = bigend - midend;
6027 16960 100       if (i > 0) {
6028 1862         Move(midend, mid, i,char);
6029 1862         mid += i;
6030           }
6031 16960         *mid = '\0';
6032 16960         SvCUR_set(bigstr, mid - big);
6033           }
6034 1005186 100       else if ((i = mid - big)) { /* faster from front */
6035 2890         midend -= littlelen;
6036           mid = midend;
6037 2890         Move(big, midend - i, i, char);
6038 2890         sv_chop(bigstr,midend-i);
6039 2890 100       if (littlelen)
6040           Move(little, mid, littlelen,char);
6041           }
6042 1002296 100       else if (littlelen) {
6043 894         midend -= littlelen;
6044 894         sv_chop(bigstr,midend);
6045           Move(little,midend,littlelen,char);
6046           }
6047           else {
6048 1001402         sv_chop(bigstr,midend);
6049           }
6050 2018449 100       SvSETMAGIC(bigstr);
6051           }
6052            
6053           /*
6054           =for apidoc sv_replace
6055            
6056           Make the first argument a copy of the second, then delete the original.
6057           The target SV physically takes over ownership of the body of the source SV
6058           and inherits its flags; however, the target keeps any magic it owns,
6059           and any magic in the source is discarded.
6060           Note that this is a rather specialist SV copying operation; most of the
6061           time you'll want to use C or one of its many macro front-ends.
6062            
6063           =cut
6064           */
6065            
6066           void
6067 15204556         Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv)
6068           {
6069           dVAR;
6070 15204556         const U32 refcnt = SvREFCNT(sv);
6071            
6072           PERL_ARGS_ASSERT_SV_REPLACE;
6073            
6074 15204556 100       SV_CHECK_THINKFIRST_COW_DROP(sv);
6075 15204556 50       if (SvREFCNT(nsv) != 1) {
6076 0         Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
6077 0         " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
6078           }
6079 15204556 50       if (SvMAGICAL(sv)) {
6080 0 0       if (SvMAGICAL(nsv))
6081 0         mg_free(nsv);
6082           else
6083 0         sv_upgrade(nsv, SVt_PVMG);
6084 0         SvMAGIC_set(nsv, SvMAGIC(sv));
6085 0         SvFLAGS(nsv) |= SvMAGICAL(sv);
6086 0         SvMAGICAL_off(sv);
6087 0         SvMAGIC_set(sv, NULL);
6088           }
6089 15204556         SvREFCNT(sv) = 0;
6090 15204556         sv_clear(sv);
6091           assert(!SvREFCNT(sv));
6092           #ifdef DEBUG_LEAKING_SCALARS
6093           sv->sv_flags = nsv->sv_flags;
6094           sv->sv_any = nsv->sv_any;
6095           sv->sv_refcnt = nsv->sv_refcnt;
6096           sv->sv_u = nsv->sv_u;
6097           #else
6098 15204556         StructCopy(nsv,sv,SV);
6099           #endif
6100 15204556 50       if(SvTYPE(sv) == SVt_IV) {
6101           SvANY(sv)
6102 0         = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
6103           }
6104          
6105            
6106           #ifdef PERL_OLD_COPY_ON_WRITE
6107           if (SvIsCOW_normal(nsv)) {
6108           /* We need to follow the pointers around the loop to make the
6109           previous SV point to sv, rather than nsv. */
6110           SV *next;
6111           SV *current = nsv;
6112           while ((next = SV_COW_NEXT_SV(current)) != nsv) {
6113           assert(next);
6114           current = next;
6115           assert(SvPVX_const(current) == SvPVX_const(nsv));
6116           }
6117           /* Make the SV before us point to the SV after us. */
6118           if (DEBUG_C_TEST) {
6119           PerlIO_printf(Perl_debug_log, "previous is\n");
6120           sv_dump(current);
6121           PerlIO_printf(Perl_debug_log,
6122           "move it from 0x%"UVxf" to 0x%"UVxf"\n",
6123           (UV) SV_COW_NEXT_SV(current), (UV) sv);
6124           }
6125           SV_COW_NEXT_SV_SET(current, sv);
6126           }
6127           #endif
6128 15204556         SvREFCNT(sv) = refcnt;
6129 15204556         SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
6130 15204556         SvREFCNT(nsv) = 0;
6131 15204556 50       del_SV(nsv);
6132 15204556         }
6133            
6134           /* We're about to free a GV which has a CV that refers back to us.
6135           * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
6136           * field) */
6137            
6138           STATIC void
6139 1480714         S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
6140           {
6141           SV *gvname;
6142           GV *anongv;
6143            
6144           PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
6145            
6146           /* be assertive! */
6147           assert(SvREFCNT(gv) == 0);
6148           assert(isGV(gv) && isGV_with_GP(gv));
6149           assert(GvGP(gv));
6150           assert(!CvANON(cv));
6151           assert(CvGV(cv) == gv);
6152           assert(!CvNAMED(cv));
6153            
6154           /* will the CV shortly be freed by gp_free() ? */
6155 1480714 100       if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
    100        
    100        
6156 1480442         SvANY(cv)->xcv_gv_u.xcv_gv = NULL;
6157 2185116         return;
6158           }
6159            
6160           /* if not, anonymise: */
6161 480 50       gvname = (GvSTASH(gv) && HvNAME(GvSTASH(gv)) && HvENAME(GvSTASH(gv)))
    50        
    100        
    50        
    100        
    50        
    50        
    50        
    100        
    50        
    100        
    50        
    50        
6162 208 50       ? newSVhek(HvENAME_HEK(GvSTASH(gv)))
    50        
    50        
    100        
    50        
6163 709 100       : newSVpvn_flags( "__ANON__", 8, 0 );
    100        
6164 272         sv_catpvs(gvname, "::__ANON__");
6165 272         anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
6166 272         SvREFCNT_dec_NN(gvname);
6167            
6168 272         CvANON_on(cv);
6169 272         CvCVGV_RC_on(cv);
6170 408         SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
6171           }
6172            
6173            
6174           /*
6175           =for apidoc sv_clear
6176            
6177           Clear an SV: call any destructors, free up any memory used by the body,
6178           and free the body itself. The SV's head is I freed, although
6179           its type is set to all 1's so that it won't inadvertently be assumed
6180           to be live during global destruction etc.
6181           This function should only be called when REFCNT is zero. Most of the time
6182           you'll want to call C (or its macro wrapper C)
6183           instead.
6184            
6185           =cut
6186           */
6187            
6188           void
6189 2362998773         Perl_sv_clear(pTHX_ SV *const orig_sv)
6190           {
6191           dVAR;
6192           HV *stash;
6193           U32 type;
6194           const struct body_details *sv_type_details;
6195           SV* iter_sv = NULL;
6196           SV* next_sv = NULL;
6197           SV *sv = orig_sv;
6198           STRLEN hash_index;
6199            
6200           PERL_ARGS_ASSERT_SV_CLEAR;
6201            
6202           /* within this loop, sv is the SV currently being freed, and
6203           * iter_sv is the most recent AV or whatever that's being iterated
6204           * over to provide more SVs */
6205            
6206 7395423869 100       while (sv) {
6207            
6208 3856485731         type = SvTYPE(sv);
6209            
6210           assert(SvREFCNT(sv) == 0);
6211           assert(SvTYPE(sv) != (svtype)SVTYPEMASK);
6212            
6213 3856485731 100       if (type <= SVt_IV) {
6214           /* See the comment in sv.h about the collusion between this
6215           * early return and the overloading of the NULL slots in the
6216           * size table. */
6217 1819468336 100       if (SvROK(sv))
6218           goto free_rv;
6219 950989246         SvFLAGS(sv) &= SVf_BREAK;
6220 950989246         SvFLAGS(sv) |= SVTYPEMASK;
6221 950989246         goto free_head;
6222           }
6223            
6224           assert(!SvOBJECT(sv) || type >= SVt_PVMG); /* objs are always >= MG */
6225            
6226 2037017395 100       if (type >= SVt_PVMG) {
6227 852788996 100       if (SvOBJECT(sv)) {
6228 484513073 100       if (!curse(sv, 1)) goto get_next_sv;
6229 484513063         type = SvTYPE(sv); /* destructor may have changed it */
6230           }
6231           /* Free back-references before magic, in case the magic calls
6232           * Perl code that has weak references to sv. */
6233 852788986 100       if (type == SVt_PVHV) {
6234 109270814         Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
6235 109270814 100       if (SvMAGIC(sv))
6236 1416582         mg_free(sv);
6237           }
6238 743518172 100       else if (type == SVt_PVMG && SvPAD_OUR(sv)) {
    100        
6239 44289 50       SvREFCNT_dec(SvOURSTASH(sv));
6240           }
6241 743473883 100       else if (type == SVt_PVAV && AvPAD_NAMELIST(sv)) {
    100        
6242           assert(!SvMAGICAL(sv));
6243 739122315 100       } else if (SvMAGIC(sv)) {
6244           /* Free back-references before other types of magic. */
6245 37118062         sv_unmagic(sv, PERL_MAGIC_backref);
6246 37118062         mg_free(sv);
6247           }
6248 852788986         SvMAGICAL_off(sv);
6249 852788986 100       if (type == SVt_PVMG && SvPAD_TYPED(sv))
    100        
6250 44         SvREFCNT_dec(SvSTASH(sv));
6251           }
6252 2037017385         switch (type) {
6253           /* case SVt_INVLIST: */
6254           case SVt_PVIO:
6255 5918376         if (IoIFP(sv) &&
6256 1618330 100       IoIFP(sv) != PerlIO_stdin() &&
6257 1569932 100       IoIFP(sv) != PerlIO_stdout() &&
6258 1521492 100       IoIFP(sv) != PerlIO_stderr() &&
6259 748637         !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6260           {
6261 740551         io_close(MUTABLE_IO(sv), FALSE);
6262           }
6263 5097121 100       if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
    100        
6264 4522         PerlDir_close(IoDIRP(sv));
6265 5097121         IoDIRP(sv) = (DIR*)NULL;
6266 5097121         Safefree(IoTOP_NAME(sv));
6267 5097121         Safefree(IoFMT_NAME(sv));
6268 5097121         Safefree(IoBOTTOM_NAME(sv));
6269 5097121 100       if ((const GV *)sv == PL_statgv)
6270 2         PL_statgv = NULL;
6271           goto freescalar;
6272           case SVt_REGEXP:
6273           /* FIXME for plugins */
6274           freeregexp:
6275 20183530         pregfree2((REGEXP*) sv);
6276 20183530         goto freescalar;
6277           case SVt_PVCV:
6278           case SVt_PVFM:
6279 8896490         cv_undef(MUTABLE_CV(sv));
6280           /* If we're in a stash, we don't own a reference to it.
6281           * However it does have a back reference to us, which needs to
6282           * be cleared. */
6283 8896488 100       if ((stash = CvSTASH(sv)))
6284 6718933         sv_del_backref(MUTABLE_SV(stash), sv);
6285           goto freescalar;
6286           case SVt_PVHV:
6287 109270814 100       if (PL_last_swash_hv == (const HV *)sv) {
6288 7784         PL_last_swash_hv = NULL;
6289           }
6290 109270814 100       if (HvTOTALKEYS((HV*)sv) > 0) {
6291           const char *name;
6292           /* this statement should match the one at the beginning of
6293           * hv_undef_flags() */
6294 101741269 100       if ( PL_phase != PERL_PHASE_DESTRUCT
6295 85653313 100       && (name = HvNAME((HV*)sv)))
    100        
    100        
    50        
    50        
    100        
    100        
6296           {
6297 536 50       if (PL_stashcache) {
6298           DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n",
6299           sv));
6300 536 50       (void)hv_delete(PL_stashcache, name,
    50        
    100        
    50        
    50        
    100        
    100        
    100        
    50        
    50        
    50        
    50        
    0        
    50        
    50        
    50        
    100        
    50        
    50        
    100        
6301           HvNAMEUTF8((HV*)sv) ? -HvNAMELEN_get((HV*)sv) : HvNAMELEN_get((HV*)sv), G_DISCARD);
6302           }
6303 536         hv_name_set((HV*)sv, NULL, 0, 0);
6304           }
6305            
6306           /* save old iter_sv in unused SvSTASH field */
6307           assert(!SvOBJECT(sv));
6308 101741269         SvSTASH(sv) = (HV*)iter_sv;
6309           iter_sv = sv;
6310            
6311           /* save old hash_index in unused SvMAGIC field */
6312           assert(!SvMAGICAL(sv));
6313           assert(!SvMAGIC(sv));
6314 101741269         ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index = hash_index;
6315 101741269         hash_index = 0;
6316            
6317 101741269         next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index);
6318 101741269         goto get_next_sv; /* process this new sv */
6319           }
6320           /* free empty hash */
6321 7529545         Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6322           assert(!HvARRAY((HV*)sv));
6323 7529545         break;
6324           case SVt_PVAV:
6325           {
6326           AV* av = MUTABLE_AV(sv);
6327 136032616 50       if (PL_comppad == av) {
6328 0         PL_comppad = NULL;
6329 0         PL_curpad = NULL;
6330           }
6331 136032616 100       if (AvREAL(av) && AvFILLp(av) > -1) {
    100        
6332 113088646         next_sv = AvARRAY(av)[AvFILLp(av)--];
6333           /* save old iter_sv in top-most slot of AV,
6334           * and pray that it doesn't get wiped in the meantime */
6335 113088646         AvARRAY(av)[AvMAX(av)] = iter_sv;
6336           iter_sv = sv;
6337 113088646         goto get_next_sv; /* process this new sv */
6338           }
6339 22943970         Safefree(AvALLOC(av));
6340           }
6341            
6342 22943970         break;
6343           case SVt_PVLV:
6344 5747671 100       if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
6345 387591         SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
6346 387591         HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
6347 387591         PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
6348           }
6349 5360080 100       else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
6350 5288302         SvREFCNT_dec(LvTARG(sv));
6351 5747671 50       if (isREGEXP(sv)) goto freeregexp;
    50        
6352           case SVt_PVGV:
6353 14186468 100       if (isGV_with_GP(sv)) {
    50        
6354 8438819 100       if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
    100        
    100        
6355 1729838 50       && HvENAME_get(stash))
    50        
    100        
    50        
    100        
    50        
    50        
6356 1729830         mro_method_changed_in(stash);
6357 8438819         gp_free(MUTABLE_GV(sv));
6358 8438817 50       if (GvNAME_HEK(sv))
6359 8438817         unshare_hek(GvNAME_HEK(sv));
6360           /* If we're in a stash, we don't own a reference to it.
6361           * However it does have a back reference to us, which
6362           * needs to be cleared. */
6363 8438817 50       if (!SvVALID(sv) && (stash = GvSTASH(sv)))
    100        
6364 8235843         sv_del_backref(MUTABLE_SV(stash), sv);
6365           }
6366           /* FIXME. There are probably more unreferenced pointers to SVs
6367           * in the interpreter struct that we should check and tidy in
6368           * a similar fashion to this: */
6369           /* See also S_sv_unglob, which does the same thing. */
6370 14186466 100       if ((const GV *)sv == PL_last_in_gv)
6371 221790         PL_last_in_gv = NULL;
6372 13964676 100       else if ((const GV *)sv == PL_statgv)
6373 3170         PL_statgv = NULL;
6374 13961506 100       else if ((const GV *)sv == PL_stderrgv)
6375 4         PL_stderrgv = NULL;
6376           case SVt_PVMG:
6377           case SVt_PVNV:
6378           case SVt_PVIV:
6379           case SVt_INVLIST:
6380           case SVt_PV:
6381           freescalar:
6382           /* Don't bother with SvOOK_off(sv); as we're only going to
6383           * free it. */
6384 1786215039 100       if (SvOOK(sv)) {
6385           STRLEN offset;
6386 36594 50       SvOOK_offset(sv, offset);
    100        
6387 36594         SvPV_set(sv, SvPVX_mutable(sv) - offset);
6388           /* Don't even bother with turning off the OOK flag. */
6389           }
6390 1786215039 100       if (SvROK(sv)) {
6391           free_rv:
6392           {
6393 874163145         SV * const target = SvRV(sv);
6394 874163145 100       if (SvWEAKREF(sv))
6395 24406         sv_del_backref(target, sv);
6396           else
6397           next_sv = target;
6398           }
6399           }
6400           #ifdef PERL_ANY_COW
6401 1780530984 100       else if (SvPVX_const(sv)
6402 1089249623 100       && !(SvTYPE(sv) == SVt_PVIO
    100        
6403 80702         && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6404           {
6405 1089137196 100       if (SvIsCOW(sv)) {
6406           if (DEBUG_C_TEST) {
6407           PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6408           sv_dump(sv);
6409           }
6410 455177718 100       if (SvLEN(sv)) {
6411           # ifdef PERL_OLD_COPY_ON_WRITE
6412           sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
6413           # else
6414 322020175 100       if (CowREFCNT(sv)) {
6415 143231133         CowREFCNT(sv)--;
6416 143231133         SvLEN_set(sv, 0);
6417           }
6418           # endif
6419           } else {
6420 133157543         unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6421           }
6422            
6423           }
6424           # ifdef PERL_OLD_COPY_ON_WRITE
6425           else
6426           # endif
6427 1089137196 100       if (SvLEN(sv)) {
6428 808903330         Safefree(SvPVX_mutable(sv));
6429           }
6430           }
6431           #else
6432           else if (SvPVX_const(sv) && SvLEN(sv)
6433           && !(SvTYPE(sv) == SVt_PVIO
6434           && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6435           Safefree(SvPVX_mutable(sv));
6436           else if (SvPVX_const(sv) && SvIsCOW(sv)) {
6437           unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6438           }
6439           #endif
6440           break;
6441           case SVt_NV:
6442           break;
6443           }
6444            
6445           free_body:
6446            
6447 2905496469         SvFLAGS(sv) &= SVf_BREAK;
6448 2905496469         SvFLAGS(sv) |= SVTYPEMASK;
6449            
6450 2905496469         sv_type_details = bodies_by_type + type;
6451 2905496469 100       if (sv_type_details->arena) {
6452 2037016995         del_body(((char *)SvANY(sv) + sv_type_details->offset),
6453           &PL_body_roots[type]);
6454           }
6455 868479474 100       else if (sv_type_details->body_size) {
6456 384         safefree(SvANY(sv));
6457           }
6458            
6459           free_head:
6460           /* caller is responsible for freeing the head of the original sv */
6461 3856485715 100       if (sv != orig_sv && !SvREFCNT(sv))
    50        
6462 2950995198 50       del_SV(sv);
6463            
6464           /* grab and free next sv, if any */
6465           get_next_sv:
6466           while (1) {
6467           sv = NULL;
6468 4396425635 100       if (next_sv) {
6469           sv = next_sv;
6470           next_sv = NULL;
6471           }
6472 3308939968 100       else if (!iter_sv) {
6473           break;
6474 945941205 100       } else if (SvTYPE(iter_sv) == SVt_PVAV) {
6475           AV *const av = (AV*)iter_sv;
6476 537779305 100       if (AvFILLp(av) > -1) {
6477 424690659         sv = AvARRAY(av)[AvFILLp(av)--];
6478           }
6479           else { /* no more elements of current AV to free */
6480           sv = iter_sv;
6481 113088646         type = SvTYPE(sv);
6482           /* restore previous value, squirrelled away */
6483 113088646         iter_sv = AvARRAY(av)[AvMAX(av)];
6484 113088646         Safefree(AvALLOC(av));
6485 113088646         goto free_body;
6486           }
6487 408161900 50       } else if (SvTYPE(iter_sv) == SVt_PVHV) {
6488 408161900         sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index);
6489 408161900 100       if (!sv && !HvTOTALKEYS((HV *)iter_sv)) {
    100        
6490           /* no more elements of current HV to free */
6491           sv = iter_sv;
6492 101741269         type = SvTYPE(sv);
6493           /* Restore previous values of iter_sv and hash_index,
6494           * squirrelled away */
6495           assert(!SvOBJECT(sv));
6496 101741269         iter_sv = (SV*)SvSTASH(sv);
6497           assert(!SvMAGICAL(sv));
6498 101741269         hash_index = ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index;
6499           #ifdef DEBUGGING
6500           /* perl -DA does not like rubbish in SvMAGIC. */
6501           SvMAGIC_set(sv, 0);
6502           #endif
6503            
6504           /* free any remaining detritus from the hash struct */
6505 101741269         Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6506           assert(!HvARRAY((HV*)sv));
6507 101741269         goto free_body;
6508           }
6509           }
6510            
6511           /* unrolled SvREFCNT_dec and sv_free2 follows: */
6512            
6513 1818596957 100       if (!sv)
6514 3549521         continue;
6515 1815047436 50       if (!SvREFCNT(sv)) {
6516 0         sv_free(sv);
6517 0         continue;
6518           }
6519 1815047436 100       if (--(SvREFCNT(sv)))
6520 321560478         continue;
6521           #ifdef DEBUGGING
6522           if (SvTEMP(sv)) {
6523           Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6524           "Attempt to free temp prematurely: SV 0x%"UVxf
6525           pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6526           continue;
6527           }
6528           #endif
6529 1493486958 100       if (SvIMMORTAL(sv)) {
    50        
    50        
    50        
    50        
6530           /* make sure SvREFCNT(sv)==0 happens very seldom */
6531 0         SvREFCNT(sv) = SvREFCNT_IMMORTAL;
6532 1934262694         continue;
6533           }
6534           break;
6535           } /* while 1 */
6536            
6537           } /* while sv */
6538 2362998763         }
6539            
6540           /* This routine curses the sv itself, not the object referenced by sv. So
6541           sv does not have to be ROK. */
6542            
6543           static bool
6544 484522821         S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
6545           dVAR;
6546            
6547           PERL_ARGS_ASSERT_CURSE;
6548           assert(SvOBJECT(sv));
6549            
6550 969045642         if (PL_defstash && /* Still have a symbol table? */
6551 484522821         SvDESTROYABLE(sv))
6552           {
6553 484522821         dSP;
6554           HV* stash;
6555           do {
6556 484522823         stash = SvSTASH(sv);
6557           assert(SvTYPE(stash) == SVt_PVHV);
6558 484522823 50       if (HvNAME(stash)) {
    50        
    100        
    100        
    100        
    50        
6559           CV* destructor = NULL;
6560           assert (SvOOK(stash));
6561 484522819 100       if (!SvOBJECT(stash)) destructor = (CV *)SvSTASH(stash);
6562 725781965 100       if (!destructor || HvMROMETA(stash)->destroy_gen
    50        
    100        
6563 482578038         != PL_sub_generation)
6564           {
6565 4176239         GV * const gv =
6566           gv_fetchmeth_autoload(stash, "DESTROY", 7, 0);
6567 4176239 100       if (gv) destructor = GvCV(gv);
6568 4176239 100       if (!SvOBJECT(stash))
6569           {
6570 8352474         SvSTASH(stash) =
6571 4176237 100       destructor ? (HV *)destructor : ((HV *)0)+1;
6572 4176237         HvAUX(stash)->xhv_mro_meta->destroy_gen =
6573           PL_sub_generation;
6574           }
6575           }
6576           assert(!destructor || destructor == ((CV *)0)+1
6577           || SvTYPE(destructor) == SVt_PVCV);
6578 484522819 100       if (destructor && destructor != ((CV *)0)+1
6579           /* A constant subroutine can have no side effects, so
6580           don't bother calling it. */
6581 7534121 100       && !CvCONST(destructor)
6582           /* Don't bother calling an empty destructor or one that
6583           returns immediately. */
6584 5447115 100       && (CvISXSUB(destructor)
6585 4707460 100       || (CvSTART(destructor)
6586 7060287 100       && (CvSTART(destructor)->op_next->op_type
6587 4707458         != OP_LEAVESUB)
6588 1438989 100       && (CvSTART(destructor)->op_next->op_type
6589 959326         != OP_PUSHMARK
6590 489 50       || CvSTART(destructor)->op_next->op_next->op_type
6591 326         != OP_RETURN
6592           )
6593           ))
6594           )
6595 1698981 50       {
6596 1698981         SV* const tmpref = newRV(sv);
6597 1698981         SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
6598 1698981         ENTER;
6599 1698981 100       PUSHSTACKi(PERLSI_DESTROY);
6600 849311         EXTEND(SP, 2);
6601 1698981 50       PUSHMARK(SP);
6602 1698981         PUSHs(tmpref);
6603 1698981         PUTBACK;
6604 1698981         call_sv(MUTABLE_SV(destructor),
6605           G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
6606 1698981 50       POPSTACK;
6607 1698981         SPAGAIN;
6608 1698981         LEAVE;
6609 1698981 50       if(SvREFCNT(tmpref) < 2) {
6610           /* tmpref is not kept alive! */
6611 1698981         SvREFCNT(sv)--;
6612 1698981         SvRV_set(tmpref, NULL);
6613 1698981         SvROK_off(tmpref);
6614           }
6615 1698981         SvREFCNT_dec_NN(tmpref);
6616           }
6617           }
6618 484522823 50       } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
    100        
6619            
6620            
6621 484522821 100       if (check_refcnt && SvREFCNT(sv)) {
    100        
6622 10 100       if (PL_in_clean_objs)
6623 10 50       Perl_croak(aTHX_
    50        
6624           "DESTROY created new reference to dead object '%"HEKf"'",
6625 8 50       HEKfARG(HvNAME_HEK(stash)));
6626           /* DESTROY gave object new lease on life */
6627           return FALSE;
6628           }
6629           }
6630            
6631 484522811 50       if (SvOBJECT(sv)) {
6632 484522811         HV * const stash = SvSTASH(sv);
6633           /* Curse before freeing the stash, as freeing the stash could cause
6634           a recursive call into S_curse. */
6635 484522811         SvOBJECT_off(sv); /* Curse the object. */
6636 484522811         SvSTASH_set(sv,0); /* SvREFCNT_dec may try to read this */
6637 484522814         SvREFCNT_dec(stash); /* possibly of changed persuasion */
6638           }
6639           return TRUE;
6640           }
6641            
6642           /*
6643           =for apidoc sv_newref
6644            
6645           Increment an SV's reference count. Use the C wrapper
6646           instead.
6647            
6648           =cut
6649           */
6650            
6651           SV *
6652 0         Perl_sv_newref(pTHX_ SV *const sv)
6653           {
6654           PERL_UNUSED_CONTEXT;
6655 0 0       if (sv)
6656 0         (SvREFCNT(sv))++;
6657 0         return sv;
6658           }
6659            
6660           /*
6661           =for apidoc sv_free
6662            
6663           Decrement an SV's reference count, and if it drops to zero, call
6664           C to invoke destructors and free up any memory used by
6665           the body; finally, deallocate the SV's head itself.
6666           Normally called via a wrapper macro C.
6667            
6668           =cut
6669           */
6670            
6671           void
6672 7268240         Perl_sv_free(pTHX_ SV *const sv)
6673           {
6674 7268240         SvREFCNT_dec(sv);
6675 7268240         }
6676            
6677            
6678           /* Private helper function for SvREFCNT_dec().
6679           * Called with rc set to original SvREFCNT(sv), where rc == 0 or 1 */
6680            
6681           void
6682 2346371909         Perl_sv_free2(pTHX_ SV *const sv, const U32 rc)
6683           {
6684           dVAR;
6685            
6686           PERL_ARGS_ASSERT_SV_FREE2;
6687            
6688 2346371909 100       if (LIKELY( rc == 1 )) {
6689           /* normal case */
6690 2346371907         SvREFCNT(sv) = 0;
6691            
6692           #ifdef DEBUGGING
6693           if (SvTEMP(sv)) {
6694           Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6695           "Attempt to free temp prematurely: SV 0x%"UVxf
6696           pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6697           return;
6698           }
6699           #endif
6700 2346371907 100       if (SvIMMORTAL(sv)) {
    50        
    50        
    50        
    50        
6701           /* make sure SvREFCNT(sv)==0 happens very seldom */
6702 0         SvREFCNT(sv) = SvREFCNT_IMMORTAL;
6703 0         return;
6704           }
6705 2346371907         sv_clear(sv);
6706 2346371897 100       if (! SvREFCNT(sv)) /* may have have been resurrected */
6707 2346371895 50       del_SV(sv);
6708           return;
6709           }
6710            
6711           /* handle exceptional cases */
6712            
6713           assert(rc == 0);
6714            
6715 2 50       if (SvFLAGS(sv) & SVf_BREAK)
6716           /* this SV's refcnt has been artificially decremented to
6717           * trigger cleanup */
6718           return;
6719 2 50       if (PL_in_clean_all) /* All is fair */
6720           return;
6721 2 50       if (SvIMMORTAL(sv)) {
    0        
    0        
    0        
    0        
6722           /* make sure SvREFCNT(sv)==0 happens very seldom */
6723 0         SvREFCNT(sv) = SvREFCNT_IMMORTAL;
6724 0         return;
6725           }
6726 2 50       if (ckWARN_d(WARN_INTERNAL)) {
6727           #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
6728           Perl_dump_sv_child(aTHX_ sv);
6729           #else
6730           #ifdef DEBUG_LEAKING_SCALARS
6731           sv_dump(sv);
6732           #endif
6733           #ifdef DEBUG_LEAKING_SCALARS_ABORT
6734           if (PL_warnhook == PERL_WARNHOOK_FATAL
6735           || ckDEAD(packWARN(WARN_INTERNAL))) {
6736           /* Don't let Perl_warner cause us to escape our fate: */
6737           abort();
6738           }
6739           #endif
6740           /* This may not return: */
6741 1178508754         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6742           "Attempt to free unreferenced scalar: SV 0x%"UVxf
6743           pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6744           #endif
6745           }
6746           #ifdef DEBUG_LEAKING_SCALARS_ABORT
6747           abort();
6748           #endif
6749            
6750           }
6751            
6752            
6753           /*
6754           =for apidoc sv_len
6755            
6756           Returns the length of the string in the SV. Handles magic and type
6757           coercion and sets the UTF8 flag appropriately. See also C, which
6758           gives raw access to the xpv_cur slot.
6759            
6760           =cut
6761           */
6762            
6763           STRLEN
6764 4926         Perl_sv_len(pTHX_ SV *const sv)
6765           {
6766           STRLEN len;
6767            
6768 4926 50       if (!sv)
6769           return 0;
6770            
6771 4926 50       (void)SvPV_const(sv, len);
6772 4926         return len;
6773           }
6774            
6775           /*
6776           =for apidoc sv_len_utf8
6777            
6778           Returns the number of characters in the string in an SV, counting wide
6779           UTF-8 bytes as a single character. Handles magic and type coercion.
6780            
6781           =cut
6782           */
6783            
6784           /*
6785           * The length is cached in PERL_MAGIC_utf8, in the mg_len field. Also the
6786           * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
6787           * (Note that the mg_len is not the length of the mg_ptr field.
6788           * This allows the cache to store the character length of the string without
6789           * needing to malloc() extra storage to attach to the mg_ptr.)
6790           *
6791           */
6792            
6793           STRLEN
6794 8916366         Perl_sv_len_utf8(pTHX_ SV *const sv)
6795 8916366 50       {
6796 8916366 50       if (!sv)
6797           return 0;
6798            
6799 4458183         SvGETMAGIC(sv);
6800 8916366         return sv_len_utf8_nomg(sv);
6801           }
6802            
6803           STRLEN
6804 39188311         Perl_sv_len_utf8_nomg(pTHX_ SV * const sv)
6805           {
6806           dVAR;
6807           STRLEN len;
6808 39188311 100       const U8 *s = (U8*)SvPV_nomg_const(sv, len);
6809            
6810           PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG;
6811            
6812 39188311 50       if (PL_utf8cache && SvUTF8(sv)) {
    100        
6813           STRLEN ulen;
6814 4080340 100       MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
6815            
6816 4080340 100       if (mg && (mg->mg_len != -1 || mg->mg_ptr)) {
    100        
    100        
6817 2641054 100       if (mg->mg_len != -1)
6818 2641046         ulen = mg->mg_len;
6819           else {
6820           /* We can use the offset cache for a headstart.
6821           The longer value is stored in the first pair. */
6822 8         STRLEN *cache = (STRLEN *) mg->mg_ptr;
6823            
6824 8         ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1],
6825           s + len);
6826           }
6827          
6828 2641054 50       if (PL_utf8cache < 0) {
6829 0         const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
6830 0         assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv);
6831           }
6832           }
6833           else {
6834 1439286         ulen = Perl_utf8_length(aTHX_ s, s + len);
6835 1439286         utf8_mg_len_cache_update(sv, &mg, ulen);
6836           }
6837 4080340         return ulen;
6838           }
6839 37148141 50       return SvUTF8(sv) ? Perl_utf8_length(aTHX_ s, s + len) : len;
6840           }
6841            
6842           /* Walk forwards to find the byte corresponding to the passed in UTF-8
6843           offset. */
6844           static STRLEN
6845           S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6846           STRLEN *const uoffset_p, bool *const at_end)
6847           {
6848           const U8 *s = start;
6849           STRLEN uoffset = *uoffset_p;
6850            
6851           PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6852            
6853 436 100       while (s < send && uoffset) {
    100        
6854 340         --uoffset;
6855 340         s += UTF8SKIP(s);
6856           }
6857 96 50       if (s == send) {
    100        
6858           *at_end = TRUE;
6859           }
6860 64 50       else if (s > send) {
    50        
6861           *at_end = TRUE;
6862           /* This is the existing behaviour. Possibly it should be a croak, as
6863           it's actually a bounds error */
6864           s = send;
6865           }
6866 96         *uoffset_p -= uoffset;
6867 96         return s - start;
6868           }
6869            
6870           /* Given the length of the string in both bytes and UTF-8 characters, decide
6871           whether to walk forwards or backwards to find the byte corresponding to
6872           the passed in UTF-8 offset. */
6873           static STRLEN
6874 150170         S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6875           STRLEN uoffset, const STRLEN uend)
6876           {
6877 150170         STRLEN backw = uend - uoffset;
6878            
6879           PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6880            
6881 150170 100       if (uoffset < 2 * backw) {
6882           /* The assumption is that going forwards is twice the speed of going
6883           forward (that's where the 2 * backw comes from).
6884           (The real figure of course depends on the UTF-8 data.) */
6885           const U8 *s = start;
6886            
6887 295116 50       while (s < send && uoffset--)
    100        
6888 151610         s += UTF8SKIP(s);
6889           assert (s <= send);
6890 143506 50       if (s > send)
6891           s = send;
6892 143506         return s - start;
6893           }
6894            
6895 8738 100       while (backw--) {
6896 2074         send--;
6897 8761 100       while (UTF8_IS_CONTINUATION(*send))
6898 2318         send--;
6899           }
6900 78417         return send - start;
6901           }
6902            
6903           /* For the string representation of the given scalar, find the byte
6904           corresponding to the passed in UTF-8 offset. uoffset0 and boffset0
6905           give another position in the string, *before* the sought offset, which
6906           (which is always true, as 0, 0 is a valid pair of positions), which should
6907           help reduce the amount of linear searching.
6908           If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6909           will be used to reduce the amount of linear searching. The cache will be
6910           created if necessary, and the found value offered to it for update. */
6911           static STRLEN
6912 302274         S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6913           const U8 *const send, STRLEN uoffset,
6914           STRLEN uoffset0, STRLEN boffset0)
6915           {
6916           STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
6917           bool found = FALSE;
6918           bool at_end = FALSE;
6919            
6920           PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6921            
6922           assert (uoffset >= uoffset0);
6923            
6924 302274 100       if (!uoffset)
6925           return 0;
6926            
6927 268568 100       if (!SvREADONLY(sv) && !SvGMAGICAL(sv) && SvPOK(sv)
6928 268516 50       && PL_utf8cache
6929 417762 100       && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
6930 149246         (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
6931 268476 100       if ((*mgp)->mg_ptr) {
6932 237464         STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6933 237464 100       if (cache[0] == uoffset) {
6934           /* An exact match. */
6935 118066         return cache[1];
6936           }
6937 119398 100       if (cache[2] == uoffset) {
6938           /* An exact match. */
6939 236         return cache[3];
6940           }
6941            
6942 119162 100       if (cache[0] < uoffset) {
6943           /* The cache already knows part of the way. */
6944 119108 100       if (cache[0] > uoffset0) {
6945           /* The cache knows more than the passed in pair */
6946 32         uoffset0 = cache[0];
6947 32         boffset0 = cache[1];
6948           }
6949 119108 100       if ((*mgp)->mg_len != -1) {
6950           /* And we know the end too. */
6951 119106         boffset = boffset0
6952 119106         + sv_pos_u2b_midway(start + boffset0, send,
6953           uoffset - uoffset0,
6954 119106         (*mgp)->mg_len - uoffset0);
6955           } else {
6956 2         uoffset -= uoffset0;
6957 2         boffset = boffset0
6958 2         + sv_pos_u2b_forwards(start + boffset0,
6959           send, &uoffset, &at_end);
6960 2         uoffset += uoffset0;
6961           }
6962           }
6963 54 100       else if (cache[2] < uoffset) {
6964           /* We're between the two cache entries. */
6965 44 100       if (cache[2] > uoffset0) {
6966           /* and the cache knows more than the passed in pair */
6967 18         uoffset0 = cache[2];
6968 18         boffset0 = cache[3];
6969           }
6970            
6971 44         boffset = boffset0
6972 44         + sv_pos_u2b_midway(start + boffset0,
6973           start + cache[1],
6974           uoffset - uoffset0,
6975 44         cache[0] - uoffset0);
6976           } else {
6977 10         boffset = boffset0
6978 10         + sv_pos_u2b_midway(start + boffset0,
6979           start + cache[3],
6980           uoffset - uoffset0,
6981 10         cache[2] - uoffset0);
6982           }
6983           found = TRUE;
6984           }
6985 31012 100       else if ((*mgp)->mg_len != -1) {
6986           /* If we can take advantage of a passed in offset, do so. */
6987           /* In fact, offset0 is either 0, or less than offset, so don't
6988           need to worry about the other possibility. */
6989 31010         boffset = boffset0
6990 31010         + sv_pos_u2b_midway(start + boffset0, send,
6991           uoffset - uoffset0,
6992 31010         (*mgp)->mg_len - uoffset0);
6993           found = TRUE;
6994           }
6995           }
6996            
6997 150266 100       if (!found || PL_utf8cache < 0) {
    50        
6998           STRLEN real_boffset;
6999 94         uoffset -= uoffset0;
7000 141         real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0,
7001           send, &uoffset, &at_end);
7002 94         uoffset += uoffset0;
7003            
7004 94 50       if (found && PL_utf8cache < 0)
    0        
7005 47         assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset,
7006           real_boffset, sv);
7007           boffset = real_boffset;
7008           }
7009            
7010 150266 50       if (PL_utf8cache && !SvGMAGICAL(sv) && SvPOK(sv)) {
    100        
7011 150242 100       if (at_end)
7012 28         utf8_mg_len_cache_update(sv, mgp, uoffset);
7013           else
7014 226244         utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
7015           }
7016           return boffset;
7017           }
7018            
7019            
7020           /*
7021           =for apidoc sv_pos_u2b_flags
7022            
7023           Converts the offset from a count of UTF-8 chars from
7024           the start of the string, to a count of the equivalent number of bytes; if
7025           lenp is non-zero, it does the same to lenp, but this time starting from
7026           the offset, rather than from the start
7027           of the string. Handles type coercion.
7028           I is passed to C, and usually should be
7029           C to handle magic.
7030            
7031           =cut
7032           */
7033            
7034           /*
7035           * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
7036           * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
7037           * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
7038           *
7039           */
7040            
7041           STRLEN
7042 153708         Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
7043           U32 flags)
7044           {
7045           const U8 *start;
7046           STRLEN len;
7047           STRLEN boffset;
7048            
7049           PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
7050            
7051 153708 100       start = (U8*)SvPV_flags(sv, len, flags);
7052 153708 100       if (len) {
7053 153698         const U8 * const send = start + len;
7054 153698         MAGIC *mg = NULL;
7055 153698         boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
7056            
7057 153698 100       if (lenp
7058 150456 100       && *lenp /* don't bother doing work for 0, as its bytes equivalent
7059           is 0, and *lenp is already set to that. */) {
7060           /* Convert the relative offset to absolute. */
7061 148576         const STRLEN uoffset2 = uoffset + *lenp;
7062 148576         const STRLEN boffset2
7063 148576         = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
7064           uoffset, boffset) - boffset;
7065            
7066 148576         *lenp = boffset2;
7067           }
7068           } else {
7069 10 50       if (lenp)
7070 10         *lenp = 0;
7071           boffset = 0;
7072           }
7073            
7074 153708         return boffset;
7075           }
7076            
7077           /*
7078           =for apidoc sv_pos_u2b
7079            
7080           Converts the value pointed to by offsetp from a count of UTF-8 chars from
7081           the start of the string, to a count of the equivalent number of bytes; if
7082           lenp is non-zero, it does the same to lenp, but this time starting from
7083           the offset, rather than from the start of the string. Handles magic and
7084           type coercion.
7085            
7086           Use C in preference, which correctly handles strings longer
7087           than 2Gb.
7088            
7089           =cut
7090           */
7091            
7092           /*
7093           * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
7094           * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
7095           * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
7096           *
7097           */
7098            
7099           /* This function is subject to size and sign problems */
7100            
7101           void
7102 114         Perl_sv_pos_u2b(pTHX_ SV *const sv, I32 *const offsetp, I32 *const lenp)
7103           {
7104           PERL_ARGS_ASSERT_SV_POS_U2B;
7105            
7106 114 100       if (lenp) {
7107 44         STRLEN ulen = (STRLEN)*lenp;
7108 44         *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
7109           SV_GMAGIC|SV_CONST_RETURN);
7110 44         *lenp = (I32)ulen;
7111           } else {
7112 70         *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
7113           SV_GMAGIC|SV_CONST_RETURN);
7114           }
7115 114         }
7116            
7117           static void
7118 1440696         S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp,
7119           const STRLEN ulen)
7120           {
7121           PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
7122 1440696 100       if (SvREADONLY(sv) || SvGMAGICAL(sv) || !SvPOK(sv))
7123 1440696         return;
7124            
7125 2369074 100       if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
7126 929360         !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
7127 1345914         *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
7128           }
7129           assert(*mgp);
7130            
7131 1439714         (*mgp)->mg_len = ulen;
7132           }
7133            
7134           /* Create and update the UTF8 magic offset cache, with the proffered utf8/
7135           byte length pairing. The (byte) length of the total SV is passed in too,
7136           as blen, because for some (more esoteric) SVs, the call to SvPV_const()
7137           may not have updated SvCUR, so we can't rely on reading it directly.
7138            
7139           The proffered utf8/byte length pairing isn't used if the cache already has
7140           two pairs, and swapping either for the proffered pair would increase the
7141           RMS of the intervals between known byte offsets.
7142            
7143           The cache itself consists of 4 STRLEN values
7144           0: larger UTF-8 offset
7145           1: corresponding byte offset
7146           2: smaller UTF-8 offset
7147           3: corresponding byte offset
7148            
7149           Unused cache pairs have the value 0, 0.
7150           Keeping the cache "backwards" means that the invariant of
7151           cache[0] >= cache[2] is maintained even with empty slots, which means that
7152           the code that uses it doesn't need to worry if only 1 entry has actually
7153           been set to non-zero. It also makes the "position beyond the end of the
7154           cache" logic much simpler, as the first slot is always the one to start
7155           from.
7156           */
7157           static void
7158 2167556         S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
7159           const STRLEN utf8, const STRLEN blen)
7160           {
7161           STRLEN *cache;
7162            
7163           PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
7164            
7165 2167556 100       if (SvREADONLY(sv))
7166 2167556         return;
7167            
7168 2167666 100       if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
7169 136         !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
7170 188         *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
7171           0);
7172 188         (*mgp)->mg_len = -1;
7173           }
7174           assert(*mgp);
7175            
7176 2167530 100       if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
7177 31494         Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
7178 31494         (*mgp)->mg_ptr = (char *) cache;
7179           }
7180           assert(cache);
7181            
7182 2167530 100       if (PL_utf8cache < 0 && SvPOKp(sv)) {
    50        
7183           /* SvPOKp() because it's possible that sv has string overloading, and
7184           therefore is a reference, hence SvPVX() is actually a pointer.
7185           This cures the (very real) symptoms of RT 69422, but I'm not actually
7186           sure whether we should even be caching the results of UTF-8
7187           operations on overloading, given that nothing stops overloading
7188           returning a different value every time it's called. */
7189 2         const U8 *start = (const U8 *) SvPVX_const(sv);
7190 2         const STRLEN realutf8 = utf8_length(start, start + byte);
7191            
7192 2         assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8,
7193           sv);
7194           }
7195            
7196           /* Cache is held with the later position first, to simplify the code
7197           that deals with unbounded ends. */
7198          
7199           ASSERT_UTF8_CACHE(cache);
7200 2167530 100       if (cache[1] == 0) {
7201           /* Cache is totally empty */
7202 31498         cache[0] = utf8;
7203 31498         cache[1] = byte;
7204 2136032 100       } else if (cache[3] == 0) {
7205 2826 100       if (byte > cache[1]) {
7206           /* New one is larger, so goes first. */
7207 2808         cache[2] = cache[0];
7208 2808         cache[3] = cache[1];
7209 2808         cache[0] = utf8;
7210 2808         cache[1] = byte;
7211           } else {
7212 18         cache[2] = utf8;
7213 18         cache[3] = byte;
7214           }
7215           } else {
7216           #define THREEWAY_SQUARE(a,b,c,d) \
7217           ((float)((d) - (c))) * ((float)((d) - (c))) \
7218           + ((float)((c) - (b))) * ((float)((c) - (b))) \
7219           + ((float)((b) - (a))) * ((float)((b) - (a)))
7220            
7221           /* Cache has 2 slots in use, and we know three potential pairs.
7222           Keep the two that give the lowest RMS distance. Do the
7223           calculation in bytes simply because we always know the byte
7224           length. squareroot has the same ordering as the positive value,
7225           so don't bother with the actual square root. */
7226 2133206 100       if (byte > cache[1]) {
7227           /* New position is after the existing pair of pairs. */
7228 2133128         const float keep_earlier
7229 2133128         = THREEWAY_SQUARE(0, cache[3], byte, blen);
7230 2133128         const float keep_later
7231 2133128         = THREEWAY_SQUARE(0, cache[1], byte, blen);
7232            
7233 2133128 100       if (keep_later < keep_earlier) {
7234 1328         cache[2] = cache[0];
7235 1328         cache[3] = cache[1];
7236 1328         cache[0] = utf8;
7237 1328         cache[1] = byte;
7238           }
7239           else {
7240 2131800         cache[0] = utf8;
7241 2131800         cache[1] = byte;
7242           }
7243           }
7244 78 100       else if (byte > cache[3]) {
7245           /* New position is between the existing pair of pairs. */
7246 60         const float keep_earlier
7247 60         = THREEWAY_SQUARE(0, cache[3], byte, blen);
7248 60         const float keep_later
7249 60         = THREEWAY_SQUARE(0, byte, cache[1], blen);
7250            
7251 60 100       if (keep_later < keep_earlier) {
7252 12         cache[2] = utf8;
7253 12         cache[3] = byte;
7254           }
7255           else {
7256 48         cache[0] = utf8;
7257 48         cache[1] = byte;
7258           }
7259           }
7260           else {
7261           /* New position is before the existing pair of pairs. */
7262 18         const float keep_earlier
7263 18         = THREEWAY_SQUARE(0, byte, cache[3], blen);
7264 18         const float keep_later
7265 18         = THREEWAY_SQUARE(0, byte, cache[1], blen);
7266            
7267 18 100       if (keep_later < keep_earlier) {
7268 8         cache[2] = utf8;
7269 8         cache[3] = byte;
7270           }
7271           else {
7272 10         cache[0] = cache[2];
7273 10         cache[1] = cache[3];
7274 10         cache[2] = utf8;
7275 10         cache[3] = byte;
7276           }
7277           }
7278           }
7279           ASSERT_UTF8_CACHE(cache);
7280           }
7281            
7282           /* We already know all of the way, now we may be able to walk back. The same
7283           assumption is made as in S_sv_pos_u2b_midway(), namely that walking
7284           backward is half the speed of walking forward. */
7285           static STRLEN
7286 18498         S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
7287           const U8 *end, STRLEN endu)
7288           {
7289 18498         const STRLEN forw = target - s;
7290 18498         STRLEN backw = end - target;
7291            
7292           PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
7293            
7294 18498 100       if (forw < 2 * backw) {
7295 16962         return utf8_length(s, target);
7296           }
7297            
7298 10383 100       while (end > target) {
7299 366         end--;
7300 577 100       while (UTF8_IS_CONTINUATION(*end)) {
7301 28         end--;
7302           }
7303 366         endu--;
7304           }
7305           return endu;
7306           }
7307            
7308           /*
7309           =for apidoc sv_pos_b2u_flags
7310            
7311           Converts the offset from a count of bytes from the start of the string, to
7312           a count of the equivalent number of UTF-8 chars. Handles type coercion.
7313           I is passed to C, and usually should be
7314           C to handle magic.
7315            
7316           =cut
7317           */
7318            
7319           /*
7320           * sv_pos_b2u_flags() uses, like sv_pos_u2b_flags(), the mg_ptr of the
7321           * potential PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8
7322           * and byte offsets.
7323           *
7324           */
7325           STRLEN
7326 2018734         Perl_sv_pos_b2u_flags(pTHX_ SV *const sv, STRLEN const offset, U32 flags)
7327           {
7328           const U8* s;
7329           STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
7330           STRLEN blen;
7331 2018734         MAGIC* mg = NULL;
7332           const U8* send;
7333           bool found = FALSE;
7334            
7335           PERL_ARGS_ASSERT_SV_POS_B2U_FLAGS;
7336            
7337 2018734 50       s = (const U8*)SvPV_flags(sv, blen, flags);
7338            
7339 2018734 50       if (blen < offset)
7340 0         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%"UVuf
7341           ", byte=%"UVuf, (UV)blen, (UV)offset);
7342            
7343 2018734         send = s + offset;
7344            
7345 2018734 100       if (!SvREADONLY(sv)
7346 2018724 50       && PL_utf8cache
7347 2018724 100       && SvTYPE(sv) >= SVt_PVMG
7348 2018696 100       && (mg = mg_find(sv, PERL_MAGIC_utf8)))
7349           {
7350 2018552 100       if (mg->mg_ptr) {
7351 2016918         STRLEN * const cache = (STRLEN *) mg->mg_ptr;
7352 2016918 100       if (cache[1] == offset) {
7353           /* An exact match. */
7354 4         return cache[0];
7355           }
7356 2016914 100       if (cache[3] == offset) {
7357           /* An exact match. */
7358 6         return cache[2];
7359           }
7360            
7361 2016908 100       if (cache[1] < offset) {
7362           /* We already know part of the way. */
7363 2016866 100       if (mg->mg_len != -1) {
7364           /* Actually, we know the end too. */
7365 16822         len = cache[0]
7366 25233         + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
7367 33644         s + blen, mg->mg_len - cache[0]);
7368           } else {
7369 2000044         len = cache[0] + utf8_length(s + cache[1], send);
7370           }
7371           }
7372 42 100       else if (cache[3] < offset) {
7373           /* We're between the two cached pairs, so we do the calculation
7374           offset by the byte/utf-8 positions for the earlier pair,
7375           then add the utf-8 characters from the string start to
7376           there. */
7377 51         len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
7378 34         s + cache[1], cache[0] - cache[2])
7379 34         + cache[2];
7380            
7381           }
7382           else { /* cache[3] > offset */
7383 8         len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
7384           cache[2]);
7385            
7386           }
7387           ASSERT_UTF8_CACHE(cache);
7388           found = TRUE;
7389 1634 50       } else if (mg->mg_len != -1) {
7390 1634         len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
7391           found = TRUE;
7392           }
7393           }
7394 2018724 100       if (!found || PL_utf8cache < 0) {
    100        
7395 184         const STRLEN real_len = utf8_length(s, send);
7396            
7397 184 100       if (found && PL_utf8cache < 0)
    50        
7398 93         assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv);
7399           len = real_len;
7400           }
7401            
7402 2018724 50       if (PL_utf8cache) {
7403 2018724 100       if (blen == offset)
7404 1382         utf8_mg_len_cache_update(sv, &mg, len);
7405           else
7406 2018038         utf8_mg_pos_cache_update(sv, &mg, offset, len, blen);
7407           }
7408            
7409           return len;
7410           }
7411            
7412           /*
7413           =for apidoc sv_pos_b2u
7414            
7415           Converts the value pointed to by offsetp from a count of bytes from the
7416           start of the string, to a count of the equivalent number of UTF-8 chars.
7417           Handles magic and type coercion.
7418            
7419           Use C in preference, which correctly handles strings
7420           longer than 2Gb.
7421            
7422           =cut
7423           */
7424            
7425           /*
7426           * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
7427           * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
7428           * byte offsets.
7429           *
7430           */
7431           void
7432 258         Perl_sv_pos_b2u(pTHX_ SV *const sv, I32 *const offsetp)
7433           {
7434           PERL_ARGS_ASSERT_SV_POS_B2U;
7435            
7436 258 50       if (!sv)
7437 258         return;
7438            
7439 258         *offsetp = (I32)sv_pos_b2u_flags(sv, (STRLEN)*offsetp,
7440           SV_GMAGIC|SV_CONST_RETURN);
7441           }
7442            
7443           static void
7444 4         S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache,
7445           STRLEN real, SV *const sv)
7446           {
7447           PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT;
7448            
7449           /* As this is debugging only code, save space by keeping this test here,
7450           rather than inlining it in all the callers. */
7451 4 50       if (from_cache == real)
7452 4         return;
7453            
7454           /* Need to turn the assertions off otherwise we may recurse infinitely
7455           while printing error messages. */
7456 0         SAVEI8(PL_utf8cache);
7457 0         PL_utf8cache = 0;
7458 0         Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf,
7459           func, (UV) from_cache, (UV) real, SVfARG(sv));
7460           }
7461            
7462           /*
7463           =for apidoc sv_eq
7464            
7465           Returns a boolean indicating whether the strings in the two SVs are
7466           identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
7467           coerce its args to strings if necessary.
7468            
7469           =for apidoc sv_eq_flags
7470            
7471           Returns a boolean indicating whether the strings in the two SVs are
7472           identical. Is UTF-8 and 'use bytes' aware and coerces its args to strings
7473           if necessary. If the flags include SV_GMAGIC, it handles get-magic, too.
7474            
7475           =cut
7476           */
7477            
7478           I32
7479 428916282         Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
7480           {
7481           dVAR;
7482           const char *pv1;
7483           STRLEN cur1;
7484           const char *pv2;
7485           STRLEN cur2;
7486           I32 eq = 0;
7487           SV* svrecode = NULL;
7488            
7489 428916282 50       if (!sv1) {
7490           pv1 = "";
7491 0         cur1 = 0;
7492           }
7493           else {
7494           /* if pv1 and pv2 are the same, second SvPV_const call may
7495           * invalidate pv1 (if we are handling magic), so we may need to
7496           * make a copy */
7497 428916282 100       if (sv1 == sv2 && flags & SV_GMAGIC
    50        
7498 0 0       && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
7499 0 0       pv1 = SvPV_const(sv1, cur1);
7500 0         sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
7501           }
7502 428916282 100       pv1 = SvPV_flags_const(sv1, cur1, flags);
7503           }
7504            
7505 428916282 50       if (!sv2){
7506           pv2 = "";
7507 0         cur2 = 0;
7508           }
7509           else
7510 428916282 100       pv2 = SvPV_flags_const(sv2, cur2, flags);
7511            
7512 428916282 100       if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
    100        
    100        
    100        
7513           /* Differing utf8ness.
7514           * Do not UTF8size the comparands as a side-effect. */
7515 261786 100       if (PL_encoding) {
7516 21766 100       if (SvUTF8(sv1)) {
7517 21584         svrecode = newSVpvn(pv2, cur2);
7518 21584         sv_recode_to_utf8(svrecode, PL_encoding);
7519 21584 50       pv2 = SvPV_const(svrecode, cur2);
7520           }
7521           else {
7522 182         svrecode = newSVpvn(pv1, cur1);
7523 182         sv_recode_to_utf8(svrecode, PL_encoding);
7524 182 50       pv1 = SvPV_const(svrecode, cur1);
7525           }
7526           /* Now both are in UTF-8. */
7527 21766 100       if (cur1 != cur2) {
7528 236         SvREFCNT_dec_NN(svrecode);
7529 236         return FALSE;
7530           }
7531           }
7532           else {
7533 240020 100       if (SvUTF8(sv1)) {
7534           /* sv1 is the UTF-8 one */
7535 235214         return bytes_cmp_utf8((const U8*)pv2, cur2,
7536           (const U8*)pv1, cur1) == 0;
7537           }
7538           else {
7539           /* sv2 is the UTF-8 one */
7540 4806         return bytes_cmp_utf8((const U8*)pv1, cur1,
7541           (const U8*)pv2, cur2) == 0;
7542           }
7543           }
7544           }
7545            
7546 428676026 100       if (cur1 == cur2)
7547 135262398 100       eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
    100        
7548          
7549 428676026         SvREFCNT_dec(svrecode);
7550            
7551 428796154         return eq;
7552           }
7553            
7554           /*
7555           =for apidoc sv_cmp
7556            
7557           Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7558           string in C is less than, equal to, or greater than the string in
7559           C. Is UTF-8 and 'use bytes' aware, handles get magic, and will
7560           coerce its args to strings if necessary. See also C.
7561            
7562           =for apidoc sv_cmp_flags
7563            
7564           Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7565           string in C is less than, equal to, or greater than the string in
7566           C. Is UTF-8 and 'use bytes' aware and will coerce its args to strings
7567           if necessary. If the flags include SV_GMAGIC, it handles get magic. See
7568           also C.
7569            
7570           =cut
7571           */
7572            
7573           I32
7574 189596769         Perl_sv_cmp(pTHX_ SV *const sv1, SV *const sv2)
7575           {
7576 189596769         return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
7577           }
7578            
7579           I32
7580 195807651         Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2,
7581           const U32 flags)
7582           {
7583           dVAR;
7584           STRLEN cur1, cur2;
7585           const char *pv1, *pv2;
7586           I32 cmp;
7587           SV *svrecode = NULL;
7588            
7589 195807651 100       if (!sv1) {
7590           pv1 = "";
7591 2         cur1 = 0;
7592           }
7593           else
7594 195807649 100       pv1 = SvPV_flags_const(sv1, cur1, flags);
7595            
7596 195807651 100       if (!sv2) {
7597           pv2 = "";
7598 8         cur2 = 0;
7599           }
7600           else
7601 195807643 100       pv2 = SvPV_flags_const(sv2, cur2, flags);
7602            
7603 195807651 100       if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
    100        
    100        
    50        
7604           /* Differing utf8ness.
7605           * Do not UTF8size the comparands as a side-effect. */
7606 34072 100       if (SvUTF8(sv1)) {
7607 18536 100       if (PL_encoding) {
7608 422         svrecode = newSVpvn(pv2, cur2);
7609 422         sv_recode_to_utf8(svrecode, PL_encoding);
7610 422 50       pv2 = SvPV_const(svrecode, cur2);
7611           }
7612           else {
7613 18114         const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2,
7614           (const U8*)pv1, cur1);
7615 18114 100       return retval ? retval < 0 ? -1 : +1 : 0;
    100        
7616           }
7617           }
7618           else {
7619 15536 100       if (PL_encoding) {
7620 462         svrecode = newSVpvn(pv1, cur1);
7621 462         sv_recode_to_utf8(svrecode, PL_encoding);
7622 462 50       pv1 = SvPV_const(svrecode, cur1);
7623           }
7624           else {
7625 15074         const int retval = bytes_cmp_utf8((const U8*)pv1, cur1,
7626           (const U8*)pv2, cur2);
7627 15074 100       return retval ? retval < 0 ? -1 : +1 : 0;
    100        
7628           }
7629           }
7630           }
7631            
7632 195774463 100       if (!cur1) {
7633 13808 100       cmp = cur2 ? -1 : 0;
7634 195760655 100       } else if (!cur2) {
7635           cmp = 1;
7636           } else {
7637 195760045         const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
7638            
7639 195760045 100       if (retval) {
7640 192725103 100       cmp = retval < 0 ? -1 : 1;
7641 3034942 100       } else if (cur1 == cur2) {
7642           cmp = 0;
7643           } else {
7644 2435684 100       cmp = cur1 < cur2 ? -1 : 1;
7645           }
7646           }
7647            
7648 195774463         SvREFCNT_dec(svrecode);
7649            
7650 195791057         return cmp;
7651           }
7652            
7653           /*
7654           =for apidoc sv_cmp_locale
7655            
7656           Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7657           'use bytes' aware, handles get magic, and will coerce its args to strings
7658           if necessary. See also C.
7659            
7660           =for apidoc sv_cmp_locale_flags
7661            
7662           Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7663           'use bytes' aware and will coerce its args to strings if necessary. If the
7664           flags contain SV_GMAGIC, it handles get magic. See also C.
7665            
7666           =cut
7667           */
7668            
7669           I32
7670 0         Perl_sv_cmp_locale(pTHX_ SV *const sv1, SV *const sv2)
7671           {
7672 0         return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
7673           }
7674            
7675           I32
7676 0         Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2,
7677           const U32 flags)
7678           {
7679           dVAR;
7680           #ifdef USE_LOCALE_COLLATE
7681            
7682           char *pv1, *pv2;
7683           STRLEN len1, len2;
7684           I32 retval;
7685            
7686 0 0       if (PL_collation_standard)
7687           goto raw_compare;
7688            
7689 0         len1 = 0;
7690 0 0       pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
7691 0         len2 = 0;
7692 0 0       pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
7693            
7694 0 0       if (!pv1 || !len1) {
    0        
7695 0 0       if (pv2 && len2)
    0        
7696           return -1;
7697           else
7698           goto raw_compare;
7699           }
7700           else {
7701 0 0       if (!pv2 || !len2)
    0        
7702           return 1;
7703           }
7704            
7705 0         retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
7706            
7707 0 0       if (retval)
7708 0 0       return retval < 0 ? -1 : 1;
7709            
7710           /*
7711           * When the result of collation is equality, that doesn't mean
7712           * that there are no differences -- some locales exclude some
7713           * characters from consideration. So to avoid false equalities,
7714           * we use the raw string as a tiebreaker.
7715           */
7716            
7717           raw_compare:
7718           /*FALLTHROUGH*/
7719            
7720           #endif /* USE_LOCALE_COLLATE */
7721            
7722 0         return sv_cmp(sv1, sv2);
7723           }
7724            
7725            
7726           #ifdef USE_LOCALE_COLLATE
7727            
7728           /*
7729           =for apidoc sv_collxfrm
7730            
7731           This calls C with the SV_GMAGIC flag. See
7732           C.
7733            
7734           =for apidoc sv_collxfrm_flags
7735            
7736           Add Collate Transform magic to an SV if it doesn't already have it. If the
7737           flags contain SV_GMAGIC, it handles get-magic.
7738            
7739           Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
7740           scalar data of the variable, but transformed to such a format that a normal
7741           memory comparison can be used to compare the data according to the locale
7742           settings.
7743            
7744           =cut
7745           */
7746            
7747           char *
7748 0         Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
7749           {
7750           dVAR;
7751           MAGIC *mg;
7752            
7753           PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
7754            
7755 0 0       mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
7756 0 0       if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
    0        
    0        
7757           const char *s;
7758           char *xf;
7759           STRLEN len, xlen;
7760            
7761 0 0       if (mg)
7762 0         Safefree(mg->mg_ptr);
7763 0 0       s = SvPV_flags_const(sv, len, flags);
7764 0 0       if ((xf = mem_collxfrm(s, len, &xlen))) {
7765 0 0       if (! mg) {
7766           #ifdef PERL_OLD_COPY_ON_WRITE
7767           if (SvIsCOW(sv))
7768           sv_force_normal_flags(sv, 0);
7769           #endif
7770 0         mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
7771           0, 0);
7772           assert(mg);
7773           }
7774 0         mg->mg_ptr = xf;
7775 0         mg->mg_len = xlen;
7776           }
7777           else {
7778 0 0       if (mg) {
7779 0         mg->mg_ptr = NULL;
7780 0         mg->mg_len = -1;
7781           }
7782           }
7783           }
7784 0 0       if (mg && mg->mg_ptr) {
    0        
7785 0         *nxp = mg->mg_len;
7786 0         return mg->mg_ptr + sizeof(PL_collation_ix);
7787           }
7788           else {
7789 0         *nxp = 0;
7790 0         return NULL;
7791           }
7792           }
7793            
7794           #endif /* USE_LOCALE_COLLATE */
7795            
7796           static char *
7797 14         S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7798           {
7799 14         SV * const tsv = newSV(0);
7800 14         ENTER;
7801 14         SAVEFREESV(tsv);
7802 14         sv_gets(tsv, fp, 0);
7803 10         sv_utf8_upgrade_nomg(tsv);
7804 10         SvCUR_set(sv,append);
7805 10         sv_catsv(sv,tsv);
7806 10         LEAVE;
7807 10 50       return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7808           }
7809            
7810           static char *
7811 4456         S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7812           {
7813           SSize_t bytesread;
7814 4456 50       const STRLEN recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
7815           /* Grab the size of the record we're getting */
7816 4456 50       char *buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
    100        
7817          
7818           /* Go yank in */
7819           #ifdef VMS
7820           #include
7821           int fd;
7822           Stat_t st;
7823            
7824           /* With a true, record-oriented file on VMS, we need to use read directly
7825           * to ensure that we respect RMS record boundaries. The user is responsible
7826           * for providing a PL_rs value that corresponds to the FAB$W_MRS (maximum
7827           * record size) field. N.B. This is likely to produce invalid results on
7828           * varying-width character data when a record ends mid-character.
7829           */
7830           fd = PerlIO_fileno(fp);
7831           if (fd != -1
7832           && PerlLIO_fstat(fd, &st) == 0
7833           && (st.st_fab_rfm == FAB$C_VAR
7834           || st.st_fab_rfm == FAB$C_VFC
7835           || st.st_fab_rfm == FAB$C_FIX)) {
7836            
7837           bytesread = PerlLIO_read(fd, buffer, recsize);
7838           }
7839           else /* in-memory file from PerlIO::Scalar
7840           * or not a record-oriented file
7841           */
7842           #endif
7843           {
7844 4456         bytesread = PerlIO_read(fp, buffer, recsize);
7845            
7846           /* At this point, the logic in sv_get() means that sv will
7847           be treated as utf-8 if the handle is utf8.
7848           */
7849 4456 100       if (PerlIO_isutf8(fp) && bytesread > 0) {
    50        
7850 12         char *bend = buffer + bytesread;
7851           char *bufp = buffer;
7852           size_t charcount = 0;
7853           bool charstart = TRUE;
7854           STRLEN skip = 0;
7855            
7856 40 100       while (charcount < recsize) {
7857           /* count accumulated characters */
7858 70 100       while (bufp < bend) {
7859 54 100       if (charstart) {
7860 46         skip = UTF8SKIP(bufp);
7861           }
7862 54 100       if (bufp + skip > bend) {
7863           /* partial at the end */
7864           charstart = FALSE;
7865           break;
7866           }
7867           else {
7868 44         ++charcount;
7869 44         bufp += skip;
7870           charstart = TRUE;
7871           }
7872           }
7873            
7874 26 100       if (charcount < recsize) {
7875           STRLEN readsize;
7876 18         STRLEN bufp_offset = bufp - buffer;
7877           SSize_t morebytesread;
7878            
7879           /* originally I read enough to fill any incomplete
7880           character and the first byte of the next
7881           character if needed, but if there's many
7882           multi-byte encoded characters we're going to be
7883           making a read call for every character beyond
7884           the original read size.
7885            
7886           So instead, read the rest of the character if
7887           any, and enough bytes to match at least the
7888           start bytes for each character we're going to
7889           read.
7890           */
7891 18 100       if (charstart)
7892 8         readsize = recsize - charcount;
7893           else
7894 10         readsize = skip - (bend - bufp) + recsize - charcount - 1;
7895 18 50       buffer = SvGROW(sv, append + bytesread + readsize + 1) + append;
    50        
7896 18         bend = buffer + bytesread;
7897 18         morebytesread = PerlIO_read(fp, bend, readsize);
7898 18 100       if (morebytesread <= 0) {
7899           /* we're done, if we still have incomplete
7900           characters the check code in sv_gets() will
7901           warn about them.
7902            
7903           I'd originally considered doing
7904           PerlIO_ungetc() on all but the lead
7905           character of the incomplete character, but
7906           read() doesn't do that, so I don't.
7907           */
7908           break;
7909           }
7910            
7911           /* prepare to scan some more */
7912 14         bytesread += morebytesread;
7913 14         bend = buffer + bytesread;
7914 18         bufp = buffer + bufp_offset;
7915           }
7916           }
7917           }
7918           }
7919            
7920 4456 50       if (bytesread < 0)
7921           bytesread = 0;
7922 4456         SvCUR_set(sv, bytesread + append);
7923 4456         buffer[bytesread] = '\0';
7924 4456 100       return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7925           }
7926            
7927           /*
7928           =for apidoc sv_gets
7929            
7930           Get a line from the filehandle and store it into the SV, optionally
7931           appending to the currently-stored string. If C is not 0, the
7932           line is appended to the SV instead of overwriting it. C should
7933           be set to the byte offset that the appended string should start at
7934           in the SV (typically, C is a suitable choice).
7935            
7936           =cut
7937           */
7938            
7939           char *
7940 224921090         Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7941 224921090 100       {
7942           dVAR;
7943           const char *rsptr;
7944           STRLEN rslen;
7945           STDCHAR rslast;
7946           STDCHAR *bp;
7947           I32 cnt;
7948           I32 i = 0;
7949           I32 rspara = 0;
7950            
7951           PERL_ARGS_ASSERT_SV_GETS;
7952            
7953 224921090 100       if (SvTHINKFIRST(sv))
7954 2716762 100       sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
7955           /* XXX. If you make this PVIV, then copy on write can copy scalars read
7956           from <>.
7957           However, perlbench says it's slower, because the existing swipe code
7958           is faster than copy on write.
7959           Swings and roundabouts. */
7960 108659411         SvUPGRADE(sv, SVt_PV);
7961            
7962 224921090 100       if (append) {
7963 6308500 100       if (PerlIO_isutf8(fp)) {
7964 26 100       if (!SvUTF8(sv)) {
7965 12         sv_utf8_upgrade_nomg(sv);
7966 12         sv_pos_u2b(sv,&append,0);
7967           }
7968 6308474 100       } else if (SvUTF8(sv)) {
7969 14         return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append);
7970           }
7971           }
7972            
7973 224921076         SvPOK_only(sv);
7974 224921076 100       if (!append) {
7975 218612590         SvCUR_set(sv,0);
7976           }
7977 224921076 100       if (PerlIO_isutf8(fp))
7978 22286         SvUTF8_on(sv);
7979            
7980 224921076 100       if (IN_PERL_COMPILETIME) {
7981           /* we always read code in line mode */
7982           rsptr = "\n";
7983 215402929         rslen = 1;
7984           }
7985 9558445 100       else if (RsSNARF(PL_rs)) {
    50        
    50        
7986           /* If it is a regular disk file use size from stat() as estimate
7987           of amount we are going to read -- may result in mallocing
7988           more memory than we really need if the layers below reduce
7989           the size we read (e.g. CRLF or a gzip layer).
7990           */
7991           Stat_t st;
7992 80596 50       if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
    100        
7993 15386         const Off_t offset = PerlIO_tell(fp);
7994 15386 100       if (offset != (Off_t) -1 && st.st_size + append > offset) {
    100        
7995 14316 50       (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
    100        
7996           }
7997           }
7998           rsptr = NULL;
7999 40298         rslen = 0;
8000           }
8001 9477849 100       else if (RsRECORD(PL_rs)) {
    100        
    100        
    50        
8002 4456         return S_sv_gets_read_record(aTHX_ sv, fp, append);
8003           }
8004 9473393 100       else if (RsPARA(PL_rs)) {
    100        
8005           rsptr = "\n\n";
8006 332698         rslen = 2;
8007 332698         rspara = 1;
8008           }
8009           else {
8010           /* Get $/ i.e. PL_rs into same encoding as stream wants */
8011 9140695 100       if (PerlIO_isutf8(fp)) {
8012 21534 100       rsptr = SvPVutf8(PL_rs, rslen);
8013           }
8014           else {
8015 9119161 100       if (SvUTF8(PL_rs)) {
8016 48 100       if (!sv_utf8_downgrade(PL_rs, TRUE)) {
8017 4         Perl_croak(aTHX_ "Wide character in $/");
8018           }
8019           }
8020 9119157 100       rsptr = SvPV_const(PL_rs, rslen);
8021           }
8022           }
8023            
8024 224916616 100       rslast = rslen ? rsptr[rslen - 1] : '\0';
8025            
8026 224916616 100       if (rspara) { /* have to do this both before and after */
8027           do { /* to make sure file boundaries work right */
8028 332908 100       if (PerlIO_eof(fp))
8029           return 0;
8030 331228         i = PerlIO_getc(fp);
8031 331228 100       if (i != '\n') {
8032 331018 50       if (i == -1)
8033           return 0;
8034 331018         PerlIO_ungetc(fp,i);
8035 331018         break;
8036           }
8037 210 50       } while (i != EOF);
8038           }
8039            
8040           /* See if we know enough about I/O mechanism to cheat it ! */
8041            
8042           /* This used to be #ifdef test - it is made run-time test for ease
8043           of abstracting out stdio interface. One call should be cheap
8044           enough here - and may even be a macro allowing compile
8045           time optimization.
8046           */
8047            
8048 224914936 100       if (PerlIO_fast_gets(fp)) {
8049            
8050           /*
8051           * We're going to steal some values from the stdio struct
8052           * and put EVERYTHING in the innermost loop into registers.
8053           */
8054           STDCHAR *ptr;
8055           STRLEN bpx;
8056           I32 shortbuffered;
8057            
8058           #if defined(VMS) && defined(PERLIO_IS_STDIO)
8059           /* An ungetc()d char is handled separately from the regular
8060           * buffer, so we getc() it back out and stuff it in the buffer.
8061           */
8062           i = PerlIO_getc(fp);
8063           if (i == EOF) return 0;
8064           *(--((*fp)->_ptr)) = (unsigned char) i;
8065           (*fp)->_cnt++;
8066           #endif
8067            
8068           /* Here is some breathtakingly efficient cheating */
8069            
8070 224914920         cnt = PerlIO_get_cnt(fp); /* get count into register */
8071           /* make sure we have the room */
8072 224914920 100       if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
8073           /* Not room for all of it
8074           if we are looking for a separator and room for some
8075           */
8076 6853665 100       if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
    100        
8077           /* just process what we have room for */
8078 4138301         shortbuffered = cnt - SvLEN(sv) + append + 1;
8079 4138301         cnt -= shortbuffered;
8080           }
8081           else {
8082           shortbuffered = 0;
8083           /* remember that cnt can be negative */
8084 2715364 50       SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
    100        
    100        
    100        
8085           }
8086           }
8087           else
8088           shortbuffered = 0;
8089 224914920         bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
8090 226909651         ptr = (STDCHAR*)PerlIO_get_ptr(fp);
8091           DEBUG_P(PerlIO_printf(Perl_debug_log,
8092           "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
8093           DEBUG_P(PerlIO_printf(Perl_debug_log,
8094           "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
8095           PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
8096           PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
8097           for (;;) {
8098           screamer:
8099 228848413 100       if (cnt > 0) {
8100 227291699 100       if (rslen) {
8101 6481523933 100       while (cnt > 0) { /* this | eat */
8102 6480266449         cnt--;
8103 6597696861 100       if ((*bp++ = *ptr++) == rslast) /* really | dust */
8104           goto thats_all_folks; /* screams | sed :-) */
8105           }
8106           }
8107           else {
8108 61040         Copy(ptr, bp, cnt, char); /* this | eat */
8109 61040         bp += cnt; /* screams | dust */
8110 61040         ptr += cnt; /* louder | sed :-) */
8111           cnt = 0;
8112           assert (!shortbuffered);
8113 61040         goto cannot_be_shortbuffered;
8114           }
8115           }
8116          
8117 2814198 100       if (shortbuffered) { /* oh well, must extend */
8118           cnt = shortbuffered;
8119           shortbuffered = 0;
8120 649767         bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
8121 649767         SvCUR_set(sv, bpx);
8122 649767 50       SvGROW(sv, SvLEN(sv) + append + cnt + 2);
    50        
8123 649767         bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
8124 649767         continue;
8125           }
8126            
8127           cannot_be_shortbuffered:
8128           DEBUG_P(PerlIO_printf(Perl_debug_log,
8129           "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
8130           PTR2UV(ptr),(long)cnt));
8131 2225471         PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
8132            
8133           DEBUG_Pv(PerlIO_printf(Perl_debug_log,
8134           "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
8135           PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
8136           PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
8137            
8138           /* This used to call 'filbuf' in stdio form, but as that behaves like
8139           getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
8140           another abstraction. */
8141 2225471         i = PerlIO_getc(fp); /* get more characters */
8142            
8143           DEBUG_Pv(PerlIO_printf(Perl_debug_log,
8144           "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
8145           PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
8146           PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
8147            
8148 2225467         cnt = PerlIO_get_cnt(fp);
8149 2225467         ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
8150           DEBUG_P(PerlIO_printf(Perl_debug_log,
8151           "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
8152            
8153 2225467 100       if (i == EOF) /* all done for ever? */
8154           goto thats_really_all_folks;
8155            
8156 1955309         bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
8157 1955309         SvCUR_set(sv, bpx);
8158 1955309 50       SvGROW(sv, bpx + cnt + 2);
    100        
8159 1955309         bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
8160            
8161 1955309         *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
8162            
8163 1955309 100       if (rslen && (STDCHAR)i == rslast) /* all done for now? */
    100        
8164           goto thats_all_folks;
8165           }
8166            
8167           thats_all_folks:
8168 335238738 100       if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
    100        
    100        
8169 226024844         memNE((char*)bp - rslen, rsptr, rslen))
8170           goto screamer; /* go back to the fray */
8171           thats_really_all_folks:
8172 224914916 100       if (shortbuffered)
8173 3488273         cnt += shortbuffered;
8174           DEBUG_P(PerlIO_printf(Perl_debug_log,
8175           "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
8176 224914916         PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
8177           DEBUG_P(PerlIO_printf(Perl_debug_log,
8178           "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
8179           PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
8180           PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
8181 224914916         *bp = '\0';
8182 224914924         SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
8183           DEBUG_P(PerlIO_printf(Perl_debug_log,
8184           "Screamer: done, len=%ld, string=|%.*s|\n",
8185           (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
8186           }
8187           else
8188           {
8189           /*The big, slow, and stupid way. */
8190           #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
8191           STDCHAR *buf = NULL;
8192           Newx(buf, 8192, STDCHAR);
8193           assert(buf);
8194           #else
8195           STDCHAR buf[8192];
8196           #endif
8197            
8198           screamer2:
8199 16 100       if (rslen) {
8200           const STDCHAR * const bpe = buf + sizeof(buf);
8201           bp = buf;
8202 24 100       while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
    100        
    50        
8203           ; /* keep reading */
8204 8         cnt = bp - buf;
8205           }
8206           else {
8207 8         cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
8208           /* Accommodate broken VAXC compiler, which applies U8 cast to
8209           * both args of ?: operator, causing EOF to change into 255
8210           */
8211 8 100       if (cnt > 0)
8212 4         i = (U8)buf[cnt - 1];
8213           else
8214           i = EOF;
8215           }
8216            
8217 16 50       if (cnt < 0)
8218           cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
8219 16 50       if (append)
8220 0         sv_catpvn_nomg(sv, (char *) buf, cnt);
8221           else
8222 16         sv_setpvn(sv, (char *) buf, cnt); /* "nomg" is implied */
8223            
8224 19 100       if (i != EOF && /* joy */
    100        
8225 5 50       (!rslen ||
8226 3 50       SvCUR(sv) < rslen ||
8227 2         memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
8228           {
8229 4         append = -1;
8230           /*
8231           * If we're reading from a TTY and we get a short read,
8232           * indicating that the user hit his EOF character, we need
8233           * to notice it now, because if we try to read from the TTY
8234           * again, the EOF condition will disappear.
8235           *
8236           * The comparison of cnt to sizeof(buf) is an optimization
8237           * that prevents unnecessary calls to feof().
8238           *
8239           * - jik 9/25/96
8240           */
8241 4 50       if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
    50        
8242           goto screamer2;
8243           }
8244            
8245           #ifdef USE_HEAP_INSTEAD_OF_STACK
8246           Safefree(buf);
8247           #endif
8248           }
8249            
8250 224914932 100       if (rspara) { /* have to do this both before and after */
8251 338138 100       while (i != EOF) { /* to make sure file boundaries work right */
8252 336784         i = PerlIO_getc(fp);
8253 336784 100       if (i != '\n') {
8254 329664         PerlIO_ungetc(fp,i);
8255 495173         break;
8256           }
8257           }
8258           }
8259            
8260 224918005 100       return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
8261           }
8262            
8263           /*
8264           =for apidoc sv_inc
8265            
8266           Auto-increment of the value in the SV, doing string to numeric conversion
8267           if necessary. Handles 'get' magic and operator overloading.
8268            
8269           =cut
8270           */
8271            
8272           void
8273 3812452         Perl_sv_inc(pTHX_ SV *const sv)
8274 3812452 100       {
8275 3812452 50       if (!sv)
8276 3812428         return;
8277 1877256         SvGETMAGIC(sv);
8278 3812452         sv_inc_nomg(sv);
8279           }
8280            
8281           /*
8282           =for apidoc sv_inc_nomg
8283            
8284           Auto-increment of the value in the SV, doing string to numeric conversion
8285           if necessary. Handles operator overloading. Skips handling 'get' magic.
8286            
8287           =cut
8288           */
8289            
8290           void
8291 17086394         Perl_sv_inc_nomg(pTHX_ SV *const sv)
8292           {
8293           dVAR;
8294           char *d;
8295           int flags;
8296            
8297 17086394 50       if (!sv)
8298           return;
8299 17086394 100       if (SvTHINKFIRST(sv)) {
8300 235432 100       if (SvREADONLY(sv)) {
8301 4         Perl_croak_no_modify();
8302           }
8303 235428 100       if (SvROK(sv)) {
8304           IV i;
8305 208 50       if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg))
    50        
    100        
    50        
8306           return;
8307 2         i = PTR2IV(SvRV(sv));
8308 2         sv_unref(sv);
8309 2         sv_setiv(sv, i);
8310           }
8311 235220         else sv_force_normal_flags(sv, 0);
8312           }
8313 17086184         flags = SvFLAGS(sv);
8314 17086184 100       if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
8315           /* It's (privately or publicly) a float, but not tested as an
8316           integer, so test it to see. */
8317 2568264 50       (void) SvIV(sv);
8318 2568264         flags = SvFLAGS(sv);
8319           }
8320 17086184 100       if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
    50        
8321           /* It's publicly an integer, or privately an integer-not-float */
8322           #ifdef PERL_PRESERVE_IVUV
8323           oops_its_int:
8324           #endif
8325 4403608 100       if (SvIsUV(sv)) {
8326 2692 100       if (SvUVX(sv) == UV_MAX)
8327 778         sv_setnv(sv, UV_MAX_P1);
8328           else
8329 1914 50       (void)SvIOK_only_UV(sv);
8330 2692         SvUV_set(sv, SvUVX(sv) + 1);
8331           } else {
8332 4400916 100       if (SvIVX(sv) == IV_MAX)
8333 4         sv_setuv(sv, (UV)IV_MAX + 1);
8334           else {
8335 4400912 50       (void)SvIOK_only(sv);
8336 4400912         SvIV_set(sv, SvIVX(sv) + 1);
8337           }
8338           }
8339           return;
8340           }
8341 12683338 100       if (flags & SVp_NOK) {
8342 1104         const NV was = SvNVX(sv);
8343 1104 100       if (NV_OVERFLOWS_INTEGERS_AT &&
8344           was >= NV_OVERFLOWS_INTEGERS_AT) {
8345           /* diag_listed_as: Lost precision when %s %f by 1 */
8346 232         Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
8347           "Lost precision when incrementing %" NVff " by 1",
8348           was);
8349           }
8350 1104 50       (void)SvNOK_only(sv);
8351 1104         SvNV_set(sv, was + 1.0);
8352 1104         return;
8353           }
8354            
8355 12682234 100       if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
    100        
8356 12600906 100       if ((flags & SVTYPEMASK) < SVt_PVIV)
8357 12600214 100       sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
8358 12600906 50       (void)SvIOK_only(sv);
8359 12600906         SvIV_set(sv, 1);
8360 12600906         return;
8361           }
8362 81328         d = SvPVX(sv);
8363 148794 100       while (isALPHA(*d)) d++;
8364 162822 100       while (isDIGIT(*d)) d++;
8365 81328 100       if (d < SvEND(sv)) {
8366 1450         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
8367           #ifdef PERL_PRESERVE_IVUV
8368           /* Got to punt this as an integer if needs be, but we don't issue
8369           warnings. Probably ought to make the sv_iv_please() that does
8370           the conversion if possible, and silently. */
8371 1450 100       if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
    50        
8372           /* Need to try really hard to see if it's an integer.
8373           9.22337203685478e+18 is an integer.
8374           but "9.22337203685478e+18" + 0 is UV=9223372036854779904
8375           so $a="9.22337203685478e+18"; $a+0; $a++
8376           needs to be the same as $a="9.22337203685478e+18"; $a++
8377           or we go insane. */
8378          
8379 1434         (void) sv_2iv(sv);
8380 1434 100       if (SvIOK(sv))
8381           goto oops_its_int;
8382            
8383           /* sv_2iv *should* have made this an NV */
8384 672 50       if (flags & SVp_NOK) {
8385 0 0       (void)SvNOK_only(sv);
8386 0         SvNV_set(sv, SvNVX(sv) + 1.0);
8387 0         return;
8388           }
8389           /* I don't think we can get here. Maybe I should assert this
8390           And if we do get here I suspect that sv_setnv will croak. NWC
8391           Fall through. */
8392           #if defined(USE_LONG_DOUBLE)
8393           DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
8394           SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8395           #else
8396           DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
8397           SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8398           #endif
8399           }
8400           #endif /* PERL_PRESERVE_IVUV */
8401 688 100       if (!numtype && ckWARN(WARN_NUMERIC))
    100        
8402           not_incrementable(sv);
8403 688         sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
8404 688         return;
8405           }
8406 79878         d--;
8407 123891 100       while (d >= SvPVX_const(sv)) {
8408 83920 100       if (isDIGIT(*d)) {
8409 26504 100       if (++*d <= '9')
8410           return;
8411 2498         *(d--) = '0';
8412           }
8413           else {
8414           #ifdef EBCDIC
8415           /* MKS: The original code here died if letters weren't consecutive.
8416           * at least it didn't have to worry about non-C locales. The
8417           * new code assumes that ('z'-'a')==('Z'-'A'), letters are
8418           * arranged in order (although not consecutively) and that only
8419           * [A-Za-z] are accepted by isALPHA in the C locale.
8420           */
8421           if (*d != 'z' && *d != 'Z') {
8422           do { ++*d; } while (!isALPHA(*d));
8423           return;
8424           }
8425           *(d--) -= 'z' - 'a';
8426           #else
8427 57416         ++*d;
8428 57416 100       if (isALPHA(*d))
8429           return;
8430 2825         *(d--) -= 'z' - 'a' + 1;
8431           #endif
8432           }
8433           }
8434           /* oh,oh, the number grew */
8435 32 50       SvGROW(sv, SvCUR(sv) + 2);
    50        
8436 32         SvCUR_set(sv, SvCUR(sv) + 1);
8437 154 100       for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
8438 122         *d = d[-1];
8439 32 100       if (isDIGIT(d[1]))
8440 12         *d = '1';
8441           else
8442 8573255         *d = d[1];
8443           }
8444            
8445           /*
8446           =for apidoc sv_dec
8447            
8448           Auto-decrement of the value in the SV, doing string to numeric conversion
8449           if necessary. Handles 'get' magic and operator overloading.
8450            
8451           =cut
8452           */
8453            
8454           void
8455 30340         Perl_sv_dec(pTHX_ SV *const sv)
8456 30340 100       {
8457           dVAR;
8458 30340 50       if (!sv)
8459 30320         return;
8460 15216         SvGETMAGIC(sv);
8461 30340         sv_dec_nomg(sv);
8462           }
8463            
8464           /*
8465           =for apidoc sv_dec_nomg
8466            
8467           Auto-decrement of the value in the SV, doing string to numeric conversion
8468           if necessary. Handles operator overloading. Skips handling 'get' magic.
8469            
8470           =cut
8471           */
8472            
8473           void
8474 107516         Perl_sv_dec_nomg(pTHX_ SV *const sv)
8475           {
8476           dVAR;
8477           int flags;
8478            
8479 107516 50       if (!sv)
8480           return;
8481 107516 100       if (SvTHINKFIRST(sv)) {
8482 76456 50       if (SvREADONLY(sv)) {
8483 0         Perl_croak_no_modify();
8484           }
8485 76456 100       if (SvROK(sv)) {
8486           IV i;
8487 258 50       if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg))
    50        
    50        
    100        
8488           return;
8489 2         i = PTR2IV(SvRV(sv));
8490 2         sv_unref(sv);
8491 2         sv_setiv(sv, i);
8492           }
8493 76198         else sv_force_normal_flags(sv, 0);
8494           }
8495           /* Unlike sv_inc we don't have to worry about string-never-numbers
8496           and keeping them magic. But we mustn't warn on punting */
8497 107260         flags = SvFLAGS(sv);
8498 107260 100       if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
    50        
8499           /* It's publicly an integer, or privately an integer-not-float */
8500           #ifdef PERL_PRESERVE_IVUV
8501           oops_its_int:
8502           #endif
8503 104702 100       if (SvIsUV(sv)) {
8504 3264 50       if (SvUVX(sv) == 0) {
8505 0 0       (void)SvIOK_only(sv);
8506 0         SvIV_set(sv, -1);
8507           }
8508           else {
8509 3264 50       (void)SvIOK_only_UV(sv);
8510 3264         SvUV_set(sv, SvUVX(sv) - 1);
8511           }
8512           } else {
8513 101438 100       if (SvIVX(sv) == IV_MIN) {
8514 1364         sv_setnv(sv, (NV)IV_MIN);
8515 1364         goto oops_its_num;
8516           }
8517           else {
8518 100074 50       (void)SvIOK_only(sv);
8519 100074         SvIV_set(sv, SvIVX(sv) - 1);
8520           }
8521           }
8522           return;
8523           }
8524 4662 100       if (flags & SVp_NOK) {
8525           oops_its_num:
8526           {
8527 3206         const NV was = SvNVX(sv);
8528 3206 100       if (NV_OVERFLOWS_INTEGERS_AT &&
8529           was <= -NV_OVERFLOWS_INTEGERS_AT) {
8530           /* diag_listed_as: Lost precision when %s %f by 1 */
8531 2020         Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
8532           "Lost precision when decrementing %" NVff " by 1",
8533           was);
8534           }
8535 3206 50       (void)SvNOK_only(sv);
8536 3206         SvNV_set(sv, was - 1.0);
8537 3206         return;
8538           }
8539           }
8540 2820 100       if (!(flags & SVp_POK)) {
8541 30 100       if ((flags & SVTYPEMASK) < SVt_PVIV)
8542 22 100       sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
8543 30         SvIV_set(sv, -1);
8544 30 50       (void)SvIOK_only(sv);
8545 30         return;
8546           }
8547           #ifdef PERL_PRESERVE_IVUV
8548           {
8549 2790         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
8550 2790 100       if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
    50        
8551           /* Need to try really hard to see if it's an integer.
8552           9.22337203685478e+18 is an integer.
8553           but "9.22337203685478e+18" + 0 is UV=9223372036854779904
8554           so $a="9.22337203685478e+18"; $a+0; $a--
8555           needs to be the same as $a="9.22337203685478e+18"; $a--
8556           or we go insane. */
8557          
8558 2776         (void) sv_2iv(sv);
8559 2776 100       if (SvIOK(sv))
8560           goto oops_its_int;
8561            
8562           /* sv_2iv *should* have made this an NV */
8563 672 50       if (flags & SVp_NOK) {
8564 0 0       (void)SvNOK_only(sv);
8565 0         SvNV_set(sv, SvNVX(sv) - 1.0);
8566 0         return;
8567           }
8568           /* I don't think we can get here. Maybe I should assert this
8569           And if we do get here I suspect that sv_setnv will croak. NWC
8570           Fall through. */
8571           #if defined(USE_LONG_DOUBLE)
8572           DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
8573           SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8574           #else
8575           DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
8576           SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8577           #endif
8578           }
8579           }
8580           #endif /* PERL_PRESERVE_IVUV */
8581 54091         sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
8582           }
8583            
8584           /* this define is used to eliminate a chunk of duplicated but shared logic
8585           * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
8586           * used anywhere but here - yves
8587           */
8588           #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
8589           STMT_START { \
8590           EXTEND_MORTAL(1); \
8591           PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
8592           } STMT_END
8593            
8594           /*
8595           =for apidoc sv_mortalcopy
8596            
8597           Creates a new SV which is a copy of the original SV (using C).
8598           The new SV is marked as mortal. It will be destroyed "soon", either by an
8599           explicit call to FREETMPS, or by an implicit call at places such as
8600           statement boundaries. See also C and C.
8601            
8602           =cut
8603           */
8604            
8605           /* Make a string that will exist for the duration of the expression
8606           * evaluation. Actually, it may have to last longer than that, but
8607           * hopefully we won't free it until it has been assigned to a
8608           * permanent location. */
8609            
8610           SV *
8611 383562987         Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags)
8612           {
8613           dVAR;
8614           SV *sv;
8615            
8616 575134761 50       if (flags & SV_GMAGIC)
    100        
8617 191975916         SvGETMAGIC(oldstr); /* before new_SV, in case it dies */
8618 383562959 100       new_SV(sv);
8619 383562959         sv_setsv_flags(sv,oldstr,flags & ~SV_GMAGIC);
8620 383562959 100       PUSH_EXTEND_MORTAL__SV_C(sv);
8621 383562959         SvTEMP_on(sv);
8622 383562959         return sv;
8623           }
8624            
8625           /*
8626           =for apidoc sv_newmortal
8627            
8628           Creates a new null SV which is mortal. The reference count of the SV is
8629           set to 1. It will be destroyed "soon", either by an explicit call to
8630           FREETMPS, or by an implicit call at places such as statement boundaries.
8631           See also C and C.
8632            
8633           =cut
8634           */
8635            
8636           SV *
8637 657288811         Perl_sv_newmortal(pTHX)
8638           {
8639           dVAR;
8640           SV *sv;
8641            
8642 657288811 100       new_SV(sv);
8643 657288811         SvFLAGS(sv) = SVs_TEMP;
8644 657288811 100       PUSH_EXTEND_MORTAL__SV_C(sv);
8645 657288811         return sv;
8646           }
8647            
8648            
8649           /*
8650           =for apidoc newSVpvn_flags
8651            
8652           Creates a new SV and copies a string into it. The reference count for the
8653           SV is set to 1. Note that if C is zero, Perl will create a zero length
8654           string. You are responsible for ensuring that the source string is at least
8655           C bytes long. If the C argument is NULL the new SV will be undefined.
8656           Currently the only flag bits accepted are C and C.
8657           If C is set, then C is called on the result before
8658           returning. If C is set, C
8659           is considered to be in UTF-8 and the
8660           C flag will be set on the new SV.
8661           C is a convenience wrapper for this function, defined as
8662            
8663           #define newSVpvn_utf8(s, len, u) \
8664           newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
8665            
8666           =cut
8667           */
8668            
8669           SV *
8670 216553523         Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
8671           {
8672           dVAR;
8673           SV *sv;
8674            
8675           /* All the flags we don't support must be zero.
8676           And we're new code so I'm going to assert this from the start. */
8677           assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
8678 216553523 100       new_SV(sv);
8679 216553523         sv_setpvn(sv,s,len);
8680            
8681           /* This code used to do a sv_2mortal(), however we now unroll the call to
8682           * sv_2mortal() and do what it does ourselves here. Since we have asserted
8683           * that flags can only have the SVf_UTF8 and/or SVs_TEMP flags set above we
8684           * can use it to enable the sv flags directly (bypassing SvTEMP_on), which
8685           * in turn means we dont need to mask out the SVf_UTF8 flag below, which
8686           * means that we eliminate quite a few steps than it looks - Yves
8687           * (explaining patch by gfx) */
8688            
8689 216553523         SvFLAGS(sv) |= flags;
8690            
8691 216553523 100       if(flags & SVs_TEMP){
8692 84595689 100       PUSH_EXTEND_MORTAL__SV_C(sv);
8693           }
8694            
8695 216553523         return sv;
8696           }
8697            
8698           /*
8699           =for apidoc sv_2mortal
8700            
8701           Marks an existing SV as mortal. The SV will be destroyed "soon", either
8702           by an explicit call to FREETMPS, or by an implicit call at places such as
8703           statement boundaries. SvTEMP() is turned on which means that the SV's
8704           string buffer can be "stolen" if this SV is copied. See also C
8705           and C.
8706            
8707           =cut
8708           */
8709            
8710           SV *
8711 456497214         Perl_sv_2mortal(pTHX_ SV *const sv)
8712           {
8713           dVAR;
8714 456497214 100       if (!sv)
8715           return NULL;
8716 456484722 100       if (SvIMMORTAL(sv))
    100        
    100        
    100        
    100        
8717           return sv;
8718 439612180 100       PUSH_EXTEND_MORTAL__SV_C(sv);
8719 439612180         SvTEMP_on(sv);
8720 448055926         return sv;
8721           }
8722            
8723           /*
8724           =for apidoc newSVpv
8725            
8726           Creates a new SV and copies a string into it. The reference count for the
8727           SV is set to 1. If C is zero, Perl will compute the length using
8728           strlen(). For efficiency, consider using C instead.
8729            
8730           =cut
8731           */
8732            
8733           SV *
8734 97702044         Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
8735           {
8736           dVAR;
8737           SV *sv;
8738            
8739 97702044 100       new_SV(sv);
8740 97702044 100       sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
8741 97702044         return sv;
8742           }
8743            
8744           /*
8745           =for apidoc newSVpvn
8746            
8747           Creates a new SV and copies a buffer into it, which may contain NUL characters
8748           (C<\0>) and other binary data. The reference count for the SV is set to 1.
8749           Note that if C is zero, Perl will create a zero length (Perl) string. You
8750           are responsible for ensuring that the source buffer is at least
8751           C bytes long. If the C argument is NULL the new SV will be
8752           undefined.
8753            
8754           =cut
8755           */
8756            
8757           SV *
8758 53663752         Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len)
8759           {
8760           dVAR;
8761           SV *sv;
8762            
8763 53663752 100       new_SV(sv);
8764 53663752         sv_setpvn(sv,buffer,len);
8765 53663752         return sv;
8766           }
8767            
8768           /*
8769           =for apidoc newSVhek
8770            
8771           Creates a new SV from the hash key structure. It will generate scalars that
8772           point to the shared string table where possible. Returns a new (undefined)
8773           SV if the hek is NULL.
8774            
8775           =cut
8776           */
8777            
8778           SV *
8779 111975385         Perl_newSVhek(pTHX_ const HEK *const hek)
8780           {
8781           dVAR;
8782 111975385 100       if (!hek) {
8783           SV *sv;
8784            
8785 4 50       new_SV(sv);
8786 4         return sv;
8787           }
8788            
8789 111975381 100       if (HEK_LEN(hek) == HEf_SVKEY) {
8790 2015198         return newSVsv(*(SV**)HEK_KEY(hek));
8791           } else {
8792 109960183         const int flags = HEK_FLAGS(hek);
8793 109960183 100       if (flags & HVhek_WASUTF8) {
8794           /* Trouble :-)
8795           Andreas would like keys he put in as utf8 to come back as utf8
8796           */
8797 7930         STRLEN utf8_len = HEK_LEN(hek);
8798 7930         SV * const sv = newSV_type(SVt_PV);
8799 7930         char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
8800           /* bytes_to_utf8() allocates a new string, which we can repurpose: */
8801 7930         sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
8802 7930         SvUTF8_on (sv);
8803 7930         return sv;
8804 109952253 50       } else if (flags & HVhek_UNSHARED) {
8805           /* A hash that isn't using shared hash keys has to have
8806           the flag in every key so that we know not to try to call
8807           share_hek_hek on it. */
8808            
8809 0         SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
8810 0 0       if (HEK_UTF8(hek))
8811 0         SvUTF8_on (sv);
8812           return sv;
8813           }
8814           /* This will be overwhelminly the most common case. */
8815           {
8816           /* Inline most of newSVpvn_share(), because share_hek_hek() is far
8817           more efficient than sharepvn(). */
8818           SV *sv;
8819            
8820 109952253 100       new_SV(sv);
8821 109952253         sv_upgrade(sv, SVt_PV);
8822 109952253         SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
8823 109952253         SvCUR_set(sv, HEK_LEN(hek));
8824 109952253         SvLEN_set(sv, 0);
8825 109952253         SvIsCOW_on(sv);
8826 109952253         SvPOK_on(sv);
8827 109952253 100       if (HEK_UTF8(hek))
8828 56355391         SvUTF8_on(sv);
8829           return sv;
8830           }
8831           }
8832           }
8833            
8834           /*
8835           =for apidoc newSVpvn_share
8836            
8837           Creates a new SV with its SvPVX_const pointing to a shared string in the string
8838           table. If the string does not already exist in the table, it is
8839           created first. Turns on the SvIsCOW flag (or READONLY
8840           and FAKE in 5.16 and earlier). If the C parameter
8841           is non-zero, that value is used; otherwise the hash is computed.
8842           The string's hash can later be retrieved from the SV
8843           with the C macro. The idea here is
8844           that as the string table is used for shared hash keys these strings will have
8845           SvPVX_const == HeKEY and hash lookup will avoid string compare.
8846            
8847           =cut
8848           */
8849            
8850           SV *
8851 31889316         Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
8852           {
8853           dVAR;
8854           SV *sv;
8855 31889316         bool is_utf8 = FALSE;
8856           const char *const orig_src = src;
8857            
8858 31889316 100       if (len < 0) {
8859 472         STRLEN tmplen = -len;
8860 472         is_utf8 = TRUE;
8861           /* See the note in hv.c:hv_fetch() --jhi */
8862 472         src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
8863 472         len = tmplen;
8864           }
8865 31889316 100       if (!hash)
8866 31889314         PERL_HASH(hash, src, len);
8867 31889316 100       new_SV(sv);
8868           /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
8869           changes here, update it there too. */
8870 31889316         sv_upgrade(sv, SVt_PV);
8871 31889316 100       SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
8872 31889316         SvCUR_set(sv, len);
8873 31889316         SvLEN_set(sv, 0);
8874 31889316         SvIsCOW_on(sv);
8875 31889316         SvPOK_on(sv);
8876 31889316 100       if (is_utf8)
8877 432         SvUTF8_on(sv);
8878 31889316 100       if (src != orig_src)
8879 40         Safefree(src);
8880 31889316         return sv;
8881           }
8882            
8883           /*
8884           =for apidoc newSVpv_share
8885            
8886           Like C, but takes a nul-terminated string instead of a
8887           string/length pair.
8888            
8889           =cut
8890           */
8891            
8892           SV *
8893 16349         Perl_newSVpv_share(pTHX_ const char *src, U32 hash)
8894           {
8895 16349         return newSVpvn_share(src, strlen(src), hash);
8896           }
8897            
8898           #if defined(PERL_IMPLICIT_CONTEXT)
8899            
8900           /* pTHX_ magic can't cope with varargs, so this is a no-context
8901           * version of the main function, (which may itself be aliased to us).
8902           * Don't access this version directly.
8903           */
8904            
8905           SV *
8906           Perl_newSVpvf_nocontext(const char *const pat, ...)
8907           {
8908           dTHX;
8909           SV *sv;
8910           va_list args;
8911            
8912           PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
8913            
8914           va_start(args, pat);
8915           sv = vnewSVpvf(pat, &args);
8916           va_end(args);
8917           return sv;
8918           }
8919           #endif
8920            
8921           /*
8922           =for apidoc newSVpvf
8923            
8924           Creates a new SV and initializes it with the string formatted like
8925           C.
8926            
8927           =cut
8928           */
8929            
8930           SV *
8931 119492         Perl_newSVpvf(pTHX_ const char *const pat, ...)
8932           {
8933           SV *sv;
8934           va_list args;
8935            
8936           PERL_ARGS_ASSERT_NEWSVPVF;
8937            
8938 119492         va_start(args, pat);
8939 119492         sv = vnewSVpvf(pat, &args);
8940 119492         va_end(args);
8941 119492         return sv;
8942           }
8943            
8944           /* backend for newSVpvf() and newSVpvf_nocontext() */
8945            
8946           SV *
8947 235502         Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
8948           {
8949           dVAR;
8950           SV *sv;
8951            
8952           PERL_ARGS_ASSERT_VNEWSVPVF;
8953            
8954 235502 100       new_SV(sv);
8955 235502         sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8956 235502         return sv;
8957           }
8958            
8959           /*
8960           =for apidoc newSVnv
8961            
8962           Creates a new SV and copies a floating point value into it.
8963           The reference count for the SV is set to 1.
8964            
8965           =cut
8966           */
8967            
8968           SV *
8969 972583         Perl_newSVnv(pTHX_ const NV n)
8970           {
8971           dVAR;
8972           SV *sv;
8973            
8974 972583 100       new_SV(sv);
8975 972583         sv_setnv(sv,n);
8976 972583         return sv;
8977           }
8978            
8979           /*
8980           =for apidoc newSViv
8981            
8982           Creates a new SV and copies an integer into it. The reference count for the
8983           SV is set to 1.
8984            
8985           =cut
8986           */
8987            
8988           SV *
8989 584303381         Perl_newSViv(pTHX_ const IV i)
8990           {
8991           dVAR;
8992           SV *sv;
8993            
8994 584303381 100       new_SV(sv);
8995 584303381         sv_setiv(sv,i);
8996 584303381         return sv;
8997           }
8998            
8999           /*
9000           =for apidoc newSVuv
9001            
9002           Creates a new SV and copies an unsigned integer into it.
9003           The reference count for the SV is set to 1.
9004            
9005           =cut
9006           */
9007            
9008           SV *
9009 64244900         Perl_newSVuv(pTHX_ const UV u)
9010           {
9011           dVAR;
9012           SV *sv;
9013            
9014 64244900 100       new_SV(sv);
9015 64244900         sv_setuv(sv,u);
9016 64244900         return sv;
9017           }
9018            
9019           /*
9020           =for apidoc newSV_type
9021            
9022           Creates a new SV, of the type specified. The reference count for the new SV
9023           is set to 1.
9024            
9025           =cut
9026           */
9027            
9028           SV *
9029 565702697         Perl_newSV_type(pTHX_ const svtype type)
9030           {
9031           SV *sv;
9032            
9033 565702697 100       new_SV(sv);
9034 565702697         sv_upgrade(sv, type);
9035 565702697         return sv;
9036           }
9037            
9038           /*
9039           =for apidoc newRV_noinc
9040            
9041           Creates an RV wrapper for an SV. The reference count for the original
9042           SV is B incremented.
9043            
9044           =cut
9045           */
9046            
9047           SV *
9048 99043456         Perl_newRV_noinc(pTHX_ SV *const tmpRef)
9049           {
9050           dVAR;
9051 99043456         SV *sv = newSV_type(SVt_IV);
9052            
9053           PERL_ARGS_ASSERT_NEWRV_NOINC;
9054            
9055 99043456         SvTEMP_off(tmpRef);
9056 99043456         SvRV_set(sv, tmpRef);
9057 99043456         SvROK_on(sv);
9058 99043456         return sv;
9059           }
9060            
9061           /* newRV_inc is the official function name to use now.
9062           * newRV_inc is in fact #defined to newRV in sv.h
9063           */
9064            
9065           SV *
9066 69595667         Perl_newRV(pTHX_ SV *const sv)
9067           {
9068           dVAR;
9069            
9070           PERL_ARGS_ASSERT_NEWRV;
9071            
9072 69595667         return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
9073           }
9074            
9075           /*
9076           =for apidoc newSVsv
9077            
9078           Creates a new SV which is an exact duplicate of the original SV.
9079           (Uses C.)
9080            
9081           =cut
9082           */
9083            
9084           SV *
9085 48349991         Perl_newSVsv(pTHX_ SV *const old)
9086 48349991 100       {
9087           dVAR;
9088           SV *sv;
9089            
9090 48349991 50       if (!old)
9091           return NULL;
9092 48349991 50       if (SvTYPE(old) == (svtype)SVTYPEMASK) {
9093 0         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
9094 0         return NULL;
9095           }
9096           /* Do this here, otherwise we leak the new SV if this croaks. */
9097 24025090         SvGETMAGIC(old);
9098 48349987 100       new_SV(sv);
9099           /* SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
9100           with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
9101 48349987         sv_setsv_flags(sv, old, SV_NOSTEAL);
9102 48349987         return sv;
9103           }
9104            
9105           /*
9106           =for apidoc sv_reset
9107            
9108           Underlying implementation for the C Perl function.
9109           Note that the perl-level function is vaguely deprecated.
9110            
9111           =cut
9112           */
9113            
9114           void
9115 0         Perl_sv_reset(pTHX_ const char *s, HV *const stash)
9116           {
9117           PERL_ARGS_ASSERT_SV_RESET;
9118            
9119 0 0       sv_resetpvn(*s ? s : NULL, strlen(s), stash);
9120 0         }
9121            
9122           void
9123 58         Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash)
9124           {
9125           dVAR;
9126           char todo[PERL_UCHAR_MAX+1];
9127           const char *send;
9128            
9129 58 50       if (!stash || SvTYPE(stash) != SVt_PVHV)
    100        
9130           return;
9131            
9132 56 100       if (!s) { /* reset ?? searches */
9133 24         MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
9134 24 100       if (mg) {
9135 12         const U32 count = mg->mg_len / sizeof(PMOP**);
9136 12         PMOP **pmp = (PMOP**) mg->mg_ptr;
9137 12         PMOP *const *const end = pmp + count;
9138            
9139 30 100       while (pmp < end) {
9140           #ifdef USE_ITHREADS
9141           SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
9142           #else
9143 12         (*pmp)->op_pmflags &= ~PMf_USED;
9144           #endif
9145 12         ++pmp;
9146           }
9147           }
9148           return;
9149           }
9150            
9151           /* reset variables */
9152            
9153 32 50       if (!HvARRAY(stash))
9154           return;
9155            
9156           Zero(todo, 256, char);
9157 32         send = s + len;
9158 99 100       while (s < send) {
9159           I32 max;
9160 38         I32 i = (unsigned char)*s;
9161 38 100       if (s[1] == '-') {
9162 2         s += 2;
9163           }
9164 38         max = (unsigned char)*s++;
9165 78 100       for ( ; i <= max; i++) {
9166 40         todo[i] = 1;
9167           }
9168 3555 100       for (i = 0; i <= (I32) HvMAX(stash); i++) {
9169           HE *entry;
9170 7366 100       for (entry = HvARRAY(stash)[i];
9171           entry;
9172 2062         entry = HeNEXT(entry))
9173           {
9174           GV *gv;
9175           SV *sv;
9176            
9177 2062 100       if (!todo[(U8)*HeKEY(entry)])
9178 1934         continue;
9179 128         gv = MUTABLE_GV(HeVAL(entry));
9180 128         sv = GvSV(gv);
9181 128 100       if (sv && !SvREADONLY(sv)) {
    100        
9182 90 100       SV_CHECK_THINKFIRST_COW_DROP(sv);
9183 90 100       if (!isGV(sv)) SvOK_off(sv);
    50        
9184           }
9185 128 100       if (GvAV(gv)) {
9186 26         av_clear(GvAV(gv));
9187           }
9188 128 100       if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
    100        
    50        
    50        
    0        
    50        
    50        
    50        
9189 24         hv_clear(GvHV(gv));
9190           }
9191           }
9192           }
9193           }
9194           }
9195            
9196           /*
9197           =for apidoc sv_2io
9198            
9199           Using various gambits, try to get an IO from an SV: the IO slot if its a
9200           GV; or the recursive result if we're an RV; or the IO slot of the symbol
9201           named after the PV if we're a string.
9202            
9203           'Get' magic is ignored on the sv passed in, but will be called on
9204           C if sv is an RV.
9205            
9206           =cut
9207           */
9208            
9209           IO*
9210 3072535         Perl_sv_2io(pTHX_ SV *const sv)
9211           {
9212           IO* io;
9213           GV* gv;
9214            
9215           PERL_ARGS_ASSERT_SV_2IO;
9216            
9217 3818624         switch (SvTYPE(sv)) {
9218           case SVt_PVIO:
9219           io = MUTABLE_IO(sv);
9220           break;
9221           case SVt_PVGV:
9222           case SVt_PVLV:
9223 3070005 50       if (isGV_with_GP(sv)) {
    50        
9224           gv = MUTABLE_GV(sv);
9225 3070005 50       io = GvIO(gv);
    50        
    50        
9226 3070005 100       if (!io)
9227 6         Perl_croak(aTHX_ "Bad filehandle: %"HEKf,
9228 6         HEKfARG(GvNAME_HEK(gv)));
9229           break;
9230           }
9231           /* FALL THROUGH */
9232           default:
9233 748619 50       if (!SvOK(sv))
    0        
    0        
9234 0         Perl_croak(aTHX_ PL_no_usym, "filehandle");
9235 1121484 100       if (SvROK(sv)) {
    50        
9236 372865         SvGETMAGIC(SvRV(sv));
9237 746089         return sv_2io(SvRV(sv));
9238           }
9239 2530         gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
9240 2530 100       if (gv)
9241 2526 50       io = GvIO(gv);
    50        
    50        
9242           else
9243           io = 0;
9244 2530 100       if (!io) {
9245           SV *newsv = sv;
9246 4 50       if (SvGMAGICAL(sv)) {
9247 0         newsv = sv_newmortal();
9248 0         sv_setsv_nomg(newsv, sv);
9249           }
9250 1536805         Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(newsv));
9251           }
9252           break;
9253           }
9254           return io;
9255           }
9256            
9257           /*
9258           =for apidoc sv_2cv
9259            
9260           Using various gambits, try to get a CV from an SV; in addition, try if
9261           possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
9262           The flags in C are passed to gv_fetchsv.
9263            
9264           =cut
9265           */
9266            
9267           CV *
9268 5248032         Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
9269           {
9270           dVAR;
9271           GV *gv = NULL;
9272           CV *cv = NULL;
9273            
9274           PERL_ARGS_ASSERT_SV_2CV;
9275            
9276 5248032 50       if (!sv) {
9277 0         *st = NULL;
9278 0         *gvp = NULL;
9279 0         return NULL;
9280           }
9281 7847896 100       switch (SvTYPE(sv)) {
9282           case SVt_PVCV:
9283 82         *st = CvSTASH(sv);
9284 82         *gvp = NULL;
9285 82         return MUTABLE_CV(sv);
9286           case SVt_PVHV:
9287           case SVt_PVAV:
9288 0         *st = NULL;
9289 0         *gvp = NULL;
9290 0         return NULL;
9291           default:
9292 2708274         SvGETMAGIC(sv);
9293 5247950 100       if (SvROK(sv)) {
9294 207203 50       if (SvAMAGIC(sv))
    100        
    50        
9295 0         sv = amagic_deref_call(sv, to_cv_amg);
9296            
9297 207203         sv = SvRV(sv);
9298 207203 100       if (SvTYPE(sv) == SVt_PVCV) {
9299           cv = MUTABLE_CV(sv);
9300 207181         *gvp = NULL;
9301 207181         *st = CvSTASH(cv);
9302 207181         return cv;
9303           }
9304 22 50       else if(SvGETMAGIC(sv), isGV_with_GP(sv))
    100        
    50        
    100        
9305           gv = MUTABLE_GV(sv);
9306           else
9307 14         Perl_croak(aTHX_ "Not a subroutine reference");
9308           }
9309 5040747 100       else if (isGV_with_GP(sv)) {
    50        
9310           gv = MUTABLE_GV(sv);
9311           }
9312           else {
9313 3088499         gv = gv_fetchsv_nomg(sv, lref, SVt_PVCV);
9314           }
9315 5040755         *gvp = gv;
9316 5040755 100       if (!gv) {
9317 589198         *st = NULL;
9318 589198         return NULL;
9319           }
9320           /* Some flags to gv_fetchsv mean don't really create the GV */
9321 4451557 100       if (!isGV_with_GP(gv)) {
    100        
9322 683758         *st = NULL;
9323 683758         return NULL;
9324           }
9325 3767799 100       *st = GvESTASH(gv);
9326 3767799 100       if (lref & ~GV_ADDMG && !GvCVu(gv)) {
    100        
    100        
9327           /* XXX this is probably not what they think they're getting.
9328           * It has the same effect as "sub name;", i.e. just a forward
9329           * declaration! */
9330 38080         newSTUB(gv,0);
9331           }
9332 4512225 100       return GvCVu(gv);
9333           }
9334           }
9335            
9336           /*
9337           =for apidoc sv_true
9338            
9339           Returns true if the SV has a true value by Perl's rules.
9340           Use the C macro instead, which may call C or may
9341           instead use an in-line version.
9342            
9343           =cut
9344           */
9345            
9346           I32
9347 0         Perl_sv_true(pTHX_ SV *const sv)
9348           {
9349 0 0       if (!sv)
9350           return 0;
9351 0 0       if (SvPOK(sv)) {
9352 0         const XPV* const tXpv = (XPV*)SvANY(sv);
9353 0 0       if (tXpv &&
    0        
9354 0 0       (tXpv->xpv_cur > 1 ||
9355 0 0       (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
9356           return 1;
9357           else
9358 0         return 0;
9359           }
9360           else {
9361 0 0       if (SvIOK(sv))
9362 0         return SvIVX(sv) != 0;
9363           else {
9364 0 0       if (SvNOK(sv))
9365 0         return SvNVX(sv) != 0.0;
9366           else
9367 0         return sv_2bool(sv);
9368           }
9369           }
9370           }
9371            
9372           /*
9373           =for apidoc sv_pvn_force
9374            
9375           Get a sensible string out of the SV somehow.
9376           A private implementation of the C macro for compilers which
9377           can't cope with complex macro expressions. Always use the macro instead.
9378            
9379           =for apidoc sv_pvn_force_flags
9380            
9381           Get a sensible string out of the SV somehow.
9382           If C has C bit set, will C on C if
9383           appropriate, else not. C and C are
9384           implemented in terms of this function.
9385           You normally want to use the various wrapper macros instead: see
9386           C and C
9387            
9388           =cut
9389           */
9390            
9391           char *
9392 12775742         Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
9393           {
9394           dVAR;
9395            
9396           PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
9397            
9398 12775742 100       if (flags & SV_GMAGIC) SvGETMAGIC(sv);
    100        
9399 12775742 100       if (SvTHINKFIRST(sv) && (!SvROK(sv) || SvREADONLY(sv)))
    100        
9400 12369752         sv_force_normal_flags(sv, 0);
9401            
9402 12775738 100       if (SvPOK(sv)) {
9403 12400810 100       if (lp)
9404 9181017         *lp = SvCUR(sv);
9405           }
9406           else {
9407           char *s;
9408           STRLEN len;
9409          
9410 374928 50       if (SvTYPE(sv) > SVt_PVLV
9411 374928 100       || isGV_with_GP(sv))
    50        
9412           /* diag_listed_as: Can't coerce %s to %s in %s */
9413 3 50       Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
9414 1 0       OP_DESC(PL_op));
9415 374926         s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC);
9416 374926 100       if (!s) {
9417           s = (char *)"";
9418           }
9419 374926 100       if (lp)
9420 357640         *lp = len;
9421            
9422 725668 100       if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
    100        
9423 350742 100       if (SvROK(sv))
9424 350606         sv_unref(sv);
9425 187891         SvUPGRADE(sv, SVt_PV); /* Never FALSE */
9426 350742 50       SvGROW(sv, len + 1);
    100        
9427 350742         Move(s,SvPVX(sv),len,char);
9428 350742         SvCUR_set(sv, len);
9429 350742         SvPVX(sv)[len] = '\0';
9430           }
9431 374926 100       if (!SvPOK(sv)) {
9432 359108         SvPOK_on(sv); /* validate pointer */
9433 359108 50       SvTAINT(sv);
    0        
    0        
9434           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
9435           PTR2UV(sv),SvPVX_const(sv)));
9436           }
9437           }
9438 12775736         (void)SvPOK_only_UTF8(sv);
9439 12775736         return SvPVX_mutable(sv);
9440           }
9441            
9442           /*
9443           =for apidoc sv_pvbyten_force
9444            
9445           The backend for the C macro. Always use the macro
9446           instead.
9447            
9448           =cut
9449           */
9450            
9451           char *
9452 2174         Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
9453           {
9454           PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
9455            
9456 2174         sv_pvn_force(sv,lp);
9457 2174         sv_utf8_downgrade(sv,0);
9458 2172         *lp = SvCUR(sv);
9459 2172         return SvPVX(sv);
9460           }
9461            
9462           /*
9463           =for apidoc sv_pvutf8n_force
9464            
9465           The backend for the C macro. Always use the macro
9466           instead.
9467            
9468           =cut
9469           */
9470            
9471           char *
9472 782         Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
9473           {
9474           PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
9475            
9476 782         sv_pvn_force(sv,0);
9477 782         sv_utf8_upgrade_nomg(sv);
9478 782         *lp = SvCUR(sv);
9479 782         return SvPVX(sv);
9480           }
9481            
9482           /*
9483           =for apidoc sv_reftype
9484            
9485           Returns a string describing what the SV is a reference to.
9486            
9487           =cut
9488           */
9489            
9490           const char *
9491 17740459         Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
9492           {
9493           PERL_ARGS_ASSERT_SV_REFTYPE;
9494 17740459 100       if (ob && SvOBJECT(sv)) {
    50        
9495 13514 50       return SvPV_nolen_const(sv_ref(NULL, sv, ob));
9496           }
9497           else {
9498 17726945         switch (SvTYPE(sv)) {
9499           case SVt_NULL:
9500           case SVt_IV:
9501           case SVt_NV:
9502           case SVt_PV:
9503           case SVt_PVIV:
9504           case SVt_PVNV:
9505           case SVt_PVMG:
9506 13601559 100       if (SvVOK(sv))
    100        
9507           return "VSTRING";
9508 13601511 100       if (SvROK(sv))
9509           return "REF";
9510           else
9511 13566361         return "SCALAR";
9512            
9513 180 100       case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
    100        
9514           /* tied lvalues should appear to be
9515           * scalars for backwards compatibility */
9516 96         : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
9517           ? "SCALAR" : "LVALUE");
9518           case SVt_PVAV: return "ARRAY";
9519 1099230         case SVt_PVHV: return "HASH";
9520 302000         case SVt_PVCV: return "CODE";
9521 503294 50       case SVt_PVGV: return (char *) (isGV_with_GP(sv)
    50        
9522           ? "GLOB" : "SCALAR");
9523 34         case SVt_PVFM: return "FORMAT";
9524 48         case SVt_PVIO: return "IO";
9525 0         case SVt_INVLIST: return "INVLIST";
9526 86         case SVt_REGEXP: return "REGEXP";
9527 8876707         default: return "UNKNOWN";
9528           }
9529           }
9530           }
9531            
9532           /*
9533           =for apidoc sv_ref
9534            
9535           Returns a SV describing what the SV passed in is a reference to.
9536            
9537           =cut
9538           */
9539            
9540           SV *
9541 257341116         Perl_sv_ref(pTHX_ SV *dst, const SV *const sv, const int ob)
9542           {
9543           PERL_ARGS_ASSERT_SV_REF;
9544            
9545 257341116 100       if (!dst)
9546 27028         dst = sv_newmortal();
9547            
9548 257341116 50       if (ob && SvOBJECT(sv)) {
    100        
9549 508238186 50       HvNAME_get(SvSTASH(sv))
    100        
    50        
    100        
9550 254119086 50       ? sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)))
    50        
    50        
    100        
9551 508238184 50       : sv_setpvn(dst, "__ANON__", 8);
    100        
9552           }
9553           else {
9554 3222026         const char * reftype = sv_reftype(sv, 0);
9555 3222026         sv_setpv(dst, reftype);
9556           }
9557 257341116         return dst;
9558           }
9559            
9560           /*
9561           =for apidoc sv_isobject
9562            
9563           Returns a boolean indicating whether the SV is an RV pointing to a blessed
9564           object. If the SV is not an RV, or if the object is not blessed, then this
9565           will return false.
9566            
9567           =cut
9568           */
9569            
9570           int
9571 1103458         Perl_sv_isobject(pTHX_ SV *sv)
9572 1103458 100       {
9573 1103458 50       if (!sv)
9574           return 0;
9575 541312         SvGETMAGIC(sv);
9576 1103458 100       if (!SvROK(sv))
9577           return 0;
9578 289750         sv = SvRV(sv);
9579 289750 100       if (!SvOBJECT(sv))
9580           return 0;
9581 702536         return 1;
9582           }
9583            
9584           /*
9585           =for apidoc sv_isa
9586            
9587           Returns a boolean indicating whether the SV is blessed into the specified
9588           class. This does not check for subtypes; use C to verify
9589           an inheritance relationship.
9590            
9591           =cut
9592           */
9593            
9594           int
9595 132         Perl_sv_isa(pTHX_ SV *sv, const char *const name)
9596 132 50       {
9597           const char *hvname;
9598            
9599           PERL_ARGS_ASSERT_SV_ISA;
9600            
9601 132 50       if (!sv)
9602           return 0;
9603 66         SvGETMAGIC(sv);
9604 132 100       if (!SvROK(sv))
9605           return 0;
9606 98         sv = SvRV(sv);
9607 98 50       if (!SvOBJECT(sv))
9608           return 0;
9609 98 50       hvname = HvNAME_get(SvSTASH(sv));
    50        
    50        
    0        
    50        
    50        
9610 98 50       if (!hvname)
9611           return 0;
9612            
9613 115         return strEQ(hvname, name);
9614           }
9615            
9616           /*
9617           =for apidoc newSVrv
9618            
9619           Creates a new SV for the existing RV, C, to point to. If C is not an
9620           RV then it will be upgraded to one. If C is non-null then the new
9621           SV will be blessed in the specified package. The new SV is returned and its
9622           reference count is 1. The reference count 1 is owned by C.
9623            
9624           =cut
9625           */
9626            
9627           SV*
9628 469101332         Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
9629           {
9630           dVAR;
9631           SV *sv;
9632            
9633           PERL_ARGS_ASSERT_NEWSVRV;
9634            
9635 469101332 100       new_SV(sv);
9636            
9637 469101332 100       SV_CHECK_THINKFIRST_COW_DROP(rv);
9638            
9639 469101332 100       if (SvTYPE(rv) >= SVt_PVMG) {
9640 832         const U32 refcnt = SvREFCNT(rv);
9641 832         SvREFCNT(rv) = 0;
9642 832         sv_clear(rv);
9643 832         SvFLAGS(rv) = 0;
9644 832         SvREFCNT(rv) = refcnt;
9645            
9646 832         sv_upgrade(rv, SVt_IV);
9647 469100500 50       } else if (SvROK(rv)) {
9648 0         SvREFCNT_dec(SvRV(rv));
9649           } else {
9650 469100500 100       prepare_SV_for_RV(rv);
    100        
    100        
    50        
    0        
    0        
9651           }
9652            
9653 469101332 50       SvOK_off(rv);
9654 469101332         SvRV_set(rv, sv);
9655 469101332         SvROK_on(rv);
9656            
9657 469101332 100       if (classname) {
9658 469101330         HV* const stash = gv_stashpv(classname, GV_ADD);
9659 469101330         (void)sv_bless(rv, stash);
9660           }
9661 469101332         return sv;
9662           }
9663            
9664           /*
9665           =for apidoc sv_setref_pv
9666            
9667           Copies a pointer into a new SV, optionally blessing the SV. The C
9668           argument will be upgraded to an RV. That RV will be modified to point to
9669           the new SV. If the C argument is NULL then C will be placed
9670           into the SV. The C argument indicates the package for the
9671           blessing. Set C to C to avoid the blessing. The new SV
9672           will have a reference count of 1, and the RV will be returned.
9673            
9674           Do not use with other Perl types such as HV, AV, SV, CV, because those
9675           objects will become corrupted by the pointer copy process.
9676            
9677           Note that C copies the string while this copies the pointer.
9678            
9679           =cut
9680           */
9681            
9682           SV*
9683 28768         Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
9684           {
9685           dVAR;
9686            
9687           PERL_ARGS_ASSERT_SV_SETREF_PV;
9688            
9689 28768 100       if (!pv) {
9690 18         sv_setsv(rv, &PL_sv_undef);
9691 18 50       SvSETMAGIC(rv);
9692           }
9693           else
9694 28750         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
9695 28768         return rv;
9696           }
9697            
9698           /*
9699           =for apidoc sv_setref_iv
9700            
9701           Copies an integer into a new SV, optionally blessing the SV. The C
9702           argument will be upgraded to an RV. That RV will be modified to point to
9703           the new SV. The C argument indicates the package for the
9704           blessing. Set C to C to avoid the blessing. The new SV
9705           will have a reference count of 1, and the RV will be returned.
9706            
9707           =cut
9708           */
9709            
9710           SV*
9711 0         Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
9712           {
9713           PERL_ARGS_ASSERT_SV_SETREF_IV;
9714            
9715 0         sv_setiv(newSVrv(rv,classname), iv);
9716 0         return rv;
9717           }
9718            
9719           /*
9720           =for apidoc sv_setref_uv
9721            
9722           Copies an unsigned integer into a new SV, optionally blessing the SV. The C
9723           argument will be upgraded to an RV. That RV will be modified to point to
9724           the new SV. The C argument indicates the package for the
9725           blessing. Set C to C to avoid the blessing. The new SV
9726           will have a reference count of 1, and the RV will be returned.
9727            
9728           =cut
9729           */
9730            
9731           SV*
9732 0         Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
9733           {
9734           PERL_ARGS_ASSERT_SV_SETREF_UV;
9735            
9736 0         sv_setuv(newSVrv(rv,classname), uv);
9737 0         return rv;
9738           }
9739            
9740           /*
9741           =for apidoc sv_setref_nv
9742            
9743           Copies a double into a new SV, optionally blessing the SV. The C
9744           argument will be upgraded to an RV. That RV will be modified to point to
9745           the new SV. The C argument indicates the package for the
9746           blessing. Set C to C to avoid the blessing. The new SV
9747           will have a reference count of 1, and the RV will be returned.
9748            
9749           =cut
9750           */
9751            
9752           SV*
9753 0         Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
9754           {
9755           PERL_ARGS_ASSERT_SV_SETREF_NV;
9756            
9757 0         sv_setnv(newSVrv(rv,classname), nv);
9758 0         return rv;
9759           }
9760            
9761           /*
9762           =for apidoc sv_setref_pvn
9763            
9764           Copies a string into a new SV, optionally blessing the SV. The length of the
9765           string must be specified with C. The C argument will be upgraded to
9766           an RV. That RV will be modified to point to the new SV. The C
9767           argument indicates the package for the blessing. Set C to
9768           C to avoid the blessing. The new SV will have a reference count
9769           of 1, and the RV will be returned.
9770            
9771           Note that C copies the pointer while this copies the string.
9772            
9773           =cut
9774           */
9775            
9776           SV*
9777 0         Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
9778           const char *const pv, const STRLEN n)
9779           {
9780           PERL_ARGS_ASSERT_SV_SETREF_PVN;
9781            
9782 0         sv_setpvn(newSVrv(rv,classname), pv, n);
9783 0         return rv;
9784           }
9785            
9786           /*
9787           =for apidoc sv_bless
9788            
9789           Blesses an SV into a specified package. The SV must be an RV. The package
9790           must be designated by its stash (see C). The reference count
9791           of the SV is unaffected.
9792            
9793           =cut
9794           */
9795            
9796           SV*
9797 479452858         Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
9798 958905712 100       {
    100        
9799           dVAR;
9800           SV *tmpRef;
9801            
9802           PERL_ARGS_ASSERT_SV_BLESS;
9803            
9804 239697997         SvGETMAGIC(sv);
9805 479452858 100       if (!SvROK(sv))
9806 2         Perl_croak(aTHX_ "Can't bless non-reference value");
9807 479452856         tmpRef = SvRV(sv);
9808 479452856 100       if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
9809 27162 100       if (SvREADONLY(tmpRef))
9810 2         Perl_croak_no_modify();
9811 27160 50       if (SvOBJECT(tmpRef)) {
9812 27160         SvREFCNT_dec(SvSTASH(tmpRef));
9813           }
9814           }
9815 479452854         SvOBJECT_on(tmpRef);
9816 710334900         SvUPGRADE(tmpRef, SVt_PVMG);
9817 958905708         SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
9818            
9819 479452854 100       if(SvSMAGICAL(tmpRef))
9820 26 50       if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
    100        
9821 8         mg_set(tmpRef);
9822            
9823            
9824            
9825 479452854         return sv;
9826           }
9827            
9828           /* Downgrades a PVGV to a PVMG. If it's actually a PVLV, we leave the type
9829           * as it is after unglobbing it.
9830           */
9831            
9832           PERL_STATIC_INLINE void
9833           S_sv_unglob(pTHX_ SV *const sv, U32 flags)
9834           {
9835           dVAR;
9836           void *xpvmg;
9837           HV *stash;
9838 27082808 100       SV * const temp = flags & SV_COW_DROP_PV ? NULL : sv_newmortal();
9839            
9840           PERL_ARGS_ASSERT_SV_UNGLOB;
9841            
9842           assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
9843 27082808         SvFAKE_off(sv);
9844 27082808 100       if (!(flags & SV_COW_DROP_PV))
9845 88         gv_efullname3(temp, MUTABLE_GV(sv), "*");
9846            
9847 27082808 50       if (GvGP(sv)) {
9848 27082808 50       if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
    100        
    100        
9849 19297452 50       && HvNAME_get(stash))
    50        
    100        
    50        
    100        
    50        
9850 19297452         mro_method_changed_in(stash);
9851 27082808         gp_free(MUTABLE_GV(sv));
9852           }
9853 27082808 100       if (GvSTASH(sv)) {
9854 27082774         sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
9855 27082774         GvSTASH(sv) = NULL;
9856           }
9857 27082808         GvMULTI_off(sv);
9858 27082808 50       if (GvNAME_HEK(sv)) {
9859 27082808         unshare_hek(GvNAME_HEK(sv));
9860           }
9861 27082808         isGV_with_GP_off(sv);
9862            
9863 27082808 100       if(SvTYPE(sv) == SVt_PVGV) {
9864           /* need to keep SvANY(sv) in the right arena */
9865 27082694         xpvmg = new_XPVMG();
9866 27082694         StructCopy(SvANY(sv), xpvmg, XPVMG);
9867 27082694         del_XPVGV(SvANY(sv));
9868 27082694         SvANY(sv) = xpvmg;
9869            
9870 27082694         SvFLAGS(sv) &= ~SVTYPEMASK;
9871 27082694         SvFLAGS(sv) |= SVt_PVMG;
9872           }
9873            
9874           /* Intentionally not calling any local SET magic, as this isn't so much a
9875           set operation as merely an internal storage change. */
9876 27082808 100       if (flags & SV_COW_DROP_PV) SvOK_off(sv);
    50        
9877 88         else sv_setsv_flags(sv, temp, 0);
9878            
9879 27082808 100       if ((const GV *)sv == PL_last_in_gv)
9880 12         PL_last_in_gv = NULL;
9881 27082796 100       else if ((const GV *)sv == PL_statgv)
9882 10         PL_statgv = NULL;
9883           }
9884            
9885           /*
9886           =for apidoc sv_unref_flags
9887            
9888           Unsets the RV status of the SV, and decrements the reference count of
9889           whatever was being referenced by the RV. This can almost be thought of
9890           as a reversal of C. The C argument can contain
9891           C to force the reference count to be decremented
9892           (otherwise the decrementing is conditional on the reference count being
9893           different from one or the reference being a readonly SV).
9894           See C.
9895            
9896           =cut
9897           */
9898            
9899           void
9900 465447685         Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
9901           {
9902 465447685         SV* const target = SvRV(ref);
9903            
9904           PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
9905            
9906 465447685 100       if (SvWEAKREF(ref)) {
9907 36         sv_del_backref(target, ref);
9908 36         SvWEAKREF_off(ref);
9909 36         SvRV_set(ref, NULL);
9910 465447701         return;
9911           }
9912 465447649         SvRV_set(ref, NULL);
9913 465447649         SvROK_off(ref);
9914           /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
9915           assigned to as BEGIN {$a = \"Foo"} will fail. */
9916 465447649 100       if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
    100        
9917 446404657         SvREFCNT_dec_NN(target);
9918           else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
9919 19042992         sv_2mortal(target); /* Schedule for freeing later */
9920           }
9921            
9922           /*
9923           =for apidoc sv_untaint
9924            
9925           Untaint an SV. Use C instead.
9926            
9927           =cut
9928           */
9929            
9930           void
9931 17538         Perl_sv_untaint(pTHX_ SV *const sv)
9932           {
9933           PERL_ARGS_ASSERT_SV_UNTAINT;
9934            
9935 17538 100       if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
    50        
9936 5574         MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9937 5574 100       if (mg)
9938 14         mg->mg_len &= ~1;
9939           }
9940 17538         }
9941            
9942           /*
9943           =for apidoc sv_tainted
9944            
9945           Test an SV for taintedness. Use C instead.
9946            
9947           =cut
9948           */
9949            
9950           bool
9951 60396687         Perl_sv_tainted(pTHX_ SV *const sv)
9952           {
9953           PERL_ARGS_ASSERT_SV_TAINTED;
9954            
9955 60396687 50       if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
    50        
9956 60396687         const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9957 60396687 100       if (mg && (mg->mg_len & 1) )
    100        
9958           return TRUE;
9959           }
9960 60390655         return FALSE;
9961           }
9962            
9963           /*
9964           =for apidoc sv_setpviv
9965            
9966           Copies an integer into the given SV, also updating its string value.
9967           Does not handle 'set' magic. See C.
9968            
9969           =cut
9970           */
9971            
9972           void
9973 0         Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
9974           {
9975           char buf[TYPE_CHARS(UV)];
9976           char *ebuf;
9977           char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
9978            
9979           PERL_ARGS_ASSERT_SV_SETPVIV;
9980            
9981 0         sv_setpvn(sv, ptr, ebuf - ptr);
9982 0         }
9983            
9984           /*
9985           =for apidoc sv_setpviv_mg
9986            
9987           Like C, but also handles 'set' magic.
9988            
9989           =cut
9990           */
9991            
9992           void
9993 0         Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
9994           {
9995           PERL_ARGS_ASSERT_SV_SETPVIV_MG;
9996            
9997 0         sv_setpviv(sv, iv);
9998 0 0       SvSETMAGIC(sv);
9999 0         }
10000            
10001           #if defined(PERL_IMPLICIT_CONTEXT)
10002            
10003           /* pTHX_ magic can't cope with varargs, so this is a no-context
10004           * version of the main function, (which may itself be aliased to us).
10005           * Don't access this version directly.
10006           */
10007            
10008           void
10009           Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
10010           {
10011           dTHX;
10012           va_list args;
10013            
10014           PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
10015            
10016           va_start(args, pat);
10017           sv_vsetpvf(sv, pat, &args);
10018           va_end(args);
10019           }
10020            
10021           /* pTHX_ magic can't cope with varargs, so this is a no-context
10022           * version of the main function, (which may itself be aliased to us).
10023           * Don't access this version directly.
10024           */
10025            
10026           void
10027           Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
10028           {
10029           dTHX;
10030           va_list args;
10031            
10032           PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
10033            
10034           va_start(args, pat);
10035           sv_vsetpvf_mg(sv, pat, &args);
10036           va_end(args);
10037           }
10038           #endif
10039            
10040           /*
10041           =for apidoc sv_setpvf
10042            
10043           Works like C but copies the text into the SV instead of
10044           appending it. Does not handle 'set' magic. See C.
10045            
10046           =cut
10047           */
10048            
10049           void
10050 4685153         Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
10051           {
10052           va_list args;
10053            
10054           PERL_ARGS_ASSERT_SV_SETPVF;
10055            
10056 4685153         va_start(args, pat);
10057 4685153         sv_vsetpvf(sv, pat, &args);
10058 4685153         va_end(args);
10059 4685153         }
10060            
10061           /*
10062           =for apidoc sv_vsetpvf
10063            
10064           Works like C but copies the text into the SV instead of
10065           appending it. Does not handle 'set' magic. See C.
10066            
10067           Usually used via its frontend C.
10068            
10069           =cut
10070           */
10071            
10072           void
10073 4685155         Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
10074           {
10075           PERL_ARGS_ASSERT_SV_VSETPVF;
10076            
10077 4685155         sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
10078 4685155         }
10079            
10080           /*
10081           =for apidoc sv_setpvf_mg
10082            
10083           Like C, but also handles 'set' magic.
10084            
10085           =cut
10086           */
10087            
10088           void
10089 6         Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
10090           {
10091           va_list args;
10092            
10093           PERL_ARGS_ASSERT_SV_SETPVF_MG;
10094            
10095 6         va_start(args, pat);
10096 6         sv_vsetpvf_mg(sv, pat, &args);
10097 6         va_end(args);
10098 6         }
10099            
10100           /*
10101           =for apidoc sv_vsetpvf_mg
10102            
10103           Like C, but also handles 'set' magic.
10104            
10105           Usually used via its frontend C.
10106            
10107           =cut
10108           */
10109            
10110           void
10111 6         Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
10112           {
10113           PERL_ARGS_ASSERT_SV_VSETPVF_MG;
10114            
10115 6         sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
10116 6 50       SvSETMAGIC(sv);
10117 6         }
10118            
10119           #if defined(PERL_IMPLICIT_CONTEXT)
10120            
10121           /* pTHX_ magic can't cope with varargs, so this is a no-context
10122           * version of the main function, (which may itself be aliased to us).
10123           * Don't access this version directly.
10124           */
10125            
10126           void
10127           Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
10128           {
10129           dTHX;
10130           va_list args;
10131            
10132           PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
10133            
10134           va_start(args, pat);
10135           sv_vcatpvf(sv, pat, &args);
10136           va_end(args);
10137           }
10138            
10139           /* pTHX_ magic can't cope with varargs, so this is a no-context
10140           * version of the main function, (which may itself be aliased to us).
10141           * Don't access this version directly.
10142           */
10143            
10144           void
10145           Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
10146           {
10147           dTHX;
10148           va_list args;
10149            
10150           PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
10151            
10152           va_start(args, pat);
10153           sv_vcatpvf_mg(sv, pat, &args);
10154           va_end(args);
10155           }
10156           #endif
10157            
10158           /*
10159           =for apidoc sv_catpvf
10160            
10161           Processes its arguments like C and appends the formatted
10162           output to an SV. If the appended data contains "wide" characters
10163           (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
10164           and characters >255 formatted with %c), the original SV might get
10165           upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
10166           C. If the original SV was UTF-8, the pattern should be
10167           valid UTF-8; if the original SV was bytes, the pattern should be too.
10168            
10169           =cut */
10170            
10171           void
10172 1553291         Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
10173           {
10174           va_list args;
10175            
10176           PERL_ARGS_ASSERT_SV_CATPVF;
10177            
10178 1553291         va_start(args, pat);
10179 1553291         sv_vcatpvf(sv, pat, &args);
10180 1553291         va_end(args);
10181 1553291         }
10182            
10183           /*
10184           =for apidoc sv_vcatpvf
10185            
10186           Processes its arguments like C and appends the formatted output
10187           to an SV. Does not handle 'set' magic. See C.
10188            
10189           Usually used via its frontend C.
10190            
10191           =cut
10192           */
10193            
10194           void
10195 1553293         Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
10196           {
10197           PERL_ARGS_ASSERT_SV_VCATPVF;
10198            
10199 1553293         sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
10200 1553293         }
10201            
10202           /*
10203           =for apidoc sv_catpvf_mg
10204            
10205           Like C, but also handles 'set' magic.
10206            
10207           =cut
10208           */
10209            
10210           void
10211 6         Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
10212           {
10213           va_list args;
10214            
10215           PERL_ARGS_ASSERT_SV_CATPVF_MG;
10216            
10217 6         va_start(args, pat);
10218 6         sv_vcatpvf_mg(sv, pat, &args);
10219 6         va_end(args);
10220 6         }
10221            
10222           /*
10223           =for apidoc sv_vcatpvf_mg
10224            
10225           Like C, but also handles 'set' magic.
10226            
10227           Usually used via its frontend C.
10228            
10229           =cut
10230           */
10231            
10232           void
10233 6         Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
10234           {
10235           PERL_ARGS_ASSERT_SV_VCATPVF_MG;
10236            
10237 6         sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
10238 6 50       SvSETMAGIC(sv);
10239 6         }
10240            
10241           /*
10242           =for apidoc sv_vsetpvfn
10243            
10244           Works like C but copies the text into the SV instead of
10245           appending it.
10246            
10247           Usually used via one of its frontends C and C.
10248            
10249           =cut
10250           */
10251            
10252           void
10253 10301269         Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
10254           va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
10255           {
10256           PERL_ARGS_ASSERT_SV_VSETPVFN;
10257            
10258 10301269         sv_setpvs(sv, "");
10259 10301269         sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, 0);
10260 10301237         }
10261            
10262            
10263           /*
10264           * Warn of missing argument to sprintf, and then return a defined value
10265           * to avoid inappropriate "use of uninit" warnings [perl #71000].
10266           */
10267           #define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
10268           STATIC SV*
10269 208         S_vcatpvfn_missing_argument(pTHX) {
10270 208 100       if (ckWARN(WARN_MISSING)) {
10271 204 50       Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
10272 153 50       PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
    0        
10273           }
10274 206         return &PL_sv_no;
10275           }
10276            
10277            
10278           STATIC I32
10279 54207043         S_expect_number(pTHX_ char **const pattern)
10280           {
10281           dVAR;
10282           I32 var = 0;
10283            
10284           PERL_ARGS_ASSERT_EXPECT_NUMBER;
10285            
10286 54207043 100       switch (**pattern) {
10287           case '1': case '2': case '3':
10288           case '4': case '5': case '6':
10289           case '7': case '8': case '9':
10290 3579391         var = *(*pattern)++ - '0';
10291 5483167 100       while (isDIGIT(**pattern)) {
10292 115352         const I32 tmp = var * 10 + (*(*pattern)++ - '0');
10293 115352 100       if (tmp < var)
10294 12 50       Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
    50        
    0        
10295           var = tmp;
10296           }
10297           }
10298 54207031         return var;
10299           }
10300            
10301           STATIC char *
10302 856         S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
10303           {
10304 856         const int neg = nv < 0;
10305           UV uv;
10306            
10307           PERL_ARGS_ASSERT_F0CONVERT;
10308            
10309 856 100       if (neg)
10310 34         nv = -nv;
10311 856 100       if (nv < UV_MAX) {
10312           char *p = endbuf;
10313 848         nv += 0.5;
10314 848         uv = (UV)nv;
10315 848 100       if (uv & 1 && uv == nv)
    50        
10316 424         uv--; /* Round to even */
10317           do {
10318 4150         const unsigned dig = uv % 10;
10319 4150         *--p = '0' + dig;
10320 4150 100       } while (uv /= 10);
10321 848 100       if (neg)
10322 34         *--p = '-';
10323 848         *len = endbuf - p;
10324 852         return p;
10325           }
10326           return NULL;
10327           }
10328            
10329            
10330           /*
10331           =for apidoc sv_vcatpvfn
10332            
10333           =for apidoc sv_vcatpvfn_flags
10334            
10335           Processes its arguments like C and appends the formatted output
10336           to an SV. Uses an array of SVs if the C style variable argument list is
10337           missing (NULL). When running with taint checks enabled, indicates via
10338           C if results are untrustworthy (often due to the use of
10339           locales).
10340            
10341           If called as C or flags include C, calls get magic.
10342            
10343           Usually used via one of its frontends C and C.
10344            
10345           =cut
10346           */
10347            
10348           #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
10349           vecstr = (U8*)SvPV_const(vecsv,veclen);\
10350           vec_utf8 = DO_UTF8(vecsv);
10351            
10352           /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
10353            
10354           void
10355 1553299         Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
10356           va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
10357           {
10358           PERL_ARGS_ASSERT_SV_VCATPVFN;
10359            
10360 1553299         sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC);
10361 1553299         }
10362            
10363           void
10364 11854568         Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
10365           va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted,
10366           const U32 flags)
10367           {
10368           dVAR;
10369           char *p;
10370           char *q;
10371           const char *patend;
10372           STRLEN origlen;
10373           I32 svix = 0;
10374           static const char nullstr[] = "(null)";
10375           SV *argsv = NULL;
10376 11854568 100       bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
    50        
10377           const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
10378           SV *nsv = NULL;
10379           /* Times 4: a decimal digit takes more than 3 binary digits.
10380           * NV_DIG: mantissa takes than many decimal digits.
10381           * Plus 32: Playing safe. */
10382           char ebuf[IV_DIG * 4 + NV_DIG + 32];
10383           /* large enough for "%#.#f" --chip */
10384           /* what about long double NVs? --jhi */
10385           #ifdef USE_LOCALE_NUMERIC
10386           SV* oldlocale = NULL;
10387           #endif
10388            
10389           PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
10390           PERL_UNUSED_ARG(maybe_tainted);
10391            
10392 12625278 100       if (flags & SV_GMAGIC)
    100        
10393 771002         SvGETMAGIC(sv);
10394            
10395           /* no matter what, this is a string now */
10396 11854568 100       (void)SvPV_force_nomg(sv, origlen);
10397            
10398           /* special-case "", "%s", and "%-p" (SVf - see below) */
10399 11854568 100       if (patlen == 0)
10400           return;
10401 11854550 100       if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
    100        
    100        
10402 1438 100       if (args) {
10403 1072 50       const char * const s = va_arg(*args, char*);
10404 1072 50       sv_catpv_nomg(sv, s ? s : nullstr);
10405           }
10406 548 100       else if (svix < svmax) {
    50        
10407           /* we want get magic on the source but not the target. sv_catsv can't do that, though */
10408 182         SvGETMAGIC(*svargs);
10409 364         sv_catsv_nomg(sv, *svargs);
10410           }
10411           else
10412 2         S_vcatpvfn_missing_argument(aTHX);
10413           return;
10414           }
10415 11941971 100       if (args && patlen == 3 && pat[0] == '%' &&
    100        
    100        
10416 116007 50       pat[1] == '-' && pat[2] == 'p') {
10417 27148 50       argsv = MUTABLE_SV(va_arg(*args, void*));
10418 27148         sv_catsv_nomg(sv, argsv);
10419 27148         return;
10420           }
10421            
10422           #ifndef USE_LONG_DOUBLE
10423           /* special-case "%.[gf]" */
10424 11825964 100       if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
    100        
    100        
10425 1232 100       && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
10426           unsigned digits = 0;
10427           const char *pp;
10428            
10429 1096         pp = pat + 2;
10430 2156 100       while (*pp >= '0' && *pp <= '9')
10431 512         digits = 10 * digits + (*pp++ - '0');
10432 1096 100       if (pp - pat == (int)patlen - 1 && svix < svmax) {
10433 386 100       const NV nv = SvNV(*svargs);
10434 386 100       if (*pp == 'g') {
10435           /* Add check for digits != 0 because it seems that some
10436           gconverts are buggy in this case, and we don't yet have
10437           a Configure test for this. */
10438 128 100       if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
10439           /* 0, point, slack */
10440 124         Gconvert(nv, (int)digits, 0, ebuf);
10441 124         sv_catpv_nomg(sv, ebuf);
10442 124 50       if (*ebuf) /* May return an empty string for digits==0 */
10443           return;
10444           }
10445 258 100       } else if (!digits) {
10446           STRLEN l;
10447            
10448 32 50       if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
10449 32         sv_catpvn_nomg(sv, p, l);
10450 32         return;
10451           }
10452           }
10453           }
10454           }
10455           #endif /* !USE_LONG_DOUBLE */
10456            
10457 11825808 100       if (!args && svix < svmax && DO_UTF8(*svargs))
    100        
    100        
10458           has_utf8 = TRUE;
10459            
10460 11825808         patend = (char*)pat + patlen;
10461 32176696 100       for (p = (char*)pat; p < patend; p = q) {
10462           bool alt = FALSE;
10463           bool left = FALSE;
10464           bool vectorize = FALSE;
10465           bool vectorarg = FALSE;
10466           bool vec_utf8 = FALSE;
10467           char fill = ' ';
10468           char plus = 0;
10469           char intsize = 0;
10470           STRLEN width = 0;
10471           STRLEN zeros = 0;
10472           bool has_precis = FALSE;
10473           STRLEN precis = 0;
10474           const I32 osvix = svix;
10475           bool is_utf8 = FALSE; /* is this item utf8? */
10476           #ifdef HAS_LDBL_SPRINTF_BUG
10477           /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10478           with sfio - Allen */
10479           bool fix_ldbl_sprintf_bug = FALSE;
10480           #endif
10481            
10482           char esignbuf[4];
10483           U8 utf8buf[UTF8_MAXBYTES+1];
10484           STRLEN esignlen = 0;
10485            
10486           const char *eptr = NULL;
10487           const char *fmtstart;
10488 27127559         STRLEN elen = 0;
10489           SV *vecsv = NULL;
10490           const U8 *vecstr = NULL;
10491 27127559         STRLEN veclen = 0;
10492 27127559         char c = 0;
10493           int i;
10494           unsigned base = 0;
10495           IV iv = 0;
10496           UV uv = 0;
10497           /* we need a long double target in case HAS_LONG_DOUBLE but
10498           not USE_LONG_DOUBLE
10499           */
10500           #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
10501           long double nv;
10502           #else
10503           NV nv;
10504           #endif
10505           STRLEN have;
10506           STRLEN need;
10507           STRLEN gap;
10508           const char *dotstr = ".";
10509 27127559         STRLEN dotstrlen = 1;
10510           I32 efix = 0; /* explicit format parameter index */
10511           I32 ewix = 0; /* explicit width index */
10512           I32 epix = 0; /* explicit precision index */
10513           I32 evix = 0; /* explicit vector index */
10514           bool asterisk = FALSE;
10515            
10516           /* echo everything up to the next format specification */
10517 73173442 100       for (q = p; q < patend && *q != '%'; ++q) ;
    100        
10518 27127559 100       if (q > p) {
10519 24562191 100       if (has_utf8 && !pat_utf8)
    100        
10520 34842 100       sv_catpvn_nomg_utf8_upgrade(sv, p, q - p, nsv);
10521           else
10522 24527349         sv_catpvn_nomg(sv, p, q - p);
10523 24562191         p = q;
10524           }
10525 27127559 100       if (q++ >= patend)
10526           break;
10527            
10528 20350920         fmtstart = q;
10529            
10530           /*
10531           We allow format specification elements in this order:
10532           \d+\$ explicit format parameter index
10533           [-+ 0#]+ flags
10534           v|\*(\d+\$)?v vector with optional (optionally specified) arg
10535           0 flag (as above): repeated to allow "v02"
10536           \d+|\*(\d+\$)? width using optional (optionally specified) arg
10537           \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
10538           [hlqLV] size
10539           [%bcdefginopsuxDFOUX] format (mandatory)
10540           */
10541            
10542 20350920 100       if (args) {
10543           /*
10544           As of perl5.9.3, printf format checking is on by default.
10545           Internally, perl uses %p formats to provide an escape to
10546           some extended formatting. This block deals with those
10547           extensions: if it does not match, (char*)q is reset and
10548           the normal format processing code is used.
10549            
10550           Currently defined extensions are:
10551           %p include pointer address (standard)
10552           %-p (SVf) include an SV (previously %_)
10553           %-p include an SV with precision
10554           %2p include a HEK
10555           %3p include a HEK with precision of 256
10556           %4p char* preceded by utf8 flag and length
10557           %p (where num is 1 or > 4) reserved for future
10558           extensions
10559            
10560           Robin Barker 2005-07-14 (but modified since)
10561            
10562           %1p (VDf) removed. RMB 2007-10-19
10563           */
10564 14442327         char* r = q;
10565           bool sv = FALSE;
10566           STRLEN n = 0;
10567 14442327 100       if (*q == '-')
10568 413088         sv = *q++;
10569 14029239 100       else if (strnEQ(q, UTF8f, sizeof(UTF8f)-1)) { /* UTF8f */
10570           /* The argument has already gone through cBOOL, so the cast
10571           is safe. */
10572 2348 50       is_utf8 = (bool)va_arg(*args, int);
10573 2348 100       elen = va_arg(*args, UV);
10574 2348 100       eptr = va_arg(*args, char *);
10575 2348         q += sizeof(UTF8f)-1;
10576 2348         goto string;
10577           }
10578 14439979         n = expect_number(&q);
10579 14439979 100       if (*q++ == 'p') {
10580 451594 100       if (sv) { /* SVf */
10581 413070 100       if (n) {
10582           precis = n;
10583           has_precis = TRUE;
10584           }
10585 413070 100       argsv = MUTABLE_SV(va_arg(*args, void*));
10586 413070 100       eptr = SvPV_const(argsv, elen);
10587 413070 100       if (DO_UTF8(argsv))
    50        
10588           is_utf8 = TRUE;
10589           goto string;
10590           }
10591 38524 100       else if (n==2 || n==3) { /* HEKf */
10592 38520 50       HEK * const hek = va_arg(*args, HEK *);
10593 38520         eptr = HEK_KEY(hek);
10594 38520         elen = HEK_LEN(hek);
10595 38520 100       if (HEK_UTF8(hek)) is_utf8 = TRUE;
10596 38520 50       if (n==3) precis = 256, has_precis = TRUE;
10597           goto string;
10598           }
10599 4 50       else if (n) {
10600 0         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
10601           "internal %%p might conflict with future printf extensions");
10602           }
10603           }
10604 13988389         q = r;
10605           }
10606            
10607 19896982 100       if ( (width = expect_number(&q)) ) {
10608 33048 100       if (*q == '$') {
10609 102         ++q;
10610 9948619         efix = width;
10611           } else {
10612           goto gotwidth;
10613           }
10614           }
10615            
10616           /* FLAGS */
10617            
10618 33720054 100       while (*q) {
10619 23768695         switch (*q) {
10620           case ' ':
10621           case '+':
10622 3970 100       if (plus == '+' && *q == ' ') /* '+' over ' ' */
    100        
10623 560         q++;
10624           else
10625 3410         plus = *q++;
10626 3970         continue;
10627            
10628           case '-':
10629           left = TRUE;
10630 125006         q++;
10631 125006         continue;
10632            
10633           case '0':
10634 3403997         fill = *q++;
10635 3403997         continue;
10636            
10637           case '#':
10638           alt = TRUE;
10639 371708         q++;
10640 2139454         continue;
10641            
10642           default:
10643           break;
10644           }
10645           break;
10646           }
10647            
10648           tryasterisk:
10649 19869596 100       if (*q == '*') {
10650 49636         q++;
10651 49636 100       if ( (ewix = expect_number(&q)) )
10652 16 100       if (*q++ != '$')
10653           goto unknown;
10654           asterisk = TRUE;
10655           }
10656 19869592 100       if (*q == 'v') {
10657 5574         q++;
10658 5574 100       if (vectorize)
10659           goto unknown;
10660 5572 100       if ((vectorarg = asterisk)) {
10661           evix = ewix;
10662           ewix = 0;
10663           asterisk = FALSE;
10664           }
10665           vectorize = TRUE;
10666           goto tryasterisk;
10667           }
10668            
10669 19864018 100       if (!asterisk)
10670           {
10671 19814490 100       if( *q == '0' )
10672 4         fill = *q++;
10673 19814490         width = expect_number(&q);
10674           }
10675            
10676 19864018 100       if (vectorize && vectorarg) {
    100        
10677           /* vectorizing, but not with the default "." */
10678 102 50       if (args)
10679 0 0       vecsv = va_arg(*args, SV*);
10680 102 100       else if (evix) {
10681 2         vecsv = (evix > 0 && evix <= svmax)
10682 2 50       ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
10683           } else {
10684           vecsv = svix < svmax
10685 100 50       ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10686           }
10687 102 50       dotstr = SvPV_const(vecsv, dotstrlen);
10688           /* Keep the DO_UTF8 test *after* the SvPV call, else things go
10689           bad with tied or overloaded values that return UTF8. */
10690 102 100       if (DO_UTF8(vecsv))
    50        
10691           is_utf8 = TRUE;
10692 84 100       else if (has_utf8) {
10693 12         vecsv = sv_mortalcopy(vecsv);
10694 12         sv_utf8_upgrade(vecsv);
10695 12 50       dotstr = SvPV_const(vecsv, dotstrlen);
10696           is_utf8 = TRUE;
10697           }
10698           }
10699            
10700 19864018 100       if (asterisk) {
10701 49528 100       if (args)
10702 37882 100       i = va_arg(*args, int);
10703           else
10704 23290 100       i = (ewix ? ewix <= svmax : svix < svmax) ?
    100        
10705 11644 100       SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
    50        
10706 49528         left |= (i < 0);
10707 49528         width = (i < 0) ? -i : i;
10708           }
10709           gotwidth:
10710            
10711           /* PRECISION */
10712            
10713 19896964 100       if (*q == '.') {
10714 14386         q++;
10715 14386 100       if (*q == '*') {
10716 5956         q++;
10717 5956 50       if ( ((epix = expect_number(&q))) && (*q++ != '$') )
    0        
10718           goto unknown;
10719           /* XXX: todo, support specified precision parameter */
10720 5956 50       if (epix)
10721           goto unknown;
10722 5956 100       if (args)
10723 5150 100       i = va_arg(*args, int);
10724           else
10725 1612 50       i = (ewix ? ewix <= svmax : svix < svmax)
10726 1612 50       ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
    50        
    50        
10727 5956         precis = i;
10728 5956         has_precis = !(i < 0);
10729           }
10730           else {
10731           precis = 0;
10732 16860 100       while (isDIGIT(*q))
10733 8430         precis = precis * 10 + (*q++ - '0');
10734           has_precis = TRUE;
10735           }
10736           }
10737            
10738 19896964 100       if (vectorize) {
10739 5568 50       if (args) {
10740 0 0       VECTORIZE_ARGS
    0        
    0        
    0        
10741           }
10742 5568 100       else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
    100        
10743 5056 50       vecsv = svargs[efix ? efix-1 : svix++];
10744 5056 100       vecstr = (U8*)SvPV_const(vecsv,veclen);
10745 5056 100       vec_utf8 = DO_UTF8(vecsv);
    100        
10746            
10747           /* if this is a version object, we need to convert
10748           * back into v-string notation and then let the
10749           * vectorize happen normally
10750           */
10751 5056 100       if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) {
    50        
10752 4740 100       if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
10753 8         Perl_ck_warner_d(aTHX_ packWARN(WARN_PRINTF),
10754           "vector argument not supported with alpha versions");
10755 8         goto vdblank;
10756           }
10757 4732         vecsv = sv_newmortal();
10758 4732         scan_vstring((char *)vecstr, (char *)vecstr + veclen,
10759           vecsv);
10760 4732 50       vecstr = (U8*)SvPV_const(vecsv, veclen);
10761 4732 100       vec_utf8 = DO_UTF8(vecsv);
    50        
10762           }
10763           }
10764           else {
10765           vdblank:
10766           vecstr = (U8*)"";
10767 520         veclen = 0;
10768           }
10769           }
10770            
10771           /* SIZE */
10772            
10773 19896964         switch (*q) {
10774           #ifdef WIN32
10775           case 'I': /* Ix, I32x, and I64x */
10776           # ifdef USE_64_BIT_INT
10777           if (q[1] == '6' && q[2] == '4') {
10778           q += 3;
10779           intsize = 'q';
10780           break;
10781           }
10782           # endif
10783           if (q[1] == '3' && q[2] == '2') {
10784           q += 3;
10785           break;
10786           }
10787           # ifdef USE_64_BIT_INT
10788           intsize = 'q';
10789           # endif
10790           q++;
10791           break;
10792           #endif
10793           #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10794           case 'L': /* Ld */
10795           /*FALLTHROUGH*/
10796           #ifdef HAS_QUAD
10797           case 'q': /* qd */
10798           #endif
10799           intsize = 'q';
10800 60         q++;
10801 60         break;
10802           #endif
10803           case 'l':
10804 8215543         ++q;
10805           #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10806 8215543 100       if (*q == 'l') { /* lld, llf */
10807           intsize = 'q';
10808 54         ++q;
10809           }
10810           else
10811           #endif
10812           intsize = 'l';
10813           break;
10814           case 'h':
10815 12 100       if (*++q == 'h') { /* hhd, hhu */
10816           intsize = 'c';
10817 2         ++q;
10818           }
10819           else
10820           intsize = 'h';
10821           break;
10822           case 'V':
10823           case 'z':
10824           case 't':
10825           #if HAS_C99
10826           case 'j':
10827           #endif
10828 22         intsize = *q++;
10829 22         break;
10830           }
10831            
10832           /* CONVERSION */
10833            
10834 19896964 100       if (*q == '%') {
10835 14548         eptr = q++;
10836 14548         elen = 1;
10837 14548 100       if (vectorize) {
10838 4         c = '%';
10839 4         goto unknown;
10840           }
10841           goto string;
10842           }
10843            
10844 19882416 100       if (!vectorize && !args) {
    100        
10845 5888529 100       if (efix) {
10846 100         const I32 i = efix-1;
10847 100         argsv = (i >= 0 && i < svmax)
10848 100 100       ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
10849           } else {
10850 5888429         argsv = (svix >= 0 && svix < svmax)
10851 5888429 100       ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10852           }
10853           }
10854            
10855 19882414         switch (c = *q++) {
10856            
10857           /* STRINGS */
10858            
10859           case 'c':
10860 255754 100       if (vectorize)
10861           goto unknown;
10862 255750 100       uv = (args) ? va_arg(*args, int) : SvIV(argsv);
    100        
    50        
10863 255750 100       if ((uv > 255 ||
    50        
10864 0 0       (!NATIVE_IS_INVARIANT(uv) && SvUTF8(sv)))
10865 18 50       && !IN_BYTES) {
10866           eptr = (char*)utf8buf;
10867 18         elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
10868 18         is_utf8 = TRUE;
10869           }
10870           else {
10871 255732         c = (char)uv;
10872           eptr = &c;
10873 255732         elen = 1;
10874           }
10875           goto string;
10876            
10877           case 's':
10878 6086202 100       if (vectorize)
10879           goto unknown;
10880 6086198 100       if (args) {
10881 5322416 100       eptr = va_arg(*args, char*);
10882 5322416 50       if (eptr)
10883 5322416         elen = strlen(eptr);
10884           else {
10885           eptr = (char *)nullstr;
10886 0         elen = sizeof nullstr - 1;
10887           }
10888           }
10889           else {
10890 763782 100       eptr = SvPV_const(argsv, elen);
10891 763782 100       if (DO_UTF8(argsv)) {
    50        
10892           STRLEN old_precis = precis;
10893 404 100       if (has_precis && precis < elen) {
    100        
10894 80 50       STRLEN ulen = sv_or_pv_len_utf8(argsv, eptr, elen);
    100        
    50        
    50        
10895 80         STRLEN p = precis > ulen ? ulen : precis;
10896 80         precis = sv_or_pv_pos_u2b(argsv, eptr, p, 0);
10897           /* sticks at end */
10898           }
10899 404 100       if (width) { /* fudge width (can't fudge elen) */
10900 108 100       if (has_precis && precis < elen)
    100        
10901 22         width += precis - old_precis;
10902           else
10903 86         width +=
10904 86 50       elen - sv_or_pv_len_utf8(argsv,eptr,elen);
    100        
    50        
    50        
10905           }
10906           is_utf8 = TRUE;
10907           }
10908           }
10909            
10910           string:
10911 6810430 100       if (has_precis && precis < elen)
    100        
10912 4178         elen = precis;
10913           break;
10914            
10915           /* INTEGERS */
10916            
10917           case 'p':
10918 14 100       if (alt || vectorize)
    100        
10919           goto unknown;
10920 8 100       uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
    50        
10921           base = 16;
10922 11         goto integer;
10923            
10924           case 'D':
10925           #ifdef IV_IS_QUAD
10926           intsize = 'q';
10927           #else
10928           intsize = 'l';
10929           #endif
10930           /*FALLTHROUGH*/
10931           case 'd':
10932           case 'i':
10933           #if vdNUMBER
10934           format_vd:
10935           #endif
10936 4504012 100       if (vectorize) {
10937           STRLEN ulen;
10938 4926 100       if (!veclen)
10939 20         continue;
10940 4906 100       if (vec_utf8)
10941 76         uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10942           UTF8_ALLOW_ANYUV);
10943           else {
10944 4830         uv = *vecstr;
10945 4830         ulen = 1;
10946           }
10947 4906         vecstr += ulen;
10948 4906         veclen -= ulen;
10949 4906 100       if (plus)
10950 8         esignbuf[esignlen++] = plus;
10951           }
10952 4499086 100       else if (args) {
10953 4149799         switch (intsize) {
10954 0 0       case 'c': iv = (char)va_arg(*args, int); break;
10955 0 0       case 'h': iv = (short)va_arg(*args, int); break;
10956 4057523 100       case 'l': iv = va_arg(*args, long); break;
10957 0 0       case 'V': iv = va_arg(*args, IV); break;
10958 0 0       case 'z': iv = va_arg(*args, SSize_t); break;
10959 0 0       case 't': iv = va_arg(*args, ptrdiff_t); break;
10960 92276 100       default: iv = va_arg(*args, int); break;
10961           #if HAS_C99
10962           case 'j': iv = va_arg(*args, intmax_t); break;
10963           #endif
10964           case 'q':
10965           #ifdef HAS_QUAD
10966 0 0       iv = va_arg(*args, Quad_t); break;
10967           #else
10968           goto unknown;
10969           #endif
10970           }
10971           }
10972           else {
10973 349287 100       IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
10974 349287         switch (intsize) {
10975 2         case 'c': iv = (char)tiv; break;
10976 2         case 'h': iv = (short)tiv; break;
10977           case 'l': iv = (long)tiv; break;
10978           case 'V':
10979           default: iv = tiv; break;
10980           case 'q':
10981           #ifdef HAS_QUAD
10982           iv = (Quad_t)tiv; break;
10983           #else
10984           goto unknown;
10985           #endif
10986           }
10987           }
10988 4503992 100       if ( !vectorize ) /* we already set uv above */
10989           {
10990 4499086 100       if (iv >= 0) {
10991 4482742         uv = iv;
10992 4482742 100       if (plus)
10993 1262         esignbuf[esignlen++] = plus;
10994           }
10995           else {
10996 16344         uv = -iv;
10997 2650326         esignbuf[esignlen++] = '-';
10998           }
10999           }
11000           base = 10;
11001           goto integer;
11002            
11003           case 'U':
11004           #ifdef IV_IS_QUAD
11005           intsize = 'q';
11006           #else
11007           intsize = 'l';
11008           #endif
11009           /*FALLTHROUGH*/
11010           case 'u':
11011           base = 10;
11012           goto uns_integer;
11013            
11014           case 'B':
11015           case 'b':
11016           base = 2;
11017           goto uns_integer;
11018            
11019           case 'O':
11020           #ifdef IV_IS_QUAD
11021           intsize = 'q';
11022           #else
11023           intsize = 'l';
11024           #endif
11025           /*FALLTHROUGH*/
11026           case 'o':
11027           base = 8;
11028           goto uns_integer;
11029            
11030           case 'X':
11031           case 'x':
11032           base = 16;
11033            
11034           uns_integer:
11035 9008362 100       if (vectorize) {
11036           STRLEN ulen;
11037           vector:
11038 10164 100       if (!veclen)
11039 16         continue;
11040 10148 100       if (vec_utf8)
11041 212         uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
11042           UTF8_ALLOW_ANYUV);
11043           else {
11044 9936         uv = *vecstr;
11045 9936         ulen = 1;
11046           }
11047 10148         vecstr += ulen;
11048 10148         veclen -= ulen;
11049           }
11050 9008236 100       else if (args) {
11051 4259478         switch (intsize) {
11052 0 0       case 'c': uv = (unsigned char)va_arg(*args, unsigned); break;
11053 0 0       case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
11054 4157740 100       case 'l': uv = va_arg(*args, unsigned long); break;
11055 0 0       case 'V': uv = va_arg(*args, UV); break;
11056 0 0       case 'z': uv = va_arg(*args, Size_t); break;
11057 0 0       case 't': uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */
11058           #if HAS_C99
11059           case 'j': uv = va_arg(*args, uintmax_t); break;
11060           #endif
11061 101738 50       default: uv = va_arg(*args, unsigned); break;
11062           case 'q':
11063           #ifdef HAS_QUAD
11064 0 0       uv = va_arg(*args, Uquad_t); break;
11065           #else
11066           goto unknown;
11067           #endif
11068           }
11069           }
11070           else {
11071 4748758 100       UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
11072 4748758         switch (intsize) {
11073 0         case 'c': uv = (unsigned char)tuv; break;
11074 0         case 'h': uv = (unsigned short)tuv; break;
11075           case 'l': uv = (unsigned long)tuv; break;
11076           case 'V':
11077           default: uv = tuv; break;
11078           case 'q':
11079           #ifdef HAS_QUAD
11080           uv = (Uquad_t)tuv; break;
11081           #else
11082           goto unknown;
11083           #endif
11084           }
11085           }
11086            
11087           integer:
11088           {
11089           char *ptr = ebuf + sizeof ebuf;
11090 13522384 100       bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
    100        
11091           zeros = 0;
11092            
11093 13522384         switch (base) {
11094           unsigned dig;
11095           case 16:
11096 5268128 100       p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
11097           do {
11098 16850100         dig = uv & 15;
11099 16850100         *--ptr = p[dig];
11100 16850100 100       } while (uv >>= 4);
11101 5268128 100       if (tempalt) {
11102 323474         esignbuf[esignlen++] = '0';
11103 534155         esignbuf[esignlen++] = c; /* 'x' or 'X' */
11104           }
11105           break;
11106           case 8:
11107           do {
11108 1202276         dig = uv & 7;
11109 1202276         *--ptr = '0' + dig;
11110 1202276 100       } while (uv >>= 3);
11111 421362 100       if (alt && *ptr != '0')
    100        
11112 2451         *--ptr = '0';
11113           break;
11114           case 2:
11115           do {
11116 17056         dig = uv & 1;
11117 17056         *--ptr = '0' + dig;
11118 17056 100       } while (uv >>= 1);
11119 4430 100       if (tempalt) {
11120 54         esignbuf[esignlen++] = '0';
11121 3923104         esignbuf[esignlen++] = c;
11122           }
11123           break;
11124           default: /* it had better be ten or less */
11125           do {
11126 21882022         dig = uv % base;
11127 21882022         *--ptr = '0' + dig;
11128 21882022 100       } while (uv /= base);
11129           break;
11130           }
11131 13522384         elen = (ebuf + sizeof ebuf) - ptr;
11132           eptr = ptr;
11133 13522384 100       if (has_precis) {
11134 4152 100       if (precis > elen)
11135 3598         zeros = precis - elen;
11136 554 100       else if (precis == 0 && elen == 1 && *eptr == '0'
    100        
    100        
11137 84 100       && !(base == 8 && alt)) /* "%#.0o" prints "0" */
    100        
11138 76         elen = 0;
11139            
11140           /* a precision nullifies the 0 flag. */
11141 4152 100       if (fill == '0')
11142           fill = ' ';
11143           }
11144           }
11145           break;
11146            
11147           /* FLOATING POINT */
11148            
11149           case 'F':
11150 6         c = 'f'; /* maybe %F isn't supported here */
11151           /*FALLTHROUGH*/
11152           case 'e': case 'E':
11153           case 'f':
11154           case 'g': case 'G':
11155 27416 100       if (vectorize)
11156           goto unknown;
11157            
11158           /* This is evil, but floating point is even more evil */
11159            
11160           /* for SV-style calling, we can only get NV
11161           for C-style calling, we assume %f is double;
11162           for simplicity we allow any of %Lf, %llf, %qf for long double
11163           */
11164 27392 100       switch (intsize) {
11165           case 'V':
11166           #if defined(USE_LONG_DOUBLE)
11167           intsize = 'q';
11168           #endif
11169           break;
11170           /* [perl #20339] - we should accept and ignore %lf rather than die */
11171           case 'l':
11172           /*FALLTHROUGH*/
11173           default:
11174           #if defined(USE_LONG_DOUBLE)
11175           intsize = args ? 0 : 'q';
11176           #endif
11177           break;
11178           case 'q':
11179           #if defined(HAS_LONG_DOUBLE)
11180           break;
11181           #else
11182           /*FALLTHROUGH*/
11183           #endif
11184           case 'c':
11185           case 'h':
11186           case 'z':
11187           case 't':
11188           case 'j':
11189           goto unknown;
11190           }
11191            
11192           /* now we need (long double) if intsize == 'q', else (double) */
11193           nv = (args) ?
11194           #if LONG_DOUBLESIZE > DOUBLESIZE
11195           intsize == 'q' ?
11196 2290 50       va_arg(*args, long double) :
11197 916 50       va_arg(*args, double)
11198           #else
11199           va_arg(*args, double)
11200           #endif
11201 40627 100       : SvNV(argsv);
    100        
11202            
11203           need = 0;
11204           /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
11205           else. frexp() has some unspecified behaviour for those three */
11206 27390 100       if (c != 'e' && c != 'E' && (nv * 0) == 0) {
    100        
11207 27000         i = PERL_INT_MIN;
11208           /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
11209           will cast our (long double) to (double) */
11210 27000         (void)Perl_frexp(nv, &i);
11211 27000 50       if (i == PERL_INT_MIN)
11212 0         Perl_die(aTHX_ "panic: frexp");
11213 27000 100       if (i > 0)
11214 23828         need = BIT_DIGITS(i);
11215           }
11216 27390 100       need += has_precis ? precis : 6; /* known default */
11217            
11218 27390 100       if (need < width)
11219           need = width;
11220            
11221           #ifdef HAS_LDBL_SPRINTF_BUG
11222           /* This is to try to fix a bug with irix/nonstop-ux/powerux and
11223           with sfio - Allen */
11224            
11225           # ifdef DBL_MAX
11226           # define MY_DBL_MAX DBL_MAX
11227           # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
11228           # if DOUBLESIZE >= 8
11229           # define MY_DBL_MAX 1.7976931348623157E+308L
11230           # else
11231           # define MY_DBL_MAX 3.40282347E+38L
11232           # endif
11233           # endif
11234            
11235           # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
11236           # define MY_DBL_MAX_BUG 1L
11237           # else
11238           # define MY_DBL_MAX_BUG MY_DBL_MAX
11239           # endif
11240            
11241           # ifdef DBL_MIN
11242           # define MY_DBL_MIN DBL_MIN
11243           # else /* XXX guessing! -Allen */
11244           # if DOUBLESIZE >= 8
11245           # define MY_DBL_MIN 2.2250738585072014E-308L
11246           # else
11247           # define MY_DBL_MIN 1.17549435E-38L
11248           # endif
11249           # endif
11250            
11251           if ((intsize == 'q') && (c == 'f') &&
11252           ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
11253           (need < DBL_DIG)) {
11254           /* it's going to be short enough that
11255           * long double precision is not needed */
11256            
11257           if ((nv <= 0L) && (nv >= -0L))
11258           fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
11259           else {
11260           /* would use Perl_fp_class as a double-check but not
11261           * functional on IRIX - see perl.h comments */
11262            
11263           if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
11264           /* It's within the range that a double can represent */
11265           #if defined(DBL_MAX) && !defined(DBL_MIN)
11266           if ((nv >= ((long double)1/DBL_MAX)) ||
11267           (nv <= (-(long double)1/DBL_MAX)))
11268           #endif
11269           fix_ldbl_sprintf_bug = TRUE;
11270           }
11271           }
11272           if (fix_ldbl_sprintf_bug == TRUE) {
11273           double temp;
11274            
11275           intsize = 0;
11276           temp = (double)nv;
11277           nv = (NV)temp;
11278           }
11279           }
11280            
11281           # undef MY_DBL_MAX
11282           # undef MY_DBL_MAX_BUG
11283           # undef MY_DBL_MIN
11284            
11285           #endif /* HAS_LDBL_SPRINTF_BUG */
11286            
11287 27390         need += 20; /* fudge factor */
11288 27390 100       if (PL_efloatsize < need) {
11289 506         Safefree(PL_efloatbuf);
11290 506         PL_efloatsize = need + 20; /* more fudge */
11291 506         Newx(PL_efloatbuf, PL_efloatsize, char);
11292 506         PL_efloatbuf[0] = '\0';
11293           }
11294            
11295 27390 100       if ( !(width || left || plus || alt) && fill != '0'
    50        
    100        
    100        
    100        
11296 24102 100       && has_precis && intsize != 'q' ) { /* Shortcuts */
    50        
11297           /* See earlier comment about buggy Gconvert when digits,
11298           aka precis is 0 */
11299 2036 100       if ( c == 'g' && precis) {
11300 76         Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
11301           /* May return an empty string for digits==0 */
11302 76 50       if (*PL_efloatbuf) {
11303 76         elen = strlen(PL_efloatbuf);
11304 76         goto float_converted;
11305           }
11306 1960 100       } else if ( c == 'f' && !precis) {
11307 824 100       if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
11308           break;
11309           }
11310           }
11311           {
11312           char *ptr = ebuf + sizeof ebuf;
11313 26498         *--ptr = '\0';
11314 26498         *--ptr = c;
11315           /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
11316           #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
11317 26498 50       if (intsize == 'q') {
11318           /* Copy the one or more characters in a long double
11319           * format before the 'base' ([efgEFG]) character to
11320           * the format string. */
11321           static char const prifldbl[] = PERL_PRIfldbl;
11322           char const *p = prifldbl + sizeof(prifldbl) - 3;
11323 0 0       while (p >= prifldbl) { *--ptr = *p--; }
11324           }
11325           #endif
11326 26498 100       if (has_precis) {
11327 4182         base = precis;
11328 4186 100       do { *--ptr = '0' + (base % 10); } while (base /= 10);
11329 4182         *--ptr = '.';
11330           }
11331 26498 100       if (width) {
11332 1180         base = width;
11333 1210 100       do { *--ptr = '0' + (base % 10); } while (base /= 10);
11334           }
11335 26498 100       if (fill == '0')
11336 2074         *--ptr = fill;
11337 26498 100       if (left)
11338 20         *--ptr = '-';
11339 26498 100       if (plus)
11340 38         *--ptr = plus;
11341 26498 100       if (alt)
11342 20         *--ptr = '#';
11343 26498         *--ptr = '%';
11344            
11345           /* No taint. Otherwise we are in the strange situation
11346           * where printf() taints but print($float) doesn't.
11347           * --jhi */
11348            
11349           #ifdef USE_LOCALE_NUMERIC
11350 26498 100       if (! PL_numeric_standard && ! IN_SOME_LOCALE_FORM) {
    50        
    50        
11351            
11352           /* We use a mortal SV, so that any failures (such as if
11353           * warnings are made fatal) won't leak */
11354 0         char *oldlocale_string = setlocale(LC_NUMERIC, NULL);
11355 0         oldlocale = newSVpvn_flags(oldlocale_string,
11356           strlen(oldlocale_string),
11357           SVs_TEMP);
11358 0         PL_numeric_standard = TRUE;
11359 0         setlocale(LC_NUMERIC, "C");
11360           }
11361           #endif
11362            
11363           #if defined(HAS_LONG_DOUBLE)
11364 52996 50       elen = ((intsize == 'q')
11365 0 0       ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
    0        
11366 39747 50       : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
    50        
11367           #else
11368           elen = my_sprintf(PL_efloatbuf, ptr, nv);
11369           #endif
11370           }
11371           float_converted:
11372 26574         eptr = PL_efloatbuf;
11373            
11374           #ifdef USE_LOCALE_NUMERIC
11375 26574 50       if (PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
    0        
11376 0 0       && instr(eptr, SvPVX_const(PL_numeric_radix_sv)))
11377           {
11378           is_utf8 = TRUE;
11379           }
11380           #endif
11381            
11382           break;
11383            
11384           /* SPECIAL */
11385            
11386           case 'n':
11387 14 100       if (vectorize)
11388           goto unknown;
11389 10         i = SvCUR(sv) - origlen;
11390 10 50       if (args) {
11391 0         switch (intsize) {
11392 0 0       case 'c': *(va_arg(*args, char*)) = i; break;
11393 0 0       case 'h': *(va_arg(*args, short*)) = i; break;
11394 0 0       default: *(va_arg(*args, int*)) = i; break;
11395 0 0       case 'l': *(va_arg(*args, long*)) = i; break;
11396 0 0       case 'V': *(va_arg(*args, IV*)) = i; break;
11397 0 0       case 'z': *(va_arg(*args, SSize_t*)) = i; break;
11398 0 0       case 't': *(va_arg(*args, ptrdiff_t*)) = i; break;
11399           #if HAS_C99
11400           case 'j': *(va_arg(*args, intmax_t*)) = i; break;
11401           #endif
11402           case 'q':
11403           #ifdef HAS_QUAD
11404 0 0       *(va_arg(*args, Quad_t*)) = i; break;
11405           #else
11406           goto unknown;
11407           #endif
11408           }
11409           }
11410           else
11411 10 100       sv_setuv_mg(argsv, has_utf8 ? (UV)sv_len_utf8(sv) : (UV)i);
11412 8         continue; /* not "break" */
11413            
11414           /* UNKNOWN */
11415            
11416           default:
11417           unknown:
11418 694 50       if (!args
11419 694 50       && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
11420 694 100       && ckWARN(WARN_PRINTF))
11421           {
11422 662         SV * const msg = sv_newmortal();
11423 662 100       Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
11424 662         (PL_op->op_type == OP_PRTF) ? "" : "s");
11425 662 100       if (fmtstart < patend) {
11426 656         const char * const fmtend = q < patend ? q : patend;
11427           const char * f;
11428 656         sv_catpvs(msg, "\"%");
11429 1996 100       for (f = fmtstart; f < fmtend; f++) {
11430 1340 100       if (isPRINT(*f)) {
11431 1006         sv_catpvn_nomg(msg, f, 1);
11432           } else {
11433 334         Perl_sv_catpvf(aTHX_ msg,
11434 334         "\\%03"UVof, (UV)*f & 0xFF);
11435           }
11436           }
11437 656         sv_catpvs(msg, "\"");
11438           } else {
11439 6         sv_catpvs(msg, "end of string");
11440           }
11441 662         Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
11442           }
11443            
11444           /* output mangled stuff ... */
11445 678 100       if (c == '\0')
11446 78         --q;
11447           eptr = p;
11448 678         elen = q - p;
11449            
11450           /* ... right here, because formatting flags should not apply */
11451 678 50       SvGROW(sv, SvCUR(sv) + elen + 1);
    50        
11452 678         p = SvEND(sv);
11453 678         Copy(eptr, p, elen, char);
11454 678         p += elen;
11455 678         *p = '\0';
11456 678         SvCUR_set(sv, p - SvPVX_const(sv));
11457           svix = osvix;
11458 678         continue; /* not "break" */
11459           }
11460            
11461 20360204 100       if (is_utf8 != has_utf8) {
11462 138074 100       if (is_utf8) {
11463 34800 100       if (SvCUR(sv))
11464 34782         sv_utf8_upgrade(sv);
11465           }
11466           else {
11467 103274         const STRLEN old_elen = elen;
11468 103274         SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
11469 103274         sv_utf8_upgrade(nsv);
11470 103274         eptr = SvPVX_const(nsv);
11471 103274         elen = SvCUR(nsv);
11472            
11473 103274 100       if (width) { /* fudge width (can't fudge elen) */
11474 14         width += elen - old_elen;
11475           }
11476           is_utf8 = TRUE;
11477           }
11478           }
11479            
11480 20360204         have = esignlen + zeros + elen;
11481 20360204 50       if (have < zeros)
11482 0         croak_memory_wrap();
11483            
11484 20360204         need = (have > width ? have : width);
11485 20360204         gap = need - have;
11486            
11487 20360204 50       if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
11488 0         croak_memory_wrap();
11489 20360204 50       SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
    100        
11490 20360204         p = SvEND(sv);
11491 20360204 100       if (esignlen && fill == '0') {
11492           int i;
11493 2974 100       for (i = 0; i < (int)esignlen; i++)
11494 2136         *p++ = esignbuf[i];
11495           }
11496 20360204 100       if (gap && !left) {
    100        
11497 1151707         memset(p, fill, gap);
11498 1151707         p += gap;
11499           }
11500 20360204 100       if (esignlen && fill != '0') {
11501           int i;
11502 832267 100       for (i = 0; i < (int)esignlen; i++)
11503 662534         *p++ = esignbuf[i];
11504           }
11505 20360204 100       if (zeros) {
11506           int i;
11507 7396 100       for (i = zeros; i; i--)
11508 3798         *p++ = '0';
11509           }
11510 20360204 100       if (elen) {
11511 20240342         Copy(eptr, p, elen, char);
11512 20240342         p += elen;
11513           }
11514 20360204 100       if (gap && left) {
    100        
11515           memset(p, ' ', gap);
11516 75216         p += gap;
11517           }
11518 20360204 100       if (vectorize) {
11519 15054 100       if (veclen) {
11520 10038         Copy(dotstr, p, dotstrlen, char);
11521 10038         p += dotstrlen;
11522           }
11523           else
11524           vectorize = FALSE; /* done iterating over vecstr */
11525           }
11526 20360204 100       if (is_utf8)
11527           has_utf8 = TRUE;
11528 20360204 100       if (has_utf8)
11529 138600         SvUTF8_on(sv);
11530 20360204         *p = '\0';
11531 20360204         SvCUR_set(sv, p - SvPVX_const(sv));
11532 20360204 100       if (vectorize) {
11533           esignlen = 0;
11534           goto vector;
11535           }
11536           }
11537 11825776 100       SvTAINT(sv);
    100        
    50        
11538            
11539           #ifdef USE_LOCALE_NUMERIC /* Done outside loop, so don't have to save/restore
11540           each iteration. */
11541 11825776 50       if (oldlocale) {
11542 0         setlocale(LC_NUMERIC, SvPVX(oldlocale));
11543 5939865         PL_numeric_standard = FALSE;
11544           }
11545           #endif
11546           }
11547            
11548           /* =========================================================================
11549            
11550           =head1 Cloning an interpreter
11551            
11552           All the macros and functions in this section are for the private use of
11553           the main function, perl_clone().
11554            
11555           The foo_dup() functions make an exact copy of an existing foo thingy.
11556           During the course of a cloning, a hash table is used to map old addresses
11557           to new addresses. The table is created and manipulated with the
11558           ptr_table_* functions.
11559            
11560           =cut
11561            
11562           * =========================================================================*/
11563            
11564            
11565           #if defined(USE_ITHREADS)
11566            
11567           /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
11568           #ifndef GpREFCNT_inc
11569           # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
11570           #endif
11571            
11572            
11573           /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
11574           that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
11575           If this changes, please unmerge ss_dup.
11576           Likewise, sv_dup_inc_multiple() relies on this fact. */
11577           #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup_inc(s,t))
11578           #define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t))
11579           #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
11580           #define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t))
11581           #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
11582           #define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t))
11583           #define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t))
11584           #define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t))
11585           #define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t))
11586           #define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t))
11587           #define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t))
11588           #define SAVEPV(p) ((p) ? savepv(p) : NULL)
11589           #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
11590            
11591           /* clone a parser */
11592            
11593           yy_parser *
11594           Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
11595           {
11596           yy_parser *parser;
11597            
11598           PERL_ARGS_ASSERT_PARSER_DUP;
11599            
11600           if (!proto)
11601           return NULL;
11602            
11603           /* look for it in the table first */
11604           parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
11605           if (parser)
11606           return parser;
11607            
11608           /* create anew and remember what it is */
11609           Newxz(parser, 1, yy_parser);
11610           ptr_table_store(PL_ptr_table, proto, parser);
11611            
11612           /* XXX these not yet duped */
11613           parser->old_parser = NULL;
11614           parser->stack = NULL;
11615           parser->ps = NULL;
11616           parser->stack_size = 0;
11617           /* XXX parser->stack->state = 0; */
11618            
11619           /* XXX eventually, just Copy() most of the parser struct ? */
11620            
11621           parser->lex_brackets = proto->lex_brackets;
11622           parser->lex_casemods = proto->lex_casemods;
11623           parser->lex_brackstack = savepvn(proto->lex_brackstack,
11624           (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
11625           parser->lex_casestack = savepvn(proto->lex_casestack,
11626           (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
11627           parser->lex_defer = proto->lex_defer;
11628           parser->lex_dojoin = proto->lex_dojoin;
11629           parser->lex_expect = proto->lex_expect;
11630           parser->lex_formbrack = proto->lex_formbrack;
11631           parser->lex_inpat = proto->lex_inpat;
11632           parser->lex_inwhat = proto->lex_inwhat;
11633           parser->lex_op = proto->lex_op;
11634           parser->lex_repl = sv_dup_inc(proto->lex_repl, param);
11635           parser->lex_starts = proto->lex_starts;
11636           parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param);
11637           parser->multi_close = proto->multi_close;
11638           parser->multi_open = proto->multi_open;
11639           parser->multi_start = proto->multi_start;
11640           parser->multi_end = proto->multi_end;
11641           parser->preambled = proto->preambled;
11642           parser->sublex_info = proto->sublex_info; /* XXX not quite right */
11643           parser->linestr = sv_dup_inc(proto->linestr, param);
11644           parser->expect = proto->expect;
11645           parser->copline = proto->copline;
11646           parser->last_lop_op = proto->last_lop_op;
11647           parser->lex_state = proto->lex_state;
11648           parser->rsfp = fp_dup(proto->rsfp, '<', param);
11649           /* rsfp_filters entries have fake IoDIRP() */
11650           parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
11651           parser->in_my = proto->in_my;
11652           parser->in_my_stash = hv_dup(proto->in_my_stash, param);
11653           parser->error_count = proto->error_count;
11654            
11655            
11656           parser->linestr = sv_dup_inc(proto->linestr, param);
11657            
11658           {
11659           char * const ols = SvPVX(proto->linestr);
11660           char * const ls = SvPVX(parser->linestr);
11661            
11662           parser->bufptr = ls + (proto->bufptr >= ols ?
11663           proto->bufptr - ols : 0);
11664           parser->oldbufptr = ls + (proto->oldbufptr >= ols ?
11665           proto->oldbufptr - ols : 0);
11666           parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
11667           proto->oldoldbufptr - ols : 0);
11668           parser->linestart = ls + (proto->linestart >= ols ?
11669           proto->linestart - ols : 0);
11670           parser->last_uni = ls + (proto->last_uni >= ols ?
11671           proto->last_uni - ols : 0);
11672           parser->last_lop = ls + (proto->last_lop >= ols ?
11673           proto->last_lop - ols : 0);
11674            
11675           parser->bufend = ls + SvCUR(parser->linestr);
11676           }
11677            
11678           Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
11679            
11680            
11681           #ifdef PERL_MAD
11682           parser->endwhite = proto->endwhite;
11683           parser->faketokens = proto->faketokens;
11684           parser->lasttoke = proto->lasttoke;
11685           parser->nextwhite = proto->nextwhite;
11686           parser->realtokenstart = proto->realtokenstart;
11687           parser->skipwhite = proto->skipwhite;
11688           parser->thisclose = proto->thisclose;
11689           parser->thismad = proto->thismad;
11690           parser->thisopen = proto->thisopen;
11691           parser->thisstuff = proto->thisstuff;
11692           parser->thistoken = proto->thistoken;
11693           parser->thiswhite = proto->thiswhite;
11694            
11695           Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
11696           parser->curforce = proto->curforce;
11697           #else
11698           Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
11699           Copy(proto->nexttype, parser->nexttype, 5, I32);
11700           parser->nexttoke = proto->nexttoke;
11701           #endif
11702            
11703           /* XXX should clone saved_curcop here, but we aren't passed
11704           * proto_perl; so do it in perl_clone_using instead */
11705            
11706           return parser;
11707           }
11708            
11709            
11710           /* duplicate a file handle */
11711            
11712           PerlIO *
11713           Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
11714           {
11715           PerlIO *ret;
11716            
11717           PERL_ARGS_ASSERT_FP_DUP;
11718           PERL_UNUSED_ARG(type);
11719            
11720           if (!fp)
11721           return (PerlIO*)NULL;
11722            
11723           /* look for it in the table first */
11724           ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
11725           if (ret)
11726           return ret;
11727            
11728           /* create anew and remember what it is */
11729           ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
11730           ptr_table_store(PL_ptr_table, fp, ret);
11731           return ret;
11732           }
11733            
11734           /* duplicate a directory handle */
11735            
11736           DIR *
11737           Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
11738           {
11739           DIR *ret;
11740            
11741           #ifdef HAS_FCHDIR
11742           DIR *pwd;
11743           const Direntry_t *dirent;
11744           char smallbuf[256];
11745           char *name = NULL;
11746           STRLEN len = 0;
11747           long pos;
11748           #endif
11749            
11750           PERL_UNUSED_CONTEXT;
11751           PERL_ARGS_ASSERT_DIRP_DUP;
11752            
11753           if (!dp)
11754           return (DIR*)NULL;
11755            
11756           /* look for it in the table first */
11757           ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
11758           if (ret)
11759           return ret;
11760            
11761           #ifdef HAS_FCHDIR
11762            
11763           PERL_UNUSED_ARG(param);
11764            
11765           /* create anew */
11766            
11767           /* open the current directory (so we can switch back) */
11768           if (!(pwd = PerlDir_open("."))) return (DIR *)NULL;
11769            
11770           /* chdir to our dir handle and open the present working directory */
11771           if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) {
11772           PerlDir_close(pwd);
11773           return (DIR *)NULL;
11774           }
11775           /* Now we should have two dir handles pointing to the same dir. */
11776            
11777           /* Be nice to the calling code and chdir back to where we were. */
11778           fchdir(my_dirfd(pwd)); /* If this fails, then what? */
11779            
11780           /* We have no need of the pwd handle any more. */
11781           PerlDir_close(pwd);
11782            
11783           #ifdef DIRNAMLEN
11784           # define d_namlen(d) (d)->d_namlen
11785           #else
11786           # define d_namlen(d) strlen((d)->d_name)
11787           #endif
11788           /* Iterate once through dp, to get the file name at the current posi-
11789           tion. Then step back. */
11790           pos = PerlDir_tell(dp);
11791           if ((dirent = PerlDir_read(dp))) {
11792           len = d_namlen(dirent);
11793           if (len <= sizeof smallbuf) name = smallbuf;
11794           else Newx(name, len, char);
11795           Move(dirent->d_name, name, len, char);
11796           }
11797           PerlDir_seek(dp, pos);
11798            
11799           /* Iterate through the new dir handle, till we find a file with the
11800           right name. */
11801           if (!dirent) /* just before the end */
11802           for(;;) {
11803           pos = PerlDir_tell(ret);
11804           if (PerlDir_read(ret)) continue; /* not there yet */
11805           PerlDir_seek(ret, pos); /* step back */
11806           break;
11807           }
11808           else {
11809           const long pos0 = PerlDir_tell(ret);
11810           for(;;) {
11811           pos = PerlDir_tell(ret);
11812           if ((dirent = PerlDir_read(ret))) {
11813           if (len == d_namlen(dirent)
11814           && memEQ(name, dirent->d_name, len)) {
11815           /* found it */
11816           PerlDir_seek(ret, pos); /* step back */
11817           break;
11818           }
11819           /* else we are not there yet; keep iterating */
11820           }
11821           else { /* This is not meant to happen. The best we can do is
11822           reset the iterator to the beginning. */
11823           PerlDir_seek(ret, pos0);
11824           break;
11825           }
11826           }
11827           }
11828           #undef d_namlen
11829            
11830           if (name && name != smallbuf)
11831           Safefree(name);
11832           #endif
11833            
11834           #ifdef WIN32
11835           ret = win32_dirp_dup(dp, param);
11836           #endif
11837            
11838           /* pop it in the pointer table */
11839           if (ret)
11840           ptr_table_store(PL_ptr_table, dp, ret);
11841            
11842           return ret;
11843           }
11844            
11845           /* duplicate a typeglob */
11846            
11847           GP *
11848           Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
11849           {
11850           GP *ret;
11851            
11852           PERL_ARGS_ASSERT_GP_DUP;
11853            
11854           if (!gp)
11855           return (GP*)NULL;
11856           /* look for it in the table first */
11857           ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
11858           if (ret)
11859           return ret;
11860            
11861           /* create anew and remember what it is */
11862           Newxz(ret, 1, GP);
11863           ptr_table_store(PL_ptr_table, gp, ret);
11864            
11865           /* clone */
11866           /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
11867           on Newxz() to do this for us. */
11868           ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
11869           ret->gp_io = io_dup_inc(gp->gp_io, param);
11870           ret->gp_form = cv_dup_inc(gp->gp_form, param);
11871           ret->gp_av = av_dup_inc(gp->gp_av, param);
11872           ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
11873           ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
11874           ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
11875           ret->gp_cvgen = gp->gp_cvgen;
11876           ret->gp_line = gp->gp_line;
11877           ret->gp_file_hek = hek_dup(gp->gp_file_hek, param);
11878           return ret;
11879           }
11880            
11881           /* duplicate a chain of magic */
11882            
11883           MAGIC *
11884           Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
11885           {
11886           MAGIC *mgret = NULL;
11887           MAGIC **mgprev_p = &mgret;
11888            
11889           PERL_ARGS_ASSERT_MG_DUP;
11890            
11891           for (; mg; mg = mg->mg_moremagic) {
11892           MAGIC *nmg;
11893            
11894           if ((param->flags & CLONEf_JOIN_IN)
11895           && mg->mg_type == PERL_MAGIC_backref)
11896           /* when joining, we let the individual SVs add themselves to
11897           * backref as needed. */
11898           continue;
11899            
11900           Newx(nmg, 1, MAGIC);
11901           *mgprev_p = nmg;
11902           mgprev_p = &(nmg->mg_moremagic);
11903            
11904           /* There was a comment "XXX copy dynamic vtable?" but as we don't have
11905           dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
11906           from the original commit adding Perl_mg_dup() - revision 4538.
11907           Similarly there is the annotation "XXX random ptr?" next to the
11908           assignment to nmg->mg_ptr. */
11909           *nmg = *mg;
11910            
11911           /* FIXME for plugins
11912           if (nmg->mg_type == PERL_MAGIC_qr) {
11913           nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
11914           }
11915           else
11916           */
11917           nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
11918           ? nmg->mg_type == PERL_MAGIC_backref
11919           /* The backref AV has its reference
11920           * count deliberately bumped by 1 */
11921           ? SvREFCNT_inc(av_dup_inc((const AV *)
11922           nmg->mg_obj, param))
11923           : sv_dup_inc(nmg->mg_obj, param)
11924           : sv_dup(nmg->mg_obj, param);
11925            
11926           if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
11927           if (nmg->mg_len > 0) {
11928           nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
11929           if (nmg->mg_type == PERL_MAGIC_overload_table &&
11930           AMT_AMAGIC((AMT*)nmg->mg_ptr))
11931           {
11932           AMT * const namtp = (AMT*)nmg->mg_ptr;
11933           sv_dup_inc_multiple((SV**)(namtp->table),
11934           (SV**)(namtp->table), NofAMmeth, param);
11935           }
11936           }
11937           else if (nmg->mg_len == HEf_SVKEY)
11938           nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
11939           }
11940           if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
11941           nmg->mg_virtual->svt_dup(aTHX_ nmg, param);
11942           }
11943           }
11944           return mgret;
11945           }
11946            
11947           #endif /* USE_ITHREADS */
11948            
11949           struct ptr_tbl_arena {
11950           struct ptr_tbl_arena *next;
11951           struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers. */
11952           };
11953            
11954           /* create a new pointer-mapping table */
11955            
11956           PTR_TBL_t *
11957 366176         Perl_ptr_table_new(pTHX)
11958           {
11959           PTR_TBL_t *tbl;
11960           PERL_UNUSED_CONTEXT;
11961            
11962 366176         Newx(tbl, 1, PTR_TBL_t);
11963 366176         tbl->tbl_max = 511;
11964 366176         tbl->tbl_items = 0;
11965 366176         tbl->tbl_arena = NULL;
11966 366176         tbl->tbl_arena_next = NULL;
11967 366176         tbl->tbl_arena_end = NULL;
11968 366176 50       Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
11969 366176         return tbl;
11970           }
11971            
11972           #define PTR_TABLE_HASH(ptr) \
11973           ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
11974            
11975           /* map an existing pointer using a table */
11976            
11977           STATIC PTR_TBL_ENT_t *
11978           S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
11979           {
11980           PTR_TBL_ENT_t *tblent;
11981 338571340         const UV hash = PTR_TABLE_HASH(sv);
11982            
11983           PERL_ARGS_ASSERT_PTR_TABLE_FIND;
11984            
11985 338571340         tblent = tbl->tbl_ary[hash & tbl->tbl_max];
11986 317437498 100       for (; tblent; tblent = tblent->next) {
    100        
11987 147978318 50       if (tblent->oldval == sv)
    100        
11988           return tblent;
11989           }
11990           return NULL;
11991           }
11992            
11993           void *
11994 169290928         Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
11995           {
11996           PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
11997            
11998           PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
11999           PERL_UNUSED_CONTEXT;
12000            
12001 169290928 100       return tblent ? tblent->newval : NULL;
12002           }
12003            
12004           /* add a new entry to a pointer-mapping table */
12005            
12006           void
12007 169280412         Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
12008           {
12009           PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
12010            
12011           PERL_ARGS_ASSERT_PTR_TABLE_STORE;
12012           PERL_UNUSED_CONTEXT;
12013            
12014 169280412 50       if (tblent) {
12015 0         tblent->newval = newsv;
12016           } else {
12017 169280412         const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
12018            
12019 169280412 100       if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
12020           struct ptr_tbl_arena *new_arena;
12021            
12022 719932         Newx(new_arena, 1, struct ptr_tbl_arena);
12023 719932         new_arena->next = tbl->tbl_arena;
12024 719932         tbl->tbl_arena = new_arena;
12025 719932         tbl->tbl_arena_next = new_arena->array;
12026 719932         tbl->tbl_arena_end = new_arena->array
12027 719932         + sizeof(new_arena->array) / sizeof(new_arena->array[0]);
12028           }
12029            
12030 169280412         tblent = tbl->tbl_arena_next++;
12031            
12032 169280412         tblent->oldval = oldsv;
12033 169280412         tblent->newval = newsv;
12034 169280412         tblent->next = tbl->tbl_ary[entry];
12035 169280412         tbl->tbl_ary[entry] = tblent;
12036 169280412         tbl->tbl_items++;
12037 169280412 100       if (tblent->next && tbl->tbl_items > tbl->tbl_max)
    100        
12038 114128         ptr_table_split(tbl);
12039           }
12040 169280412         }
12041            
12042           /* double the hash bucket size of an existing ptr table */
12043            
12044           void
12045 114130         Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
12046           {
12047 114130         PTR_TBL_ENT_t **ary = tbl->tbl_ary;
12048 114130         const UV oldsize = tbl->tbl_max + 1;
12049 114130         UV newsize = oldsize * 2;
12050           UV i;
12051            
12052           PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
12053           PERL_UNUSED_CONTEXT;
12054            
12055 114130 50       Renew(ary, newsize, PTR_TBL_ENT_t*);
12056 114130 50       Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
12057 114130         tbl->tbl_max = --newsize;
12058 114130         tbl->tbl_ary = ary;
12059 145558994 100       for (i=0; i < oldsize; i++, ary++) {
12060           PTR_TBL_ENT_t **entp = ary;
12061 145444864         PTR_TBL_ENT_t *ent = *ary;
12062           PTR_TBL_ENT_t **curentp;
12063 145444864 100       if (!ent)
12064 48989868         continue;
12065 96454996         curentp = ary + oldsize;
12066           do {
12067 145571460 100       if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
12068 72859810         *entp = ent->next;
12069 72859810         ent->next = *curentp;
12070 72859810         *curentp = ent;
12071           }
12072           else
12073 72711650         entp = &ent->next;
12074 145571460         ent = *entp;
12075 145571460 100       } while (ent);
12076           }
12077 114130         }
12078            
12079           /* remove all the entries from a ptr table */
12080           /* Deprecated - will be removed post 5.14 */
12081            
12082           void
12083 2         Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
12084           {
12085 2 50       if (tbl && tbl->tbl_items) {
    50        
12086 2         struct ptr_tbl_arena *arena = tbl->tbl_arena;
12087            
12088 2 50       Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
12089            
12090 4 100       while (arena) {
12091 2         struct ptr_tbl_arena *next = arena->next;
12092            
12093 2         Safefree(arena);
12094           arena = next;
12095           };
12096            
12097 2         tbl->tbl_items = 0;
12098 2         tbl->tbl_arena = NULL;
12099 2         tbl->tbl_arena_next = NULL;
12100 2         tbl->tbl_arena_end = NULL;
12101           }
12102 2         }
12103            
12104           /* clear and free a ptr table */
12105            
12106           void
12107 366176         Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
12108           {
12109           struct ptr_tbl_arena *arena;
12110            
12111 366176 50       if (!tbl) {
12112 366176         return;
12113           }
12114            
12115 366176         arena = tbl->tbl_arena;
12116            
12117 1268835 100       while (arena) {
12118 719930         struct ptr_tbl_arena *next = arena->next;
12119            
12120 719930         Safefree(arena);
12121           arena = next;
12122           }
12123            
12124 366176         Safefree(tbl->tbl_ary);
12125 366176         Safefree(tbl);
12126           }
12127            
12128           #if defined(USE_ITHREADS)
12129            
12130           void
12131           Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
12132           {
12133           PERL_ARGS_ASSERT_RVPV_DUP;
12134            
12135           assert(!isREGEXP(sstr));
12136           if (SvROK(sstr)) {
12137           if (SvWEAKREF(sstr)) {
12138           SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
12139           if (param->flags & CLONEf_JOIN_IN) {
12140           /* if joining, we add any back references individually rather
12141           * than copying the whole backref array */
12142           Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
12143           }
12144           }
12145           else
12146           SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
12147           }
12148           else if (SvPVX_const(sstr)) {
12149           /* Has something there */
12150           if (SvLEN(sstr)) {
12151           /* Normal PV - clone whole allocated space */
12152           SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
12153           /* sstr may not be that normal, but actually copy on write.
12154           But we are a true, independent SV, so: */
12155           SvIsCOW_off(dstr);
12156           }
12157           else {
12158           /* Special case - not normally malloced for some reason */
12159           if (isGV_with_GP(sstr)) {
12160           /* Don't need to do anything here. */
12161           }
12162           else if ((SvIsCOW(sstr))) {
12163           /* A "shared" PV - clone it as "shared" PV */
12164           SvPV_set(dstr,
12165           HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
12166           param)));
12167           }
12168           else {
12169           /* Some other special case - random pointer */
12170           SvPV_set(dstr, (char *) SvPVX_const(sstr));
12171           }
12172           }
12173           }
12174           else {
12175           /* Copy the NULL */
12176           SvPV_set(dstr, NULL);
12177           }
12178           }
12179            
12180           /* duplicate a list of SVs. source and dest may point to the same memory. */
12181           static SV **
12182           S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
12183           SSize_t items, CLONE_PARAMS *const param)
12184           {
12185           PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
12186            
12187           while (items-- > 0) {
12188           *dest++ = sv_dup_inc(*source++, param);
12189           }
12190            
12191           return dest;
12192           }
12193            
12194           /* duplicate an SV of any type (including AV, HV etc) */
12195            
12196           static SV *
12197           S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12198           {
12199           dVAR;
12200           SV *dstr;
12201            
12202           PERL_ARGS_ASSERT_SV_DUP_COMMON;
12203            
12204           if (SvTYPE(sstr) == (svtype)SVTYPEMASK) {
12205           #ifdef DEBUG_LEAKING_SCALARS_ABORT
12206           abort();
12207           #endif
12208           return NULL;
12209           }
12210           /* look for it in the table first */
12211           dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
12212           if (dstr)
12213           return dstr;
12214            
12215           if(param->flags & CLONEf_JOIN_IN) {
12216           /** We are joining here so we don't want do clone
12217           something that is bad **/
12218           if (SvTYPE(sstr) == SVt_PVHV) {
12219           const HEK * const hvname = HvNAME_HEK(sstr);
12220           if (hvname) {
12221           /** don't clone stashes if they already exist **/
12222           dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
12223           HEK_UTF8(hvname) ? SVf_UTF8 : 0));
12224           ptr_table_store(PL_ptr_table, sstr, dstr);
12225           return dstr;
12226           }
12227           }
12228           else if (SvTYPE(sstr) == SVt_PVGV && !SvFAKE(sstr)) {
12229           HV *stash = GvSTASH(sstr);
12230           const HEK * hvname;
12231           if (stash && (hvname = HvNAME_HEK(stash))) {
12232           /** don't clone GVs if they already exist **/
12233           SV **svp;
12234           stash = gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
12235           HEK_UTF8(hvname) ? SVf_UTF8 : 0);
12236           svp = hv_fetch(
12237           stash, GvNAME(sstr),
12238           GvNAMEUTF8(sstr)
12239           ? -GvNAMELEN(sstr)
12240           : GvNAMELEN(sstr),
12241           0
12242           );
12243           if (svp && *svp && SvTYPE(*svp) == SVt_PVGV) {
12244           ptr_table_store(PL_ptr_table, sstr, *svp);
12245           return *svp;
12246           }
12247           }
12248           }
12249           }
12250            
12251           /* create anew and remember what it is */
12252           new_SV(dstr);
12253            
12254           #ifdef DEBUG_LEAKING_SCALARS
12255           dstr->sv_debug_optype = sstr->sv_debug_optype;
12256           dstr->sv_debug_line = sstr->sv_debug_line;
12257           dstr->sv_debug_inpad = sstr->sv_debug_inpad;
12258           dstr->sv_debug_parent = (SV*)sstr;
12259           FREE_SV_DEBUG_FILE(dstr);
12260           dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
12261           #endif
12262            
12263           ptr_table_store(PL_ptr_table, sstr, dstr);
12264            
12265           /* clone */
12266           SvFLAGS(dstr) = SvFLAGS(sstr);
12267           SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
12268           SvREFCNT(dstr) = 0; /* must be before any other dups! */
12269            
12270           #ifdef DEBUGGING
12271           if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
12272           PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
12273           (void*)PL_watch_pvx, SvPVX_const(sstr));
12274           #endif
12275            
12276           /* don't clone objects whose class has asked us not to */
12277           if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
12278           SvFLAGS(dstr) = 0;
12279           return dstr;
12280           }
12281            
12282           switch (SvTYPE(sstr)) {
12283           case SVt_NULL:
12284           SvANY(dstr) = NULL;
12285           break;
12286           case SVt_IV:
12287           SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
12288           if(SvROK(sstr)) {
12289           Perl_rvpv_dup(aTHX_ dstr, sstr, param);
12290           } else {
12291           SvIV_set(dstr, SvIVX(sstr));
12292           }
12293           break;
12294           case SVt_NV:
12295           SvANY(dstr) = new_XNV();
12296           SvNV_set(dstr, SvNVX(sstr));
12297           break;
12298           default:
12299           {
12300           /* These are all the types that need complex bodies allocating. */
12301           void *new_body;
12302           const svtype sv_type = SvTYPE(sstr);
12303           const struct body_details *const sv_type_details
12304           = bodies_by_type + sv_type;
12305            
12306           switch (sv_type) {
12307           default:
12308           Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
12309           break;
12310            
12311           case SVt_PVGV:
12312           case SVt_PVIO:
12313           case SVt_PVFM:
12314           case SVt_PVHV:
12315           case SVt_PVAV:
12316           case SVt_PVCV:
12317           case SVt_PVLV:
12318           case SVt_REGEXP:
12319           case SVt_PVMG:
12320           case SVt_PVNV:
12321           case SVt_PVIV:
12322           case SVt_INVLIST:
12323           case SVt_PV:
12324           assert(sv_type_details->body_size);
12325           if (sv_type_details->arena) {
12326           new_body_inline(new_body, sv_type);
12327           new_body
12328           = (void*)((char*)new_body - sv_type_details->offset);
12329           } else {
12330           new_body = new_NOARENA(sv_type_details);
12331           }
12332           }
12333           assert(new_body);
12334           SvANY(dstr) = new_body;
12335            
12336           #ifndef PURIFY
12337           Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
12338           ((char*)SvANY(dstr)) + sv_type_details->offset,
12339           sv_type_details->copy, char);
12340           #else
12341           Copy(((char*)SvANY(sstr)),
12342           ((char*)SvANY(dstr)),
12343           sv_type_details->body_size + sv_type_details->offset, char);
12344           #endif
12345            
12346           if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
12347           && !isGV_with_GP(dstr)
12348           && !isREGEXP(dstr)
12349           && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
12350           Perl_rvpv_dup(aTHX_ dstr, sstr, param);
12351            
12352           /* The Copy above means that all the source (unduplicated) pointers
12353           are now in the destination. We can check the flags and the
12354           pointers in either, but it's possible that there's less cache
12355           missing by always going for the destination.
12356           FIXME - instrument and check that assumption */
12357           if (sv_type >= SVt_PVMG) {
12358           if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
12359           SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
12360           } else if (sv_type == SVt_PVAV && AvPAD_NAMELIST(dstr)) {
12361           NOOP;
12362           } else if (SvMAGIC(dstr))
12363           SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
12364           if (SvOBJECT(dstr) && SvSTASH(dstr))
12365           SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
12366           else SvSTASH_set(dstr, 0); /* don't copy DESTROY cache */
12367           }
12368            
12369           /* The cast silences a GCC warning about unhandled types. */
12370           switch ((int)sv_type) {
12371           case SVt_PV:
12372           break;
12373           case SVt_PVIV:
12374           break;
12375           case SVt_PVNV:
12376           break;
12377           case SVt_PVMG:
12378           break;
12379           case SVt_REGEXP:
12380           duprex:
12381           /* FIXME for plugins */
12382           dstr->sv_u.svu_rx = ((REGEXP *)dstr)->sv_any;
12383           re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
12384           break;
12385           case SVt_PVLV:
12386           /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
12387           if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
12388           LvTARG(dstr) = dstr;
12389           else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
12390           LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
12391           else
12392           LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
12393           if (isREGEXP(sstr)) goto duprex;
12394           case SVt_PVGV:
12395           /* non-GP case already handled above */
12396           if(isGV_with_GP(sstr)) {
12397           GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
12398           /* Don't call sv_add_backref here as it's going to be
12399           created as part of the magic cloning of the symbol
12400           table--unless this is during a join and the stash
12401           is not actually being cloned. */
12402           /* Danger Will Robinson - GvGP(dstr) isn't initialised
12403           at the point of this comment. */
12404           GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
12405           if (param->flags & CLONEf_JOIN_IN)
12406           Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
12407           GvGP_set(dstr, gp_dup(GvGP(sstr), param));
12408           (void)GpREFCNT_inc(GvGP(dstr));
12409           }
12410           break;
12411           case SVt_PVIO:
12412           /* PL_parser->rsfp_filters entries have fake IoDIRP() */
12413           if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
12414           /* I have no idea why fake dirp (rsfps)
12415           should be treated differently but otherwise
12416           we end up with leaks -- sky*/
12417           IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
12418           IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
12419           IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
12420           } else {
12421           IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
12422           IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
12423           IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
12424           if (IoDIRP(dstr)) {
12425           IoDIRP(dstr) = dirp_dup(IoDIRP(dstr), param);
12426           } else {
12427           NOOP;
12428           /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
12429           }
12430           IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(dstr), param);
12431           }
12432           if (IoOFP(dstr) == IoIFP(sstr))
12433           IoOFP(dstr) = IoIFP(dstr);
12434           else
12435           IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
12436           IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
12437           IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
12438           IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
12439           break;
12440           case SVt_PVAV:
12441           /* avoid cloning an empty array */
12442           if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
12443           SV **dst_ary, **src_ary;
12444           SSize_t items = AvFILLp((const AV *)sstr) + 1;
12445            
12446           src_ary = AvARRAY((const AV *)sstr);
12447           Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
12448           ptr_table_store(PL_ptr_table, src_ary, dst_ary);
12449           AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
12450           AvALLOC((const AV *)dstr) = dst_ary;
12451           if (AvREAL((const AV *)sstr)) {
12452           dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
12453           param);
12454           }
12455           else {
12456           while (items-- > 0)
12457           *dst_ary++ = sv_dup(*src_ary++, param);
12458           }
12459           items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
12460           while (items-- > 0) {
12461           *dst_ary++ = &PL_sv_undef;
12462           }
12463           }
12464           else {
12465           AvARRAY(MUTABLE_AV(dstr)) = NULL;
12466           AvALLOC((const AV *)dstr) = (SV**)NULL;
12467           AvMAX( (const AV *)dstr) = -1;
12468           AvFILLp((const AV *)dstr) = -1;
12469           }
12470           break;
12471           case SVt_PVHV:
12472           if (HvARRAY((const HV *)sstr)) {
12473           STRLEN i = 0;
12474           const bool sharekeys = !!HvSHAREKEYS(sstr);
12475           XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
12476           XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
12477           char *darray;
12478           Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
12479           + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
12480           char);
12481           HvARRAY(dstr) = (HE**)darray;
12482           while (i <= sxhv->xhv_max) {
12483           const HE * const source = HvARRAY(sstr)[i];
12484           HvARRAY(dstr)[i] = source
12485           ? he_dup(source, sharekeys, param) : 0;
12486           ++i;
12487           }
12488           if (SvOOK(sstr)) {
12489           const struct xpvhv_aux * const saux = HvAUX(sstr);
12490           struct xpvhv_aux * const daux = HvAUX(dstr);
12491           /* This flag isn't copied. */
12492           SvOOK_on(dstr);
12493            
12494           if (saux->xhv_name_count) {
12495           HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
12496           const I32 count
12497           = saux->xhv_name_count < 0
12498           ? -saux->xhv_name_count
12499           : saux->xhv_name_count;
12500           HEK **shekp = sname + count;
12501           HEK **dhekp;
12502           Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *);
12503           dhekp = daux->xhv_name_u.xhvnameu_names + count;
12504           while (shekp-- > sname) {
12505           dhekp--;
12506           *dhekp = hek_dup(*shekp, param);
12507           }
12508           }
12509           else {
12510           daux->xhv_name_u.xhvnameu_name
12511           = hek_dup(saux->xhv_name_u.xhvnameu_name,
12512           param);
12513           }
12514           daux->xhv_name_count = saux->xhv_name_count;
12515            
12516           daux->xhv_fill_lazy = saux->xhv_fill_lazy;
12517           daux->xhv_riter = saux->xhv_riter;
12518           daux->xhv_eiter = saux->xhv_eiter
12519           ? he_dup(saux->xhv_eiter,
12520           cBOOL(HvSHAREKEYS(sstr)), param) : 0;
12521           /* backref array needs refcnt=2; see sv_add_backref */
12522           daux->xhv_backreferences =
12523           (param->flags & CLONEf_JOIN_IN)
12524           /* when joining, we let the individual GVs and
12525           * CVs add themselves to backref as
12526           * needed. This avoids pulling in stuff
12527           * that isn't required, and simplifies the
12528           * case where stashes aren't cloned back
12529           * if they already exist in the parent
12530           * thread */
12531           ? NULL
12532           : saux->xhv_backreferences
12533           ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
12534           ? MUTABLE_AV(SvREFCNT_inc(
12535           sv_dup_inc((const SV *)
12536           saux->xhv_backreferences, param)))
12537           : MUTABLE_AV(sv_dup((const SV *)
12538           saux->xhv_backreferences, param))
12539           : 0;
12540            
12541           daux->xhv_mro_meta = saux->xhv_mro_meta
12542           ? mro_meta_dup(saux->xhv_mro_meta, param)
12543           : 0;
12544            
12545           /* Record stashes for possible cloning in Perl_clone(). */
12546           if (HvNAME(sstr))
12547           av_push(param->stashes, dstr);
12548           }
12549           }
12550           else
12551           HvARRAY(MUTABLE_HV(dstr)) = NULL;
12552           break;
12553           case SVt_PVCV:
12554           if (!(param->flags & CLONEf_COPY_STACKS)) {
12555           CvDEPTH(dstr) = 0;
12556           }
12557           /*FALLTHROUGH*/
12558           case SVt_PVFM:
12559           /* NOTE: not refcounted */
12560           SvANY(MUTABLE_CV(dstr))->xcv_stash =
12561           hv_dup(CvSTASH(dstr), param);
12562           if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
12563           Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
12564           if (!CvISXSUB(dstr)) {
12565           OP_REFCNT_LOCK;
12566           CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
12567           OP_REFCNT_UNLOCK;
12568           CvSLABBED_off(dstr);
12569           } else if (CvCONST(dstr)) {
12570           CvXSUBANY(dstr).any_ptr =
12571           sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
12572           }
12573           assert(!CvSLABBED(dstr));
12574           if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr));
12575           if (CvNAMED(dstr))
12576           SvANY((CV *)dstr)->xcv_gv_u.xcv_hek =
12577           share_hek_hek(CvNAME_HEK((CV *)sstr));
12578           /* don't dup if copying back - CvGV isn't refcounted, so the
12579           * duped GV may never be freed. A bit of a hack! DAPM */
12580           else
12581           SvANY(MUTABLE_CV(dstr))->xcv_gv_u.xcv_gv =
12582           CvCVGV_RC(dstr)
12583           ? gv_dup_inc(CvGV(sstr), param)
12584           : (param->flags & CLONEf_JOIN_IN)
12585           ? NULL
12586           : gv_dup(CvGV(sstr), param);
12587            
12588           CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
12589           CvOUTSIDE(dstr) =
12590           CvWEAKOUTSIDE(sstr)
12591           ? cv_dup( CvOUTSIDE(dstr), param)
12592           : cv_dup_inc(CvOUTSIDE(dstr), param);
12593           break;
12594           }
12595           }
12596           }
12597            
12598           return dstr;
12599           }
12600            
12601           SV *
12602           Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12603           {
12604           PERL_ARGS_ASSERT_SV_DUP_INC;
12605           return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL;
12606           }
12607            
12608           SV *
12609           Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12610           {
12611           SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
12612           PERL_ARGS_ASSERT_SV_DUP;
12613            
12614           /* Track every SV that (at least initially) had a reference count of 0.
12615           We need to do this by holding an actual reference to it in this array.
12616           If we attempt to cheat, turn AvREAL_off(), and store only pointers
12617           (akin to the stashes hash, and the perl stack), we come unstuck if
12618           a weak reference (or other SV legitimately SvREFCNT() == 0 for this
12619           thread) is manipulated in a CLONE method, because CLONE runs before the
12620           unreferenced array is walked to find SVs still with SvREFCNT() == 0
12621           (and fix things up by giving each a reference via the temps stack).
12622           Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
12623           then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
12624           before the walk of unreferenced happens and a reference to that is SV
12625           added to the temps stack. At which point we have the same SV considered
12626           to be in use, and free to be re-used. Not good.
12627           */
12628           if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
12629           assert(param->unreferenced);
12630           av_push(param->unreferenced, SvREFCNT_inc(dstr));
12631           }
12632            
12633           return dstr;
12634           }
12635            
12636           /* duplicate a context */
12637            
12638           PERL_CONTEXT *
12639           Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
12640           {
12641           PERL_CONTEXT *ncxs;
12642            
12643           PERL_ARGS_ASSERT_CX_DUP;
12644            
12645           if (!cxs)
12646           return (PERL_CONTEXT*)NULL;
12647            
12648           /* look for it in the table first */
12649           ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
12650           if (ncxs)
12651           return ncxs;
12652            
12653           /* create anew and remember what it is */
12654           Newx(ncxs, max + 1, PERL_CONTEXT);
12655           ptr_table_store(PL_ptr_table, cxs, ncxs);
12656           Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
12657            
12658           while (ix >= 0) {
12659           PERL_CONTEXT * const ncx = &ncxs[ix];
12660           if (CxTYPE(ncx) == CXt_SUBST) {
12661           Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
12662           }
12663           else {
12664           ncx->blk_oldcop = (COP*)any_dup(ncx->blk_oldcop, param->proto_perl);
12665           switch (CxTYPE(ncx)) {
12666           case CXt_SUB:
12667           ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
12668           ? cv_dup_inc(ncx->blk_sub.cv, param)
12669           : cv_dup(ncx->blk_sub.cv,param));
12670           ncx->blk_sub.argarray = (CxHASARGS(ncx)
12671           ? av_dup_inc(ncx->blk_sub.argarray,
12672           param)
12673           : NULL);
12674           ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,
12675           param);
12676           ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
12677           ncx->blk_sub.oldcomppad);
12678           break;
12679           case CXt_EVAL:
12680           ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
12681           param);
12682           ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
12683           ncx->blk_eval.cv = cv_dup(ncx->blk_eval.cv, param);
12684           break;
12685           case CXt_LOOP_LAZYSV:
12686           ncx->blk_loop.state_u.lazysv.end
12687           = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
12688           /* We are taking advantage of av_dup_inc and sv_dup_inc
12689           actually being the same function, and order equivalence of
12690           the two unions.
12691           We can assert the later [but only at run time :-(] */
12692           assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
12693           (void *) &ncx->blk_loop.state_u.lazysv.cur);
12694           case CXt_LOOP_FOR:
12695           ncx->blk_loop.state_u.ary.ary
12696           = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
12697           case CXt_LOOP_LAZYIV:
12698           case CXt_LOOP_PLAIN:
12699           if (CxPADLOOP(ncx)) {
12700           ncx->blk_loop.itervar_u.oldcomppad
12701           = (PAD*)ptr_table_fetch(PL_ptr_table,
12702           ncx->blk_loop.itervar_u.oldcomppad);
12703           } else {
12704           ncx->blk_loop.itervar_u.gv
12705           = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
12706           param);
12707           }
12708           break;
12709           case CXt_FORMAT:
12710           ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param);
12711           ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param);
12712           ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
12713           param);
12714           break;
12715           case CXt_BLOCK:
12716           case CXt_NULL:
12717           case CXt_WHEN:
12718           case CXt_GIVEN:
12719           break;
12720           }
12721           }
12722           --ix;
12723           }
12724           return ncxs;
12725           }
12726            
12727           /* duplicate a stack info structure */
12728            
12729           PERL_SI *
12730           Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
12731           {
12732           PERL_SI *nsi;
12733            
12734           PERL_ARGS_ASSERT_SI_DUP;
12735            
12736           if (!si)
12737           return (PERL_SI*)NULL;
12738            
12739           /* look for it in the table first */
12740           nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
12741           if (nsi)
12742           return nsi;
12743            
12744           /* create anew and remember what it is */
12745           Newxz(nsi, 1, PERL_SI);
12746           ptr_table_store(PL_ptr_table, si, nsi);
12747            
12748           nsi->si_stack = av_dup_inc(si->si_stack, param);
12749           nsi->si_cxix = si->si_cxix;
12750           nsi->si_cxmax = si->si_cxmax;
12751           nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
12752           nsi->si_type = si->si_type;
12753           nsi->si_prev = si_dup(si->si_prev, param);
12754           nsi->si_next = si_dup(si->si_next, param);
12755           nsi->si_markoff = si->si_markoff;
12756            
12757           return nsi;
12758           }
12759            
12760           #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
12761           #define TOPINT(ss,ix) ((ss)[ix].any_i32)
12762           #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
12763           #define TOPLONG(ss,ix) ((ss)[ix].any_long)
12764           #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
12765           #define TOPIV(ss,ix) ((ss)[ix].any_iv)
12766           #define POPUV(ss,ix) ((ss)[--(ix)].any_uv)
12767           #define TOPUV(ss,ix) ((ss)[ix].any_uv)
12768           #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
12769           #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
12770           #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
12771           #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
12772           #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
12773           #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
12774           #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
12775           #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
12776            
12777           /* XXXXX todo */
12778           #define pv_dup_inc(p) SAVEPV(p)
12779           #define pv_dup(p) SAVEPV(p)
12780           #define svp_dup_inc(p,pp) any_dup(p,pp)
12781            
12782           /* map any object to the new equivent - either something in the
12783           * ptr table, or something in the interpreter structure
12784           */
12785            
12786           void *
12787           Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
12788           {
12789           void *ret;
12790            
12791           PERL_ARGS_ASSERT_ANY_DUP;
12792            
12793           if (!v)
12794           return (void*)NULL;
12795            
12796           /* look for it in the table first */
12797           ret = ptr_table_fetch(PL_ptr_table, v);
12798           if (ret)
12799           return ret;
12800            
12801           /* see if it is part of the interpreter structure */
12802           if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
12803           ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
12804           else {
12805           ret = v;
12806           }
12807            
12808           return ret;
12809           }
12810            
12811           /* duplicate the save stack */
12812            
12813           ANY *
12814           Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
12815           {
12816           dVAR;
12817           ANY * const ss = proto_perl->Isavestack;
12818           const I32 max = proto_perl->Isavestack_max;
12819           I32 ix = proto_perl->Isavestack_ix;
12820           ANY *nss;
12821           const SV *sv;
12822           const GV *gv;
12823           const AV *av;
12824           const HV *hv;
12825           void* ptr;
12826           int intval;
12827           long longval;
12828           GP *gp;
12829           IV iv;
12830           I32 i;
12831           char *c = NULL;
12832           void (*dptr) (void*);
12833           void (*dxptr) (pTHX_ void*);
12834            
12835           PERL_ARGS_ASSERT_SS_DUP;
12836            
12837           Newxz(nss, max, ANY);
12838            
12839           while (ix > 0) {
12840           const UV uv = POPUV(ss,ix);
12841           const U8 type = (U8)uv & SAVE_MASK;
12842            
12843           TOPUV(nss,ix) = uv;
12844           switch (type) {
12845           case SAVEt_CLEARSV:
12846           case SAVEt_CLEARPADRANGE:
12847           break;
12848           case SAVEt_HELEM: /* hash element */
12849           sv = (const SV *)POPPTR(ss,ix);
12850           TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12851           /* fall through */
12852           case SAVEt_ITEM: /* normal string */
12853           case SAVEt_GVSV: /* scalar slot in GV */
12854           case SAVEt_SV: /* scalar reference */
12855           sv = (const SV *)POPPTR(ss,ix);
12856           TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12857           /* fall through */
12858           case SAVEt_FREESV:
12859           case SAVEt_MORTALIZESV:
12860           case SAVEt_READONLY_OFF:
12861           sv = (const SV *)POPPTR(ss,ix);
12862           TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12863           break;
12864           case SAVEt_SHARED_PVREF: /* char* in shared space */
12865           c = (char*)POPPTR(ss,ix);
12866           TOPPTR(nss,ix) = savesharedpv(c);
12867           ptr = POPPTR(ss,ix);
12868           TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12869           break;
12870           case SAVEt_GENERIC_SVREF: /* generic sv */
12871           case SAVEt_SVREF: /* scalar reference */
12872           sv = (const SV *)POPPTR(ss,ix);
12873           TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12874           ptr = POPPTR(ss,ix);
12875           TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
12876           break;
12877           case SAVEt_GVSLOT: /* any slot in GV */
12878           sv = (const SV *)POPPTR(ss,ix);
12879           TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12880           ptr = POPPTR(ss,ix);
12881           TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
12882           sv = (const SV *)POPPTR(ss,ix);
12883           TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12884           break;
12885           case SAVEt_HV: /* hash reference */
12886           case SAVEt_AV: /* array reference */
12887           sv = (const SV *) POPPTR(ss,ix);
12888           TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12889           /* fall through */
12890           case SAVEt_COMPPAD:
12891           case SAVEt_NSTAB:
12892           sv = (const SV *) POPPTR(ss,ix);
12893           TOPPTR(nss,ix) = sv_dup(sv, param);
12894           break;
12895           case SAVEt_INT: /* int reference */
12896           ptr = POPPTR(ss,ix);
12897           TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12898           intval = (int)POPINT(ss,ix);
12899           TOPINT(nss,ix) = intval;
12900           break;
12901           case SAVEt_LONG: /* long reference */
12902           ptr = POPPTR(ss,ix);
12903           TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12904           longval = (long)POPLONG(ss,ix);
12905           TOPLONG(nss,ix) = longval;
12906           break;
12907           case SAVEt_I32: /* I32 reference */
12908           ptr = POPPTR(ss,ix);
12909           TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12910           i = POPINT(ss,ix);
12911           TOPINT(nss,ix) = i;
12912           break;
12913           case SAVEt_IV: /* IV reference */
12914           case SAVEt_STRLEN: /* STRLEN/size_t ref */
12915           ptr = POPPTR(ss,ix);
12916           TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12917           iv = POPIV(ss,ix);
12918           TOPIV(nss,ix) = iv;
12919           break;
12920           case SAVEt_HPTR: /* HV* reference */
12921           case SAVEt_APTR: /* AV* reference */
12922           case SAVEt_SPTR: /* SV* reference */
12923           ptr = POPPTR(ss,ix);
12924           TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12925           sv = (const SV *)POPPTR(ss,ix);
12926           TOPPTR(nss,ix) = sv_dup(sv, param);
12927           break;
12928           case SAVEt_VPTR: /* random* reference */
12929           ptr = POPPTR(ss,ix);
12930           TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12931           /* Fall through */
12932           case SAVEt_INT_SMALL:
12933           case SAVEt_I32_SMALL:
12934           case SAVEt_I16: /* I16 reference */
12935           case SAVEt_I8: /* I8 reference */
12936           case SAVEt_BOOL:
12937           ptr = POPPTR(ss,ix);
12938           TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12939           break;
12940           case SAVEt_GENERIC_PVREF: /* generic char* */
12941           case SAVEt_PPTR: /* char* reference */
12942           ptr = POPPTR(ss,ix);
12943           TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12944           c = (char*)POPPTR(ss,ix);
12945           TOPPTR(nss,ix) = pv_dup(c);
12946           break;
12947           case SAVEt_GP: /* scalar reference */
12948           gp = (GP*)POPPTR(ss,ix);
12949           TOPPTR(nss,ix) = gp = gp_dup(gp, param);
12950           (void)GpREFCNT_inc(gp);
12951           gv = (const GV *)POPPTR(ss,ix);
12952           TOPPTR(nss,ix) = gv_dup_inc(gv, param);
12953           break;
12954           case SAVEt_FREEOP:
12955           ptr = POPPTR(ss,ix);
12956           if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
12957           /* these are assumed to be refcounted properly */
12958           OP *o;
12959           switch (((OP*)ptr)->op_type) {
12960           case OP_LEAVESUB:
12961           case OP_LEAVESUBLV:
12962           case OP_LEAVEEVAL:
12963           case OP_LEAVE:
12964           case OP_SCOPE:
12965           case OP_LEAVEWRITE:
12966           TOPPTR(nss,ix) = ptr;
12967           o = (OP*)ptr;
12968           OP_REFCNT_LOCK;
12969           (void) OpREFCNT_inc(o);
12970           OP_REFCNT_UNLOCK;
12971           break;
12972           default:
12973           TOPPTR(nss,ix) = NULL;
12974           break;
12975           }
12976           }
12977           else
12978           TOPPTR(nss,ix) = NULL;
12979           break;
12980           case SAVEt_FREECOPHH:
12981           ptr = POPPTR(ss,ix);
12982           TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr);
12983           break;
12984           case SAVEt_ADELETE:
12985           av = (const AV *)POPPTR(ss,ix);
12986           TOPPTR(nss,ix) = av_dup_inc(av, param);
12987           i = POPINT(ss,ix);
12988           TOPINT(nss,ix) = i;
12989           break;
12990           case SAVEt_DELETE:
12991           hv = (const HV *)POPPTR(ss,ix);
12992           TOPPTR(nss,ix) = hv_dup_inc(hv, param);
12993           i = POPINT(ss,ix);
12994           TOPINT(nss,ix) = i;
12995           /* Fall through */
12996           case SAVEt_FREEPV:
12997           c = (char*)POPPTR(ss,ix);
12998           TOPPTR(nss,ix) = pv_dup_inc(c);
12999           break;
13000           case SAVEt_STACK_POS: /* Position on Perl stack */
13001           i = POPINT(ss,ix);
13002           TOPINT(nss,ix) = i;
13003           break;
13004           case SAVEt_DESTRUCTOR:
13005           ptr = POPPTR(ss,ix);
13006           TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
13007           dptr = POPDPTR(ss,ix);
13008           TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
13009           any_dup(FPTR2DPTR(void *, dptr),
13010           proto_perl));
13011           break;
13012           case SAVEt_DESTRUCTOR_X:
13013           ptr = POPPTR(ss,ix);
13014           TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
13015           dxptr = POPDXPTR(ss,ix);
13016           TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
13017           any_dup(FPTR2DPTR(void *, dxptr),
13018           proto_perl));
13019           break;
13020           case SAVEt_REGCONTEXT:
13021           case SAVEt_ALLOC:
13022           ix -= uv >> SAVE_TIGHT_SHIFT;
13023           break;
13024           case SAVEt_AELEM: /* array element */
13025           sv = (const SV *)POPPTR(ss,ix);
13026           TOPPTR(nss,ix) = sv_dup_inc(sv, param);
13027           i = POPINT(ss,ix);
13028           TOPINT(nss,ix) = i;
13029           av = (const AV *)POPPTR(ss,ix);
13030           TOPPTR(nss,ix) = av_dup_inc(av, param);
13031           break;
13032           case SAVEt_OP:
13033           ptr = POPPTR(ss,ix);
13034           TOPPTR(nss,ix) = ptr;
13035           break;
13036           case SAVEt_HINTS:
13037           ptr = POPPTR(ss,ix);
13038           ptr = cophh_copy((COPHH*)ptr);
13039           TOPPTR(nss,ix) = ptr;
13040           i = POPINT(ss,ix);
13041           TOPINT(nss,ix) = i;
13042           if (i & HINT_LOCALIZE_HH) {
13043           hv = (const HV *)POPPTR(ss,ix);
13044           TOPPTR(nss,ix) = hv_dup_inc(hv, param);
13045           }
13046           break;
13047           case SAVEt_PADSV_AND_MORTALIZE:
13048           longval = (long)POPLONG(ss,ix);
13049           TOPLONG(nss,ix) = longval;
13050           ptr = POPPTR(ss,ix);
13051           TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
13052           sv = (const SV *)POPPTR(ss,ix);
13053           TOPPTR(nss,ix) = sv_dup_inc(sv, param);
13054           break;
13055           case SAVEt_SET_SVFLAGS:
13056           i = POPINT(ss,ix);
13057           TOPINT(nss,ix) = i;
13058           i = POPINT(ss,ix);
13059           TOPINT(nss,ix) = i;
13060           sv = (const SV *)POPPTR(ss,ix);
13061           TOPPTR(nss,ix) = sv_dup(sv, param);
13062           break;
13063           case SAVEt_COMPILE_WARNINGS:
13064           ptr = POPPTR(ss,ix);
13065           TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
13066           break;
13067           case SAVEt_PARSER:
13068           ptr = POPPTR(ss,ix);
13069           TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
13070           break;
13071           default:
13072           Perl_croak(aTHX_
13073           "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
13074           }
13075           }
13076            
13077           return nss;
13078           }
13079            
13080            
13081           /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
13082           * flag to the result. This is done for each stash before cloning starts,
13083           * so we know which stashes want their objects cloned */
13084            
13085           static void
13086           do_mark_cloneable_stash(pTHX_ SV *const sv)
13087           {
13088           const HEK * const hvname = HvNAME_HEK((const HV *)sv);
13089           if (hvname) {
13090           GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
13091           SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
13092           if (cloner && GvCV(cloner)) {
13093           dSP;
13094           UV status;
13095            
13096           ENTER;
13097           SAVETMPS;
13098           PUSHMARK(SP);
13099           mXPUSHs(newSVhek(hvname));
13100           PUTBACK;
13101           call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
13102           SPAGAIN;
13103           status = POPu;
13104           PUTBACK;
13105           FREETMPS;
13106           LEAVE;
13107           if (status)
13108           SvFLAGS(sv) &= ~SVphv_CLONEABLE;
13109           }
13110           }
13111           }
13112            
13113            
13114            
13115           /*
13116           =for apidoc perl_clone
13117            
13118           Create and return a new interpreter by cloning the current one.
13119            
13120           perl_clone takes these flags as parameters:
13121            
13122           CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
13123           without it we only clone the data and zero the stacks,
13124           with it we copy the stacks and the new perl interpreter is
13125           ready to run at the exact same point as the previous one.
13126           The pseudo-fork code uses COPY_STACKS while the
13127           threads->create doesn't.
13128            
13129           CLONEf_KEEP_PTR_TABLE -
13130           perl_clone keeps a ptr_table with the pointer of the old
13131           variable as a key and the new variable as a value,
13132           this allows it to check if something has been cloned and not
13133           clone it again but rather just use the value and increase the
13134           refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
13135           the ptr_table using the function
13136           C,
13137           reason to keep it around is if you want to dup some of your own
13138           variable who are outside the graph perl scans, example of this
13139           code is in threads.xs create.
13140            
13141           CLONEf_CLONE_HOST -
13142           This is a win32 thing, it is ignored on unix, it tells perls
13143           win32host code (which is c++) to clone itself, this is needed on
13144           win32 if you want to run two threads at the same time,
13145           if you just want to do some stuff in a separate perl interpreter
13146           and then throw it away and return to the original one,
13147           you don't need to do anything.
13148            
13149           =cut
13150           */
13151            
13152           /* XXX the above needs expanding by someone who actually understands it ! */
13153           EXTERN_C PerlInterpreter *
13154           perl_clone_host(PerlInterpreter* proto_perl, UV flags);
13155            
13156           PerlInterpreter *
13157           perl_clone(PerlInterpreter *proto_perl, UV flags)
13158           {
13159           dVAR;
13160           #ifdef PERL_IMPLICIT_SYS
13161            
13162           PERL_ARGS_ASSERT_PERL_CLONE;
13163            
13164           /* perlhost.h so we need to call into it
13165           to clone the host, CPerlHost should have a c interface, sky */
13166            
13167           if (flags & CLONEf_CLONE_HOST) {
13168           return perl_clone_host(proto_perl,flags);
13169           }
13170           return perl_clone_using(proto_perl, flags,
13171           proto_perl->IMem,
13172           proto_perl->IMemShared,
13173           proto_perl->IMemParse,
13174           proto_perl->IEnv,
13175           proto_perl->IStdIO,
13176           proto_perl->ILIO,
13177           proto_perl->IDir,
13178           proto_perl->ISock,
13179           proto_perl->IProc);
13180           }
13181            
13182           PerlInterpreter *
13183           perl_clone_using(PerlInterpreter *proto_perl, UV flags,
13184           struct IPerlMem* ipM, struct IPerlMem* ipMS,
13185           struct IPerlMem* ipMP, struct IPerlEnv* ipE,
13186           struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
13187           struct IPerlDir* ipD, struct IPerlSock* ipS,
13188           struct IPerlProc* ipP)
13189           {
13190           /* XXX many of the string copies here can be optimized if they're
13191           * constants; they need to be allocated as common memory and just
13192           * their pointers copied. */
13193            
13194           IV i;
13195           CLONE_PARAMS clone_params;
13196           CLONE_PARAMS* const param = &clone_params;
13197            
13198           PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
13199            
13200           PERL_ARGS_ASSERT_PERL_CLONE_USING;
13201           #else /* !PERL_IMPLICIT_SYS */
13202           IV i;
13203           CLONE_PARAMS clone_params;
13204           CLONE_PARAMS* param = &clone_params;
13205           PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
13206            
13207           PERL_ARGS_ASSERT_PERL_CLONE;
13208           #endif /* PERL_IMPLICIT_SYS */
13209            
13210           /* for each stash, determine whether its objects should be cloned */
13211           S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
13212           PERL_SET_THX(my_perl);
13213            
13214           #ifdef DEBUGGING
13215           PoisonNew(my_perl, 1, PerlInterpreter);
13216           PL_op = NULL;
13217           PL_curcop = NULL;
13218           PL_defstash = NULL; /* may be used by perl malloc() */
13219           PL_markstack = 0;
13220           PL_scopestack = 0;
13221           PL_scopestack_name = 0;
13222           PL_savestack = 0;
13223           PL_savestack_ix = 0;
13224           PL_savestack_max = -1;
13225           PL_sig_pending = 0;
13226           PL_parser = NULL;
13227           Zero(&PL_debug_pad, 1, struct perl_debug_pad);
13228           # ifdef DEBUG_LEAKING_SCALARS
13229           PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
13230           # endif
13231           #else /* !DEBUGGING */
13232           Zero(my_perl, 1, PerlInterpreter);
13233           #endif /* DEBUGGING */
13234            
13235           #ifdef PERL_IMPLICIT_SYS
13236           /* host pointers */
13237           PL_Mem = ipM;
13238           PL_MemShared = ipMS;
13239           PL_MemParse = ipMP;
13240           PL_Env = ipE;
13241           PL_StdIO = ipStd;
13242           PL_LIO = ipLIO;
13243           PL_Dir = ipD;
13244           PL_Sock = ipS;
13245           PL_Proc = ipP;
13246           #endif /* PERL_IMPLICIT_SYS */
13247            
13248            
13249           param->flags = flags;
13250           /* Nothing in the core code uses this, but we make it available to
13251           extensions (using mg_dup). */
13252           param->proto_perl = proto_perl;
13253           /* Likely nothing will use this, but it is initialised to be consistent
13254           with Perl_clone_params_new(). */
13255           param->new_perl = my_perl;
13256           param->unreferenced = NULL;
13257            
13258            
13259           INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
13260            
13261           PL_body_arenas = NULL;
13262           Zero(&PL_body_roots, 1, PL_body_roots);
13263          
13264           PL_sv_count = 0;
13265           PL_sv_root = NULL;
13266           PL_sv_arenaroot = NULL;
13267            
13268           PL_debug = proto_perl->Idebug;
13269            
13270           /* dbargs array probably holds garbage */
13271           PL_dbargs = NULL;
13272            
13273           PL_compiling = proto_perl->Icompiling;
13274            
13275           /* pseudo environmental stuff */
13276           PL_origargc = proto_perl->Iorigargc;
13277           PL_origargv = proto_perl->Iorigargv;
13278            
13279           #if !NO_TAINT_SUPPORT
13280           /* Set tainting stuff before PerlIO_debug can possibly get called */
13281           PL_tainting = proto_perl->Itainting;
13282           PL_taint_warn = proto_perl->Itaint_warn;
13283           #else
13284           PL_tainting = FALSE;
13285           PL_taint_warn = FALSE;
13286           #endif
13287            
13288           PL_minus_c = proto_perl->Iminus_c;
13289            
13290           PL_localpatches = proto_perl->Ilocalpatches;
13291           PL_splitstr = proto_perl->Isplitstr;
13292           PL_minus_n = proto_perl->Iminus_n;
13293           PL_minus_p = proto_perl->Iminus_p;
13294           PL_minus_l = proto_perl->Iminus_l;
13295           PL_minus_a = proto_perl->Iminus_a;
13296           PL_minus_E = proto_perl->Iminus_E;
13297           PL_minus_F = proto_perl->Iminus_F;
13298           PL_doswitches = proto_perl->Idoswitches;
13299           PL_dowarn = proto_perl->Idowarn;
13300           #ifdef PERL_SAWAMPERSAND
13301           PL_sawampersand = proto_perl->Isawampersand;
13302           #endif
13303           PL_unsafe = proto_perl->Iunsafe;
13304           PL_perldb = proto_perl->Iperldb;
13305           PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
13306           PL_exit_flags = proto_perl->Iexit_flags;
13307            
13308           /* XXX time(&PL_basetime) when asked for? */
13309           PL_basetime = proto_perl->Ibasetime;
13310            
13311           PL_maxsysfd = proto_perl->Imaxsysfd;
13312           PL_statusvalue = proto_perl->Istatusvalue;
13313           #ifdef VMS
13314           PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
13315           #else
13316           PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
13317           #endif
13318            
13319           /* RE engine related */
13320           PL_regmatch_slab = NULL;
13321           PL_reg_curpm = NULL;
13322            
13323           PL_sub_generation = proto_perl->Isub_generation;
13324            
13325           /* funky return mechanisms */
13326           PL_forkprocess = proto_perl->Iforkprocess;
13327            
13328           /* internal state */
13329           PL_maxo = proto_perl->Imaxo;
13330            
13331           PL_main_start = proto_perl->Imain_start;
13332           PL_eval_root = proto_perl->Ieval_root;
13333           PL_eval_start = proto_perl->Ieval_start;
13334            
13335           PL_filemode = proto_perl->Ifilemode;
13336           PL_lastfd = proto_perl->Ilastfd;
13337           PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
13338           PL_Argv = NULL;
13339           PL_Cmd = NULL;
13340           PL_gensym = proto_perl->Igensym;
13341            
13342           PL_laststatval = proto_perl->Ilaststatval;
13343           PL_laststype = proto_perl->Ilaststype;
13344           PL_mess_sv = NULL;
13345            
13346           PL_profiledata = NULL;
13347            
13348           PL_generation = proto_perl->Igeneration;
13349            
13350           PL_in_clean_objs = proto_perl->Iin_clean_objs;
13351           PL_in_clean_all = proto_perl->Iin_clean_all;
13352            
13353           PL_delaymagic_uid = proto_perl->Idelaymagic_uid;
13354           PL_delaymagic_euid = proto_perl->Idelaymagic_euid;
13355           PL_delaymagic_gid = proto_perl->Idelaymagic_gid;
13356           PL_delaymagic_egid = proto_perl->Idelaymagic_egid;
13357           PL_nomemok = proto_perl->Inomemok;
13358           PL_an = proto_perl->Ian;
13359           PL_evalseq = proto_perl->Ievalseq;
13360           PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
13361           PL_origalen = proto_perl->Iorigalen;
13362            
13363           PL_sighandlerp = proto_perl->Isighandlerp;
13364            
13365           PL_runops = proto_perl->Irunops;
13366            
13367           PL_subline = proto_perl->Isubline;
13368            
13369           #ifdef FCRYPT
13370           PL_cryptseen = proto_perl->Icryptseen;
13371           #endif
13372            
13373           #ifdef USE_LOCALE_COLLATE
13374           PL_collation_ix = proto_perl->Icollation_ix;
13375           PL_collation_standard = proto_perl->Icollation_standard;
13376           PL_collxfrm_base = proto_perl->Icollxfrm_base;
13377           PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
13378           #endif /* USE_LOCALE_COLLATE */
13379            
13380           #ifdef USE_LOCALE_NUMERIC
13381           PL_numeric_standard = proto_perl->Inumeric_standard;
13382           PL_numeric_local = proto_perl->Inumeric_local;
13383           #endif /* !USE_LOCALE_NUMERIC */
13384            
13385           /* Did the locale setup indicate UTF-8? */
13386           PL_utf8locale = proto_perl->Iutf8locale;
13387           /* Unicode features (see perlrun/-C) */
13388           PL_unicode = proto_perl->Iunicode;
13389            
13390           /* Pre-5.8 signals control */
13391           PL_signals = proto_perl->Isignals;
13392            
13393           /* times() ticks per second */
13394           PL_clocktick = proto_perl->Iclocktick;
13395            
13396           /* Recursion stopper for PerlIO_find_layer */
13397           PL_in_load_module = proto_perl->Iin_load_module;
13398            
13399           /* sort() routine */
13400           PL_sort_RealCmp = proto_perl->Isort_RealCmp;
13401            
13402           /* Not really needed/useful since the reenrant_retint is "volatile",
13403           * but do it for consistency's sake. */
13404           PL_reentrant_retint = proto_perl->Ireentrant_retint;
13405            
13406           /* Hooks to shared SVs and locks. */
13407           PL_sharehook = proto_perl->Isharehook;
13408           PL_lockhook = proto_perl->Ilockhook;
13409           PL_unlockhook = proto_perl->Iunlockhook;
13410           PL_threadhook = proto_perl->Ithreadhook;
13411           PL_destroyhook = proto_perl->Idestroyhook;
13412           PL_signalhook = proto_perl->Isignalhook;
13413            
13414           PL_globhook = proto_perl->Iglobhook;
13415            
13416           /* swatch cache */
13417           PL_last_swash_hv = NULL; /* reinits on demand */
13418           PL_last_swash_klen = 0;
13419           PL_last_swash_key[0]= '\0';
13420           PL_last_swash_tmps = (U8*)NULL;
13421           PL_last_swash_slen = 0;
13422            
13423           PL_srand_called = proto_perl->Isrand_called;
13424            
13425           if (flags & CLONEf_COPY_STACKS) {
13426           /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
13427           PL_tmps_ix = proto_perl->Itmps_ix;
13428           PL_tmps_max = proto_perl->Itmps_max;
13429           PL_tmps_floor = proto_perl->Itmps_floor;
13430            
13431           /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
13432           * NOTE: unlike the others! */
13433           PL_scopestack_ix = proto_perl->Iscopestack_ix;
13434           PL_scopestack_max = proto_perl->Iscopestack_max;
13435            
13436           /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
13437           * NOTE: unlike the others! */
13438           PL_savestack_ix = proto_perl->Isavestack_ix;
13439           PL_savestack_max = proto_perl->Isavestack_max;
13440           }
13441            
13442           PL_start_env = proto_perl->Istart_env; /* XXXXXX */
13443           PL_top_env = &PL_start_env;
13444            
13445           PL_op = proto_perl->Iop;
13446            
13447           PL_Sv = NULL;
13448           PL_Xpv = (XPV*)NULL;
13449           my_perl->Ina = proto_perl->Ina;
13450            
13451           PL_statbuf = proto_perl->Istatbuf;
13452           PL_statcache = proto_perl->Istatcache;
13453            
13454           #ifdef HAS_TIMES
13455           PL_timesbuf = proto_perl->Itimesbuf;
13456           #endif
13457            
13458           #if !NO_TAINT_SUPPORT
13459           PL_tainted = proto_perl->Itainted;
13460           #else
13461           PL_tainted = FALSE;
13462           #endif
13463           PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
13464            
13465           PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
13466            
13467           PL_restartjmpenv = proto_perl->Irestartjmpenv;
13468           PL_restartop = proto_perl->Irestartop;
13469           PL_in_eval = proto_perl->Iin_eval;
13470           PL_delaymagic = proto_perl->Idelaymagic;
13471           PL_phase = proto_perl->Iphase;
13472           PL_localizing = proto_perl->Ilocalizing;
13473            
13474           PL_hv_fetch_ent_mh = NULL;
13475           PL_modcount = proto_perl->Imodcount;
13476           PL_lastgotoprobe = NULL;
13477           PL_dumpindent = proto_perl->Idumpindent;
13478            
13479           PL_efloatbuf = NULL; /* reinits on demand */
13480           PL_efloatsize = 0; /* reinits on demand */
13481            
13482           /* regex stuff */
13483            
13484           PL_colorset = 0; /* reinits PL_colors[] */
13485           /*PL_colors[6] = {0,0,0,0,0,0};*/
13486            
13487           /* Pluggable optimizer */
13488           PL_peepp = proto_perl->Ipeepp;
13489           PL_rpeepp = proto_perl->Irpeepp;
13490           /* op_free() hook */
13491           PL_opfreehook = proto_perl->Iopfreehook;
13492            
13493           #ifdef USE_REENTRANT_API
13494           /* XXX: things like -Dm will segfault here in perlio, but doing
13495           * PERL_SET_CONTEXT(proto_perl);
13496           * breaks too many other things
13497           */
13498           Perl_reentrant_init(aTHX);
13499           #endif
13500            
13501           /* create SV map for pointer relocation */
13502           PL_ptr_table = ptr_table_new();
13503            
13504           /* initialize these special pointers as early as possible */
13505           init_constants();
13506           ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
13507           ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
13508           ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
13509            
13510           /* create (a non-shared!) shared string table */
13511           PL_strtab = newHV();
13512           HvSHAREKEYS_off(PL_strtab);
13513           hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
13514           ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
13515            
13516           Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
13517            
13518           /* This PV will be free'd special way so must set it same way op.c does */
13519           PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
13520           ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
13521            
13522           ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
13523           PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
13524           CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling)));
13525           PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
13526            
13527           param->stashes = newAV(); /* Setup array of objects to call clone on */
13528           /* This makes no difference to the implementation, as it always pushes
13529           and shifts pointers to other SVs without changing their reference
13530           count, with the array becoming empty before it is freed. However, it
13531           makes it conceptually clear what is going on, and will avoid some
13532           work inside av.c, filling slots between AvFILL() and AvMAX() with
13533           &PL_sv_undef, and SvREFCNT_dec()ing those. */
13534           AvREAL_off(param->stashes);
13535            
13536           if (!(flags & CLONEf_COPY_STACKS)) {
13537           param->unreferenced = newAV();
13538           }
13539            
13540           #ifdef PERLIO_LAYERS
13541           /* Clone PerlIO tables as soon as we can handle general xx_dup() */
13542           PerlIO_clone(aTHX_ proto_perl, param);
13543           #endif
13544            
13545           PL_envgv = gv_dup(proto_perl->Ienvgv, param);
13546           PL_incgv = gv_dup(proto_perl->Iincgv, param);
13547           PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
13548           PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
13549           PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
13550           PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
13551            
13552           /* switches */
13553           PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
13554           PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param);
13555           PL_inplace = SAVEPV(proto_perl->Iinplace);
13556           PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
13557            
13558           /* magical thingies */
13559            
13560           PL_encoding = sv_dup(proto_perl->Iencoding, param);
13561            
13562           sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
13563           sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
13564           sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
13565            
13566          
13567           /* Clone the regex array */
13568           /* ORANGE FIXME for plugins, probably in the SV dup code.
13569           newSViv(PTR2IV(CALLREGDUPE(
13570           INT2PTR(REGEXP *, SvIVX(regex)), param))))
13571           */
13572           PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
13573           PL_regex_pad = AvARRAY(PL_regex_padav);
13574            
13575           PL_stashpadmax = proto_perl->Istashpadmax;
13576           PL_stashpadix = proto_perl->Istashpadix ;
13577           Newx(PL_stashpad, PL_stashpadmax, HV *);
13578           {
13579           PADOFFSET o = 0;
13580           for (; o < PL_stashpadmax; ++o)
13581           PL_stashpad[o] = hv_dup(proto_perl->Istashpad[o], param);
13582           }
13583            
13584           /* shortcuts to various I/O objects */
13585           PL_ofsgv = gv_dup_inc(proto_perl->Iofsgv, param);
13586           PL_stdingv = gv_dup(proto_perl->Istdingv, param);
13587           PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
13588           PL_defgv = gv_dup(proto_perl->Idefgv, param);
13589           PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
13590           PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
13591           PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
13592            
13593           /* shortcuts to regexp stuff */
13594           PL_replgv = gv_dup(proto_perl->Ireplgv, param);
13595            
13596           /* shortcuts to misc objects */
13597           PL_errgv = gv_dup(proto_perl->Ierrgv, param);
13598            
13599           /* shortcuts to debugging objects */
13600           PL_DBgv = gv_dup(proto_perl->IDBgv, param);
13601           PL_DBline = gv_dup(proto_perl->IDBline, param);
13602           PL_DBsub = gv_dup(proto_perl->IDBsub, param);
13603           PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
13604           PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
13605           PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
13606            
13607           /* symbol tables */
13608           PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
13609           PL_curstash = hv_dup_inc(proto_perl->Icurstash, param);
13610           PL_debstash = hv_dup(proto_perl->Idebstash, param);
13611           PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
13612           PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
13613            
13614           PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
13615           PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
13616           PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
13617           PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
13618           PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
13619           PL_endav = av_dup_inc(proto_perl->Iendav, param);
13620           PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
13621           PL_initav = av_dup_inc(proto_perl->Iinitav, param);
13622            
13623           PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
13624            
13625           /* subprocess state */
13626           PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
13627            
13628           if (proto_perl->Iop_mask)
13629           PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
13630           else
13631           PL_op_mask = NULL;
13632           /* PL_asserting = proto_perl->Iasserting; */
13633            
13634           /* current interpreter roots */
13635           PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
13636           OP_REFCNT_LOCK;
13637           PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
13638           OP_REFCNT_UNLOCK;
13639            
13640           /* runtime control stuff */
13641           PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
13642            
13643           PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
13644            
13645           PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
13646            
13647           /* interpreter atexit processing */
13648           PL_exitlistlen = proto_perl->Iexitlistlen;
13649           if (PL_exitlistlen) {
13650           Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
13651           Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
13652           }
13653           else
13654           PL_exitlist = (PerlExitListEntry*)NULL;
13655            
13656           PL_my_cxt_size = proto_perl->Imy_cxt_size;
13657           if (PL_my_cxt_size) {
13658           Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
13659           Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
13660           #ifdef PERL_GLOBAL_STRUCT_PRIVATE
13661           Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
13662           Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
13663           #endif
13664           }
13665           else {
13666           PL_my_cxt_list = (void**)NULL;
13667           #ifdef PERL_GLOBAL_STRUCT_PRIVATE
13668           PL_my_cxt_keys = (const char**)NULL;
13669           #endif
13670           }
13671           PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
13672           PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
13673           PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
13674           PL_custom_ops = hv_dup_inc(proto_perl->Icustom_ops, param);
13675            
13676           PL_compcv = cv_dup(proto_perl->Icompcv, param);
13677            
13678           PAD_CLONE_VARS(proto_perl, param);
13679            
13680           #ifdef HAVE_INTERP_INTERN
13681           sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
13682           #endif
13683            
13684           PL_DBcv = cv_dup(proto_perl->IDBcv, param);
13685            
13686           #ifdef PERL_USES_PL_PIDSTATUS
13687           PL_pidstatus = newHV(); /* XXX flag for cloning? */
13688           #endif
13689           PL_osname = SAVEPV(proto_perl->Iosname);
13690           PL_parser = parser_dup(proto_perl->Iparser, param);
13691            
13692           /* XXX this only works if the saved cop has already been cloned */
13693           if (proto_perl->Iparser) {
13694           PL_parser->saved_curcop = (COP*)any_dup(
13695           proto_perl->Iparser->saved_curcop,
13696           proto_perl);
13697           }
13698            
13699           PL_subname = sv_dup_inc(proto_perl->Isubname, param);
13700            
13701           #ifdef USE_LOCALE_COLLATE
13702           PL_collation_name = SAVEPV(proto_perl->Icollation_name);
13703           #endif /* USE_LOCALE_COLLATE */
13704            
13705           #ifdef USE_LOCALE_NUMERIC
13706           PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
13707           PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
13708           #endif /* !USE_LOCALE_NUMERIC */
13709            
13710           /* Unicode inversion lists */
13711           PL_ASCII = sv_dup_inc(proto_perl->IASCII, param);
13712           PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
13713           PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param);
13714            
13715           PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param);
13716           PL_HasMultiCharFold= sv_dup_inc(proto_perl->IHasMultiCharFold, param);
13717            
13718           /* utf8 character class swashes */
13719           for (i = 0; i < POSIX_SWASH_COUNT; i++) {
13720           PL_utf8_swash_ptrs[i] = sv_dup_inc(proto_perl->Iutf8_swash_ptrs[i], param);
13721           }
13722           for (i = 0; i < POSIX_CC_COUNT; i++) {
13723           PL_Posix_ptrs[i] = sv_dup_inc(proto_perl->IPosix_ptrs[i], param);
13724           PL_L1Posix_ptrs[i] = sv_dup_inc(proto_perl->IL1Posix_ptrs[i], param);
13725           PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param);
13726           }
13727           PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
13728           PL_utf8_X_regular_begin = sv_dup_inc(proto_perl->Iutf8_X_regular_begin, param);
13729           PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
13730           PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
13731           PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
13732           PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
13733           PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
13734           PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
13735           PL_utf8_xidstart = sv_dup_inc(proto_perl->Iutf8_xidstart, param);
13736           PL_utf8_perl_idstart = sv_dup_inc(proto_perl->Iutf8_perl_idstart, param);
13737           PL_utf8_perl_idcont = sv_dup_inc(proto_perl->Iutf8_perl_idcont, param);
13738           PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
13739           PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param);
13740           PL_utf8_foldable = sv_dup_inc(proto_perl->Iutf8_foldable, param);
13741           PL_utf8_charname_begin = sv_dup_inc(proto_perl->Iutf8_charname_begin, param);
13742           PL_utf8_charname_continue = sv_dup_inc(proto_perl->Iutf8_charname_continue, param);
13743            
13744           if (proto_perl->Ipsig_pend) {
13745           Newxz(PL_psig_pend, SIG_SIZE, int);
13746           }
13747           else {
13748           PL_psig_pend = (int*)NULL;
13749           }
13750            
13751           if (proto_perl->Ipsig_name) {
13752           Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
13753           sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
13754           param);
13755           PL_psig_ptr = PL_psig_name + SIG_SIZE;
13756           }
13757           else {
13758           PL_psig_ptr = (SV**)NULL;
13759           PL_psig_name = (SV**)NULL;
13760           }
13761            
13762           if (flags & CLONEf_COPY_STACKS) {
13763           Newx(PL_tmps_stack, PL_tmps_max, SV*);
13764           sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
13765           PL_tmps_ix+1, param);
13766            
13767           /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
13768           i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
13769           Newxz(PL_markstack, i, I32);
13770           PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
13771           - proto_perl->Imarkstack);
13772           PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
13773           - proto_perl->Imarkstack);
13774           Copy(proto_perl->Imarkstack, PL_markstack,
13775           PL_markstack_ptr - PL_markstack + 1, I32);
13776            
13777           /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
13778           * NOTE: unlike the others! */
13779           Newxz(PL_scopestack, PL_scopestack_max, I32);
13780           Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
13781            
13782           #ifdef DEBUGGING
13783           Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
13784           Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
13785           #endif
13786           /* reset stack AV to correct length before its duped via
13787           * PL_curstackinfo */
13788           AvFILLp(proto_perl->Icurstack) =
13789           proto_perl->Istack_sp - proto_perl->Istack_base;
13790            
13791           /* NOTE: si_dup() looks at PL_markstack */
13792           PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
13793            
13794           /* PL_curstack = PL_curstackinfo->si_stack; */
13795           PL_curstack = av_dup(proto_perl->Icurstack, param);
13796           PL_mainstack = av_dup(proto_perl->Imainstack, param);
13797            
13798           /* next PUSHs() etc. set *(PL_stack_sp+1) */
13799           PL_stack_base = AvARRAY(PL_curstack);
13800           PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp
13801           - proto_perl->Istack_base);
13802           PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
13803            
13804           /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
13805           PL_savestack = ss_dup(proto_perl, param);
13806           }
13807           else {
13808           init_stacks();
13809           ENTER; /* perl_destruct() wants to LEAVE; */
13810           }
13811            
13812           PL_statgv = gv_dup(proto_perl->Istatgv, param);
13813           PL_statname = sv_dup_inc(proto_perl->Istatname, param);
13814            
13815           PL_rs = sv_dup_inc(proto_perl->Irs, param);
13816           PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
13817           PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
13818           PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
13819           PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
13820           PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
13821            
13822           PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
13823            
13824           PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
13825           PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
13826           PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
13827            
13828           PL_stashcache = newHV();
13829            
13830           PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
13831           proto_perl->Iwatchaddr);
13832           PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
13833           if (PL_debug && PL_watchaddr) {
13834           PerlIO_printf(Perl_debug_log,
13835           "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
13836           PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
13837           PTR2UV(PL_watchok));
13838           }
13839            
13840           PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
13841           PL_blockhooks = av_dup_inc(proto_perl->Iblockhooks, param);
13842           PL_utf8_foldclosures = hv_dup_inc(proto_perl->Iutf8_foldclosures, param);
13843            
13844           /* Call the ->CLONE method, if it exists, for each of the stashes
13845           identified by sv_dup() above.
13846           */
13847           while(av_len(param->stashes) != -1) {
13848           HV* const stash = MUTABLE_HV(av_shift(param->stashes));
13849           GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
13850           if (cloner && GvCV(cloner)) {
13851           dSP;
13852           ENTER;
13853           SAVETMPS;
13854           PUSHMARK(SP);
13855           mXPUSHs(newSVhek(HvNAME_HEK(stash)));
13856           PUTBACK;
13857           call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
13858           FREETMPS;
13859           LEAVE;
13860           }
13861           }
13862            
13863           if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
13864           ptr_table_free(PL_ptr_table);
13865           PL_ptr_table = NULL;
13866           }
13867            
13868           if (!(flags & CLONEf_COPY_STACKS)) {
13869           unreferenced_to_tmp_stack(param->unreferenced);
13870           }
13871            
13872           SvREFCNT_dec(param->stashes);
13873            
13874           /* orphaned? eg threads->new inside BEGIN or use */
13875           if (PL_compcv && ! SvREFCNT(PL_compcv)) {
13876           SvREFCNT_inc_simple_void(PL_compcv);
13877           SAVEFREESV(PL_compcv);
13878           }
13879            
13880           return my_perl;
13881           }
13882            
13883           static void
13884           S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
13885           {
13886           PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK;
13887          
13888           if (AvFILLp(unreferenced) > -1) {
13889           SV **svp = AvARRAY(unreferenced);
13890           SV **const last = svp + AvFILLp(unreferenced);
13891           SSize_t count = 0;
13892            
13893           do {
13894           if (SvREFCNT(*svp) == 1)
13895           ++count;
13896           } while (++svp <= last);
13897            
13898           EXTEND_MORTAL(count);
13899           svp = AvARRAY(unreferenced);
13900            
13901           do {
13902           if (SvREFCNT(*svp) == 1) {
13903           /* Our reference is the only one to this SV. This means that
13904           in this thread, the scalar effectively has a 0 reference.
13905           That doesn't work (cleanup never happens), so donate our
13906           reference to it onto the save stack. */
13907           PL_tmps_stack[++PL_tmps_ix] = *svp;
13908           } else {
13909           /* As an optimisation, because we are already walking the
13910           entire array, instead of above doing either
13911           SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
13912           release our reference to the scalar, so that at the end of
13913           the array owns zero references to the scalars it happens to
13914           point to. We are effectively converting the array from
13915           AvREAL() on to AvREAL() off. This saves the av_clear()
13916           (triggered by the SvREFCNT_dec(unreferenced) below) from
13917           walking the array a second time. */
13918           SvREFCNT_dec(*svp);
13919           }
13920            
13921           } while (++svp <= last);
13922           AvREAL_off(unreferenced);
13923           }
13924           SvREFCNT_dec_NN(unreferenced);
13925           }
13926            
13927           void
13928           Perl_clone_params_del(CLONE_PARAMS *param)
13929           {
13930           /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT
13931           happy: */
13932           PerlInterpreter *const to = param->new_perl;
13933           dTHXa(to);
13934           PerlInterpreter *const was = PERL_GET_THX;
13935            
13936           PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
13937            
13938           if (was != to) {
13939           PERL_SET_THX(to);
13940           }
13941            
13942           SvREFCNT_dec(param->stashes);
13943           if (param->unreferenced)
13944           unreferenced_to_tmp_stack(param->unreferenced);
13945            
13946           Safefree(param);
13947            
13948           if (was != to) {
13949           PERL_SET_THX(was);
13950           }
13951           }
13952            
13953           CLONE_PARAMS *
13954           Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
13955           {
13956           dVAR;
13957           /* Need to play this game, as newAV() can call safesysmalloc(), and that
13958           does a dTHX; to get the context from thread local storage.
13959           FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
13960           a version that passes in my_perl. */
13961           PerlInterpreter *const was = PERL_GET_THX;
13962           CLONE_PARAMS *param;
13963            
13964           PERL_ARGS_ASSERT_CLONE_PARAMS_NEW;
13965            
13966           if (was != to) {
13967           PERL_SET_THX(to);
13968           }
13969            
13970           /* Given that we've set the context, we can do this unshared. */
13971           Newx(param, 1, CLONE_PARAMS);
13972            
13973           param->flags = 0;
13974           param->proto_perl = from;
13975           param->new_perl = to;
13976           param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
13977           AvREAL_off(param->stashes);
13978           param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
13979            
13980           if (was != to) {
13981           PERL_SET_THX(was);
13982           }
13983           return param;
13984           }
13985            
13986           #endif /* USE_ITHREADS */
13987            
13988           void
13989 24346         Perl_init_constants(pTHX)
13990           {
13991 24346         SvREFCNT(&PL_sv_undef) = SvREFCNT_IMMORTAL;
13992 24346         SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
13993 24346         SvANY(&PL_sv_undef) = NULL;
13994            
13995 24346         SvANY(&PL_sv_no) = new_XPVNV();
13996 24346         SvREFCNT(&PL_sv_no) = SvREFCNT_IMMORTAL;
13997 24346         SvFLAGS(&PL_sv_no) = SVt_PVNV|SVf_READONLY
13998           |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
13999           |SVp_POK|SVf_POK;
14000            
14001 24346         SvANY(&PL_sv_yes) = new_XPVNV();
14002 24346         SvREFCNT(&PL_sv_yes) = SvREFCNT_IMMORTAL;
14003 24346         SvFLAGS(&PL_sv_yes) = SVt_PVNV|SVf_READONLY
14004           |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
14005           |SVp_POK|SVf_POK;
14006            
14007 24346         SvPV_set(&PL_sv_no, (char*)PL_No);
14008 24346         SvCUR_set(&PL_sv_no, 0);
14009 24346         SvLEN_set(&PL_sv_no, 0);
14010 24346         SvIV_set(&PL_sv_no, 0);
14011 24346         SvNV_set(&PL_sv_no, 0);
14012            
14013 24346         SvPV_set(&PL_sv_yes, (char*)PL_Yes);
14014 24346         SvCUR_set(&PL_sv_yes, 1);
14015 24346         SvLEN_set(&PL_sv_yes, 0);
14016 24346         SvIV_set(&PL_sv_yes, 1);
14017 24346         SvNV_set(&PL_sv_yes, 1);
14018 24346         }
14019            
14020           /*
14021           =head1 Unicode Support
14022            
14023           =for apidoc sv_recode_to_utf8
14024            
14025           The encoding is assumed to be an Encode object, on entry the PV
14026           of the sv is assumed to be octets in that encoding, and the sv
14027           will be converted into Unicode (and UTF-8).
14028            
14029           If the sv already is UTF-8 (or if it is not POK), or if the encoding
14030           is not a reference, nothing is done to the sv. If the encoding is not
14031           an C Encoding object, bad things will happen.
14032           (See F and L.)
14033            
14034           The PV of the sv is returned.
14035            
14036           =cut */
14037            
14038           char *
14039 185856         Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
14040           {
14041           dVAR;
14042            
14043           PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
14044            
14045 371678 100       if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
    50        
    50        
    50        
14046           SV *uni;
14047           STRLEN len;
14048           const char *s;
14049 185822         dSP;
14050 185822         ENTER;
14051 185822         SAVETMPS;
14052 185822         save_re_context();
14053 185822 50       PUSHMARK(sp);
14054 92911         EXTEND(SP, 3);
14055 185822         PUSHs(encoding);
14056 185822         PUSHs(sv);
14057           /*
14058           NI-S 2002/07/09
14059           Passing sv_yes is wrong - it needs to be or'ed set of constants
14060           for Encode::XS, while UTf-8 decode (currently) assumes a true value means
14061           remove converted chars from source.
14062            
14063           Both will default the value - let them.
14064            
14065           XPUSHs(&PL_sv_yes);
14066           */
14067 185822         PUTBACK;
14068 185822         call_method("decode", G_SCALAR);
14069 185818         SPAGAIN;
14070 185818         uni = POPs;
14071 185818         PUTBACK;
14072 185818 50       s = SvPV_const(uni, len);
14073 185818 50       if (s != SvPVX_const(sv)) {
14074 185818 100       SvGROW(sv, len + 1);
    50        
14075 185818         Move(s, SvPVX(sv), len + 1, char);
14076 185818         SvCUR_set(sv, len);
14077           }
14078 185818 50       FREETMPS;
14079 185818         LEAVE;
14080 185818 100       if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
    100        
14081           /* clear pos and any utf8 cache */
14082 94         MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
14083 94 50       if (mg)
14084 0         mg->mg_len = -1;
14085 94 50       if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
14086 94         magic_setutf8(sv,mg); /* clear UTF8 cache */
14087           }
14088 185818         SvUTF8_on(sv);
14089 185818         return SvPVX(sv);
14090           }
14091 92943 100       return SvPOKp(sv) ? SvPVX(sv) : NULL;
14092           }
14093            
14094           /*
14095           =for apidoc sv_cat_decode
14096            
14097           The encoding is assumed to be an Encode object, the PV of the ssv is
14098           assumed to be octets in that encoding and decoding the input starts
14099           from the position which (PV + *offset) pointed to. The dsv will be
14100           concatenated the decoded UTF-8 string from ssv. Decoding will terminate
14101           when the string tstr appears in decoding output or the input ends on
14102           the PV of the ssv. The value which the offset points will be modified
14103           to the last input position on the ssv.
14104            
14105           Returns TRUE if the terminator was found, else returns FALSE.
14106            
14107           =cut */
14108            
14109           bool
14110 1692         Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
14111           SV *ssv, int *offset, char *tstr, int tlen)
14112           {
14113           dVAR;
14114           bool ret = FALSE;
14115            
14116           PERL_ARGS_ASSERT_SV_CAT_DECODE;
14117            
14118 3384 50       if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
    50        
    50        
    50        
14119           SV *offsv;
14120 1692         dSP;
14121 1692         ENTER;
14122 1692         SAVETMPS;
14123 1692         save_re_context();
14124 1692 50       PUSHMARK(sp);
14125 846         EXTEND(SP, 6);
14126 1692         PUSHs(encoding);
14127 1692         PUSHs(dsv);
14128 1692         PUSHs(ssv);
14129 1692         offsv = newSViv(*offset);
14130 1692         mPUSHs(offsv);
14131 1692         mPUSHp(tstr, tlen);
14132 1692         PUTBACK;
14133 1692         call_method("cat_decode", G_SCALAR);
14134 1692         SPAGAIN;
14135 1692 50       ret = SvTRUE(TOPs);
    50        
    0        
    50        
    0        
    0        
    100        
    50        
    50        
    50        
    50        
    50        
    50        
    50        
    50        
    0        
    0        
    50        
    0        
14136 1692 50       *offset = SvIV(offsv);
14137 1692         PUTBACK;
14138 1692 50       FREETMPS;
14139 1692         LEAVE;
14140           }
14141           else
14142 0         Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
14143 1692         return ret;
14144            
14145           }
14146            
14147           /* ---------------------------------------------------------------------
14148           *
14149           * support functions for report_uninit()
14150           */
14151            
14152           /* the maxiumum size of array or hash where we will scan looking
14153           * for the undefined element that triggered the warning */
14154            
14155           #define FUV_MAX_SEARCH_SIZE 1000
14156            
14157           /* Look for an entry in the hash whose value has the same SV as val;
14158           * If so, return a mortal copy of the key. */
14159            
14160           STATIC SV*
14161 82         S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
14162           {
14163           dVAR;
14164           HE **array;
14165           I32 i;
14166            
14167           PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
14168            
14169 115 50       if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
    100        
    100        
    100        
14170 66         (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
14171           return NULL;
14172            
14173 62         array = HvARRAY(hv);
14174            
14175 297 50       for (i=HvMAX(hv); i>=0; i--) {
14176           HE *entry;
14177 268 100       for (entry = array[i]; entry; entry = HeNEXT(entry)) {
14178 74 100       if (HeVAL(entry) != val)
14179 12         continue;
14180 93 50       if ( HeVAL(entry) == &PL_sv_undef ||
    50        
14181 62         HeVAL(entry) == &PL_sv_placeholder)
14182 0         continue;
14183 62 50       if (!HeKEY(entry))
14184           return NULL;
14185 62 50       if (HeKLEN(entry) == HEf_SVKEY)
14186 0         return sv_mortalcopy(HeKEY_sv(entry));
14187 62         return sv_2mortal(newSVhek(HeKEY_hek(entry)));
14188           }
14189           }
14190           return NULL;
14191           }
14192            
14193           /* Look for an entry in the array whose value has the same SV as val;
14194           * If so, return the index, otherwise return -1. */
14195            
14196           STATIC I32
14197           S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
14198           {
14199           dVAR;
14200            
14201           PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
14202            
14203 75 50       if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
    50        
    100        
    50        
    50        
    100        
    100        
    50        
14204 30         (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
14205           return -1;
14206            
14207 30 50       if (val != &PL_sv_undef) {
    50        
14208 30         SV ** const svp = AvARRAY(av);
14209           I32 i;
14210            
14211 2468 100       for (i=AvFILLp(av); i>=0; i--)
    50        
14212 2464 100       if (svp[i] == val)
    100        
14213           return i;
14214           }
14215           return -1;
14216           }
14217            
14218           /* varname(): return the name of a variable, optionally with a subscript.
14219           * If gv is non-zero, use the name of that global, along with gvtype (one
14220           * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
14221           * targ. Depending on the value of the subscript_type flag, return:
14222           */
14223            
14224           #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
14225           #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
14226           #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
14227           #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
14228            
14229           SV*
14230 2710         Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
14231           const SV *const keyname, I32 aindex, int subscript_type)
14232           {
14233            
14234 2710         SV * const name = sv_newmortal();
14235 2710 100       if (gv && isGV(gv)) {
    100        
14236           char buffer[2];
14237 906         buffer[0] = gvtype;
14238 906         buffer[1] = 0;
14239            
14240           /* as gv_fullname4(), but add literal '^' for $^FOO names */
14241            
14242 906         gv_fullname4(name, gv, buffer, 0);
14243            
14244 906 100       if ((unsigned int)SvPVX(name)[1] <= 26) {
14245 4         buffer[0] = '^';
14246 4         buffer[1] = SvPVX(name)[1] + 'A' - 1;
14247            
14248           /* Swap the 1 unprintable control character for the 2 byte pretty
14249           version - ie substr($name, 1, 1) = $buffer; */
14250 4         sv_insert(name, 1, 1, buffer, 2);
14251           }
14252           }
14253           else {
14254 1804 100       CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL);
14255           SV *sv;
14256           AV *av;
14257            
14258           assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
14259            
14260 1804 50       if (!cv || !CvPADLIST(cv))
    50        
14261           return NULL;
14262 1804         av = *PadlistARRAY(CvPADLIST(cv));
14263 1804         sv = *av_fetch(av, targ, FALSE);
14264 1804         sv_setsv_flags(name, sv, 0);
14265           }
14266            
14267 2710 100       if (subscript_type == FUV_SUBSCRIPT_HASH) {
14268 76         SV * const sv = newSV(0);
14269 76         *SvPVX(name) = '$';
14270 114         Perl_sv_catpvf(aTHX_ name, "{%s}",
14271 152         pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL,
14272           PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT ));
14273 76         SvREFCNT_dec_NN(sv);
14274           }
14275 2634 100       else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
14276 122         *SvPVX(name) = '$';
14277 122         Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
14278           }
14279 2512 100       else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
14280           /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
14281 1366         Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
14282           }
14283            
14284           return name;
14285           }
14286            
14287            
14288           /*
14289           =for apidoc find_uninit_var
14290            
14291           Find the name of the undefined variable (if any) that caused the operator
14292           to issue a "Use of uninitialized value" warning.
14293           If match is true, only return a name if its value matches uninit_sv.
14294           So roughly speaking, if a unary operator (such as OP_COS) generates a
14295           warning, then following the direct child of the op may yield an
14296           OP_PADSV or OP_GV that gives the name of the undefined variable. On the
14297           other hand, with OP_ADD there are two branches to follow, so we only print
14298           the variable name if we get an exact match.
14299            
14300           The name is returned as a mortal SV.
14301            
14302           Assumes that PL_op is the op that originally triggered the error, and that
14303           PL_comppad/PL_curpad points to the currently executing pad.
14304            
14305           =cut
14306           */
14307            
14308           STATIC SV *
14309 9816         S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
14310           bool match)
14311           {
14312           dVAR;
14313           SV *sv;
14314           const GV *gv;
14315           const OP *o, *o2, *kid;
14316            
14317 9816 50       if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
    100        
    50        
    100        
    50        
14318           uninit_sv == &PL_sv_placeholder)))
14319           return NULL;
14320            
14321 9408         switch (obase->op_type) {
14322            
14323           case OP_RV2AV:
14324           case OP_RV2HV:
14325           case OP_PADAV:
14326           case OP_PADHV:
14327           {
14328 128         const bool pad = ( obase->op_type == OP_PADAV
14329           || obase->op_type == OP_PADHV
14330 64         || obase->op_type == OP_PADRANGE
14331           );
14332            
14333 128         const bool hash = ( obase->op_type == OP_PADHV
14334 64         || obase->op_type == OP_RV2HV
14335 64 100       || (obase->op_type == OP_PADRANGE
    50        
14336 21 0       && SvTYPE(PAD_SVl(obase->op_targ)) == SVt_PVHV)
14337           );
14338           I32 index = 0;
14339           SV *keysv = NULL;
14340           int subscript_type = FUV_SUBSCRIPT_WITHIN;
14341            
14342 64 100       if (pad) { /* @lex, %lex */
14343 30         sv = PAD_SVl(obase->op_targ);
14344           gv = NULL;
14345           }
14346           else {
14347 34 100       if (cUNOPx(obase)->op_first->op_type == OP_GV) {
14348           /* @global, %global */
14349 16         gv = cGVOPx_gv(cUNOPx(obase)->op_first);
14350 16 50       if (!gv)
14351           break;
14352 16 100       sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
14353           }
14354 18 100       else if (obase == PL_op) /* @{expr}, %{expr} */
14355 14         return find_uninit_var(cUNOPx(obase)->op_first,
14356           uninit_sv, match);
14357           else /* @{expr}, %{expr} as a sub-expression */
14358           return NULL;
14359           }
14360            
14361           /* attempt to find a match within the aggregate */
14362 46 100       if (hash) {
14363 16         keysv = find_hash_subscript((const HV*)sv, uninit_sv);
14364 16 100       if (keysv)
14365           subscript_type = FUV_SUBSCRIPT_HASH;
14366           }
14367           else {
14368           index = find_array_subscript((const AV *)sv, uninit_sv);
14369 30 100       if (index >= 0)
14370           subscript_type = FUV_SUBSCRIPT_ARRAY;
14371           }
14372            
14373 46 100       if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
    100        
14374           break;
14375            
14376 30 100       return varname(gv, hash ? '%' : '@', obase->op_targ,
14377           keysv, index, subscript_type);
14378           }
14379            
14380           case OP_RV2SV:
14381 14 50       if (cUNOPx(obase)->op_first->op_type == OP_GV) {
14382           /* $global */
14383 0         gv = cGVOPx_gv(cUNOPx(obase)->op_first);
14384 0 0       if (!gv || !GvSTASH(gv))
    0        
14385           break;
14386 0 0       if (match && (GvSV(gv) != uninit_sv))
    0        
14387           break;
14388 0         return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
14389           }
14390           /* ${expr} */
14391 14         return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1);
14392            
14393           case OP_PADSV:
14394 2058 100       if (match && PAD_SVl(obase->op_targ) != uninit_sv)
    100        
14395           break;
14396 1680         return varname(NULL, '$', obase->op_targ,
14397           NULL, 0, FUV_SUBSCRIPT_NONE);
14398            
14399           case OP_GVSV:
14400 1084         gv = cGVOPx_gv(obase);
14401 1084 50       if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv))
    100        
    100        
    100        
14402           break;
14403 786         return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
14404            
14405           case OP_AELEMFAST_LEX:
14406 28 100       if (match) {
14407           SV **svp;
14408 16         AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
14409 16 50       if (!av || SvRMAGICAL(av))
    100        
14410           break;
14411 8         svp = av_fetch(av, (I32)obase->op_private, FALSE);
14412 8 100       if (!svp || *svp != uninit_sv)
    100        
14413           break;
14414           }
14415 16         return varname(NULL, '$', obase->op_targ,
14416           NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
14417           case OP_AELEMFAST:
14418           {
14419 50         gv = cGVOPx_gv(obase);
14420 50 50       if (!gv)
14421           break;
14422 50 100       if (match) {
14423           SV **svp;
14424 36         AV *const av = GvAV(gv);
14425 36 50       if (!av || SvRMAGICAL(av))
    50        
14426           break;
14427 36         svp = av_fetch(av, (I32)obase->op_private, FALSE);
14428 36 100       if (!svp || *svp != uninit_sv)
    100        
14429           break;
14430           }
14431 46         return varname(gv, '$', 0,
14432           NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
14433           }
14434           break;
14435            
14436           case OP_EXISTS:
14437 8         o = cUNOPx(obase)->op_first;
14438 12 50       if (!o || o->op_type != OP_NULL ||
    50        
    50        
14439 8         ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
14440           break;
14441 8         return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
14442            
14443           case OP_AELEM:
14444           case OP_HELEM:
14445           {
14446           bool negate = FALSE;
14447            
14448 206 100       if (PL_op == obase)
14449           /* $a[uninit_expr] or $h{uninit_expr} */
14450 20         return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
14451            
14452           gv = NULL;
14453 186         o = cBINOPx(obase)->op_first;
14454 186         kid = cBINOPx(obase)->op_last;
14455            
14456           /* get the av or hv, and optionally the gv */
14457           sv = NULL;
14458 186 100       if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
14459 124         sv = PAD_SV(o->op_targ);
14460           }
14461 62 50       else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
14462 62 50       && cUNOPo->op_first->op_type == OP_GV)
14463           {
14464 62         gv = cGVOPx_gv(cUNOPo->op_first);
14465 62 50       if (!gv)
14466           break;
14467           sv = o->op_type
14468 62 100       == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
14469           }
14470 186 50       if (!sv)
14471           break;
14472            
14473 186 50       if (kid && kid->op_type == OP_NEGATE) {
    50        
14474           negate = TRUE;
14475 0         kid = cUNOPx(kid)->op_first;
14476           }
14477            
14478 186 50       if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
    100        
    50        
    0        
    0        
14479           /* index is constant */
14480           SV* kidsv;
14481 90 50       if (negate) {
14482 0         kidsv = sv_2mortal(newSVpvs("-"));
14483 0         sv_catsv(kidsv, cSVOPx_sv(kid));
14484           }
14485           else
14486 90         kidsv = cSVOPx_sv(kid);
14487 90 100       if (match) {
14488 66 100       if (SvMAGICAL(sv))
14489           break;
14490 50 100       if (obase->op_type == OP_HELEM) {
14491 12         HE* he = hv_fetch_ent(MUTABLE_HV(sv), kidsv, 0, 0);
14492 12 50       if (!he || HeVAL(he) != uninit_sv)
    100        
14493           break;
14494           }
14495           else {
14496 38         SV * const opsv = cSVOPx_sv(kid);
14497 38 50       const IV opsviv = SvIV(opsv);
14498 38 50       SV * const * const svp = av_fetch(MUTABLE_AV(sv),
14499           negate ? - opsviv : opsviv,
14500           FALSE);
14501 38 100       if (!svp || *svp != uninit_sv)
    100        
14502           break;
14503           }
14504           }
14505 48 100       if (obase->op_type == OP_HELEM)
14506 14         return varname(gv, '%', o->op_targ,
14507           kidsv, 0, FUV_SUBSCRIPT_HASH);
14508           else
14509 34 50       return varname(gv, '@', o->op_targ, NULL,
    0        
    50        
14510           negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)),
14511           FUV_SUBSCRIPT_ARRAY);
14512           }
14513           else {
14514           /* index is an expression;
14515           * attempt to find a match within the aggregate */
14516 96 100       if (obase->op_type == OP_HELEM) {
14517 66         SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
14518 66 100       if (keysv)
14519 52         return varname(gv, '%', o->op_targ,
14520           keysv, 0, FUV_SUBSCRIPT_HASH);
14521           }
14522           else {
14523           const I32 index
14524           = find_array_subscript((const AV *)sv, uninit_sv);
14525 30 100       if (index >= 0)
14526 10         return varname(gv, '@', o->op_targ,
14527           NULL, index, FUV_SUBSCRIPT_ARRAY);
14528           }
14529 34 100       if (match)
14530           break;
14531 18 100       return varname(gv,
14532           (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
14533           ? '@' : '%',
14534           o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
14535           }
14536           break;
14537           }
14538            
14539           case OP_AASSIGN:
14540           /* only examine RHS */
14541 2         return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
14542            
14543           case OP_OPEN:
14544 16         o = cUNOPx(obase)->op_first;
14545 16 50       if ( o->op_type == OP_PUSHMARK
14546 0 0       || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)
    0        
14547           )
14548 16         o = o->op_sibling;
14549            
14550 16 100       if (!o->op_sibling) {
14551           /* one-arg version of open is highly magical */
14552            
14553 8 100       if (o->op_type == OP_GV) { /* open FOO; */
14554 2         gv = cGVOPx_gv(o);
14555 2 50       if (match && GvSV(gv) != uninit_sv)
    0        
14556           break;
14557 2         return varname(gv, '$', 0,
14558           NULL, 0, FUV_SUBSCRIPT_NONE);
14559           }
14560           /* other possibilities not handled are:
14561           * open $x; or open my $x; should return '${*$x}'
14562           * open expr; should return '$'.expr ideally
14563           */
14564           break;
14565           }
14566           goto do_op;
14567            
14568           /* ops where $_ may be an implicit arg */
14569           case OP_TRANS:
14570           case OP_TRANSR:
14571           case OP_SUBST:
14572           case OP_MATCH:
14573 1026 100       if ( !(obase->op_flags & OPf_STACKED)) {
14574 75 50       if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
14575 24         ? PAD_SVl(obase->op_targ)
14576 62 100       : DEFSV))
    50        
14577           {
14578 50         sv = sv_newmortal();
14579 50         sv_setpvs(sv, "$_");
14580 50         return sv;
14581           }
14582           }
14583           goto do_op;
14584            
14585           case OP_PRTF:
14586           case OP_PRINT:
14587           case OP_SAY:
14588           match = 1; /* print etc can return undef on defined args */
14589           /* skip filehandle as it can't produce 'undef' warning */
14590 146         o = cUNOPx(obase)->op_first;
14591 146 100       if ((obase->op_flags & OPf_STACKED)
14592 38 50       &&
14593 38         ( o->op_type == OP_PUSHMARK
14594 0 0       || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)))
    0        
14595 38         o = o->op_sibling->op_sibling;
14596           goto do_op2;
14597            
14598            
14599           case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
14600           case OP_CUSTOM: /* XS or custom code could trigger random warnings */
14601            
14602           /* the following ops are capable of returning PL_sv_undef even for
14603           * defined arg(s) */
14604            
14605           case OP_BACKTICK:
14606           case OP_PIPE_OP:
14607           case OP_FILENO:
14608           case OP_BINMODE:
14609           case OP_TIED:
14610           case OP_GETC:
14611           case OP_SYSREAD:
14612           case OP_SEND:
14613           case OP_IOCTL:
14614           case OP_SOCKET:
14615           case OP_SOCKPAIR:
14616           case OP_BIND:
14617           case OP_CONNECT:
14618           case OP_LISTEN:
14619           case OP_ACCEPT:
14620           case OP_SHUTDOWN:
14621           case OP_SSOCKOPT:
14622           case OP_GETPEERNAME:
14623           case OP_FTRREAD:
14624           case OP_FTRWRITE:
14625           case OP_FTREXEC:
14626           case OP_FTROWNED:
14627           case OP_FTEREAD:
14628           case OP_FTEWRITE:
14629           case OP_FTEEXEC:
14630           case OP_FTEOWNED:
14631           case OP_FTIS:
14632           case OP_FTZERO:
14633           case OP_FTSIZE:
14634           case OP_FTFILE:
14635           case OP_FTDIR:
14636           case OP_FTLINK:
14637           case OP_FTPIPE:
14638           case OP_FTSOCK:
14639           case OP_FTBLK:
14640           case OP_FTCHR:
14641           case OP_FTTTY:
14642           case OP_FTSUID:
14643           case OP_FTSGID:
14644           case OP_FTSVTX:
14645           case OP_FTTEXT:
14646           case OP_FTBINARY:
14647           case OP_FTMTIME:
14648           case OP_FTATIME:
14649           case OP_FTCTIME:
14650           case OP_READLINK:
14651           case OP_OPEN_DIR:
14652           case OP_READDIR:
14653           case OP_TELLDIR:
14654           case OP_SEEKDIR:
14655           case OP_REWINDDIR:
14656           case OP_CLOSEDIR:
14657           case OP_GMTIME:
14658           case OP_ALARM:
14659           case OP_SEMGET:
14660           case OP_GETLOGIN:
14661           case OP_UNDEF:
14662           case OP_SUBSTR:
14663           case OP_AEACH:
14664           case OP_EACH:
14665           case OP_SORT:
14666           case OP_CALLER:
14667           case OP_DOFILE:
14668           case OP_PROTOTYPE:
14669           case OP_NCMP:
14670           case OP_SMARTMATCH:
14671           case OP_UNPACK:
14672           case OP_SYSOPEN:
14673           case OP_SYSSEEK:
14674           match = 1;
14675 292         goto do_op;
14676            
14677           case OP_ENTERSUB:
14678           case OP_GOTO:
14679           /* XXX tmp hack: these two may call an XS sub, and currently
14680           XS subs don't have a SUB entry on the context stack, so CV and
14681           pad determination goes wrong, and BAD things happen. So, just
14682           don't try to determine the value under those circumstances.
14683           Need a better fix at dome point. DAPM 11/2007 */
14684           break;
14685            
14686           case OP_FLIP:
14687           case OP_FLOP:
14688           {
14689 70         GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
14690 70 100       if (gv && GvSV(gv) == uninit_sv)
    100        
14691 22         return newSVpvs_flags("$.", SVs_TEMP);
14692           goto do_op;
14693           }
14694            
14695           case OP_POS:
14696           /* def-ness of rval pos() is independent of the def-ness of its arg */
14697 12 100       if ( !(obase->op_flags & OPf_MOD))
14698           break;
14699            
14700           case OP_SCHOMP:
14701           case OP_CHOMP:
14702 24 100       if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
    100        
14703 6         return newSVpvs_flags("${$/}", SVs_TEMP);
14704           /*FALLTHROUGH*/
14705            
14706           default:
14707           do_op:
14708 5632 100       if (!(obase->op_flags & OPf_KIDS))
14709           break;
14710 5260         o = cUNOPx(obase)->op_first;
14711          
14712           do_op2:
14713 5406 50       if (!o)
14714           break;
14715            
14716           /* This loop checks all the kid ops, skipping any that cannot pos-
14717           * sibly be responsible for the uninitialized value; i.e., defined
14718           * constants and ops that return nothing. If there is only one op
14719           * left that is not skipped, then we *know* it is responsible for
14720           * the uninitialized value. If there is more than one op left, we
14721           * have to look for an exact match in the while() loop below.
14722           * Note that we skip padrange, because the individual pad ops that
14723           * it replaced are still in the tree, so we work on them instead.
14724           */
14725           o2 = NULL;
14726 10671 100       for (kid=o; kid; kid = kid->op_sibling) {
14727 8990 50       if (kid) {
14728 8990         const OPCODE type = kid->op_type;
14729 8990 100       if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
    50        
    0        
    0        
14730 7054 100       || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
    100        
14731 6816         || (type == OP_PUSHMARK)
14732 6816 100       || (type == OP_PADRANGE)
14733           )
14734 2568         continue;
14735           }
14736 6422 100       if (o2) { /* more than one found */
14737           o2 = NULL;
14738           break;
14739           }
14740           o2 = kid;
14741           }
14742 5406 100       if (o2)
14743 4378         return find_uninit_var(o2, uninit_sv, match);
14744            
14745           /* scan all args */
14746 7280 100       while (o) {
14747 2272         sv = find_uninit_var(o, uninit_sv, 1);
14748 2272 100       if (sv)
14749           return sv;
14750 1444         o = o->op_sibling;
14751           }
14752           break;
14753           }
14754           return NULL;
14755           }
14756            
14757            
14758           /*
14759           =for apidoc report_uninit
14760            
14761           Print appropriate "Use of uninitialized variable" warning.
14762            
14763           =cut
14764           */
14765            
14766           void
14767 3128         Perl_report_uninit(pTHX_ const SV *uninit_sv)
14768           {
14769           dVAR;
14770 3128 50       if (PL_op) {
14771           SV* varname = NULL;
14772 3128 100       if (uninit_sv && PL_curpad) {
    100        
14773 3108         varname = find_uninit_var(PL_op, uninit_sv,0);
14774 3108 100       if (varname)
14775 2766         sv_insert(varname, 0, 0, " ", 1);
14776           }
14777           /* diag_listed_as: Use of uninitialized value%s */
14778 4692 50       Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
    100        
14779           SVfARG(varname ? varname : &PL_sv_no),
14780 1564 0       " in ", OP_DESC(PL_op));
14781           }
14782           else
14783 0         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
14784           "", "", "");
14785 1006270         }
14786            
14787           /*
14788           * Local variables:
14789           * c-indentation-style: bsd
14790           * c-basic-offset: 4
14791           * indent-tabs-mode: nil
14792           * End:
14793           *
14794           * ex: set ts=8 sts=4 sw=4 et:
14795           */