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
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.
13 * 'I wonder what the Entish is for "yes" and "no",' he thought.
16 * [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
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
36 # if __STDC_VERSION__ >= 199901L && !defined(VMS)
45 /* Missing proto on LynxOS */
46 char *gconvert(double, int, int, char *);
49 #ifdef PERL_UTF8_CACHE_ASSERT
50 /* if adding more checks watch out for the following tests:
51 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
52 * lib/utf8.t lib/Unicode/Collate/t/index.t
55 # define ASSERT_UTF8_CACHE(cache) \
56 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
57 assert((cache)[2] <= (cache)[3]); \
58 assert((cache)[3] <= (cache)[1]);} \
61 # define ASSERT_UTF8_CACHE(cache) NOOP
64 #ifdef PERL_OLD_COPY_ON_WRITE
65 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
66 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
69 /* ============================================================================
71 =head1 Allocation and deallocation of SVs.
73 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
74 sv, av, hv...) contains type and reference count information, and for
75 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
76 contains fields specific to each type. Some types store all they need
77 in the head, so don't have a body.
79 In all but the most memory-paranoid configurations (ex: PURIFY), heads
80 and bodies are allocated out of arenas, which by default are
81 approximately 4K chunks of memory parcelled up into N heads or bodies.
82 Sv-bodies are allocated by their sv-type, guaranteeing size
83 consistency needed to allocate safely from arrays.
85 For SV-heads, the first slot in each arena is reserved, and holds a
86 link to the next arena, some flags, and a note of the number of slots.
87 Snaked through each arena chain is a linked list of free items; when
88 this becomes empty, an extra arena is allocated and divided up into N
89 items which are threaded into the free list.
91 SV-bodies are similar, but they use arena-sets by default, which
92 separate the link and info from the arena itself, and reclaim the 1st
93 slot in the arena. SV-bodies are further described later.
95 The following global variables are associated with arenas:
97 PL_sv_arenaroot pointer to list of SV arenas
98 PL_sv_root pointer to list of free SV structures
100 PL_body_arenas head of linked-list of body arenas
101 PL_body_roots[] array of pointers to list of free bodies of svtype
102 arrays are indexed by the svtype needed
104 A few special SV heads are not allocated from an arena, but are
105 instead directly created in the interpreter structure, eg PL_sv_undef.
106 The size of arenas can be changed from the default by setting
107 PERL_ARENA_SIZE appropriately at compile time.
109 The SV arena serves the secondary purpose of allowing still-live SVs
110 to be located and destroyed during final cleanup.
112 At the lowest level, the macros new_SV() and del_SV() grab and free
113 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
114 to return the SV to the free list with error checking.) new_SV() calls
115 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
116 SVs in the free list have their SvTYPE field set to all ones.
118 At the time of very final cleanup, sv_free_arenas() is called from
119 perl_destruct() to physically free all the arenas allocated since the
120 start of the interpreter.
122 The function visit() scans the SV arenas list, and calls a specified
123 function for each SV it finds which is still live - ie which has an SvTYPE
124 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
125 following functions (specified as [function that calls visit()] / [function
126 called by visit() for each SV]):
128 sv_report_used() / do_report_used()
129 dump all remaining SVs (debugging aid)
131 sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
132 do_clean_named_io_objs(),do_curse()
133 Attempt to free all objects pointed to by RVs,
134 try to do the same for all objects indir-
135 ectly referenced by typeglobs too, and
136 then do a final sweep, cursing any
137 objects that remain. Called once from
138 perl_destruct(), prior to calling sv_clean_all()
141 sv_clean_all() / do_clean_all()
142 SvREFCNT_dec(sv) each remaining SV, possibly
143 triggering an sv_free(). It also sets the
144 SVf_BREAK flag on the SV to indicate that the
145 refcnt has been artificially lowered, and thus
146 stopping sv_free() from giving spurious warnings
147 about SVs which unexpectedly have a refcnt
148 of zero. called repeatedly from perl_destruct()
149 until there are no SVs left.
151 =head2 Arena allocator API Summary
153 Private API to rest of sv.c
157 new_XPVNV(), del_XPVGV(),
162 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
166 * ========================================================================= */
169 * "A time to plant, and a time to uproot what was planted..."
173 # define MEM_LOG_NEW_SV(sv, file, line, func) \
174 Perl_mem_log_new_sv(sv, file, line, func)
175 # define MEM_LOG_DEL_SV(sv, file, line, func) \
176 Perl_mem_log_del_sv(sv, file, line, func)
178 # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP
179 # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP
182 #ifdef DEBUG_LEAKING_SCALARS
183 # define FREE_SV_DEBUG_FILE(sv) STMT_START { \
184 if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \
186 # define DEBUG_SV_SERIAL(sv) \
187 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
188 PTR2UV(sv), (long)(sv)->sv_debug_serial))
190 # define FREE_SV_DEBUG_FILE(sv)
191 # define DEBUG_SV_SERIAL(sv) NOOP
195 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
196 # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val))
197 /* Whilst I'd love to do this, it seems that things like to check on
199 # define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
201 # define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
202 PoisonNew(&SvREFCNT(sv), 1, U32)
204 # define SvARENA_CHAIN(sv) SvANY(sv)
205 # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val)
206 # define POSION_SV_HEAD(sv)
209 /* Mark an SV head as unused, and add to free list.
211 * If SVf_BREAK is set, skip adding it to the free list, as this SV had
212 * its refcount artificially decremented during global destruction, so
213 * there may be dangling pointers to it. The last thing we want in that
214 * case is for it to be reused. */
216 #define plant_SV(p) \
218 const U32 old_flags = SvFLAGS(p); \
219 MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
220 DEBUG_SV_SERIAL(p); \
221 FREE_SV_DEBUG_FILE(p); \
223 SvFLAGS(p) = SVTYPEMASK; \
224 if (!(old_flags & SVf_BREAK)) { \
225 SvARENA_CHAIN_SET(p, PL_sv_root); \
231 #define uproot_SV(p) \
234 PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \
239 /* make some more SVs by adding another arena */
246 char *chunk; /* must use New here to match call to */
247 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
248 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
253 /* new_SV(): return a new, empty SV head */
255 #ifdef DEBUG_LEAKING_SCALARS
256 /* provide a real function for a debugger to play with */
258 S_new_SV(pTHX_ const char *file, int line, const char *func)
265 sv = S_more_sv(aTHX);
269 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
270 sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
276 sv->sv_debug_inpad = 0;
277 sv->sv_debug_parent = NULL;
278 sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
280 sv->sv_debug_serial = PL_sv_serial++;
282 MEM_LOG_NEW_SV(sv, file, line, func);
283 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
284 PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
288 # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
296 (p) = S_more_sv(aTHX); \
300 MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \
305 /* del_SV(): return an empty SV head to the free list */
318 S_del_sv(pTHX_ SV *p)
322 PERL_ARGS_ASSERT_DEL_SV;
327 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
328 const SV * const sv = sva + 1;
329 const SV * const svend = &sva[SvREFCNT(sva)];
330 if (p >= sv && p < svend) {
336 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
337 "Attempt to free non-arena SV: 0x%"UVxf
338 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
345 #else /* ! DEBUGGING */
347 #define del_SV(p) plant_SV(p)
349 #endif /* DEBUGGING */
353 =head1 SV Manipulation Functions
355 =for apidoc sv_add_arena
357 Given a chunk of memory, link it to the head of the list of arenas,
358 and split it into a list of free SVs.
364 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
367 SV *const sva = MUTABLE_SV(ptr);
371 PERL_ARGS_ASSERT_SV_ADD_ARENA;
373 /* The first SV in an arena isn't an SV. */
374 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
375 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
376 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
378 PL_sv_arenaroot = sva;
379 PL_sv_root = sva + 1;
381 svend = &sva[SvREFCNT(sva) - 1];
384 SvARENA_CHAIN_SET(sv, (sv + 1));
388 /* Must always set typemask because it's always checked in on cleanup
389 when the arenas are walked looking for objects. */
390 SvFLAGS(sv) = SVTYPEMASK;
393 SvARENA_CHAIN_SET(sv, 0);
397 SvFLAGS(sv) = SVTYPEMASK;
400 /* visit(): call the named function for each non-free SV in the arenas
401 * whose flags field matches the flags/mask args. */
404 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
410 PERL_ARGS_ASSERT_VISIT;
412 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
413 const SV * const svend = &sva[SvREFCNT(sva)];
415 for (sv = sva + 1; sv < svend; ++sv) {
416 if (SvTYPE(sv) != (svtype)SVTYPEMASK
417 && (sv->sv_flags & mask) == flags
430 /* called by sv_report_used() for each live SV */
433 do_report_used(pTHX_ SV *const sv)
435 if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
436 PerlIO_printf(Perl_debug_log, "****\n");
443 =for apidoc sv_report_used
445 Dump the contents of all SVs not yet freed (debugging aid).
451 Perl_sv_report_used(pTHX)
454 visit(do_report_used, 0, 0);
460 /* called by sv_clean_objs() for each live SV */
463 do_clean_objs(pTHX_ SV *const ref)
468 SV * const target = SvRV(ref);
469 if (SvOBJECT(target)) {
470 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
471 if (SvWEAKREF(ref)) {
472 sv_del_backref(target, ref);
478 SvREFCNT_dec_NN(target);
485 /* clear any slots in a GV which hold objects - except IO;
486 * called by sv_clean_objs() for each live GV */
489 do_clean_named_objs(pTHX_ SV *const sv)
493 assert(SvTYPE(sv) == SVt_PVGV);
494 assert(isGV_with_GP(sv));
498 /* freeing GP entries may indirectly free the current GV;
499 * hold onto it while we mess with the GP slots */
502 if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
503 DEBUG_D((PerlIO_printf(Perl_debug_log,
504 "Cleaning named glob SV object:\n "), sv_dump(obj)));
506 SvREFCNT_dec_NN(obj);
508 if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
509 DEBUG_D((PerlIO_printf(Perl_debug_log,
510 "Cleaning named glob AV object:\n "), sv_dump(obj)));
512 SvREFCNT_dec_NN(obj);
514 if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
515 DEBUG_D((PerlIO_printf(Perl_debug_log,
516 "Cleaning named glob HV object:\n "), sv_dump(obj)));
518 SvREFCNT_dec_NN(obj);
520 if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
521 DEBUG_D((PerlIO_printf(Perl_debug_log,
522 "Cleaning named glob CV object:\n "), sv_dump(obj)));
524 SvREFCNT_dec_NN(obj);
526 SvREFCNT_dec_NN(sv); /* undo the inc above */
529 /* clear any IO slots in a GV which hold objects (except stderr, defout);
530 * called by sv_clean_objs() for each live GV */
533 do_clean_named_io_objs(pTHX_ SV *const sv)
537 assert(SvTYPE(sv) == SVt_PVGV);
538 assert(isGV_with_GP(sv));
539 if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
543 if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
544 DEBUG_D((PerlIO_printf(Perl_debug_log,
545 "Cleaning named glob IO object:\n "), sv_dump(obj)));
547 SvREFCNT_dec_NN(obj);
549 SvREFCNT_dec_NN(sv); /* undo the inc above */
552 /* Void wrapper to pass to visit() */
554 do_curse(pTHX_ SV * const sv) {
555 if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
556 || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
562 =for apidoc sv_clean_objs
564 Attempt to destroy all objects not yet freed.
570 Perl_sv_clean_objs(pTHX)
574 PL_in_clean_objs = TRUE;
575 visit(do_clean_objs, SVf_ROK, SVf_ROK);
576 /* Some barnacles may yet remain, clinging to typeglobs.
577 * Run the non-IO destructors first: they may want to output
578 * error messages, close files etc */
579 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
580 visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
581 /* And if there are some very tenacious barnacles clinging to arrays,
582 closures, or what have you.... */
583 visit(do_curse, SVs_OBJECT, SVs_OBJECT);
584 olddef = PL_defoutgv;
585 PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
586 if (olddef && isGV_with_GP(olddef))
587 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
588 olderr = PL_stderrgv;
589 PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
590 if (olderr && isGV_with_GP(olderr))
591 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
592 SvREFCNT_dec(olddef);
593 PL_in_clean_objs = FALSE;
596 /* called by sv_clean_all() for each live SV */
599 do_clean_all(pTHX_ SV *const sv)
602 if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
603 /* don't clean pid table and strtab */
606 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
607 SvFLAGS(sv) |= SVf_BREAK;
612 =for apidoc sv_clean_all
614 Decrement the refcnt of each remaining SV, possibly triggering a
615 cleanup. This function may have to be called multiple times to free
616 SVs which are in complex self-referential hierarchies.
622 Perl_sv_clean_all(pTHX)
626 PL_in_clean_all = TRUE;
627 cleaned = visit(do_clean_all, 0,0);
632 ARENASETS: a meta-arena implementation which separates arena-info
633 into struct arena_set, which contains an array of struct
634 arena_descs, each holding info for a single arena. By separating
635 the meta-info from the arena, we recover the 1st slot, formerly
636 borrowed for list management. The arena_set is about the size of an
637 arena, avoiding the needless malloc overhead of a naive linked-list.
639 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
640 memory in the last arena-set (1/2 on average). In trade, we get
641 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
642 smaller types). The recovery of the wasted space allows use of
643 small arenas for large, rare body types, by changing array* fields
644 in body_details_by_type[] below.
647 char *arena; /* the raw storage, allocated aligned */
648 size_t size; /* its size ~4k typ */
649 svtype utype; /* bodytype stored in arena */
654 /* Get the maximum number of elements in set[] such that struct arena_set
655 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
656 therefore likely to be 1 aligned memory page. */
658 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
659 - 2 * sizeof(int)) / sizeof (struct arena_desc))
662 struct arena_set* next;
663 unsigned int set_size; /* ie ARENAS_PER_SET */
664 unsigned int curr; /* index of next available arena-desc */
665 struct arena_desc set[ARENAS_PER_SET];
669 =for apidoc sv_free_arenas
671 Deallocate the memory used by all arenas. Note that all the individual SV
672 heads and bodies within the arenas must already have been freed.
677 Perl_sv_free_arenas(pTHX)
684 /* Free arenas here, but be careful about fake ones. (We assume
685 contiguity of the fake ones with the corresponding real ones.) */
687 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
688 svanext = MUTABLE_SV(SvANY(sva));
689 while (svanext && SvFAKE(svanext))
690 svanext = MUTABLE_SV(SvANY(svanext));
697 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
700 struct arena_set *current = aroot;
703 assert(aroot->set[i].arena);
704 Safefree(aroot->set[i].arena);
712 i = PERL_ARENA_ROOTS_SIZE;
714 PL_body_roots[i] = 0;
721 Here are mid-level routines that manage the allocation of bodies out
722 of the various arenas. There are 5 kinds of arenas:
724 1. SV-head arenas, which are discussed and handled above
725 2. regular body arenas
726 3. arenas for reduced-size bodies
729 Arena types 2 & 3 are chained by body-type off an array of
730 arena-root pointers, which is indexed by svtype. Some of the
731 larger/less used body types are malloced singly, since a large
732 unused block of them is wasteful. Also, several svtypes dont have
733 bodies; the data fits into the sv-head itself. The arena-root
734 pointer thus has a few unused root-pointers (which may be hijacked
735 later for arena types 4,5)
737 3 differs from 2 as an optimization; some body types have several
738 unused fields in the front of the structure (which are kept in-place
739 for consistency). These bodies can be allocated in smaller chunks,
740 because the leading fields arent accessed. Pointers to such bodies
741 are decremented to point at the unused 'ghost' memory, knowing that
742 the pointers are used with offsets to the real memory.
745 =head1 SV-Body Allocation
747 Allocation of SV-bodies is similar to SV-heads, differing as follows;
748 the allocation mechanism is used for many body types, so is somewhat
749 more complicated, it uses arena-sets, and has no need for still-live
752 At the outermost level, (new|del)_X*V macros return bodies of the
753 appropriate type. These macros call either (new|del)_body_type or
754 (new|del)_body_allocated macro pairs, depending on specifics of the
755 type. Most body types use the former pair, the latter pair is used to
756 allocate body types with "ghost fields".
758 "ghost fields" are fields that are unused in certain types, and
759 consequently don't need to actually exist. They are declared because
760 they're part of a "base type", which allows use of functions as
761 methods. The simplest examples are AVs and HVs, 2 aggregate types
762 which don't use the fields which support SCALAR semantics.
764 For these types, the arenas are carved up into appropriately sized
765 chunks, we thus avoid wasted memory for those unaccessed members.
766 When bodies are allocated, we adjust the pointer back in memory by the
767 size of the part not allocated, so it's as if we allocated the full
768 structure. (But things will all go boom if you write to the part that
769 is "not there", because you'll be overwriting the last members of the
770 preceding structure in memory.)
772 We calculate the correction using the STRUCT_OFFSET macro on the first
773 member present. If the allocated structure is smaller (no initial NV
774 actually allocated) then the net effect is to subtract the size of the NV
775 from the pointer, to return a new pointer as if an initial NV were actually
776 allocated. (We were using structures named *_allocated for this, but
777 this turned out to be a subtle bug, because a structure without an NV
778 could have a lower alignment constraint, but the compiler is allowed to
779 optimised accesses based on the alignment constraint of the actual pointer
780 to the full structure, for example, using a single 64 bit load instruction
781 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
783 This is the same trick as was used for NV and IV bodies. Ironically it
784 doesn't need to be used for NV bodies any more, because NV is now at
785 the start of the structure. IV bodies don't need it either, because
786 they are no longer allocated.
788 In turn, the new_body_* allocators call S_new_body(), which invokes
789 new_body_inline macro, which takes a lock, and takes a body off the
790 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
791 necessary to refresh an empty list. Then the lock is released, and
792 the body is returned.
794 Perl_more_bodies allocates a new arena, and carves it up into an array of N
795 bodies, which it strings into a linked list. It looks up arena-size
796 and body-size from the body_details table described below, thus
797 supporting the multiple body-types.
799 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
800 the (new|del)_X*V macros are mapped directly to malloc/free.
802 For each sv-type, struct body_details bodies_by_type[] carries
803 parameters which control these aspects of SV handling:
805 Arena_size determines whether arenas are used for this body type, and if
806 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
807 zero, forcing individual mallocs and frees.
809 Body_size determines how big a body is, and therefore how many fit into
810 each arena. Offset carries the body-pointer adjustment needed for
811 "ghost fields", and is used in *_allocated macros.
813 But its main purpose is to parameterize info needed in
814 Perl_sv_upgrade(). The info here dramatically simplifies the function
815 vs the implementation in 5.8.8, making it table-driven. All fields
816 are used for this, except for arena_size.
818 For the sv-types that have no bodies, arenas are not used, so those
819 PL_body_roots[sv_type] are unused, and can be overloaded. In
820 something of a special case, SVt_NULL is borrowed for HE arenas;
821 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
822 bodies_by_type[SVt_NULL] slot is not used, as the table is not
827 struct body_details {
828 U8 body_size; /* Size to allocate */
829 U8 copy; /* Size of structure to copy (may be shorter) */
831 unsigned int type : 4; /* We have space for a sanity check. */
832 unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
833 unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
834 unsigned int arena : 1; /* Allocated from an arena */
835 size_t arena_size; /* Size of arena to allocate */
843 /* With -DPURFIY we allocate everything directly, and don't use arenas.
844 This seems a rather elegant way to simplify some of the code below. */
845 #define HASARENA FALSE
847 #define HASARENA TRUE
849 #define NOARENA FALSE
851 /* Size the arenas to exactly fit a given number of bodies. A count
852 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
853 simplifying the default. If count > 0, the arena is sized to fit
854 only that many bodies, allowing arenas to be used for large, rare
855 bodies (XPVFM, XPVIO) without undue waste. The arena size is
856 limited by PERL_ARENA_SIZE, so we can safely oversize the
859 #define FIT_ARENA0(body_size) \
860 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
861 #define FIT_ARENAn(count,body_size) \
862 ( count * body_size <= PERL_ARENA_SIZE) \
863 ? count * body_size \
864 : FIT_ARENA0 (body_size)
865 #define FIT_ARENA(count,body_size) \
867 ? FIT_ARENAn (count, body_size) \
868 : FIT_ARENA0 (body_size)
870 /* Calculate the length to copy. Specifically work out the length less any
871 final padding the compiler needed to add. See the comment in sv_upgrade
872 for why copying the padding proved to be a bug. */
874 #define copy_length(type, last_member) \
875 STRUCT_OFFSET(type, last_member) \
876 + sizeof (((type*)SvANY((const SV *)0))->last_member)
878 static const struct body_details bodies_by_type[] = {
879 /* HEs use this offset for their arena. */
880 { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
882 /* IVs are in the head, so the allocation size is 0. */
884 sizeof(IV), /* This is used to copy out the IV body. */
885 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
886 NOARENA /* IVS don't need an arena */, 0
889 { sizeof(NV), sizeof(NV),
890 STRUCT_OFFSET(XPVNV, xnv_u),
891 SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
893 { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
894 copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
895 + STRUCT_OFFSET(XPV, xpv_cur),
896 SVt_PV, FALSE, NONV, HASARENA,
897 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
899 { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur),
900 copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur),
901 + STRUCT_OFFSET(XPV, xpv_cur),
902 SVt_INVLIST, TRUE, NONV, HASARENA,
903 FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) },
905 { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
906 copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
907 + STRUCT_OFFSET(XPV, xpv_cur),
908 SVt_PVIV, FALSE, NONV, HASARENA,
909 FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
911 { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
912 copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
913 + STRUCT_OFFSET(XPV, xpv_cur),
914 SVt_PVNV, FALSE, HADNV, HASARENA,
915 FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
917 { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
918 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
923 SVt_REGEXP, TRUE, NONV, HASARENA,
924 FIT_ARENA(0, sizeof(regexp))
927 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
928 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
930 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
931 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
934 copy_length(XPVAV, xav_alloc),
936 SVt_PVAV, TRUE, NONV, HASARENA,
937 FIT_ARENA(0, sizeof(XPVAV)) },
940 copy_length(XPVHV, xhv_max),
942 SVt_PVHV, TRUE, NONV, HASARENA,
943 FIT_ARENA(0, sizeof(XPVHV)) },
948 SVt_PVCV, TRUE, NONV, HASARENA,
949 FIT_ARENA(0, sizeof(XPVCV)) },
954 SVt_PVFM, TRUE, NONV, NOARENA,
955 FIT_ARENA(20, sizeof(XPVFM)) },
960 SVt_PVIO, TRUE, NONV, HASARENA,
961 FIT_ARENA(24, sizeof(XPVIO)) },
964 #define new_body_allocated(sv_type) \
965 (void *)((char *)S_new_body(aTHX_ sv_type) \
966 - bodies_by_type[sv_type].offset)
968 /* return a thing to the free list */
970 #define del_body(thing, root) \
972 void ** const thing_copy = (void **)thing; \
973 *thing_copy = *root; \
974 *root = (void*)thing_copy; \
979 #define new_XNV() safemalloc(sizeof(XPVNV))
980 #define new_XPVNV() safemalloc(sizeof(XPVNV))
981 #define new_XPVMG() safemalloc(sizeof(XPVMG))
983 #define del_XPVGV(p) safefree(p)
987 #define new_XNV() new_body_allocated(SVt_NV)
988 #define new_XPVNV() new_body_allocated(SVt_PVNV)
989 #define new_XPVMG() new_body_allocated(SVt_PVMG)
991 #define del_XPVGV(p) del_body(p + bodies_by_type[SVt_PVGV].offset, \
992 &PL_body_roots[SVt_PVGV])
996 /* no arena for you! */
998 #define new_NOARENA(details) \
999 safemalloc((details)->body_size + (details)->offset)
1000 #define new_NOARENAZ(details) \
1001 safecalloc((details)->body_size + (details)->offset, 1)
1004 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
1005 const size_t arena_size)
1008 void ** const root = &PL_body_roots[sv_type];
1009 struct arena_desc *adesc;
1010 struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1014 const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1015 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1016 static bool done_sanity_check;
1018 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1019 * variables like done_sanity_check. */
1020 if (!done_sanity_check) {
1021 unsigned int i = SVt_LAST;
1023 done_sanity_check = TRUE;
1026 assert (bodies_by_type[i].type == i);
1032 /* may need new arena-set to hold new arena */
1033 if (!aroot || aroot->curr >= aroot->set_size) {
1034 struct arena_set *newroot;
1035 Newxz(newroot, 1, struct arena_set);
1036 newroot->set_size = ARENAS_PER_SET;
1037 newroot->next = aroot;
1039 PL_body_arenas = (void *) newroot;
1040 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1043 /* ok, now have arena-set with at least 1 empty/available arena-desc */
1044 curr = aroot->curr++;
1045 adesc = &(aroot->set[curr]);
1046 assert(!adesc->arena);
1048 Newx(adesc->arena, good_arena_size, char);
1049 adesc->size = good_arena_size;
1050 adesc->utype = sv_type;
1051 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
1052 curr, (void*)adesc->arena, (UV)good_arena_size));
1054 start = (char *) adesc->arena;
1056 /* Get the address of the byte after the end of the last body we can fit.
1057 Remember, this is integer division: */
1058 end = start + good_arena_size / body_size * body_size;
1060 /* computed count doesn't reflect the 1st slot reservation */
1061 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1062 DEBUG_m(PerlIO_printf(Perl_debug_log,
1063 "arena %p end %p arena-size %d (from %d) type %d "
1065 (void*)start, (void*)end, (int)good_arena_size,
1066 (int)arena_size, sv_type, (int)body_size,
1067 (int)good_arena_size / (int)body_size));
1069 DEBUG_m(PerlIO_printf(Perl_debug_log,
1070 "arena %p end %p arena-size %d type %d size %d ct %d\n",
1071 (void*)start, (void*)end,
1072 (int)arena_size, sv_type, (int)body_size,
1073 (int)good_arena_size / (int)body_size));
1075 *root = (void *)start;
1078 /* Where the next body would start: */
1079 char * const next = start + body_size;
1082 /* This is the last body: */
1083 assert(next == end);
1085 *(void **)start = 0;
1089 *(void**) start = (void *)next;
1094 /* grab a new thing from the free list, allocating more if necessary.
1095 The inline version is used for speed in hot routines, and the
1096 function using it serves the rest (unless PURIFY).
1098 #define new_body_inline(xpv, sv_type) \
1100 void ** const r3wt = &PL_body_roots[sv_type]; \
1101 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
1102 ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1103 bodies_by_type[sv_type].body_size,\
1104 bodies_by_type[sv_type].arena_size)); \
1105 *(r3wt) = *(void**)(xpv); \
1111 S_new_body(pTHX_ const svtype sv_type)
1115 new_body_inline(xpv, sv_type);
1121 static const struct body_details fake_rv =
1122 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1125 =for apidoc sv_upgrade
1127 Upgrade an SV to a more complex form. Generally adds a new body type to the
1128 SV, then copies across as much information as possible from the old body.
1129 It croaks if the SV is already in a more complex form than requested. You
1130 generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
1131 before calling C<sv_upgrade>, and hence does not croak. See also
1138 Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
1143 const svtype old_type = SvTYPE(sv);
1144 const struct body_details *new_type_details;
1145 const struct body_details *old_type_details
1146 = bodies_by_type + old_type;
1147 SV *referant = NULL;
1149 PERL_ARGS_ASSERT_SV_UPGRADE;
1151 if (old_type == new_type)
1154 /* This clause was purposefully added ahead of the early return above to
1155 the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1156 inference by Nick I-S that it would fix other troublesome cases. See
1157 changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1159 Given that shared hash key scalars are no longer PVIV, but PV, there is
1160 no longer need to unshare so as to free up the IVX slot for its proper
1161 purpose. So it's safe to move the early return earlier. */
1163 if (new_type > SVt_PVMG && SvIsCOW(sv)) {
1164 sv_force_normal_flags(sv, 0);
1167 old_body = SvANY(sv);
1169 /* Copying structures onto other structures that have been neatly zeroed
1170 has a subtle gotcha. Consider XPVMG
1172 +------+------+------+------+------+-------+-------+
1173 | NV | CUR | LEN | IV | MAGIC | STASH |
1174 +------+------+------+------+------+-------+-------+
1175 0 4 8 12 16 20 24 28
1177 where NVs are aligned to 8 bytes, so that sizeof that structure is
1178 actually 32 bytes long, with 4 bytes of padding at the end:
1180 +------+------+------+------+------+-------+-------+------+
1181 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1182 +------+------+------+------+------+-------+-------+------+
1183 0 4 8 12 16 20 24 28 32
1185 so what happens if you allocate memory for this structure:
1187 +------+------+------+------+------+-------+-------+------+------+...
1188 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1189 +------+------+------+------+------+-------+-------+------+------+...
1190 0 4 8 12 16 20 24 28 32 36
1192 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1193 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1194 started out as zero once, but it's quite possible that it isn't. So now,
1195 rather than a nicely zeroed GP, you have it pointing somewhere random.
1198 (In fact, GP ends up pointing at a previous GP structure, because the
1199 principle cause of the padding in XPVMG getting garbage is a copy of
1200 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1201 this happens to be moot because XPVGV has been re-ordered, with GP
1202 no longer after STASH)
1204 So we are careful and work out the size of used parts of all the
1212 referant = SvRV(sv);
1213 old_type_details = &fake_rv;
1214 if (new_type == SVt_NV)
1215 new_type = SVt_PVNV;
1217 if (new_type < SVt_PVIV) {
1218 new_type = (new_type == SVt_NV)
1219 ? SVt_PVNV : SVt_PVIV;
1224 if (new_type < SVt_PVNV) {
1225 new_type = SVt_PVNV;
1229 assert(new_type > SVt_PV);
1230 assert(SVt_IV < SVt_PV);
1231 assert(SVt_NV < SVt_PV);
1238 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1239 there's no way that it can be safely upgraded, because perl.c
1240 expects to Safefree(SvANY(PL_mess_sv)) */
1241 assert(sv != PL_mess_sv);
1242 /* This flag bit is used to mean other things in other scalar types.
1243 Given that it only has meaning inside the pad, it shouldn't be set
1244 on anything that can get upgraded. */
1245 assert(!SvPAD_TYPED(sv));
1248 if (UNLIKELY(old_type_details->cant_upgrade))
1249 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1250 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1253 if (UNLIKELY(old_type > new_type))
1254 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1255 (int)old_type, (int)new_type);
1257 new_type_details = bodies_by_type + new_type;
1259 SvFLAGS(sv) &= ~SVTYPEMASK;
1260 SvFLAGS(sv) |= new_type;
1262 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1263 the return statements above will have triggered. */
1264 assert (new_type != SVt_NULL);
1267 assert(old_type == SVt_NULL);
1268 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1272 assert(old_type == SVt_NULL);
1273 SvANY(sv) = new_XNV();
1278 assert(new_type_details->body_size);
1281 assert(new_type_details->arena);
1282 assert(new_type_details->arena_size);
1283 /* This points to the start of the allocated area. */
1284 new_body_inline(new_body, new_type);
1285 Zero(new_body, new_type_details->body_size, char);
1286 new_body = ((char *)new_body) - new_type_details->offset;
1288 /* We always allocated the full length item with PURIFY. To do this
1289 we fake things so that arena is false for all 16 types.. */
1290 new_body = new_NOARENAZ(new_type_details);
1292 SvANY(sv) = new_body;
1293 if (new_type == SVt_PVAV) {
1297 if (old_type_details->body_size) {
1300 /* It will have been zeroed when the new body was allocated.
1301 Lets not write to it, in case it confuses a write-back
1307 #ifndef NODEFAULT_SHAREKEYS
1308 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1310 /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
1311 HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
1314 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1315 The target created by newSVrv also is, and it can have magic.
1316 However, it never has SvPVX set.
1318 if (old_type == SVt_IV) {
1320 } else if (old_type >= SVt_PV) {
1321 assert(SvPVX_const(sv) == 0);
1324 if (old_type >= SVt_PVMG) {
1325 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1326 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1328 sv->sv_u.svu_array = NULL; /* or svu_hash */
1333 /* XXX Is this still needed? Was it ever needed? Surely as there is
1334 no route from NV to PVIV, NOK can never be true */
1335 assert(!SvNOKp(sv));
1348 assert(new_type_details->body_size);
1349 /* We always allocated the full length item with PURIFY. To do this
1350 we fake things so that arena is false for all 16 types.. */
1351 if(new_type_details->arena) {
1352 /* This points to the start of the allocated area. */
1353 new_body_inline(new_body, new_type);
1354 Zero(new_body, new_type_details->body_size, char);
1355 new_body = ((char *)new_body) - new_type_details->offset;
1357 new_body = new_NOARENAZ(new_type_details);
1359 SvANY(sv) = new_body;
1361 if (old_type_details->copy) {
1362 /* There is now the potential for an upgrade from something without
1363 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1364 int offset = old_type_details->offset;
1365 int length = old_type_details->copy;
1367 if (new_type_details->offset > old_type_details->offset) {
1368 const int difference
1369 = new_type_details->offset - old_type_details->offset;
1370 offset += difference;
1371 length -= difference;
1373 assert (length >= 0);
1375 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1379 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1380 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1381 * correct 0.0 for us. Otherwise, if the old body didn't have an
1382 * NV slot, but the new one does, then we need to initialise the
1383 * freshly created NV slot with whatever the correct bit pattern is
1385 if (old_type_details->zero_nv && !new_type_details->zero_nv
1386 && !isGV_with_GP(sv))
1390 if (UNLIKELY(new_type == SVt_PVIO)) {
1391 IO * const io = MUTABLE_IO(sv);
1392 GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1395 /* Clear the stashcache because a new IO could overrule a package
1397 DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
1398 hv_clear(PL_stashcache);
1400 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1401 IoPAGE_LEN(sv) = 60;
1403 if (UNLIKELY(new_type == SVt_REGEXP))
1404 sv->sv_u.svu_rx = (regexp *)new_body;
1405 else if (old_type < SVt_PV) {
1406 /* referant will be NULL unless the old type was SVt_IV emulating
1408 sv->sv_u.svu_rv = referant;
1412 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1413 (unsigned long)new_type);
1416 if (old_type > SVt_IV) {
1420 /* Note that there is an assumption that all bodies of types that
1421 can be upgraded came from arenas. Only the more complex non-
1422 upgradable types are allowed to be directly malloc()ed. */
1423 assert(old_type_details->arena);
1424 del_body((void*)((char*)old_body + old_type_details->offset),
1425 &PL_body_roots[old_type]);
1431 =for apidoc sv_backoff
1433 Remove any string offset. You should normally use the C<SvOOK_off> macro
1440 Perl_sv_backoff(pTHX_ SV *const sv)
1443 const char * const s = SvPVX_const(sv);
1445 PERL_ARGS_ASSERT_SV_BACKOFF;
1446 PERL_UNUSED_CONTEXT;
1449 assert(SvTYPE(sv) != SVt_PVHV);
1450 assert(SvTYPE(sv) != SVt_PVAV);
1452 SvOOK_offset(sv, delta);
1454 SvLEN_set(sv, SvLEN(sv) + delta);
1455 SvPV_set(sv, SvPVX(sv) - delta);
1456 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1457 SvFLAGS(sv) &= ~SVf_OOK;
1464 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1465 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1466 Use the C<SvGROW> wrapper instead.
1471 static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
1474 Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
1478 PERL_ARGS_ASSERT_SV_GROW;
1482 if (SvTYPE(sv) < SVt_PV) {
1483 sv_upgrade(sv, SVt_PV);
1484 s = SvPVX_mutable(sv);
1486 else if (SvOOK(sv)) { /* pv is offset? */
1488 s = SvPVX_mutable(sv);
1489 if (newlen > SvLEN(sv))
1490 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1494 if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0);
1495 s = SvPVX_mutable(sv);
1498 #ifdef PERL_NEW_COPY_ON_WRITE
1499 /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1500 * to store the COW count. So in general, allocate one more byte than
1501 * asked for, to make it likely this byte is always spare: and thus
1502 * make more strings COW-able.
1503 * If the new size is a big power of two, don't bother: we assume the
1504 * caller wanted a nice 2^N sized block and will be annoyed at getting
1510 if (newlen > SvLEN(sv)) { /* need more room? */
1511 STRLEN minlen = SvCUR(sv);
1512 minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1513 if (newlen < minlen)
1515 #ifndef Perl_safesysmalloc_size
1516 newlen = PERL_STRLEN_ROUNDUP(newlen);
1518 if (SvLEN(sv) && s) {
1519 s = (char*)saferealloc(s, newlen);
1522 s = (char*)safemalloc(newlen);
1523 if (SvPVX_const(sv) && SvCUR(sv)) {
1524 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1528 #ifdef Perl_safesysmalloc_size
1529 /* Do this here, do it once, do it right, and then we will never get
1530 called back into sv_grow() unless there really is some growing
1532 SvLEN_set(sv, Perl_safesysmalloc_size(s));
1534 SvLEN_set(sv, newlen);
1541 =for apidoc sv_setiv
1543 Copies an integer into the given SV, upgrading first if necessary.
1544 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1550 Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
1554 PERL_ARGS_ASSERT_SV_SETIV;
1556 SV_CHECK_THINKFIRST_COW_DROP(sv);
1557 switch (SvTYPE(sv)) {
1560 sv_upgrade(sv, SVt_IV);
1563 sv_upgrade(sv, SVt_PVIV);
1567 if (!isGV_with_GP(sv))
1574 /* diag_listed_as: Can't coerce %s to %s in %s */
1575 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1579 (void)SvIOK_only(sv); /* validate number */
1585 =for apidoc sv_setiv_mg
1587 Like C<sv_setiv>, but also handles 'set' magic.
1593 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1595 PERL_ARGS_ASSERT_SV_SETIV_MG;
1602 =for apidoc sv_setuv
1604 Copies an unsigned integer into the given SV, upgrading first if necessary.
1605 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1611 Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1613 PERL_ARGS_ASSERT_SV_SETUV;
1615 /* With the if statement to ensure that integers are stored as IVs whenever
1617 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1620 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1622 If you wish to remove the following if statement, so that this routine
1623 (and its callers) always return UVs, please benchmark to see what the
1624 effect is. Modern CPUs may be different. Or may not :-)
1626 if (u <= (UV)IV_MAX) {
1627 sv_setiv(sv, (IV)u);
1636 =for apidoc sv_setuv_mg
1638 Like C<sv_setuv>, but also handles 'set' magic.
1644 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1646 PERL_ARGS_ASSERT_SV_SETUV_MG;
1653 =for apidoc sv_setnv
1655 Copies a double into the given SV, upgrading first if necessary.
1656 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1662 Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1666 PERL_ARGS_ASSERT_SV_SETNV;
1668 SV_CHECK_THINKFIRST_COW_DROP(sv);
1669 switch (SvTYPE(sv)) {
1672 sv_upgrade(sv, SVt_NV);
1676 sv_upgrade(sv, SVt_PVNV);
1680 if (!isGV_with_GP(sv))
1687 /* diag_listed_as: Can't coerce %s to %s in %s */
1688 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1693 (void)SvNOK_only(sv); /* validate number */
1698 =for apidoc sv_setnv_mg
1700 Like C<sv_setnv>, but also handles 'set' magic.
1706 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1708 PERL_ARGS_ASSERT_SV_SETNV_MG;
1714 /* Return a cleaned-up, printable version of sv, for non-numeric, or
1715 * not incrementable warning display.
1716 * Originally part of S_not_a_number().
1717 * The return value may be != tmpbuf.
1721 S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1724 PERL_ARGS_ASSERT_SV_DISPLAY;
1727 SV *dsv = newSVpvs_flags("", SVs_TEMP);
1728 pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
1731 const char * const limit = tmpbuf + tmpbuf_size - 8;
1732 /* each *s can expand to 4 chars + "...\0",
1733 i.e. need room for 8 chars */
1735 const char *s = SvPVX_const(sv);
1736 const char * const end = s + SvCUR(sv);
1737 for ( ; s < end && d < limit; s++ ) {
1739 if (! isASCII(ch) && !isPRINT_LC(ch)) {
1743 /* Map to ASCII "equivalent" of Latin1 */
1744 ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1750 else if (ch == '\r') {
1754 else if (ch == '\f') {
1758 else if (ch == '\\') {
1762 else if (ch == '\0') {
1766 else if (isPRINT_LC(ch))
1785 /* Print an "isn't numeric" warning, using a cleaned-up,
1786 * printable version of the offending string
1790 S_not_a_number(pTHX_ SV *const sv)
1796 PERL_ARGS_ASSERT_NOT_A_NUMBER;
1798 pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1801 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1802 /* diag_listed_as: Argument "%s" isn't numeric%s */
1803 "Argument \"%s\" isn't numeric in %s", pv,
1806 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1807 /* diag_listed_as: Argument "%s" isn't numeric%s */
1808 "Argument \"%s\" isn't numeric", pv);
1812 S_not_incrementable(pTHX_ SV *const sv) {
1817 PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1819 pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1821 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1822 "Argument \"%s\" treated as 0 in increment (++)", pv);
1826 =for apidoc looks_like_number
1828 Test if the content of an SV looks like a number (or is a number).
1829 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1830 non-numeric warning), even if your atof() doesn't grok them. Get-magic is
1837 Perl_looks_like_number(pTHX_ SV *const sv)
1842 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1844 if (SvPOK(sv) || SvPOKp(sv)) {
1845 sbegin = SvPV_nomg_const(sv, len);
1848 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1849 return grok_number(sbegin, len, NULL);
1853 S_glob_2number(pTHX_ GV * const gv)
1855 PERL_ARGS_ASSERT_GLOB_2NUMBER;
1857 /* We know that all GVs stringify to something that is not-a-number,
1858 so no need to test that. */
1859 if (ckWARN(WARN_NUMERIC))
1861 SV *const buffer = sv_newmortal();
1862 gv_efullname3(buffer, gv, "*");
1863 not_a_number(buffer);
1865 /* We just want something true to return, so that S_sv_2iuv_common
1866 can tail call us and return true. */
1870 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1871 until proven guilty, assume that things are not that bad... */
1876 As 64 bit platforms often have an NV that doesn't preserve all bits of
1877 an IV (an assumption perl has been based on to date) it becomes necessary
1878 to remove the assumption that the NV always carries enough precision to
1879 recreate the IV whenever needed, and that the NV is the canonical form.
1880 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1881 precision as a side effect of conversion (which would lead to insanity
1882 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1883 1) to distinguish between IV/UV/NV slots that have cached a valid
1884 conversion where precision was lost and IV/UV/NV slots that have a
1885 valid conversion which has lost no precision
1886 2) to ensure that if a numeric conversion to one form is requested that
1887 would lose precision, the precise conversion (or differently
1888 imprecise conversion) is also performed and cached, to prevent
1889 requests for different numeric formats on the same SV causing
1890 lossy conversion chains. (lossless conversion chains are perfectly
1895 SvIOKp is true if the IV slot contains a valid value
1896 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1897 SvNOKp is true if the NV slot contains a valid value
1898 SvNOK is true only if the NV value is accurate
1901 while converting from PV to NV, check to see if converting that NV to an
1902 IV(or UV) would lose accuracy over a direct conversion from PV to
1903 IV(or UV). If it would, cache both conversions, return NV, but mark
1904 SV as IOK NOKp (ie not NOK).
1906 While converting from PV to IV, check to see if converting that IV to an
1907 NV would lose accuracy over a direct conversion from PV to NV. If it
1908 would, cache both conversions, flag similarly.
1910 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1911 correctly because if IV & NV were set NV *always* overruled.
1912 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1913 changes - now IV and NV together means that the two are interchangeable:
1914 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1916 The benefit of this is that operations such as pp_add know that if
1917 SvIOK is true for both left and right operands, then integer addition
1918 can be used instead of floating point (for cases where the result won't
1919 overflow). Before, floating point was always used, which could lead to
1920 loss of precision compared with integer addition.
1922 * making IV and NV equal status should make maths accurate on 64 bit
1924 * may speed up maths somewhat if pp_add and friends start to use
1925 integers when possible instead of fp. (Hopefully the overhead in
1926 looking for SvIOK and checking for overflow will not outweigh the
1927 fp to integer speedup)
1928 * will slow down integer operations (callers of SvIV) on "inaccurate"
1929 values, as the change from SvIOK to SvIOKp will cause a call into
1930 sv_2iv each time rather than a macro access direct to the IV slot
1931 * should speed up number->string conversion on integers as IV is
1932 favoured when IV and NV are equally accurate
1934 ####################################################################
1935 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1936 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1937 On the other hand, SvUOK is true iff UV.
1938 ####################################################################
1940 Your mileage will vary depending your CPU's relative fp to integer
1944 #ifndef NV_PRESERVES_UV
1945 # define IS_NUMBER_UNDERFLOW_IV 1
1946 # define IS_NUMBER_UNDERFLOW_UV 2
1947 # define IS_NUMBER_IV_AND_UV 2
1948 # define IS_NUMBER_OVERFLOW_IV 4
1949 # define IS_NUMBER_OVERFLOW_UV 5
1951 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1953 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1955 S_sv_2iuv_non_preserve(pTHX_ SV *const sv
1963 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1965 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));
1966 if (SvNVX(sv) < (NV)IV_MIN) {
1967 (void)SvIOKp_on(sv);
1969 SvIV_set(sv, IV_MIN);
1970 return IS_NUMBER_UNDERFLOW_IV;
1972 if (SvNVX(sv) > (NV)UV_MAX) {
1973 (void)SvIOKp_on(sv);
1976 SvUV_set(sv, UV_MAX);
1977 return IS_NUMBER_OVERFLOW_UV;
1979 (void)SvIOKp_on(sv);
1981 /* Can't use strtol etc to convert this string. (See truth table in
1983 if (SvNVX(sv) <= (UV)IV_MAX) {
1984 SvIV_set(sv, I_V(SvNVX(sv)));
1985 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1986 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1988 /* Integer is imprecise. NOK, IOKp */
1990 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1993 SvUV_set(sv, U_V(SvNVX(sv)));
1994 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1995 if (SvUVX(sv) == UV_MAX) {
1996 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1997 possibly be preserved by NV. Hence, it must be overflow.
1999 return IS_NUMBER_OVERFLOW_UV;
2001 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2003 /* Integer is imprecise. NOK, IOKp */
2005 return IS_NUMBER_OVERFLOW_IV;
2007 #endif /* !NV_PRESERVES_UV*/
2010 S_sv_2iuv_common(pTHX_ SV *const sv)
2014 PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2017 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2018 * without also getting a cached IV/UV from it at the same time
2019 * (ie PV->NV conversion should detect loss of accuracy and cache
2020 * IV or UV at same time to avoid this. */
2021 /* IV-over-UV optimisation - choose to cache IV if possible */
2023 if (SvTYPE(sv) == SVt_NV)
2024 sv_upgrade(sv, SVt_PVNV);
2026 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2027 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2028 certainly cast into the IV range at IV_MAX, whereas the correct
2029 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2031 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2032 if (Perl_isnan(SvNVX(sv))) {
2038 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2039 SvIV_set(sv, I_V(SvNVX(sv)));
2040 if (SvNVX(sv) == (NV) SvIVX(sv)
2041 #ifndef NV_PRESERVES_UV
2042 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2043 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2044 /* Don't flag it as "accurately an integer" if the number
2045 came from a (by definition imprecise) NV operation, and
2046 we're outside the range of NV integer precision */
2050 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2052 /* scalar has trailing garbage, eg "42a" */
2054 DEBUG_c(PerlIO_printf(Perl_debug_log,
2055 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2061 /* IV not precise. No need to convert from PV, as NV
2062 conversion would already have cached IV if it detected
2063 that PV->IV would be better than PV->NV->IV
2064 flags already correct - don't set public IOK. */
2065 DEBUG_c(PerlIO_printf(Perl_debug_log,
2066 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2071 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2072 but the cast (NV)IV_MIN rounds to a the value less (more
2073 negative) than IV_MIN which happens to be equal to SvNVX ??
2074 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2075 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2076 (NV)UVX == NVX are both true, but the values differ. :-(
2077 Hopefully for 2s complement IV_MIN is something like
2078 0x8000000000000000 which will be exact. NWC */
2081 SvUV_set(sv, U_V(SvNVX(sv)));
2083 (SvNVX(sv) == (NV) SvUVX(sv))
2084 #ifndef NV_PRESERVES_UV
2085 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2086 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2087 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2088 /* Don't flag it as "accurately an integer" if the number
2089 came from a (by definition imprecise) NV operation, and
2090 we're outside the range of NV integer precision */
2096 DEBUG_c(PerlIO_printf(Perl_debug_log,
2097 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2103 else if (SvPOKp(sv)) {
2105 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2106 /* We want to avoid a possible problem when we cache an IV/ a UV which
2107 may be later translated to an NV, and the resulting NV is not
2108 the same as the direct translation of the initial string
2109 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2110 be careful to ensure that the value with the .456 is around if the
2111 NV value is requested in the future).
2113 This means that if we cache such an IV/a UV, we need to cache the
2114 NV as well. Moreover, we trade speed for space, and do not
2115 cache the NV if we are sure it's not needed.
2118 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2119 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2120 == IS_NUMBER_IN_UV) {
2121 /* It's definitely an integer, only upgrade to PVIV */
2122 if (SvTYPE(sv) < SVt_PVIV)
2123 sv_upgrade(sv, SVt_PVIV);
2125 } else if (SvTYPE(sv) < SVt_PVNV)
2126 sv_upgrade(sv, SVt_PVNV);
2128 /* If NVs preserve UVs then we only use the UV value if we know that
2129 we aren't going to call atof() below. If NVs don't preserve UVs
2130 then the value returned may have more precision than atof() will
2131 return, even though value isn't perfectly accurate. */
2132 if ((numtype & (IS_NUMBER_IN_UV
2133 #ifdef NV_PRESERVES_UV
2136 )) == IS_NUMBER_IN_UV) {
2137 /* This won't turn off the public IOK flag if it was set above */
2138 (void)SvIOKp_on(sv);
2140 if (!(numtype & IS_NUMBER_NEG)) {
2142 if (value <= (UV)IV_MAX) {
2143 SvIV_set(sv, (IV)value);
2145 /* it didn't overflow, and it was positive. */
2146 SvUV_set(sv, value);
2150 /* 2s complement assumption */
2151 if (value <= (UV)IV_MIN) {
2152 SvIV_set(sv, -(IV)value);
2154 /* Too negative for an IV. This is a double upgrade, but
2155 I'm assuming it will be rare. */
2156 if (SvTYPE(sv) < SVt_PVNV)
2157 sv_upgrade(sv, SVt_PVNV);
2161 SvNV_set(sv, -(NV)value);
2162 SvIV_set(sv, IV_MIN);
2166 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2167 will be in the previous block to set the IV slot, and the next
2168 block to set the NV slot. So no else here. */
2170 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2171 != IS_NUMBER_IN_UV) {
2172 /* It wasn't an (integer that doesn't overflow the UV). */
2173 SvNV_set(sv, Atof(SvPVX_const(sv)));
2175 if (! numtype && ckWARN(WARN_NUMERIC))
2178 #if defined(USE_LONG_DOUBLE)
2179 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2180 PTR2UV(sv), SvNVX(sv)));
2182 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2183 PTR2UV(sv), SvNVX(sv)));
2186 #ifdef NV_PRESERVES_UV
2187 (void)SvIOKp_on(sv);
2189 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2190 SvIV_set(sv, I_V(SvNVX(sv)));
2191 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2194 NOOP; /* Integer is imprecise. NOK, IOKp */
2196 /* UV will not work better than IV */
2198 if (SvNVX(sv) > (NV)UV_MAX) {
2200 /* Integer is inaccurate. NOK, IOKp, is UV */
2201 SvUV_set(sv, UV_MAX);
2203 SvUV_set(sv, U_V(SvNVX(sv)));
2204 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2205 NV preservse UV so can do correct comparison. */
2206 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2209 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
2214 #else /* NV_PRESERVES_UV */
2215 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2216 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2217 /* The IV/UV slot will have been set from value returned by
2218 grok_number above. The NV slot has just been set using
2221 assert (SvIOKp(sv));
2223 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2224 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2225 /* Small enough to preserve all bits. */
2226 (void)SvIOKp_on(sv);
2228 SvIV_set(sv, I_V(SvNVX(sv)));
2229 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2231 /* Assumption: first non-preserved integer is < IV_MAX,
2232 this NV is in the preserved range, therefore: */
2233 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2235 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);
2239 0 0 already failed to read UV.
2240 0 1 already failed to read UV.
2241 1 0 you won't get here in this case. IV/UV
2242 slot set, public IOK, Atof() unneeded.
2243 1 1 already read UV.
2244 so there's no point in sv_2iuv_non_preserve() attempting
2245 to use atol, strtol, strtoul etc. */
2247 sv_2iuv_non_preserve (sv, numtype);
2249 sv_2iuv_non_preserve (sv);
2253 #endif /* NV_PRESERVES_UV */
2254 /* It might be more code efficient to go through the entire logic above
2255 and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2256 gets complex and potentially buggy, so more programmer efficient
2257 to do it this way, by turning off the public flags: */
2259 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2263 if (isGV_with_GP(sv))
2264 return glob_2number(MUTABLE_GV(sv));
2266 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2268 if (SvTYPE(sv) < SVt_IV)
2269 /* Typically the caller expects that sv_any is not NULL now. */
2270 sv_upgrade(sv, SVt_IV);
2271 /* Return 0 from the caller. */
2278 =for apidoc sv_2iv_flags
2280 Return the integer value of an SV, doing any necessary string
2281 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2282 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2288 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2295 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2296 && SvTYPE(sv) != SVt_PVFM);
2298 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2304 if (flags & SV_SKIP_OVERLOAD)
2306 tmpstr = AMG_CALLunary(sv, numer_amg);
2307 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2308 return SvIV(tmpstr);
2311 return PTR2IV(SvRV(sv));
2314 if (SvVALID(sv) || isREGEXP(sv)) {
2315 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2316 the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2317 In practice they are extremely unlikely to actually get anywhere
2318 accessible by user Perl code - the only way that I'm aware of is when
2319 a constant subroutine which is used as the second argument to index.
2321 Regexps have no SvIVX and SvNVX fields.
2323 assert(isREGEXP(sv) || SvPOKp(sv));
2326 const char * const ptr =
2327 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2329 = grok_number(ptr, SvCUR(sv), &value);
2331 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2332 == IS_NUMBER_IN_UV) {
2333 /* It's definitely an integer */
2334 if (numtype & IS_NUMBER_NEG) {
2335 if (value < (UV)IV_MIN)
2338 if (value < (UV)IV_MAX)
2343 if (ckWARN(WARN_NUMERIC))
2346 return I_V(Atof(ptr));
2350 if (SvTHINKFIRST(sv)) {
2351 #ifdef PERL_OLD_COPY_ON_WRITE
2353 sv_force_normal_flags(sv, 0);
2356 if (SvREADONLY(sv) && !SvOK(sv)) {
2357 if (ckWARN(WARN_UNINITIALIZED))
2364 if (S_sv_2iuv_common(aTHX_ sv))
2368 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2369 PTR2UV(sv),SvIVX(sv)));
2370 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2374 =for apidoc sv_2uv_flags
2376 Return the unsigned integer value of an SV, doing any necessary string
2377 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2378 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2384 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2391 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2397 if (flags & SV_SKIP_OVERLOAD)
2399 tmpstr = AMG_CALLunary(sv, numer_amg);
2400 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2401 return SvUV(tmpstr);
2404 return PTR2UV(SvRV(sv));
2407 if (SvVALID(sv) || isREGEXP(sv)) {
2408 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2409 the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2410 Regexps have no SvIVX and SvNVX fields. */
2411 assert(isREGEXP(sv) || SvPOKp(sv));
2414 const char * const ptr =
2415 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2417 = grok_number(ptr, SvCUR(sv), &value);
2419 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2420 == IS_NUMBER_IN_UV) {
2421 /* It's definitely an integer */
2422 if (!(numtype & IS_NUMBER_NEG))
2426 if (ckWARN(WARN_NUMERIC))
2429 return U_V(Atof(ptr));
2433 if (SvTHINKFIRST(sv)) {
2434 #ifdef PERL_OLD_COPY_ON_WRITE
2436 sv_force_normal_flags(sv, 0);
2439 if (SvREADONLY(sv) && !SvOK(sv)) {
2440 if (ckWARN(WARN_UNINITIALIZED))
2447 if (S_sv_2iuv_common(aTHX_ sv))
2451 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2452 PTR2UV(sv),SvUVX(sv)));
2453 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2457 =for apidoc sv_2nv_flags
2459 Return the num value of an SV, doing any necessary string or integer
2460 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2461 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2467 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2472 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2473 && SvTYPE(sv) != SVt_PVFM);
2474 if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
2475 /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2476 the same flag bit as SVf_IVisUV, so must not let them cache NVs.
2477 Regexps have no SvIVX and SvNVX fields. */
2479 if (flags & SV_GMAGIC)
2483 if (SvPOKp(sv) && !SvIOKp(sv)) {
2484 ptr = SvPVX_const(sv);
2486 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2487 !grok_number(ptr, SvCUR(sv), NULL))
2493 return (NV)SvUVX(sv);
2495 return (NV)SvIVX(sv);
2501 ptr = RX_WRAPPED((REGEXP *)sv);
2504 assert(SvTYPE(sv) >= SVt_PVMG);
2505 /* This falls through to the report_uninit near the end of the
2507 } else if (SvTHINKFIRST(sv)) {
2512 if (flags & SV_SKIP_OVERLOAD)
2514 tmpstr = AMG_CALLunary(sv, numer_amg);
2515 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2516 return SvNV(tmpstr);
2519 return PTR2NV(SvRV(sv));
2521 #ifdef PERL_OLD_COPY_ON_WRITE
2523 sv_force_normal_flags(sv, 0);
2526 if (SvREADONLY(sv) && !SvOK(sv)) {
2527 if (ckWARN(WARN_UNINITIALIZED))
2532 if (SvTYPE(sv) < SVt_NV) {
2533 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2534 sv_upgrade(sv, SVt_NV);
2535 #ifdef USE_LONG_DOUBLE
2537 STORE_NUMERIC_LOCAL_SET_STANDARD();
2538 PerlIO_printf(Perl_debug_log,
2539 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2540 PTR2UV(sv), SvNVX(sv));
2541 RESTORE_NUMERIC_LOCAL();
2545 STORE_NUMERIC_LOCAL_SET_STANDARD();
2546 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2547 PTR2UV(sv), SvNVX(sv));
2548 RESTORE_NUMERIC_LOCAL();
2552 else if (SvTYPE(sv) < SVt_PVNV)
2553 sv_upgrade(sv, SVt_PVNV);
2558 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2559 #ifdef NV_PRESERVES_UV
2565 /* Only set the public NV OK flag if this NV preserves the IV */
2566 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2568 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2569 : (SvIVX(sv) == I_V(SvNVX(sv))))
2575 else if (SvPOKp(sv)) {
2577 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2578 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2580 #ifdef NV_PRESERVES_UV
2581 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2582 == IS_NUMBER_IN_UV) {
2583 /* It's definitely an integer */
2584 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2586 SvNV_set(sv, Atof(SvPVX_const(sv)));
2592 SvNV_set(sv, Atof(SvPVX_const(sv)));
2593 /* Only set the public NV OK flag if this NV preserves the value in
2594 the PV at least as well as an IV/UV would.
2595 Not sure how to do this 100% reliably. */
2596 /* if that shift count is out of range then Configure's test is
2597 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2599 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2600 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2601 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2602 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2603 /* Can't use strtol etc to convert this string, so don't try.
2604 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2607 /* value has been set. It may not be precise. */
2608 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2609 /* 2s complement assumption for (UV)IV_MIN */
2610 SvNOK_on(sv); /* Integer is too negative. */
2615 if (numtype & IS_NUMBER_NEG) {
2616 SvIV_set(sv, -(IV)value);
2617 } else if (value <= (UV)IV_MAX) {
2618 SvIV_set(sv, (IV)value);
2620 SvUV_set(sv, value);
2624 if (numtype & IS_NUMBER_NOT_INT) {
2625 /* I believe that even if the original PV had decimals,
2626 they are lost beyond the limit of the FP precision.
2627 However, neither is canonical, so both only get p
2628 flags. NWC, 2000/11/25 */
2629 /* Both already have p flags, so do nothing */
2631 const NV nv = SvNVX(sv);
2632 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2633 if (SvIVX(sv) == I_V(nv)) {
2636 /* It had no "." so it must be integer. */
2640 /* between IV_MAX and NV(UV_MAX).
2641 Could be slightly > UV_MAX */
2643 if (numtype & IS_NUMBER_NOT_INT) {
2644 /* UV and NV both imprecise. */
2646 const UV nv_as_uv = U_V(nv);
2648 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2657 /* It might be more code efficient to go through the entire logic above
2658 and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2659 gets complex and potentially buggy, so more programmer efficient
2660 to do it this way, by turning off the public flags: */
2662 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2663 #endif /* NV_PRESERVES_UV */
2666 if (isGV_with_GP(sv)) {
2667 glob_2number(MUTABLE_GV(sv));
2671 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2673 assert (SvTYPE(sv) >= SVt_NV);
2674 /* Typically the caller expects that sv_any is not NULL now. */
2675 /* XXX Ilya implies that this is a bug in callers that assume this
2676 and ideally should be fixed. */
2679 #if defined(USE_LONG_DOUBLE)
2681 STORE_NUMERIC_LOCAL_SET_STANDARD();
2682 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2683 PTR2UV(sv), SvNVX(sv));
2684 RESTORE_NUMERIC_LOCAL();
2688 STORE_NUMERIC_LOCAL_SET_STANDARD();
2689 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2690 PTR2UV(sv), SvNVX(sv));
2691 RESTORE_NUMERIC_LOCAL();
2700 Return an SV with the numeric value of the source SV, doing any necessary
2701 reference or overload conversion. You must use the C<SvNUM(sv)> macro to
2702 access this function.
2708 Perl_sv_2num(pTHX_ SV *const sv)
2710 PERL_ARGS_ASSERT_SV_2NUM;
2715 SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2716 TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2717 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2718 return sv_2num(tmpsv);
2720 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2723 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2724 * UV as a string towards the end of buf, and return pointers to start and
2727 * We assume that buf is at least TYPE_CHARS(UV) long.
2731 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2733 char *ptr = buf + TYPE_CHARS(UV);
2734 char * const ebuf = ptr;
2737 PERL_ARGS_ASSERT_UIV_2BUF;
2749 *--ptr = '0' + (char)(uv % 10);
2758 =for apidoc sv_2pv_flags
2760 Returns a pointer to the string value of an SV, and sets *lp to its length.
2761 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a
2762 string if necessary. Normally invoked via the C<SvPV_flags> macro.
2763 C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
2769 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
2779 assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2780 && SvTYPE(sv) != SVt_PVFM);
2781 if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2786 if (flags & SV_SKIP_OVERLOAD)
2788 tmpstr = AMG_CALLunary(sv, string_amg);
2789 TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2790 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2792 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2796 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2797 if (flags & SV_CONST_RETURN) {
2798 pv = (char *) SvPVX_const(tmpstr);
2800 pv = (flags & SV_MUTABLE_RETURN)
2801 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2804 *lp = SvCUR(tmpstr);
2806 pv = sv_2pv_flags(tmpstr, lp, flags);
2819 SV *const referent = SvRV(sv);
2823 retval = buffer = savepvn("NULLREF", len);
2824 } else if (SvTYPE(referent) == SVt_REGEXP &&
2825 (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
2826 amagic_is_enabled(string_amg))) {
2827 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2831 /* If the regex is UTF-8 we want the containing scalar to
2832 have an UTF-8 flag too */
2839 *lp = RX_WRAPLEN(re);
2841 return RX_WRAPPED(re);
2843 const char *const typestr = sv_reftype(referent, 0);
2844 const STRLEN typelen = strlen(typestr);
2845 UV addr = PTR2UV(referent);
2846 const char *stashname = NULL;
2847 STRLEN stashnamelen = 0; /* hush, gcc */
2848 const char *buffer_end;
2850 if (SvOBJECT(referent)) {
2851 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2854 stashname = HEK_KEY(name);
2855 stashnamelen = HEK_LEN(name);
2857 if (HEK_UTF8(name)) {
2863 stashname = "__ANON__";
2866 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2867 + 2 * sizeof(UV) + 2 /* )\0 */;
2869 len = typelen + 3 /* (0x */
2870 + 2 * sizeof(UV) + 2 /* )\0 */;
2873 Newx(buffer, len, char);
2874 buffer_end = retval = buffer + len;
2876 /* Working backwards */
2880 *--retval = PL_hexdigit[addr & 15];
2881 } while (addr >>= 4);
2887 memcpy(retval, typestr, typelen);
2891 retval -= stashnamelen;
2892 memcpy(retval, stashname, stashnamelen);
2894 /* retval may not necessarily have reached the start of the
2896 assert (retval >= buffer);
2898 len = buffer_end - retval - 1; /* -1 for that \0 */
2910 if (flags & SV_MUTABLE_RETURN)
2911 return SvPVX_mutable(sv);
2912 if (flags & SV_CONST_RETURN)
2913 return (char *)SvPVX_const(sv);
2918 /* I'm assuming that if both IV and NV are equally valid then
2919 converting the IV is going to be more efficient */
2920 const U32 isUIOK = SvIsUV(sv);
2921 char buf[TYPE_CHARS(UV)];
2925 if (SvTYPE(sv) < SVt_PVIV)
2926 sv_upgrade(sv, SVt_PVIV);
2927 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2929 /* inlined from sv_setpvn */
2930 s = SvGROW_mutable(sv, len + 1);
2931 Move(ptr, s, len, char);
2936 else if (SvNOK(sv)) {
2937 if (SvTYPE(sv) < SVt_PVNV)
2938 sv_upgrade(sv, SVt_PVNV);
2939 if (SvNVX(sv) == 0.0) {
2940 s = SvGROW_mutable(sv, 2);
2945 /* The +20 is pure guesswork. Configure test needed. --jhi */
2946 s = SvGROW_mutable(sv, NV_DIG + 20);
2947 /* some Xenix systems wipe out errno here */
2949 #ifndef USE_LOCALE_NUMERIC
2950 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2953 /* Gconvert always uses the current locale. That's the right thing
2954 * to do if we're supposed to be using locales. But otherwise, we
2955 * want the result to be based on the C locale, so we need to
2956 * change to the C locale during the Gconvert and then change back.
2957 * But if we're already in the C locale (PL_numeric_standard is
2958 * TRUE in that case), no need to do any changing */
2959 if (PL_numeric_standard || IN_SOME_LOCALE_FORM_RUNTIME) {
2960 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2962 /* If the radix character is UTF-8, and actually is in the
2963 * output, turn on the UTF-8 flag for the scalar */
2964 if (! PL_numeric_standard
2965 && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
2966 && instr(s, SvPVX_const(PL_numeric_radix_sv)))
2972 char *loc = savepv(setlocale(LC_NUMERIC, NULL));
2973 setlocale(LC_NUMERIC, "C");
2974 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2975 setlocale(LC_NUMERIC, loc);
2980 /* We don't call SvPOK_on(), because it may come to pass that the
2981 * locale changes so that the stringification we just did is no
2982 * longer correct. We will have to re-stringify every time it is
2989 else if (isGV_with_GP(sv)) {
2990 GV *const gv = MUTABLE_GV(sv);
2991 SV *const buffer = sv_newmortal();
2993 gv_efullname3(buffer, gv, "*");
2995 assert(SvPOK(buffer));
2999 *lp = SvCUR(buffer);
3000 return SvPVX(buffer);
3002 else if (isREGEXP(sv)) {
3003 if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
3004 return RX_WRAPPED((REGEXP *)sv);
3009 if (flags & SV_UNDEF_RETURNS_NULL)
3011 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3013 /* Typically the caller expects that sv_any is not NULL now. */
3014 if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
3015 sv_upgrade(sv, SVt_PV);
3020 const STRLEN len = s - SvPVX_const(sv);
3025 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3026 PTR2UV(sv),SvPVX_const(sv)));
3027 if (flags & SV_CONST_RETURN)
3028 return (char *)SvPVX_const(sv);
3029 if (flags & SV_MUTABLE_RETURN)
3030 return SvPVX_mutable(sv);
3035 =for apidoc sv_copypv
3037 Copies a stringified representation of the source SV into the
3038 destination SV. Automatically performs any necessary mg_get and
3039 coercion of numeric values into strings. Guaranteed to preserve
3040 UTF8 flag even from overloaded objects. Similar in nature to
3041 sv_2pv[_flags] but operates directly on an SV instead of just the
3042 string. Mostly uses sv_2pv_flags to do its work, except when that
3043 would lose the UTF-8'ness of the PV.
3045 =for apidoc sv_copypv_nomg
3047 Like sv_copypv, but doesn't invoke get magic first.
3049 =for apidoc sv_copypv_flags
3051 Implementation of sv_copypv and sv_copypv_nomg. Calls get magic iff flags
3058 Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
3060 PERL_ARGS_ASSERT_SV_COPYPV;
3062 sv_copypv_flags(dsv, ssv, 0);
3066 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3071 PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3073 if ((flags & SV_GMAGIC) && SvGMAGICAL(ssv))
3075 s = SvPV_nomg_const(ssv,len);
3076 sv_setpvn(dsv,s,len);
3084 =for apidoc sv_2pvbyte
3086 Return a pointer to the byte-encoded representation of the SV, and set *lp
3087 to its length. May cause the SV to be downgraded from UTF-8 as a
3090 Usually accessed via the C<SvPVbyte> macro.
3096 Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
3098 PERL_ARGS_ASSERT_SV_2PVBYTE;
3101 if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3102 || isGV_with_GP(sv) || SvROK(sv)) {
3103 SV *sv2 = sv_newmortal();
3104 sv_copypv_nomg(sv2,sv);
3107 sv_utf8_downgrade(sv,0);
3108 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3112 =for apidoc sv_2pvutf8
3114 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3115 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3117 Usually accessed via the C<SvPVutf8> macro.
3123 Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
3125 PERL_ARGS_ASSERT_SV_2PVUTF8;
3127 if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3128 || isGV_with_GP(sv) || SvROK(sv))
3129 sv = sv_mortalcopy(sv);
3132 sv_utf8_upgrade_nomg(sv);
3133 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3138 =for apidoc sv_2bool
3140 This macro is only used by sv_true() or its macro equivalent, and only if
3141 the latter's argument is neither SvPOK, SvIOK nor SvNOK.
3142 It calls sv_2bool_flags with the SV_GMAGIC flag.
3144 =for apidoc sv_2bool_flags
3146 This function is only used by sv_true() and friends, and only if
3147 the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags
3148 contain SV_GMAGIC, then it does an mg_get() first.
3155 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
3159 PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3162 if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3168 SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3169 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
3172 if(SvGMAGICAL(sv)) {
3174 goto restart; /* call sv_2bool */
3176 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
3177 else if(!SvOK(sv)) {
3180 else if(SvPOK(sv)) {
3181 svb = SvPVXtrue(sv);
3183 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
3184 svb = (SvIOK(sv) && SvIVX(sv) != 0)
3185 || (SvNOK(sv) && SvNVX(sv) != 0.0);
3189 goto restart; /* call sv_2bool_nomg */
3194 return SvRV(sv) != 0;
3198 RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
3199 return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
3203 =for apidoc sv_utf8_upgrade
3205 Converts the PV of an SV to its UTF-8-encoded form.
3206 Forces the SV to string form if it is not already.
3207 Will C<mg_get> on C<sv> if appropriate.
3208 Always sets the SvUTF8 flag to avoid future validity checks even
3209 if the whole string is the same in UTF-8 as not.
3210 Returns the number of bytes in the converted string
3212 This is not a general purpose byte encoding to Unicode interface:
3213 use the Encode extension for that.
3215 =for apidoc sv_utf8_upgrade_nomg
3217 Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
3219 =for apidoc sv_utf8_upgrade_flags
3221 Converts the PV of an SV to its UTF-8-encoded form.
3222 Forces the SV to string form if it is not already.
3223 Always sets the SvUTF8 flag to avoid future validity checks even
3224 if all the bytes are invariant in UTF-8.
3225 If C<flags> has C<SV_GMAGIC> bit set,
3226 will C<mg_get> on C<sv> if appropriate, else not.
3227 Returns the number of bytes in the converted string
3228 C<sv_utf8_upgrade> and
3229 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3231 This is not a general purpose byte encoding to Unicode interface:
3232 use the Encode extension for that.
3236 The grow version is currently not externally documented. It adds a parameter,
3237 extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3238 have free after it upon return. This allows the caller to reserve extra space
3239 that it intends to fill, to avoid extra grows.
3241 Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3242 which can be used to tell this function to not first check to see if there are
3243 any characters that are different in UTF-8 (variant characters) which would
3244 force it to allocate a new string to sv, but to assume there are. Typically
3245 this flag is used by a routine that has already parsed the string to find that
3246 there are such characters, and passes this information on so that the work
3247 doesn't have to be repeated.
3249 (One might think that the calling routine could pass in the position of the
3250 first such variant, so it wouldn't have to be found again. But that is not the
3251 case, because typically when the caller is likely to use this flag, it won't be
3252 calling this routine unless it finds something that won't fit into a byte.
3253 Otherwise it tries to not upgrade and just use bytes. But some things that
3254 do fit into a byte are variants in utf8, and the caller may not have been
3255 keeping track of these.)
3257 If the routine itself changes the string, it adds a trailing NUL. Such a NUL
3258 isn't guaranteed due to having other routines do the work in some input cases,
3259 or if the input is already flagged as being in utf8.
3261 The speed of this could perhaps be improved for many cases if someone wanted to
3262 write a fast function that counts the number of variant characters in a string,
3263 especially if it could return the position of the first one.
3268 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3272 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3274 if (sv == &PL_sv_undef)
3276 if (!SvPOK_nog(sv)) {
3278 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3279 (void) sv_2pv_flags(sv,&len, flags);
3281 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3285 (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3290 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3295 S_sv_uncow(aTHX_ sv, 0);
3298 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3299 sv_recode_to_utf8(sv, PL_encoding);
3300 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3304 if (SvCUR(sv) == 0) {
3305 if (extra) SvGROW(sv, extra);
3306 } else { /* Assume Latin-1/EBCDIC */
3307 /* This function could be much more efficient if we
3308 * had a FLAG in SVs to signal if there are any variant
3309 * chars in the PV. Given that there isn't such a flag
3310 * make the loop as fast as possible (although there are certainly ways
3311 * to speed this up, eg. through vectorization) */
3312 U8 * s = (U8 *) SvPVX_const(sv);
3313 U8 * e = (U8 *) SvEND(sv);
3315 STRLEN two_byte_count = 0;
3317 if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3319 /* See if really will need to convert to utf8. We mustn't rely on our
3320 * incoming SV being well formed and having a trailing '\0', as certain
3321 * code in pp_formline can send us partially built SVs. */
3325 if (NATIVE_BYTE_IS_INVARIANT(ch)) continue;
3327 t--; /* t already incremented; re-point to first variant */
3332 /* utf8 conversion not needed because all are invariants. Mark as
3333 * UTF-8 even if no variant - saves scanning loop */
3335 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3340 /* Here, the string should be converted to utf8, either because of an
3341 * input flag (two_byte_count = 0), or because a character that
3342 * requires 2 bytes was found (two_byte_count = 1). t points either to
3343 * the beginning of the string (if we didn't examine anything), or to
3344 * the first variant. In either case, everything from s to t - 1 will
3345 * occupy only 1 byte each on output.
3347 * There are two main ways to convert. One is to create a new string
3348 * and go through the input starting from the beginning, appending each
3349 * converted value onto the new string as we go along. It's probably
3350 * best to allocate enough space in the string for the worst possible
3351 * case rather than possibly running out of space and having to
3352 * reallocate and then copy what we've done so far. Since everything
3353 * from s to t - 1 is invariant, the destination can be initialized
3354 * with these using a fast memory copy
3356 * The other way is to figure out exactly how big the string should be
3357 * by parsing the entire input. Then you don't have to make it big
3358 * enough to handle the worst possible case, and more importantly, if
3359 * the string you already have is large enough, you don't have to
3360 * allocate a new string, you can copy the last character in the input
3361 * string to the final position(s) that will be occupied by the
3362 * converted string and go backwards, stopping at t, since everything
3363 * before that is invariant.
3365 * There are advantages and disadvantages to each method.
3367 * In the first method, we can allocate a new string, do the memory
3368 * copy from the s to t - 1, and then proceed through the rest of the
3369 * string byte-by-byte.
3371 * In the second method, we proceed through the rest of the input
3372 * string just calculating how big the converted string will be. Then
3373 * there are two cases:
3374 * 1) if the string has enough extra space to handle the converted
3375 * value. We go backwards through the string, converting until we
3376 * get to the position we are at now, and then stop. If this
3377 * position is far enough along in the string, this method is
3378 * faster than the other method. If the memory copy were the same
3379 * speed as the byte-by-byte loop, that position would be about
3380 * half-way, as at the half-way mark, parsing to the end and back
3381 * is one complete string's parse, the same amount as starting
3382 * over and going all the way through. Actually, it would be
3383 * somewhat less than half-way, as it's faster to just count bytes
3384 * than to also copy, and we don't have the overhead of allocating
3385 * a new string, changing the scalar to use it, and freeing the
3386 * existing one. But if the memory copy is fast, the break-even
3387 * point is somewhere after half way. The counting loop could be
3388 * sped up by vectorization, etc, to move the break-even point
3389 * further towards the beginning.
3390 * 2) if the string doesn't have enough space to handle the converted
3391 * value. A new string will have to be allocated, and one might
3392 * as well, given that, start from the beginning doing the first
3393 * method. We've spent extra time parsing the string and in
3394 * exchange all we've gotten is that we know precisely how big to
3395 * make the new one. Perl is more optimized for time than space,
3396 * so this case is a loser.
3397 * So what I've decided to do is not use the 2nd method unless it is
3398 * guaranteed that a new string won't have to be allocated, assuming
3399 * the worst case. I also decided not to put any more conditions on it
3400 * than this, for now. It seems likely that, since the worst case is
3401 * twice as big as the unknown portion of the string (plus 1), we won't
3402 * be guaranteed enough space, causing us to go to the first method,
3403 * unless the string is short, or the first variant character is near
3404 * the end of it. In either of these cases, it seems best to use the
3405 * 2nd method. The only circumstance I can think of where this would
3406 * be really slower is if the string had once had much more data in it
3407 * than it does now, but there is still a substantial amount in it */
3410 STRLEN invariant_head = t - s;
3411 STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3412 if (SvLEN(sv) < size) {
3414 /* Here, have decided to allocate a new string */
3419 Newx(dst, size, U8);
3421 /* If no known invariants at the beginning of the input string,
3422 * set so starts from there. Otherwise, can use memory copy to
3423 * get up to where we are now, and then start from here */
3425 if (invariant_head <= 0) {
3428 Copy(s, dst, invariant_head, char);
3429 d = dst + invariant_head;
3433 append_utf8_from_native_byte(*t, &d);
3437 SvPV_free(sv); /* No longer using pre-existing string */
3438 SvPV_set(sv, (char*)dst);
3439 SvCUR_set(sv, d - dst);
3440 SvLEN_set(sv, size);
3443 /* Here, have decided to get the exact size of the string.
3444 * Currently this happens only when we know that there is
3445 * guaranteed enough space to fit the converted string, so
3446 * don't have to worry about growing. If two_byte_count is 0,
3447 * then t points to the first byte of the string which hasn't
3448 * been examined yet. Otherwise two_byte_count is 1, and t
3449 * points to the first byte in the string that will expand to
3450 * two. Depending on this, start examining at t or 1 after t.
3453 U8 *d = t + two_byte_count;
3456 /* Count up the remaining bytes that expand to two */
3459 const U8 chr = *d++;
3460 if (! NATIVE_BYTE_IS_INVARIANT(chr)) two_byte_count++;
3463 /* The string will expand by just the number of bytes that
3464 * occupy two positions. But we are one afterwards because of
3465 * the increment just above. This is the place to put the
3466 * trailing NUL, and to set the length before we decrement */
3468 d += two_byte_count;
3469 SvCUR_set(sv, d - s);
3473 /* Having decremented d, it points to the position to put the
3474 * very last byte of the expanded string. Go backwards through
3475 * the string, copying and expanding as we go, stopping when we
3476 * get to the part that is invariant the rest of the way down */
3480 if (NATIVE_BYTE_IS_INVARIANT(*e)) {
3483 *d-- = UTF8_EIGHT_BIT_LO(*e);
3484 *d-- = UTF8_EIGHT_BIT_HI(*e);
3490 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3491 /* Update pos. We do it at the end rather than during
3492 * the upgrade, to avoid slowing down the common case
3493 * (upgrade without pos).
3494 * pos can be stored as either bytes or characters. Since
3495 * this was previously a byte string we can just turn off
3496 * the bytes flag. */
3497 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3499 mg->mg_flags &= ~MGf_BYTES;
3501 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3502 magic_setutf8(sv,mg); /* clear UTF8 cache */
3507 /* Mark as UTF-8 even if no variant - saves scanning loop */
3513 =for apidoc sv_utf8_downgrade
3515 Attempts to convert the PV of an SV from characters to bytes.
3516 If the PV contains a character that cannot fit
3517 in a byte, this conversion will fail;
3518 in this case, either returns false or, if C<fail_ok> is not
3521 This is not a general purpose Unicode to byte encoding interface:
3522 use the Encode extension for that.
3528 Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
3532 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3534 if (SvPOKp(sv) && SvUTF8(sv)) {
3538 int mg_flags = SV_GMAGIC;
3541 S_sv_uncow(aTHX_ sv, 0);
3543 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3545 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3546 if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
3547 mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
3548 SV_GMAGIC|SV_CONST_RETURN);
3549 mg_flags = 0; /* sv_pos_b2u does get magic */
3551 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3552 magic_setutf8(sv,mg); /* clear UTF8 cache */
3555 s = (U8 *) SvPV_flags(sv, len, mg_flags);
3557 if (!utf8_to_bytes(s, &len)) {
3562 Perl_croak(aTHX_ "Wide character in %s",
3565 Perl_croak(aTHX_ "Wide character");
3576 =for apidoc sv_utf8_encode
3578 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3579 flag off so that it looks like octets again.
3585 Perl_sv_utf8_encode(pTHX_ SV *const sv)
3587 PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3589 if (SvREADONLY(sv)) {
3590 sv_force_normal_flags(sv, 0);
3592 (void) sv_utf8_upgrade(sv);
3597 =for apidoc sv_utf8_decode
3599 If the PV of the SV is an octet sequence in UTF-8
3600 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3601 so that it looks like a character. If the PV contains only single-byte
3602 characters, the C<SvUTF8> flag stays off.
3603 Scans PV for validity and returns false if the PV is invalid UTF-8.
3609 Perl_sv_utf8_decode(pTHX_ SV *const sv)
3611 PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3614 const U8 *start, *c;
3617 /* The octets may have got themselves encoded - get them back as
3620 if (!sv_utf8_downgrade(sv, TRUE))
3623 /* it is actually just a matter of turning the utf8 flag on, but
3624 * we want to make sure everything inside is valid utf8 first.
3626 c = start = (const U8 *) SvPVX_const(sv);
3627 if (!is_utf8_string(c, SvCUR(sv)))
3629 e = (const U8 *) SvEND(sv);
3632 if (!UTF8_IS_INVARIANT(ch)) {
3637 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3638 /* XXX Is this dead code? XS_utf8_decode calls SvSETMAGIC
3639 after this, clearing pos. Does anything on CPAN
3641 /* adjust pos to the start of a UTF8 char sequence */
3642 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3644 I32 pos = mg->mg_len;
3646 for (c = start + pos; c > start; c--) {
3647 if (UTF8_IS_START(*c))
3650 mg->mg_len = c - start;
3653 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3654 magic_setutf8(sv,mg); /* clear UTF8 cache */
3661 =for apidoc sv_setsv
3663 Copies the contents of the source SV C<ssv> into the destination SV
3664 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3665 function if the source SV needs to be reused. Does not handle 'set' magic on
3666 destination SV. Calls 'get' magic on source SV. Loosely speaking, it
3667 performs a copy-by-value, obliterating any previous content of the
3670 You probably want to use one of the assortment of wrappers, such as
3671 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3672 C<SvSetMagicSV_nosteal>.
3674 =for apidoc sv_setsv_flags
3676 Copies the contents of the source SV C<ssv> into the destination SV
3677 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3678 function if the source SV needs to be reused. Does not handle 'set' magic.
3679 Loosely speaking, it performs a copy-by-value, obliterating any previous
3680 content of the destination.
3681 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3682 C<ssv> if appropriate, else not. If the C<flags>
3683 parameter has the C<SV_NOSTEAL> bit set then the
3684 buffers of temps will not be stolen. <sv_setsv>
3685 and C<sv_setsv_nomg> are implemented in terms of this function.
3687 You probably want to use one of the assortment of wrappers, such as
3688 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3689 C<SvSetMagicSV_nosteal>.
3691 This is the primary function for copying scalars, and most other
3692 copy-ish functions and macros use this underneath.
3698 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3700 I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3701 HV *old_stash = NULL;
3703 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3705 if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3706 const char * const name = GvNAME(sstr);
3707 const STRLEN len = GvNAMELEN(sstr);
3709 if (dtype >= SVt_PV) {
3715 SvUPGRADE(dstr, SVt_PVGV);
3716 (void)SvOK_off(dstr);
3717 /* We have to turn this on here, even though we turn it off
3718 below, as GvSTASH will fail an assertion otherwise. */
3719 isGV_with_GP_on(dstr);
3721 GvSTASH(dstr) = GvSTASH(sstr);
3723 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3724 gv_name_set(MUTABLE_GV(dstr), name, len,
3725 GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
3726 SvFAKE_on(dstr); /* can coerce to non-glob */
3729 if(GvGP(MUTABLE_GV(sstr))) {
3730 /* If source has method cache entry, clear it */
3732 SvREFCNT_dec(GvCV(sstr));
3733 GvCV_set(sstr, NULL);
3736 /* If source has a real method, then a method is
3739 GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3745 /* If dest already had a real method, that's a change as well */
3747 !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3748 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3753 /* We don't need to check the name of the destination if it was not a
3754 glob to begin with. */
3755 if(dtype == SVt_PVGV) {
3756 const char * const name = GvNAME((const GV *)dstr);
3759 /* The stash may have been detached from the symbol table, so
3761 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3765 const STRLEN len = GvNAMELEN(dstr);
3766 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3767 || (len == 1 && name[0] == ':')) {
3770 /* Set aside the old stash, so we can reset isa caches on
3772 if((old_stash = GvHV(dstr)))
3773 /* Make sure we do not lose it early. */
3774 SvREFCNT_inc_simple_void_NN(
3775 sv_2mortal((SV *)old_stash)
3781 gp_free(MUTABLE_GV(dstr));
3782 isGV_with_GP_off(dstr); /* SvOK_off does not like globs. */
3783 (void)SvOK_off(dstr);
3784 isGV_with_GP_on(dstr);
3785 GvINTRO_off(dstr); /* one-shot flag */
3786 GvGP_set(dstr, gp_ref(GvGP(sstr)));
3787 if (SvTAINTED(sstr))
3789 if (GvIMPORTED(dstr) != GVf_IMPORTED
3790 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3792 GvIMPORTED_on(dstr);
3795 if(mro_changes == 2) {
3796 if (GvAV((const GV *)sstr)) {
3798 SV * const sref = (SV *)GvAV((const GV *)dstr);
3799 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3800 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3801 AV * const ary = newAV();
3802 av_push(ary, mg->mg_obj); /* takes the refcount */
3803 mg->mg_obj = (SV *)ary;
3805 av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3807 else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3809 mro_isa_changed_in(GvSTASH(dstr));
3811 else if(mro_changes == 3) {
3812 HV * const stash = GvHV(dstr);
3813 if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3819 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3820 if (GvIO(dstr) && dtype == SVt_PVGV) {
3821 DEBUG_o(Perl_deb(aTHX_
3822 "glob_assign_glob clearing PL_stashcache\n"));
3823 /* It's a cache. It will rebuild itself quite happily.
3824 It's a lot of effort to work out exactly which key (or keys)
3825 might be invalidated by the creation of the this file handle.
3827 hv_clear(PL_stashcache);
3833 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3835 SV * const sref = SvRV(sstr);
3837 const int intro = GvINTRO(dstr);
3840 const U32 stype = SvTYPE(sref);
3842 PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3845 GvINTRO_off(dstr); /* one-shot flag */
3846 GvLINE(dstr) = CopLINE(PL_curcop);
3847 GvEGV(dstr) = MUTABLE_GV(dstr);
3852 location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
3853 import_flag = GVf_IMPORTED_CV;
3856 location = (SV **) &GvHV(dstr);
3857 import_flag = GVf_IMPORTED_HV;
3860 location = (SV **) &GvAV(dstr);
3861 import_flag = GVf_IMPORTED_AV;
3864 location = (SV **) &GvIOp(dstr);
3867 location = (SV **) &GvFORM(dstr);
3870 location = &GvSV(dstr);
3871 import_flag = GVf_IMPORTED_SV;
3874 if (stype == SVt_PVCV) {
3875 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3876 if (GvCVGEN(dstr)) {
3877 SvREFCNT_dec(GvCV(dstr));
3878 GvCV_set(dstr, NULL);
3879 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3882 /* SAVEt_GVSLOT takes more room on the savestack and has more
3883 overhead in leave_scope than SAVEt_GENERIC_SV. But for CVs
3884 leave_scope needs access to the GV so it can reset method
3885 caches. We must use SAVEt_GVSLOT whenever the type is
3886 SVt_PVCV, even if the stash is anonymous, as the stash may
3887 gain a name somehow before leave_scope. */
3888 if (stype == SVt_PVCV) {
3889 /* There is no save_pushptrptrptr. Creating it for this
3890 one call site would be overkill. So inline the ss add
3894 SS_ADD_PTR(location);
3895 SS_ADD_PTR(SvREFCNT_inc(*location));
3896 SS_ADD_UV(SAVEt_GVSLOT);
3899 else SAVEGENERICSV(*location);
3902 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3903 CV* const cv = MUTABLE_CV(*location);
3905 if (!GvCVGEN((const GV *)dstr) &&
3906 (CvROOT(cv) || CvXSUB(cv)) &&
3907 /* redundant check that avoids creating the extra SV
3908 most of the time: */
3909 (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
3911 SV * const new_const_sv =
3912 CvCONST((const CV *)sref)
3913 ? cv_const_sv((const CV *)sref)
3915 report_redefined_cv(
3916 sv_2mortal(Perl_newSVpvf(aTHX_
3919 HvNAME_HEK(GvSTASH((const GV *)dstr))
3921 HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
3924 CvCONST((const CV *)sref) ? &new_const_sv : NULL
3928 cv_ckproto_len_flags(cv, (const GV *)dstr,
3929 SvPOK(sref) ? CvPROTO(sref) : NULL,
3930 SvPOK(sref) ? CvPROTOLEN(sref) : 0,
3931 SvPOK(sref) ? SvUTF8(sref) : 0);
3933 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3934 GvASSUMECV_on(dstr);
3935 if(GvSTASH(dstr)) gv_method_changed(dstr); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3937 *location = SvREFCNT_inc_simple_NN(sref);
3938 if (import_flag && !(GvFLAGS(dstr) & import_flag)
3939 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3940 GvFLAGS(dstr) |= import_flag;
3942 if (stype == SVt_PVHV) {
3943 const char * const name = GvNAME((GV*)dstr);
3944 const STRLEN len = GvNAMELEN(dstr);
3947 (len > 1 && name[len-2] == ':' && name[len-1] == ':')
3948 || (len == 1 && name[0] == ':')
3950 && (!dref || HvENAME_get(dref))
3953 (HV *)sref, (HV *)dref,
3959 stype == SVt_PVAV && sref != dref
3960 && strEQ(GvNAME((GV*)dstr), "ISA")
3961 /* The stash may have been detached from the symbol table, so
3962 check its name before doing anything. */
3963 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3966 MAGIC * const omg = dref && SvSMAGICAL(dref)
3967 ? mg_find(dref, PERL_MAGIC_isa)
3969 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3970 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3971 AV * const ary = newAV();
3972 av_push(ary, mg->mg_obj); /* takes the refcount */
3973 mg->mg_obj = (SV *)ary;
3976 if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
3977 SV **svp = AvARRAY((AV *)omg->mg_obj);
3978 I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
3982 SvREFCNT_inc_simple_NN(*svp++)
3988 SvREFCNT_inc_simple_NN(omg->mg_obj)
3992 av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
3997 sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
3999 mg = mg_find(sref, PERL_MAGIC_isa);
4001 /* Since the *ISA assignment could have affected more than
4002 one stash, don't call mro_isa_changed_in directly, but let
4003 magic_clearisa do it for us, as it already has the logic for
4004 dealing with globs vs arrays of globs. */
4006 Perl_magic_clearisa(aTHX_ NULL, mg);
4008 else if (stype == SVt_PVIO) {
4009 DEBUG_o(Perl_deb(aTHX_ "glob_assign_ref clearing PL_stashcache\n"));
4010 /* It's a cache. It will rebuild itself quite happily.
4011 It's a lot of effort to work out exactly which key (or keys)
4012 might be invalidated by the creation of the this file handle.
4014 hv_clear(PL_stashcache);
4018 if (!intro) SvREFCNT_dec(dref);
4019 if (SvTAINTED(sstr))
4024 /* Work around compiler warnings about unsigned >= THRESHOLD when thres-
4026 #if SV_COW_THRESHOLD
4027 # define GE_COW_THRESHOLD(len) ((len) >= SV_COW_THRESHOLD)
4029 # define GE_COW_THRESHOLD(len) 1
4031 #if SV_COWBUF_THRESHOLD
4032 # define GE_COWBUF_THRESHOLD(len) ((len) >= SV_COWBUF_THRESHOLD)
4034 # define GE_COWBUF_THRESHOLD(len) 1
4038 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
4045 PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
4050 if (SvIS_FREED(dstr)) {
4051 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
4052 " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
4054 SV_CHECK_THINKFIRST_COW_DROP(dstr);
4056 sstr = &PL_sv_undef;
4057 if (SvIS_FREED(sstr)) {
4058 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
4059 (void*)sstr, (void*)dstr);
4061 stype = SvTYPE(sstr);
4062 dtype = SvTYPE(dstr);
4064 /* There's a lot of redundancy below but we're going for speed here */
4069 if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
4070 (void)SvOK_off(dstr);
4078 sv_upgrade(dstr, SVt_IV);
4082 sv_upgrade(dstr, SVt_PVIV);
4086 goto end_of_first_switch;
4088 (void)SvIOK_only(dstr);
4089 SvIV_set(dstr, SvIVX(sstr));
4092 /* SvTAINTED can only be true if the SV has taint magic, which in
4093 turn means that the SV type is PVMG (or greater). This is the
4094 case statement for SVt_IV, so this cannot be true (whatever gcov
4096 assert(!SvTAINTED(sstr));
4101 if (dtype < SVt_PV && dtype != SVt_IV)
4102 sv_upgrade(dstr, SVt_IV);
4110 sv_upgrade(dstr, SVt_NV);
4114 sv_upgrade(dstr, SVt_PVNV);
4118 goto end_of_first_switch;
4120 SvNV_set(dstr, SvNVX(sstr));
4121 (void)SvNOK_only(dstr);
4122 /* SvTAINTED can only be true if the SV has taint magic, which in
4123 turn means that the SV type is PVMG (or greater). This is the
4124 case statement for SVt_NV, so this cannot be true (whatever gcov
4126 assert(!SvTAINTED(sstr));
4133 sv_upgrade(dstr, SVt_PV);
4136 if (dtype < SVt_PVIV)
4137 sv_upgrade(dstr, SVt_PVIV);
4140 if (dtype < SVt_PVNV)
4141 sv_upgrade(dstr, SVt_PVNV);
4145 const char * const type = sv_reftype(sstr,0);
4147 /* diag_listed_as: Bizarre copy of %s */
4148 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4150 Perl_croak(aTHX_ "Bizarre copy of %s", type);
4156 if (dtype < SVt_REGEXP)
4158 if (dtype >= SVt_PV) {
4164 sv_upgrade(dstr, SVt_REGEXP);
4172 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4174 if (SvTYPE(sstr) != stype)
4175 stype = SvTYPE(sstr);
4177 if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4178 glob_assign_glob(dstr, sstr, dtype);
4181 if (stype == SVt_PVLV)
4183 if (isREGEXP(sstr)) goto upgregexp;
4184 SvUPGRADE(dstr, SVt_PVNV);
4187 SvUPGRADE(dstr, (svtype)stype);
4189 end_of_first_switch:
4191 /* dstr may have been upgraded. */
4192 dtype = SvTYPE(dstr);
4193 sflags = SvFLAGS(sstr);
4195 if (dtype == SVt_PVCV) {
4196 /* Assigning to a subroutine sets the prototype. */
4199 const char *const ptr = SvPV_const(sstr, len);
4201 SvGROW(dstr, len + 1);
4202 Copy(ptr, SvPVX(dstr), len + 1, char);
4203 SvCUR_set(dstr, len);
4205 SvFLAGS(dstr) |= sflags & SVf_UTF8;
4206 CvAUTOLOAD_off(dstr);
4211 else if (dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM) {
4212 const char * const type = sv_reftype(dstr,0);
4214 /* diag_listed_as: Cannot copy to %s */
4215 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4217 Perl_croak(aTHX_ "Cannot copy to %s", type);
4218 } else if (sflags & SVf_ROK) {
4219 if (isGV_with_GP(dstr)
4220 && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4223 if (GvIMPORTED(dstr) != GVf_IMPORTED
4224 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4226 GvIMPORTED_on(dstr);
4231 glob_assign_glob(dstr, sstr, dtype);
4235 if (dtype >= SVt_PV) {
4236 if (isGV_with_GP(dstr)) {
4237 glob_assign_ref(dstr, sstr);
4240 if (SvPVX_const(dstr)) {
4246 (void)SvOK_off(dstr);
4247 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4248 SvFLAGS(dstr) |= sflags & SVf_ROK;
4249 assert(!(sflags & SVp_NOK));
4250 assert(!(sflags & SVp_IOK));
4251 assert(!(sflags & SVf_NOK));
4252 assert(!(sflags & SVf_IOK));
4254 else if (isGV_with_GP(dstr)) {
4255 if (!(sflags & SVf_OK)) {
4256 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4257 "Undefined value assigned to typeglob");
4260 GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
4261 if (dstr != (const SV *)gv) {
4262 const char * const name = GvNAME((const GV *)dstr);
4263 const STRLEN len = GvNAMELEN(dstr);
4264 HV *old_stash = NULL;
4265 bool reset_isa = FALSE;
4266 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4267 || (len == 1 && name[0] == ':')) {
4268 /* Set aside the old stash, so we can reset isa caches
4269 on its subclasses. */
4270 if((old_stash = GvHV(dstr))) {
4271 /* Make sure we do not lose it early. */
4272 SvREFCNT_inc_simple_void_NN(
4273 sv_2mortal((SV *)old_stash)
4280 gp_free(MUTABLE_GV(dstr));
4281 GvGP_set(dstr, gp_ref(GvGP(gv)));
4284 HV * const stash = GvHV(dstr);
4286 old_stash ? (HV *)HvENAME_get(old_stash) : stash
4296 else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4297 && (stype == SVt_REGEXP || isREGEXP(sstr))) {
4298 reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4300 else if (sflags & SVp_POK) {
4302 const STRLEN cur = SvCUR(sstr);
4303 const STRLEN len = SvLEN(sstr);
4306 * Check to see if we can just swipe the string. If so, it's a
4307 * possible small lose on short strings, but a big win on long ones.
4308 * It might even be a win on short strings if SvPVX_const(dstr)
4309 * has to be allocated and SvPVX_const(sstr) has to be freed.
4310 * Likewise if we can set up COW rather than doing an actual copy, we
4311 * drop to the else clause, as the swipe code and the COW setup code
4312 * have much in common.
4315 /* Whichever path we take through the next code, we want this true,
4316 and doing it now facilitates the COW check. */
4317 (void)SvPOK_only(dstr);
4320 /* If we're already COW then this clause is not true, and if COW
4321 is allowed then we drop down to the else and make dest COW
4322 with us. If caller hasn't said that we're allowed to COW
4323 shared hash keys then we don't do the COW setup, even if the
4324 source scalar is a shared hash key scalar. */
4325 (((flags & SV_COW_SHARED_HASH_KEYS)
4326 ? !(sflags & SVf_IsCOW)
4327 #ifdef PERL_NEW_COPY_ON_WRITE
4329 ((!GE_COWBUF_THRESHOLD(cur) && SvLEN(dstr) > cur)
4330 /* If this is a regular (non-hek) COW, only so many COW
4331 "copies" are possible. */
4332 || CowREFCNT(sstr) == SV_COW_REFCNT_MAX))
4334 : 1 /* If making a COW copy is forbidden then the behaviour we
4335 desire is as if the source SV isn't actually already
4336 COW, even if it is. So we act as if the source flags
4337 are not COW, rather than actually testing them. */
4339 #ifndef PERL_ANY_COW
4340 /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4341 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4342 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4343 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4344 but in turn, it's somewhat dead code, never expected to go
4345 live, but more kept as a placeholder on how to do it better
4346 in a newer implementation. */
4347 /* If we are COW and dstr is a suitable target then we drop down
4348 into the else and make dest a COW of us. */
4349 || (SvFLAGS(dstr) & SVf_BREAK)
4354 #ifdef PERL_NEW_COPY_ON_WRITE
4355 /* slated for free anyway (and not COW)? */
4356 (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP &&
4358 (sflags & SVs_TEMP) && /* slated for free anyway? */
4360 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4361 (!(flags & SV_NOSTEAL)) &&
4362 /* and we're allowed to steal temps */
4363 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4364 len) /* and really is a string */
4366 && ((flags & SV_COW_SHARED_HASH_KEYS)
4367 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4368 # ifdef PERL_OLD_COPY_ON_WRITE
4369 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4370 && SvTYPE(sstr) >= SVt_PVIV && len
4372 && !(SvFLAGS(dstr) & SVf_BREAK)
4373 && !(sflags & SVf_IsCOW)
4374 && GE_COW_THRESHOLD(cur) && cur+1 < len
4375 && (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1)
4381 /* Failed the swipe test, and it's not a shared hash key either.
4382 Have to copy the string. */
4383 SvGROW(dstr, cur + 1); /* inlined from sv_setpvn */
4384 Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
4385 SvCUR_set(dstr, cur);
4386 *SvEND(dstr) = '\0';
4388 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4390 /* Either it's a shared hash key, or it's suitable for
4391 copy-on-write or we can swipe the string. */
4393 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4399 if (!(sflags & SVf_IsCOW)) {
4401 # ifdef PERL_OLD_COPY_ON_WRITE
4402 /* Make the source SV into a loop of 1.
4403 (about to become 2) */
4404 SV_COW_NEXT_SV_SET(sstr, sstr);
4406 CowREFCNT(sstr) = 0;
4411 /* Initial code is common. */
4412 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4417 /* making another shared SV. */
4420 # ifdef PERL_OLD_COPY_ON_WRITE
4421 assert (SvTYPE(dstr) >= SVt_PVIV);
4422 /* SvIsCOW_normal */
4423 /* splice us in between source and next-after-source. */
4424 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4425 SV_COW_NEXT_SV_SET(sstr, dstr);
4429 SvPV_set(dstr, SvPVX_mutable(sstr));
4433 /* SvIsCOW_shared_hash */
4434 DEBUG_C(PerlIO_printf(Perl_debug_log,
4435 "Copy on write: Sharing hash\n"));
4437 assert (SvTYPE(dstr) >= SVt_PV);
4439 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4441 SvLEN_set(dstr, len);
4442 SvCUR_set(dstr, cur);
4446 { /* Passes the swipe test. */
4447 SvPV_set(dstr, SvPVX_mutable(sstr));
4448 SvLEN_set(dstr, SvLEN(sstr));
4449 SvCUR_set(dstr, SvCUR(sstr));
4452 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4453 SvPV_set(sstr, NULL);
4459 if (sflags & SVp_NOK) {
4460 SvNV_set(dstr, SvNVX(sstr));
4462 if (sflags & SVp_IOK) {
4463 SvIV_set(dstr, SvIVX(sstr));
4464 /* Must do this otherwise some other overloaded use of 0x80000000
4465 gets confused. I guess SVpbm_VALID */
4466 if (sflags & SVf_IVisUV)
4469 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4471 const MAGIC * const smg = SvVSTRING_mg(sstr);
4473 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4474 smg->mg_ptr, smg->mg_len);
4475 SvRMAGICAL_on(dstr);
4479 else if (sflags & (SVp_IOK|SVp_NOK)) {
4480 (void)SvOK_off(dstr);
4481 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4482 if (sflags & SVp_IOK) {
4483 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4484 SvIV_set(dstr, SvIVX(sstr));
4486 if (sflags & SVp_NOK) {
4487 SvNV_set(dstr, SvNVX(sstr));
4491 if (isGV_with_GP(sstr)) {
4492 gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4495 (void)SvOK_off(dstr);
4497 if (SvTAINTED(sstr))
4502 =for apidoc sv_setsv_mg
4504 Like C<sv_setsv>, but also handles 'set' magic.
4510 Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr)
4512 PERL_ARGS_ASSERT_SV_SETSV_MG;
4514 sv_setsv(dstr,sstr);
4519 # ifdef PERL_OLD_COPY_ON_WRITE
4520 # define SVt_COW SVt_PVIV
4522 # define SVt_COW SVt_PV
4525 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4527 STRLEN cur = SvCUR(sstr);
4528 STRLEN len = SvLEN(sstr);
4531 PERL_ARGS_ASSERT_SV_SETSV_COW;
4534 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4535 (void*)sstr, (void*)dstr);
4542 if (SvTHINKFIRST(dstr))
4543 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4544 else if (SvPVX_const(dstr))
4545 Safefree(SvPVX_mutable(dstr));
4549 SvUPGRADE(dstr, SVt_COW);
4551 assert (SvPOK(sstr));
4552 assert (SvPOKp(sstr));
4553 # ifdef PERL_OLD_COPY_ON_WRITE
4554 assert (!SvIOK(sstr));
4555 assert (!SvIOKp(sstr));
4556 assert (!SvNOK(sstr));
4557 assert (!SvNOKp(sstr));
4560 if (SvIsCOW(sstr)) {
4562 if (SvLEN(sstr) == 0) {
4563 /* source is a COW shared hash key. */
4564 DEBUG_C(PerlIO_printf(Perl_debug_log,
4565 "Fast copy on write: Sharing hash\n"));
4566 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4569 # ifdef PERL_OLD_COPY_ON_WRITE
4570 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4572 assert(SvCUR(sstr)+1 < SvLEN(sstr));
4573 assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX);
4576 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4577 SvUPGRADE(sstr, SVt_COW);
4579 DEBUG_C(PerlIO_printf(Perl_debug_log,
4580 "Fast copy on write: Converting sstr to COW\n"));
4581 # ifdef PERL_OLD_COPY_ON_WRITE
4582 SV_COW_NEXT_SV_SET(dstr, sstr);
4584 CowREFCNT(sstr) = 0;
4587 # ifdef PERL_OLD_COPY_ON_WRITE
4588 SV_COW_NEXT_SV_SET(sstr, dstr);
4592 new_pv = SvPVX_mutable(sstr);
4595 SvPV_set(dstr, new_pv);
4596 SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
4599 SvLEN_set(dstr, len);
4600 SvCUR_set(dstr, cur);
4609 =for apidoc sv_setpvn
4611 Copies a string into an SV. The C<len> parameter indicates the number of
4612 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4613 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4619 Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4624 PERL_ARGS_ASSERT_SV_SETPVN;
4626 SV_CHECK_THINKFIRST_COW_DROP(sv);
4632 /* len is STRLEN which is unsigned, need to copy to signed */
4635 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
4638 SvUPGRADE(sv, SVt_PV);
4640 dptr = SvGROW(sv, len + 1);
4641 Move(ptr,dptr,len,char);
4644 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4646 if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4650 =for apidoc sv_setpvn_mg
4652 Like C<sv_setpvn>, but also handles 'set' magic.
4658 Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4660 PERL_ARGS_ASSERT_SV_SETPVN_MG;
4662 sv_setpvn(sv,ptr,len);
4667 =for apidoc sv_setpv
4669 Copies a string into an SV. The string must be null-terminated. Does not
4670 handle 'set' magic. See C<sv_setpv_mg>.
4676 Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
4681 PERL_ARGS_ASSERT_SV_SETPV;
4683 SV_CHECK_THINKFIRST_COW_DROP(sv);
4689 SvUPGRADE(sv, SVt_PV);
4691 SvGROW(sv, len + 1);
4692 Move(ptr,SvPVX(sv),len+1,char);
4694 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4696 if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4700 =for apidoc sv_setpv_mg
4702 Like C<sv_setpv>, but also handles 'set' magic.
4708 Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
4710 PERL_ARGS_ASSERT_SV_SETPV_MG;
4717 Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
4721 PERL_ARGS_ASSERT_SV_SETHEK;
4727 if (HEK_LEN(hek) == HEf_SVKEY) {
4728 sv_setsv(sv, *(SV**)HEK_KEY(hek));
4731 const int flags = HEK_FLAGS(hek);
4732 if (flags & HVhek_WASUTF8) {
4733 STRLEN utf8_len = HEK_LEN(hek);
4734 char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
4735 sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
4738 } else if (flags & HVhek_UNSHARED) {
4739 sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
4742 else SvUTF8_off(sv);
4746 SV_CHECK_THINKFIRST_COW_DROP(sv);
4747 SvUPGRADE(sv, SVt_PV);
4749 SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
4750 SvCUR_set(sv, HEK_LEN(hek));
4756 else SvUTF8_off(sv);
4764 =for apidoc sv_usepvn_flags
4766 Tells an SV to use C<ptr> to find its string value. Normally the
4767 string is stored inside the SV but sv_usepvn allows the SV to use an
4768 outside string. The C<ptr> should point to memory that was allocated
4769 by C<malloc>. It must be the start of a mallocked block
4770 of memory, and not a pointer to the middle of it. The
4771 string length, C<len>, must be supplied. By default
4772 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4773 so that pointer should not be freed or used by the programmer after
4774 giving it to sv_usepvn, and neither should any pointers from "behind"
4775 that pointer (e.g. ptr + 1) be used.
4777 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4778 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4779 will be skipped (i.e. the buffer is actually at least 1 byte longer than
4780 C<len>, and already meets the requirements for storing in C<SvPVX>).
4786 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4791 PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4793 SV_CHECK_THINKFIRST_COW_DROP(sv);
4794 SvUPGRADE(sv, SVt_PV);
4797 if (flags & SV_SMAGIC)
4801 if (SvPVX_const(sv))
4805 if (flags & SV_HAS_TRAILING_NUL)
4806 assert(ptr[len] == '\0');
4809 allocate = (flags & SV_HAS_TRAILING_NUL)
4811 #ifdef Perl_safesysmalloc_size
4814 PERL_STRLEN_ROUNDUP(len + 1);
4816 if (flags & SV_HAS_TRAILING_NUL) {
4817 /* It's long enough - do nothing.
4818 Specifically Perl_newCONSTSUB is relying on this. */
4821 /* Force a move to shake out bugs in callers. */
4822 char *new_ptr = (char*)safemalloc(allocate);
4823 Copy(ptr, new_ptr, len, char);
4824 PoisonFree(ptr,len,char);
4828 ptr = (char*) saferealloc (ptr, allocate);
4831 #ifdef Perl_safesysmalloc_size
4832 SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4834 SvLEN_set(sv, allocate);
4838 if (!(flags & SV_HAS_TRAILING_NUL)) {
4841 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4843 if (flags & SV_SMAGIC)
4847 #ifdef PERL_OLD_COPY_ON_WRITE
4848 /* Need to do this *after* making the SV normal, as we need the buffer
4849 pointer to remain valid until after we've copied it. If we let go too early,
4850 another thread could invalidate it by unsharing last of the same hash key
4851 (which it can do by means other than releasing copy-on-write Svs)
4852 or by changing the other copy-on-write SVs in the loop. */
4854 S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after)
4856 PERL_ARGS_ASSERT_SV_RELEASE_COW;
4858 { /* this SV was SvIsCOW_normal(sv) */
4859 /* we need to find the SV pointing to us. */
4860 SV *current = SV_COW_NEXT_SV(after);
4862 if (current == sv) {
4863 /* The SV we point to points back to us (there were only two of us
4865 Hence other SV is no longer copy on write either. */
4868 /* We need to follow the pointers around the loop. */
4870 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4873 /* don't loop forever if the structure is bust, and we have
4874 a pointer into a closed loop. */
4875 assert (current != after);
4876 assert (SvPVX_const(current) == pvx);
4878 /* Make the SV before us point to the SV after us. */
4879 SV_COW_NEXT_SV_SET(current, after);
4885 =for apidoc sv_force_normal_flags
4887 Undo various types of fakery on an SV, where fakery means
4888 "more than" a string: if the PV is a shared string, make
4889 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4890 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4891 we do the copy, and is also used locally; if this is a
4892 vstring, drop the vstring magic. If C<SV_COW_DROP_PV> is set
4893 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4894 SvPOK_off rather than making a copy. (Used where this
4895 scalar is about to be set to some other value.) In addition,
4896 the C<flags> parameter gets passed to C<sv_unref_flags()>
4897 when unreffing. C<sv_force_normal> calls this function
4898 with flags set to 0.
4904 S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
4908 assert(SvIsCOW(sv));
4911 const char * const pvx = SvPVX_const(sv);
4912 const STRLEN len = SvLEN(sv);
4913 const STRLEN cur = SvCUR(sv);
4914 # ifdef PERL_OLD_COPY_ON_WRITE
4915 /* next COW sv in the loop. If len is 0 then this is a shared-hash
4916 key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4917 we'll fail an assertion. */
4918 SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4922 PerlIO_printf(Perl_debug_log,
4923 "Copy on write: Force normal %ld\n",
4928 # ifdef PERL_NEW_COPY_ON_WRITE
4929 if (len && CowREFCNT(sv) == 0)
4930 /* We own the buffer ourselves. */
4936 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4937 # ifdef PERL_NEW_COPY_ON_WRITE
4938 /* Must do this first, since the macro uses SvPVX. */
4939 if (len) CowREFCNT(sv)--;
4943 if (flags & SV_COW_DROP_PV) {
4944 /* OK, so we don't need to copy our buffer. */
4947 SvGROW(sv, cur + 1);
4948 Move(pvx,SvPVX(sv),cur,char);
4953 # ifdef PERL_OLD_COPY_ON_WRITE
4954 sv_release_COW(sv, pvx, next);
4957 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4964 const char * const pvx = SvPVX_const(sv);
4965 const STRLEN len = SvCUR(sv);
4969 if (flags & SV_COW_DROP_PV) {
4970 /* OK, so we don't need to copy our buffer. */
4973 SvGROW(sv, len + 1);
4974 Move(pvx,SvPVX(sv),len,char);
4977 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4983 Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
4985 PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4988 Perl_croak_no_modify();
4989 else if (SvIsCOW(sv))
4990 S_sv_uncow(aTHX_ sv, flags);
4992 sv_unref_flags(sv, flags);
4993 else if (SvFAKE(sv) && isGV_with_GP(sv))
4994 sv_unglob(sv, flags);
4995 else if (SvFAKE(sv) && isREGEXP(sv)) {
4996 /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
4997 to sv_unglob. We only need it here, so inline it. */
4998 const bool islv = SvTYPE(sv) == SVt_PVLV;
4999 const svtype new_type =
5000 islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
5001 SV *const temp = newSV_type(new_type);
5002 regexp *const temp_p = ReANY((REGEXP *)sv);
5004 if (new_type == SVt_PVMG) {
5005 SvMAGIC_set(temp, SvMAGIC(sv));
5006 SvMAGIC_set(sv, NULL);
5007 SvSTASH_set(temp, SvSTASH(sv));
5008 SvSTASH_set(sv, NULL);
5010 if (!islv) SvCUR_set(temp, SvCUR(sv));
5011 /* Remember that SvPVX is in the head, not the body. But
5012 RX_WRAPPED is in the body. */
5013 assert(ReANY((REGEXP *)sv)->mother_re);
5014 /* Their buffer is already owned by someone else. */
5015 if (flags & SV_COW_DROP_PV) {
5016 /* SvLEN is already 0. For SVt_REGEXP, we have a brand new
5017 zeroed body. For SVt_PVLV, it should have been set to 0
5018 before turning into a regexp. */
5019 assert(!SvLEN(islv ? sv : temp));
5020 sv->sv_u.svu_pv = 0;
5023 sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
5024 SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
5028 /* Now swap the rest of the bodies. */
5032 SvFLAGS(sv) &= ~SVTYPEMASK;
5033 SvFLAGS(sv) |= new_type;
5034 SvANY(sv) = SvANY(temp);
5037 SvFLAGS(temp) &= ~(SVTYPEMASK);
5038 SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
5039 SvANY(temp) = temp_p;
5040 temp->sv_u.svu_rx = (regexp *)temp_p;
5042 SvREFCNT_dec_NN(temp);
5044 else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
5050 Efficient removal of characters from the beginning of the string buffer.
5051 SvPOK(sv), or at least SvPOKp(sv), must be true and the C<ptr> must be a
5052 pointer to somewhere inside the string buffer. The C<ptr> becomes the first
5053 character of the adjusted string. Uses the "OOK hack". On return, only
5054 SvPOK(sv) and SvPOKp(sv) among the OK flags will be true.
5056 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
5057 refer to the same chunk of data.
5059 The unfortunate similarity of this function's name to that of Perl's C<chop>
5060 operator is strictly coincidental. This function works from the left;
5061 C<chop> works from the right.
5067 Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
5078 PERL_ARGS_ASSERT_SV_CHOP;
5080 if (!ptr || !SvPOKp(sv))
5082 delta = ptr - SvPVX_const(sv);
5084 /* Nothing to do. */
5087 max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
5088 if (delta > max_delta)
5089 Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
5090 ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
5091 /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
5092 SV_CHECK_THINKFIRST(sv);
5093 SvPOK_only_UTF8(sv);
5096 if (!SvLEN(sv)) { /* make copy of shared string */
5097 const char *pvx = SvPVX_const(sv);
5098 const STRLEN len = SvCUR(sv);
5099 SvGROW(sv, len + 1);
5100 Move(pvx,SvPVX(sv),len,char);
5106 SvOOK_offset(sv, old_delta);
5108 SvLEN_set(sv, SvLEN(sv) - delta);
5109 SvCUR_set(sv, SvCUR(sv) - delta);
5110 SvPV_set(sv, SvPVX(sv) + delta);
5112 p = (U8 *)SvPVX_const(sv);
5115 /* how many bytes were evacuated? we will fill them with sentinel
5116 bytes, except for the part holding the new offset of course. */
5119 evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
5121 assert(evacn <= delta + old_delta);
5125 /* This sets 'delta' to the accumulated value of all deltas so far */
5129 /* If 'delta' fits in a byte, store it just prior to the new beginning of
5130 * the string; otherwise store a 0 byte there and store 'delta' just prior
5131 * to that, using as many bytes as a STRLEN occupies. Thus it overwrites a
5132 * portion of the chopped part of the string */
5133 if (delta < 0x100) {
5137 p -= sizeof(STRLEN);
5138 Copy((U8*)&delta, p, sizeof(STRLEN), U8);
5142 /* Fill the preceding buffer with sentinals to verify that no-one is
5152 =for apidoc sv_catpvn
5154 Concatenates the string onto the end of the string which is in the SV. The
5155 C<len> 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 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
5159 =for apidoc sv_catpvn_flags
5161 Concatenates the string onto the end of the string which is in the SV. The
5162 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5163 status set, then the bytes appended should be valid UTF-8.
5164 If C<flags> has the C<SV_SMAGIC> bit set, will
5165 C<mg_set> on C<dsv> afterwards if appropriate.
5166 C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5167 in terms of this function.
5173 Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
5177 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5179 PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5180 assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5182 if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
5183 if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
5184 sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5187 else SvGROW(dsv, dlen + slen + 1);
5189 sstr = SvPVX_const(dsv);
5190 Move(sstr, SvPVX(dsv) + dlen, slen, char);
5191 SvCUR_set(dsv, SvCUR(dsv) + slen);
5194 /* We inline bytes_to_utf8, to avoid an extra malloc. */
5195 const char * const send = sstr + slen;
5198 /* Something this code does not account for, which I think is
5199 impossible; it would require the same pv to be treated as
5200 bytes *and* utf8, which would indicate a bug elsewhere. */
5201 assert(sstr != dstr);
5203 SvGROW(dsv, dlen + slen * 2 + 1);
5204 d = (U8 *)SvPVX(dsv) + dlen;
5206 while (sstr < send) {
5207 append_utf8_from_native_byte(*sstr, &d);
5210 SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5213 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
5215 if (flags & SV_SMAGIC)
5220 =for apidoc sv_catsv
5222 Concatenates the string from SV C<ssv> onto the end of the string in SV
5223 C<dsv>. If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5224 Handles 'get' magic on both SVs, but no 'set' magic. See C<sv_catsv_mg> and
5227 =for apidoc sv_catsv_flags
5229 Concatenates the string from SV C<ssv> onto the end of the string in SV
5230 C<dsv>. If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5231 If C<flags> include C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if
5232 appropriate. If C<flags> include C<SV_SMAGIC>, C<mg_set> will be called on
5233 the modified SV afterward, if appropriate. C<sv_catsv>, C<sv_catsv_nomg>,
5234 and C<sv_catsv_mg> are implemented in terms of this function.
5239 Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
5243 PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5247 const char *spv = SvPV_flags_const(ssv, slen, flags);
5249 if (flags & SV_GMAGIC)
5251 sv_catpvn_flags(dsv, spv, slen,
5252 DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
5253 if (flags & SV_SMAGIC)
5260 =for apidoc sv_catpv
5262 Concatenates the string onto the end of the string which is in the SV.
5263 If the SV has the UTF-8 status set, then the bytes appended should be
5264 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
5269 Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
5276 PERL_ARGS_ASSERT_SV_CATPV;
5280 junk = SvPV_force(sv, tlen);
5282 SvGROW(sv, tlen + len + 1);
5284 ptr = SvPVX_const(sv);
5285 Move(ptr,SvPVX(sv)+tlen,len+1,char);
5286 SvCUR_set(sv, SvCUR(sv) + len);
5287 (void)SvPOK_only_UTF8(sv); /* validate pointer */
5292 =for apidoc sv_catpv_flags
5294 Concatenates the string onto the end of the string which is in the SV.
5295 If the SV has the UTF-8 status set, then the bytes appended should
5296 be valid UTF-8. If C<flags> has the C<SV_SMAGIC> bit set, will C<mg_set>
5297 on the modified SV if appropriate.
5303 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
5305 PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5306 sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
5310 =for apidoc sv_catpv_mg
5312 Like C<sv_catpv>, but also handles 'set' magic.
5318 Perl_sv_catpv_mg(pTHX_ SV *const sv, const char *const ptr)
5320 PERL_ARGS_ASSERT_SV_CATPV_MG;
5329 Creates a new SV. A non-zero C<len> parameter indicates the number of
5330 bytes of preallocated string space the SV should have. An extra byte for a
5331 trailing NUL is also reserved. (SvPOK is not set for the SV even if string
5332 space is allocated.) The reference count for the new SV is set to 1.
5334 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
5335 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5336 This aid has been superseded by a new build option, PERL_MEM_LOG (see
5337 L<perlhacktips/PERL_MEM_LOG>). The older API is still there for use in XS
5338 modules supporting older perls.
5344 Perl_newSV(pTHX_ const STRLEN len)
5351 sv_upgrade(sv, SVt_PV);
5352 SvGROW(sv, len + 1);
5357 =for apidoc sv_magicext
5359 Adds magic to an SV, upgrading it if necessary. Applies the
5360 supplied vtable and returns a pointer to the magic added.
5362 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5363 In particular, you can add magic to SvREADONLY SVs, and add more than
5364 one instance of the same 'how'.
5366 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5367 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5368 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5369 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5371 (This is now used as a subroutine by C<sv_magic>.)
5376 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
5377 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5382 PERL_ARGS_ASSERT_SV_MAGICEXT;
5384 if (SvTYPE(sv)==SVt_PVAV) { assert (!AvPAD_NAMELIST(sv)); }
5386 SvUPGRADE(sv, SVt_PVMG);
5387 Newxz(mg, 1, MAGIC);
5388 mg->mg_moremagic = SvMAGIC(sv);
5389 SvMAGIC_set(sv, mg);
5391 /* Sometimes a magic contains a reference loop, where the sv and
5392 object refer to each other. To prevent a reference loop that
5393 would prevent such objects being freed, we look for such loops
5394 and if we find one we avoid incrementing the object refcount.
5396 Note we cannot do this to avoid self-tie loops as intervening RV must
5397 have its REFCNT incremented to keep it in existence.
5400 if (!obj || obj == sv ||
5401 how == PERL_MAGIC_arylen ||
5402 how == PERL_MAGIC_symtab ||
5403 (SvTYPE(obj) == SVt_PVGV &&
5404 (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5405 || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5406 || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5411 mg->mg_obj = SvREFCNT_inc_simple(obj);
5412 mg->mg_flags |= MGf_REFCOUNTED;
5415 /* Normal self-ties simply pass a null object, and instead of
5416 using mg_obj directly, use the SvTIED_obj macro to produce a
5417 new RV as needed. For glob "self-ties", we are tieing the PVIO
5418 with an RV obj pointing to the glob containing the PVIO. In
5419 this case, to avoid a reference loop, we need to weaken the
5423 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5424 obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5430 mg->mg_len = namlen;
5433 mg->mg_ptr = savepvn(name, namlen);
5434 else if (namlen == HEf_SVKEY) {
5435 /* Yes, this is casting away const. This is only for the case of
5436 HEf_SVKEY. I think we need to document this aberation of the
5437 constness of the API, rather than making name non-const, as
5438 that change propagating outwards a long way. */
5439 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5441 mg->mg_ptr = (char *) name;
5443 mg->mg_virtual = (MGVTBL *) vtable;
5450 Perl_sv_magicext_mglob(pTHX_ SV *sv)
5452 PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB;
5453 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
5454 /* This sv is only a delegate. //g magic must be attached to
5459 #ifdef PERL_OLD_COPY_ON_WRITE
5461 sv_force_normal_flags(sv, 0);
5463 return sv_magicext(sv, NULL, PERL_MAGIC_regex_global,
5464 &PL_vtbl_mglob, 0, 0);
5468 =for apidoc sv_magic
5470 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if
5471 necessary, then adds a new magic item of type C<how> to the head of the
5474 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5475 handling of the C<name> and C<namlen> arguments.
5477 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5478 to add more than one instance of the same 'how'.
5484 Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
5485 const char *const name, const I32 namlen)
5488 const MGVTBL *vtable;
5491 unsigned int vtable_index;
5493 PERL_ARGS_ASSERT_SV_MAGIC;
5495 if (how < 0 || (unsigned)how > C_ARRAY_LENGTH(PL_magic_data)
5496 || ((flags = PL_magic_data[how]),
5497 (vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
5498 > magic_vtable_max))
5499 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5501 /* PERL_MAGIC_ext is reserved for use by extensions not perl internals.
5502 Useful for attaching extension internal data to perl vars.
5503 Note that multiple extensions may clash if magical scalars
5504 etc holding private data from one are passed to another. */
5506 vtable = (vtable_index == magic_vtable_max)
5507 ? NULL : PL_magic_vtables + vtable_index;
5509 #ifdef PERL_OLD_COPY_ON_WRITE
5511 sv_force_normal_flags(sv, 0);
5513 if (SvREADONLY(sv)) {
5515 !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
5518 Perl_croak_no_modify();
5521 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5522 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5523 /* sv_magic() refuses to add a magic of the same 'how' as an
5526 if (how == PERL_MAGIC_taint)
5532 /* Force pos to be stored as characters, not bytes. */
5533 if (SvMAGICAL(sv) && DO_UTF8(sv)
5534 && (mg = mg_find(sv, PERL_MAGIC_regex_global))
5536 && mg->mg_flags & MGf_BYTES) {
5537 mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len,
5539 mg->mg_flags &= ~MGf_BYTES;
5542 /* Rest of work is done else where */
5543 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5546 case PERL_MAGIC_taint:
5549 case PERL_MAGIC_ext:
5550 case PERL_MAGIC_dbfile:
5557 S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
5564 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5566 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5567 for (mg = *mgp; mg; mg = *mgp) {
5568 const MGVTBL* const virt = mg->mg_virtual;
5569 if (mg->mg_type == type && (!flags || virt == vtbl)) {
5570 *mgp = mg->mg_moremagic;
5571 if (virt && virt->svt_free)
5572 virt->svt_free(aTHX_ sv, mg);
5573 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5575 Safefree(mg->mg_ptr);
5576 else if (mg->mg_len == HEf_SVKEY)
5577 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5578 else if (mg->mg_type == PERL_MAGIC_utf8)
5579 Safefree(mg->mg_ptr);
5581 if (mg->mg_flags & MGf_REFCOUNTED)
5582 SvREFCNT_dec(mg->mg_obj);
5586 mgp = &mg->mg_moremagic;
5589 if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */
5590 mg_magical(sv); /* else fix the flags now */
5594 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5600 =for apidoc sv_unmagic
5602 Removes all magic of type C<type> from an SV.
5608 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5610 PERL_ARGS_ASSERT_SV_UNMAGIC;
5611 return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
5615 =for apidoc sv_unmagicext
5617 Removes all magic of type C<type> with the specified C<vtbl> from an SV.
5623 Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
5625 PERL_ARGS_ASSERT_SV_UNMAGICEXT;
5626 return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
5630 =for apidoc sv_rvweaken
5632 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5633 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5634 push a back-reference to this RV onto the array of backreferences
5635 associated with that magic. If the RV is magical, set magic will be
5636 called after the RV is cleared.
5642 Perl_sv_rvweaken(pTHX_ SV *const sv)
5646 PERL_ARGS_ASSERT_SV_RVWEAKEN;
5648 if (!SvOK(sv)) /* let undefs pass */
5651 Perl_croak(aTHX_ "Can't weaken a nonreference");
5652 else if (SvWEAKREF(sv)) {
5653 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5656 else if (SvREADONLY(sv)) croak_no_modify();
5658 Perl_sv_add_backref(aTHX_ tsv, sv);
5660 SvREFCNT_dec_NN(tsv);
5664 /* Give tsv backref magic if it hasn't already got it, then push a
5665 * back-reference to sv onto the array associated with the backref magic.
5667 * As an optimisation, if there's only one backref and it's not an AV,
5668 * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5669 * allocate an AV. (Whether the slot holds an AV tells us whether this is
5673 /* A discussion about the backreferences array and its refcount:
5675 * The AV holding the backreferences is pointed to either as the mg_obj of
5676 * PERL_MAGIC_backref, or in the specific case of a HV, from the
5677 * xhv_backreferences field. The array is created with a refcount
5678 * of 2. This means that if during global destruction the array gets
5679 * picked on before its parent to have its refcount decremented by the
5680 * random zapper, it won't actually be freed, meaning it's still there for
5681 * when its parent gets freed.
5683 * When the parent SV is freed, the extra ref is killed by
5684 * Perl_sv_kill_backrefs. The other ref is killed, in the case of magic,
5685 * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5687 * When a single backref SV is stored directly, it is not reference
5692 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5699 PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5701 /* find slot to store array or singleton backref */
5703 if (SvTYPE(tsv) == SVt_PVHV) {
5704 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5707 mg = mg_find(tsv, PERL_MAGIC_backref);
5709 mg = sv_magicext(tsv, NULL, PERL_MAGIC_backref, &PL_vtbl_backref, NULL, 0);
5710 svp = &(mg->mg_obj);
5713 /* create or retrieve the array */
5715 if ( (!*svp && SvTYPE(sv) == SVt_PVAV)
5716 || (*svp && SvTYPE(*svp) != SVt_PVAV)
5720 mg->mg_flags |= MGf_REFCOUNTED;
5723 SvREFCNT_inc_simple_void_NN(av);
5724 /* av now has a refcnt of 2; see discussion above */
5725 av_extend(av, *svp ? 2 : 1);
5727 /* move single existing backref to the array */
5728 AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5733 av = MUTABLE_AV(*svp);
5735 /* optimisation: store single backref directly in HvAUX or mg_obj */
5739 assert(SvTYPE(av) == SVt_PVAV);
5740 if (AvFILLp(av) >= AvMAX(av)) {
5741 av_extend(av, AvFILLp(av)+1);
5744 /* push new backref */
5745 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5748 /* delete a back-reference to ourselves from the backref magic associated
5749 * with the SV we point to.
5753 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5758 PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5760 if (SvTYPE(tsv) == SVt_PVHV) {
5762 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5764 else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) {
5765 /* It's possible for the the last (strong) reference to tsv to have
5766 become freed *before* the last thing holding a weak reference.
5767 If both survive longer than the backreferences array, then when
5768 the referent's reference count drops to 0 and it is freed, it's
5769 not able to chase the backreferences, so they aren't NULLed.
5771 For example, a CV holds a weak reference to its stash. If both the
5772 CV and the stash survive longer than the backreferences array,
5773 and the CV gets picked for the SvBREAK() treatment first,
5774 *and* it turns out that the stash is only being kept alive because
5775 of an our variable in the pad of the CV, then midway during CV
5776 destruction the stash gets freed, but CvSTASH() isn't set to NULL.
5777 It ends up pointing to the freed HV. Hence it's chased in here, and
5778 if this block wasn't here, it would hit the !svp panic just below.
5780 I don't believe that "better" destruction ordering is going to help
5781 here - during global destruction there's always going to be the
5782 chance that something goes out of order. We've tried to make it
5783 foolproof before, and it only resulted in evolutionary pressure on
5784 fools. Which made us look foolish for our hubris. :-(
5790 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5791 svp = mg ? &(mg->mg_obj) : NULL;
5795 Perl_croak(aTHX_ "panic: del_backref, svp=0");
5797 /* It's possible that sv is being freed recursively part way through the
5798 freeing of tsv. If this happens, the backreferences array of tsv has
5799 already been freed, and so svp will be NULL. If this is the case,
5800 we should not panic. Instead, nothing needs doing, so return. */
5801 if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
5803 Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
5804 *svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
5807 if (SvTYPE(*svp) == SVt_PVAV) {
5811 AV * const av = (AV*)*svp;
5813 assert(!SvIS_FREED(av));
5817 /* for an SV with N weak references to it, if all those
5818 * weak refs are deleted, then sv_del_backref will be called
5819 * N times and O(N^2) compares will be done within the backref
5820 * array. To ameliorate this potential slowness, we:
5821 * 1) make sure this code is as tight as possible;
5822 * 2) when looking for SV, look for it at both the head and tail of the
5823 * array first before searching the rest, since some create/destroy
5824 * patterns will cause the backrefs to be freed in order.
5831 SV **p = &svp[fill];
5832 SV *const topsv = *p;
5839 /* We weren't the last entry.
5840 An unordered list has this property that you
5841 can take the last element off the end to fill
5842 the hole, and it's still an unordered list :-)
5848 break; /* should only be one */
5855 AvFILLp(av) = fill-1;
5857 else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) {
5858 /* freed AV; skip */
5861 /* optimisation: only a single backref, stored directly */
5863 Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p", *svp, sv);
5870 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5876 PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5881 /* after multiple passes through Perl_sv_clean_all() for a thingy
5882 * that has badly leaked, the backref array may have gotten freed,
5883 * since we only protect it against 1 round of cleanup */
5884 if (SvIS_FREED(av)) {
5885 if (PL_in_clean_all) /* All is fair */
5888 "panic: magic_killbackrefs (freed backref AV/SV)");
5892 is_array = (SvTYPE(av) == SVt_PVAV);
5894 assert(!SvIS_FREED(av));
5897 last = svp + AvFILLp(av);
5900 /* optimisation: only a single backref, stored directly */
5906 while (svp <= last) {
5908 SV *const referrer = *svp;
5909 if (SvWEAKREF(referrer)) {
5910 /* XXX Should we check that it hasn't changed? */
5911 assert(SvROK(referrer));
5912 SvRV_set(referrer, 0);
5914 SvWEAKREF_off(referrer);
5915 SvSETMAGIC(referrer);
5916 } else if (SvTYPE(referrer) == SVt_PVGV ||
5917 SvTYPE(referrer) == SVt_PVLV) {
5918 assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
5919 /* You lookin' at me? */
5920 assert(GvSTASH(referrer));
5921 assert(GvSTASH(referrer) == (const HV *)sv);
5922 GvSTASH(referrer) = 0;
5923 } else if (SvTYPE(referrer) == SVt_PVCV ||
5924 SvTYPE(referrer) == SVt_PVFM) {
5925 if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
5926 /* You lookin' at me? */
5927 assert(CvSTASH(referrer));
5928 assert(CvSTASH(referrer) == (const HV *)sv);
5929 SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
5932 assert(SvTYPE(sv) == SVt_PVGV);
5933 /* You lookin' at me? */
5934 assert(CvGV(referrer));
5935 assert(CvGV(referrer) == (const GV *)sv);
5936 anonymise_cv_maybe(MUTABLE_GV(sv),
5937 MUTABLE_CV(referrer));
5942 "panic: magic_killbackrefs (flags=%"UVxf")",
5943 (UV)SvFLAGS(referrer));
5954 SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */
5960 =for apidoc sv_insert
5962 Inserts a string at the specified offset/length within the SV. Similar to
5963 the Perl substr() function. Handles get magic.
5965 =for apidoc sv_insert_flags
5967 Same as C<sv_insert>, but the extra C<flags> are passed to the
5968 C<SvPV_force_flags> that applies to C<bigstr>.
5974 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5981 SSize_t i; /* better be sizeof(STRLEN) or bad things happen */
5984 PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5987 Perl_croak(aTHX_ "Can't modify nonexistent substring");
5988 SvPV_force_flags(bigstr, curlen, flags);
5989 (void)SvPOK_only_UTF8(bigstr);
5990 if (offset + len > curlen) {
5991 SvGROW(bigstr, offset+len+1);
5992 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5993 SvCUR_set(bigstr, offset+len);
5997 i = littlelen - len;
5998 if (i > 0) { /* string might grow */
5999 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
6000 mid = big + offset + len;
6001 midend = bigend = big + SvCUR(bigstr);
6004 while (midend > mid) /* shove everything down */
6005 *--bigend = *--midend;
6006 Move(little,big+offset,littlelen,char);
6007 SvCUR_set(bigstr, SvCUR(bigstr) + i);
6012 Move(little,SvPVX(bigstr)+offset,len,char);
6017 big = SvPVX(bigstr);
6020 bigend = big + SvCUR(bigstr);
6022 if (midend > bigend)
6023 Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p",
6026 if (mid - big > bigend - midend) { /* faster to shorten from end */
6028 Move(little, mid, littlelen,char);
6031 i = bigend - midend;
6033 Move(midend, mid, i,char);
6037 SvCUR_set(bigstr, mid - big);
6039 else if ((i = mid - big)) { /* faster from front */
6040 midend -= littlelen;
6042 Move(big, midend - i, i, char);
6043 sv_chop(bigstr,midend-i);
6045 Move(little, mid, littlelen,char);
6047 else if (littlelen) {
6048 midend -= littlelen;
6049 sv_chop(bigstr,midend);
6050 Move(little,midend,littlelen,char);
6053 sv_chop(bigstr,midend);
6059 =for apidoc sv_replace
6061 Make the first argument a copy of the second, then delete the original.
6062 The target SV physically takes over ownership of the body of the source SV
6063 and inherits its flags; however, the target keeps any magic it owns,
6064 and any magic in the source is discarded.
6065 Note that this is a rather specialist SV copying operation; most of the
6066 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
6072 Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv)
6075 const U32 refcnt = SvREFCNT(sv);
6077 PERL_ARGS_ASSERT_SV_REPLACE;
6079 SV_CHECK_THINKFIRST_COW_DROP(sv);
6080 if (SvREFCNT(nsv) != 1) {
6081 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
6082 " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
6084 if (SvMAGICAL(sv)) {
6088 sv_upgrade(nsv, SVt_PVMG);
6089 SvMAGIC_set(nsv, SvMAGIC(sv));
6090 SvFLAGS(nsv) |= SvMAGICAL(sv);
6092 SvMAGIC_set(sv, NULL);
6096 assert(!SvREFCNT(sv));
6097 #ifdef DEBUG_LEAKING_SCALARS
6098 sv->sv_flags = nsv->sv_flags;
6099 sv->sv_any = nsv->sv_any;
6100 sv->sv_refcnt = nsv->sv_refcnt;
6101 sv->sv_u = nsv->sv_u;
6103 StructCopy(nsv,sv,SV);
6105 if(SvTYPE(sv) == SVt_IV) {
6107 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
6111 #ifdef PERL_OLD_COPY_ON_WRITE
6112 if (SvIsCOW_normal(nsv)) {
6113 /* We need to follow the pointers around the loop to make the
6114 previous SV point to sv, rather than nsv. */
6117 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
6120 assert(SvPVX_const(current) == SvPVX_const(nsv));
6122 /* Make the SV before us point to the SV after us. */
6124 PerlIO_printf(Perl_debug_log, "previous is\n");
6126 PerlIO_printf(Perl_debug_log,
6127 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
6128 (UV) SV_COW_NEXT_SV(current), (UV) sv);
6130 SV_COW_NEXT_SV_SET(current, sv);
6133 SvREFCNT(sv) = refcnt;
6134 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
6139 /* We're about to free a GV which has a CV that refers back to us.
6140 * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
6144 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
6149 PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
6152 assert(SvREFCNT(gv) == 0);
6153 assert(isGV(gv) && isGV_with_GP(gv));
6155 assert(!CvANON(cv));
6156 assert(CvGV(cv) == gv);
6157 assert(!CvNAMED(cv));
6159 /* will the CV shortly be freed by gp_free() ? */
6160 if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
6161 SvANY(cv)->xcv_gv_u.xcv_gv = NULL;
6165 /* if not, anonymise: */
6166 gvname = (GvSTASH(gv) && HvNAME(GvSTASH(gv)) && HvENAME(GvSTASH(gv)))
6167 ? newSVhek(HvENAME_HEK(GvSTASH(gv)))
6168 : newSVpvn_flags( "__ANON__", 8, 0 );
6169 sv_catpvs(gvname, "::__ANON__");
6170 anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
6171 SvREFCNT_dec_NN(gvname);
6175 SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
6180 =for apidoc sv_clear
6182 Clear an SV: call any destructors, free up any memory used by the body,
6183 and free the body itself. The SV's head is I<not> freed, although
6184 its type is set to all 1's so that it won't inadvertently be assumed
6185 to be live during global destruction etc.
6186 This function should only be called when REFCNT is zero. Most of the time
6187 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
6194 Perl_sv_clear(pTHX_ SV *const orig_sv)
6199 const struct body_details *sv_type_details;
6205 PERL_ARGS_ASSERT_SV_CLEAR;
6207 /* within this loop, sv is the SV currently being freed, and
6208 * iter_sv is the most recent AV or whatever that's being iterated
6209 * over to provide more SVs */
6215 assert(SvREFCNT(sv) == 0);
6216 assert(SvTYPE(sv) != (svtype)SVTYPEMASK);
6218 if (type <= SVt_IV) {
6219 /* See the comment in sv.h about the collusion between this
6220 * early return and the overloading of the NULL slots in the
6224 SvFLAGS(sv) &= SVf_BREAK;
6225 SvFLAGS(sv) |= SVTYPEMASK;
6229 assert(!SvOBJECT(sv) || type >= SVt_PVMG); /* objs are always >= MG */
6231 if (type >= SVt_PVMG) {
6233 if (!curse(sv, 1)) goto get_next_sv;
6234 type = SvTYPE(sv); /* destructor may have changed it */
6236 /* Free back-references before magic, in case the magic calls
6237 * Perl code that has weak references to sv. */
6238 if (type == SVt_PVHV) {
6239 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
6243 else if (type == SVt_PVMG && SvPAD_OUR(sv)) {
6244 SvREFCNT_dec(SvOURSTASH(sv));
6246 else if (type == SVt_PVAV && AvPAD_NAMELIST(sv)) {
6247 assert(!SvMAGICAL(sv));
6248 } else if (SvMAGIC(sv)) {
6249 /* Free back-references before other types of magic. */
6250 sv_unmagic(sv, PERL_MAGIC_backref);
6254 if (type == SVt_PVMG && SvPAD_TYPED(sv))
6255 SvREFCNT_dec(SvSTASH(sv));
6258 /* case SVt_INVLIST: */
6261 IoIFP(sv) != PerlIO_stdin() &&
6262 IoIFP(sv) != PerlIO_stdout() &&
6263 IoIFP(sv) != PerlIO_stderr() &&
6264 !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6266 io_close(MUTABLE_IO(sv), FALSE);
6268 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6269 PerlDir_close(IoDIRP(sv));
6270 IoDIRP(sv) = (DIR*)NULL;
6271 Safefree(IoTOP_NAME(sv));
6272 Safefree(IoFMT_NAME(sv));
6273 Safefree(IoBOTTOM_NAME(sv));
6274 if ((const GV *)sv == PL_statgv)
6278 /* FIXME for plugins */
6280 pregfree2((REGEXP*) sv);
6284 cv_undef(MUTABLE_CV(sv));
6285 /* If we're in a stash, we don't own a reference to it.
6286 * However it does have a back reference to us, which needs to
6288 if ((stash = CvSTASH(sv)))
6289 sv_del_backref(MUTABLE_SV(stash), sv);
6292 if (PL_last_swash_hv == (const HV *)sv) {
6293 PL_last_swash_hv = NULL;
6295 if (HvTOTALKEYS((HV*)sv) > 0) {
6297 /* this statement should match the one at the beginning of
6298 * hv_undef_flags() */
6299 if ( PL_phase != PERL_PHASE_DESTRUCT
6300 && (name = HvNAME((HV*)sv)))
6302 if (PL_stashcache) {
6303 DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n",
6305 (void)hv_deletehek(PL_stashcache,
6306 HvNAME_HEK((HV*)sv), G_DISCARD);
6308 hv_name_set((HV*)sv, NULL, 0, 0);
6311 /* save old iter_sv in unused SvSTASH field */
6312 assert(!SvOBJECT(sv));
6313 SvSTASH(sv) = (HV*)iter_sv;
6316 /* save old hash_index in unused SvMAGIC field */
6317 assert(!SvMAGICAL(sv));
6318 assert(!SvMAGIC(sv));
6319 ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index = hash_index;
6322 next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index);
6323 goto get_next_sv; /* process this new sv */
6325 /* free empty hash */
6326 Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6327 assert(!HvARRAY((HV*)sv));
6331 AV* av = MUTABLE_AV(sv);
6332 if (PL_comppad == av) {
6336 if (AvREAL(av) && AvFILLp(av) > -1) {
6337 next_sv = AvARRAY(av)[AvFILLp(av)--];
6338 /* save old iter_sv in top-most slot of AV,
6339 * and pray that it doesn't get wiped in the meantime */
6340 AvARRAY(av)[AvMAX(av)] = iter_sv;
6342 goto get_next_sv; /* process this new sv */
6344 Safefree(AvALLOC(av));
6349 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
6350 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
6351 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
6352 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
6354 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
6355 SvREFCNT_dec(LvTARG(sv));
6356 if (isREGEXP(sv)) goto freeregexp;
6358 if (isGV_with_GP(sv)) {
6359 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
6360 && HvENAME_get(stash))
6361 mro_method_changed_in(stash);
6362 gp_free(MUTABLE_GV(sv));
6364 unshare_hek(GvNAME_HEK(sv));
6365 /* If we're in a stash, we don't own a reference to it.
6366 * However it does have a back reference to us, which
6367 * needs to be cleared. */
6368 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
6369 sv_del_backref(MUTABLE_SV(stash), sv);
6371 /* FIXME. There are probably more unreferenced pointers to SVs
6372 * in the interpreter struct that we should check and tidy in
6373 * a similar fashion to this: */
6374 /* See also S_sv_unglob, which does the same thing. */
6375 if ((const GV *)sv == PL_last_in_gv)
6376 PL_last_in_gv = NULL;
6377 else if ((const GV *)sv == PL_statgv)
6379 else if ((const GV *)sv == PL_stderrgv)
6387 /* Don't bother with SvOOK_off(sv); as we're only going to
6391 SvOOK_offset(sv, offset);
6392 SvPV_set(sv, SvPVX_mutable(sv) - offset);
6393 /* Don't even bother with turning off the OOK flag. */
6398 SV * const target = SvRV(sv);
6400 sv_del_backref(target, sv);
6406 else if (SvPVX_const(sv)
6407 && !(SvTYPE(sv) == SVt_PVIO
6408 && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6412 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6416 # ifdef PERL_OLD_COPY_ON_WRITE
6417 sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
6419 if (CowREFCNT(sv)) {
6425 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6429 # ifdef PERL_OLD_COPY_ON_WRITE
6433 Safefree(SvPVX_mutable(sv));
6437 else if (SvPVX_const(sv) && SvLEN(sv)
6438 && !(SvTYPE(sv) == SVt_PVIO
6439 && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6440 Safefree(SvPVX_mutable(sv));
6441 else if (SvPVX_const(sv) && SvIsCOW(sv)) {
6442 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6452 SvFLAGS(sv) &= SVf_BREAK;
6453 SvFLAGS(sv) |= SVTYPEMASK;
6455 sv_type_details = bodies_by_type + type;
6456 if (sv_type_details->arena) {
6457 del_body(((char *)SvANY(sv) + sv_type_details->offset),
6458 &PL_body_roots[type]);
6460 else if (sv_type_details->body_size) {
6461 safefree(SvANY(sv));
6465 /* caller is responsible for freeing the head of the original sv */
6466 if (sv != orig_sv && !SvREFCNT(sv))
6469 /* grab and free next sv, if any */
6477 else if (!iter_sv) {
6479 } else if (SvTYPE(iter_sv) == SVt_PVAV) {
6480 AV *const av = (AV*)iter_sv;
6481 if (AvFILLp(av) > -1) {
6482 sv = AvARRAY(av)[AvFILLp(av)--];
6484 else { /* no more elements of current AV to free */
6487 /* restore previous value, squirrelled away */
6488 iter_sv = AvARRAY(av)[AvMAX(av)];
6489 Safefree(AvALLOC(av));
6492 } else if (SvTYPE(iter_sv) == SVt_PVHV) {
6493 sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index);
6494 if (!sv && !HvTOTALKEYS((HV *)iter_sv)) {
6495 /* no more elements of current HV to free */
6498 /* Restore previous values of iter_sv and hash_index,
6499 * squirrelled away */
6500 assert(!SvOBJECT(sv));
6501 iter_sv = (SV*)SvSTASH(sv);
6502 assert(!SvMAGICAL(sv));
6503 hash_index = ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index;
6505 /* perl -DA does not like rubbish in SvMAGIC. */
6509 /* free any remaining detritus from the hash struct */
6510 Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6511 assert(!HvARRAY((HV*)sv));
6516 /* unrolled SvREFCNT_dec and sv_free2 follows: */
6520 if (!SvREFCNT(sv)) {
6524 if (--(SvREFCNT(sv)))
6528 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6529 "Attempt to free temp prematurely: SV 0x%"UVxf
6530 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6534 if (SvIMMORTAL(sv)) {
6535 /* make sure SvREFCNT(sv)==0 happens very seldom */
6536 SvREFCNT(sv) = SvREFCNT_IMMORTAL;
6545 /* This routine curses the sv itself, not the object referenced by sv. So
6546 sv does not have to be ROK. */
6549 S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
6552 PERL_ARGS_ASSERT_CURSE;
6553 assert(SvOBJECT(sv));
6555 if (PL_defstash && /* Still have a symbol table? */
6561 stash = SvSTASH(sv);
6562 assert(SvTYPE(stash) == SVt_PVHV);
6563 if (HvNAME(stash)) {
6564 CV* destructor = NULL;
6565 assert (SvOOK(stash));
6566 if (!SvOBJECT(stash)) destructor = (CV *)SvSTASH(stash);
6567 if (!destructor || HvMROMETA(stash)->destroy_gen
6568 != PL_sub_generation)
6571 gv_fetchmeth_autoload(stash, "DESTROY", 7, 0);
6572 if (gv) destructor = GvCV(gv);
6573 if (!SvOBJECT(stash))
6576 destructor ? (HV *)destructor : ((HV *)0)+1;
6577 HvAUX(stash)->xhv_mro_meta->destroy_gen =
6581 assert(!destructor || destructor == ((CV *)0)+1
6582 || SvTYPE(destructor) == SVt_PVCV);
6583 if (destructor && destructor != ((CV *)0)+1
6584 /* A constant subroutine can have no side effects, so
6585 don't bother calling it. */
6586 && !CvCONST(destructor)
6587 /* Don't bother calling an empty destructor or one that
6588 returns immediately. */
6589 && (CvISXSUB(destructor)
6590 || (CvSTART(destructor)
6591 && (CvSTART(destructor)->op_next->op_type
6593 && (CvSTART(destructor)->op_next->op_type
6595 || CvSTART(destructor)->op_next->op_next->op_type
6601 SV* const tmpref = newRV(sv);
6602 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
6604 PUSHSTACKi(PERLSI_DESTROY);
6609 call_sv(MUTABLE_SV(destructor),
6610 G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
6614 if(SvREFCNT(tmpref) < 2) {
6615 /* tmpref is not kept alive! */
6617 SvRV_set(tmpref, NULL);
6620 SvREFCNT_dec_NN(tmpref);
6623 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
6626 if (check_refcnt && SvREFCNT(sv)) {
6627 if (PL_in_clean_objs)
6629 "DESTROY created new reference to dead object '%"HEKf"'",
6630 HEKfARG(HvNAME_HEK(stash)));
6631 /* DESTROY gave object new lease on life */
6637 HV * const stash = SvSTASH(sv);
6638 /* Curse before freeing the stash, as freeing the stash could cause
6639 a recursive call into S_curse. */
6640 SvOBJECT_off(sv); /* Curse the object. */
6641 SvSTASH_set(sv,0); /* SvREFCNT_dec may try to read this */
6642 SvREFCNT_dec(stash); /* possibly of changed persuasion */
6648 =for apidoc sv_newref
6650 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
6657 Perl_sv_newref(pTHX_ SV *const sv)
6659 PERL_UNUSED_CONTEXT;
6668 Decrement an SV's reference count, and if it drops to zero, call
6669 C<sv_clear> to invoke destructors and free up any memory used by
6670 the body; finally, deallocate the SV's head itself.
6671 Normally called via a wrapper macro C<SvREFCNT_dec>.
6677 Perl_sv_free(pTHX_ SV *const sv)
6683 /* Private helper function for SvREFCNT_dec().
6684 * Called with rc set to original SvREFCNT(sv), where rc == 0 or 1 */
6687 Perl_sv_free2(pTHX_ SV *const sv, const U32 rc)
6691 PERL_ARGS_ASSERT_SV_FREE2;
6693 if (LIKELY( rc == 1 )) {
6699 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6700 "Attempt to free temp prematurely: SV 0x%"UVxf
6701 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6705 if (SvIMMORTAL(sv)) {
6706 /* make sure SvREFCNT(sv)==0 happens very seldom */
6707 SvREFCNT(sv) = SvREFCNT_IMMORTAL;
6711 if (! SvREFCNT(sv)) /* may have have been resurrected */
6716 /* handle exceptional cases */
6720 if (SvFLAGS(sv) & SVf_BREAK)
6721 /* this SV's refcnt has been artificially decremented to
6722 * trigger cleanup */
6724 if (PL_in_clean_all) /* All is fair */
6726 if (SvIMMORTAL(sv)) {
6727 /* make sure SvREFCNT(sv)==0 happens very seldom */
6728 SvREFCNT(sv) = SvREFCNT_IMMORTAL;
6731 if (ckWARN_d(WARN_INTERNAL)) {
6732 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
6733 Perl_dump_sv_child(aTHX_ sv);
6735 #ifdef DEBUG_LEAKING_SCALARS
6738 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6739 if (PL_warnhook == PERL_WARNHOOK_FATAL
6740 || ckDEAD(packWARN(WARN_INTERNAL))) {
6741 /* Don't let Perl_warner cause us to escape our fate: */
6745 /* This may not return: */
6746 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6747 "Attempt to free unreferenced scalar: SV 0x%"UVxf
6748 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6751 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6761 Returns the length of the string in the SV. Handles magic and type
6762 coercion and sets the UTF8 flag appropriately. See also C<SvCUR>, which
6763 gives raw access to the xpv_cur slot.
6769 Perl_sv_len(pTHX_ SV *const sv)
6776 (void)SvPV_const(sv, len);
6781 =for apidoc sv_len_utf8
6783 Returns the number of characters in the string in an SV, counting wide
6784 UTF-8 bytes as a single character. Handles magic and type coercion.
6790 * The length is cached in PERL_MAGIC_utf8, in the mg_len field. Also the
6791 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
6792 * (Note that the mg_len is not the length of the mg_ptr field.
6793 * This allows the cache to store the character length of the string without
6794 * needing to malloc() extra storage to attach to the mg_ptr.)
6799 Perl_sv_len_utf8(pTHX_ SV *const sv)
6805 return sv_len_utf8_nomg(sv);
6809 Perl_sv_len_utf8_nomg(pTHX_ SV * const sv)
6813 const U8 *s = (U8*)SvPV_nomg_const(sv, len);
6815 PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG;
6817 if (PL_utf8cache && SvUTF8(sv)) {
6819 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
6821 if (mg && (mg->mg_len != -1 || mg->mg_ptr)) {
6822 if (mg->mg_len != -1)
6825 /* We can use the offset cache for a headstart.
6826 The longer value is stored in the first pair. */
6827 STRLEN *cache = (STRLEN *) mg->mg_ptr;
6829 ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1],
6833 if (PL_utf8cache < 0) {
6834 const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
6835 assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv);
6839 ulen = Perl_utf8_length(aTHX_ s, s + len);
6840 utf8_mg_len_cache_update(sv, &mg, ulen);
6844 return SvUTF8(sv) ? Perl_utf8_length(aTHX_ s, s + len) : len;
6847 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6850 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6851 STRLEN *const uoffset_p, bool *const at_end)
6853 const U8 *s = start;
6854 STRLEN uoffset = *uoffset_p;
6856 PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6858 while (s < send && uoffset) {
6865 else if (s > send) {
6867 /* This is the existing behaviour. Possibly it should be a croak, as
6868 it's actually a bounds error */
6871 *uoffset_p -= uoffset;
6875 /* Given the length of the string in both bytes and UTF-8 characters, decide
6876 whether to walk forwards or backwards to find the byte corresponding to
6877 the passed in UTF-8 offset. */
6879 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6880 STRLEN uoffset, const STRLEN uend)
6882 STRLEN backw = uend - uoffset;
6884 PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6886 if (uoffset < 2 * backw) {
6887 /* The assumption is that going forwards is twice the speed of going
6888 forward (that's where the 2 * backw comes from).
6889 (The real figure of course depends on the UTF-8 data.) */
6890 const U8 *s = start;
6892 while (s < send && uoffset--)
6902 while (UTF8_IS_CONTINUATION(*send))
6905 return send - start;
6908 /* For the string representation of the given scalar, find the byte
6909 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0
6910 give another position in the string, *before* the sought offset, which
6911 (which is always true, as 0, 0 is a valid pair of positions), which should
6912 help reduce the amount of linear searching.
6913 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6914 will be used to reduce the amount of linear searching. The cache will be
6915 created if necessary, and the found value offered to it for update. */
6917 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6918 const U8 *const send, STRLEN uoffset,
6919 STRLEN uoffset0, STRLEN boffset0)
6921 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
6923 bool at_end = FALSE;
6925 PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6927 assert (uoffset >= uoffset0);
6932 if (!SvREADONLY(sv) && !SvGMAGICAL(sv) && SvPOK(sv)
6934 && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
6935 (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
6936 if ((*mgp)->mg_ptr) {
6937 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6938 if (cache[0] == uoffset) {
6939 /* An exact match. */
6942 if (cache[2] == uoffset) {
6943 /* An exact match. */
6947 if (cache[0] < uoffset) {
6948 /* The cache already knows part of the way. */
6949 if (cache[0] > uoffset0) {
6950 /* The cache knows more than the passed in pair */
6951 uoffset0 = cache[0];
6952 boffset0 = cache[1];
6954 if ((*mgp)->mg_len != -1) {
6955 /* And we know the end too. */
6957 + sv_pos_u2b_midway(start + boffset0, send,
6959 (*mgp)->mg_len - uoffset0);
6961 uoffset -= uoffset0;
6963 + sv_pos_u2b_forwards(start + boffset0,
6964 send, &uoffset, &at_end);
6965 uoffset += uoffset0;
6968 else if (cache[2] < uoffset) {
6969 /* We're between the two cache entries. */
6970 if (cache[2] > uoffset0) {
6971 /* and the cache knows more than the passed in pair */
6972 uoffset0 = cache[2];
6973 boffset0 = cache[3];
6977 + sv_pos_u2b_midway(start + boffset0,
6980 cache[0] - uoffset0);
6983 + sv_pos_u2b_midway(start + boffset0,
6986 cache[2] - uoffset0);
6990 else if ((*mgp)->mg_len != -1) {
6991 /* If we can take advantage of a passed in offset, do so. */
6992 /* In fact, offset0 is either 0, or less than offset, so don't
6993 need to worry about the other possibility. */
6995 + sv_pos_u2b_midway(start + boffset0, send,
6997 (*mgp)->mg_len - uoffset0);
7002 if (!found || PL_utf8cache < 0) {
7003 STRLEN real_boffset;
7004 uoffset -= uoffset0;
7005 real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0,
7006 send, &uoffset, &at_end);
7007 uoffset += uoffset0;
7009 if (found && PL_utf8cache < 0)
7010 assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset,
7012 boffset = real_boffset;
7015 if (PL_utf8cache && !SvGMAGICAL(sv) && SvPOK(sv)) {
7017 utf8_mg_len_cache_update(sv, mgp, uoffset);
7019 utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
7026 =for apidoc sv_pos_u2b_flags
7028 Converts the offset from a count of UTF-8 chars from
7029 the start of the string, to a count of the equivalent number of bytes; if
7030 lenp is non-zero, it does the same to lenp, but this time starting from
7031 the offset, rather than from the start
7032 of the string. Handles type coercion.
7033 I<flags> is passed to C<SvPV_flags>, and usually should be
7034 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
7040 * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
7041 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
7042 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
7047 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
7054 PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
7056 start = (U8*)SvPV_flags(sv, len, flags);
7058 const U8 * const send = start + len;
7060 boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
7063 && *lenp /* don't bother doing work for 0, as its bytes equivalent
7064 is 0, and *lenp is already set to that. */) {
7065 /* Convert the relative offset to absolute. */
7066 const STRLEN uoffset2 = uoffset + *lenp;
7067 const STRLEN boffset2
7068 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
7069 uoffset, boffset) - boffset;
7083 =for apidoc sv_pos_u2b
7085 Converts the value pointed to by offsetp from a count of UTF-8 chars from
7086 the start of the string, to a count of the equivalent number of bytes; if
7087 lenp is non-zero, it does the same to lenp, but this time starting from
7088 the offset, rather than from the start of the string. Handles magic and
7091 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
7098 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
7099 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
7100 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
7104 /* This function is subject to size and sign problems */
7107 Perl_sv_pos_u2b(pTHX_ SV *const sv, I32 *const offsetp, I32 *const lenp)
7109 PERL_ARGS_ASSERT_SV_POS_U2B;
7112 STRLEN ulen = (STRLEN)*lenp;
7113 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
7114 SV_GMAGIC|SV_CONST_RETURN);
7117 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
7118 SV_GMAGIC|SV_CONST_RETURN);
7123 S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp,
7126 PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
7127 if (SvREADONLY(sv) || SvGMAGICAL(sv) || !SvPOK(sv))
7130 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
7131 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
7132 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
7136 (*mgp)->mg_len = ulen;
7139 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
7140 byte length pairing. The (byte) length of the total SV is passed in too,
7141 as blen, because for some (more esoteric) SVs, the call to SvPV_const()
7142 may not have updated SvCUR, so we can't rely on reading it directly.
7144 The proffered utf8/byte length pairing isn't used if the cache already has
7145 two pairs, and swapping either for the proffered pair would increase the
7146 RMS of the intervals between known byte offsets.
7148 The cache itself consists of 4 STRLEN values
7149 0: larger UTF-8 offset
7150 1: corresponding byte offset
7151 2: smaller UTF-8 offset
7152 3: corresponding byte offset
7154 Unused cache pairs have the value 0, 0.
7155 Keeping the cache "backwards" means that the invariant of
7156 cache[0] >= cache[2] is maintained even with empty slots, which means that
7157 the code that uses it doesn't need to worry if only 1 entry has actually
7158 been set to non-zero. It also makes the "position beyond the end of the
7159 cache" logic much simpler, as the first slot is always the one to start
7163 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
7164 const STRLEN utf8, const STRLEN blen)
7168 PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
7173 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
7174 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
7175 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
7177 (*mgp)->mg_len = -1;
7181 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
7182 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
7183 (*mgp)->mg_ptr = (char *) cache;
7187 if (PL_utf8cache < 0 && SvPOKp(sv)) {
7188 /* SvPOKp() because it's possible that sv has string overloading, and
7189 therefore is a reference, hence SvPVX() is actually a pointer.
7190 This cures the (very real) symptoms of RT 69422, but I'm not actually
7191 sure whether we should even be caching the results of UTF-8
7192 operations on overloading, given that nothing stops overloading
7193 returning a different value every time it's called. */
7194 const U8 *start = (const U8 *) SvPVX_const(sv);
7195 const STRLEN realutf8 = utf8_length(start, start + byte);
7197 assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8,
7201 /* Cache is held with the later position first, to simplify the code
7202 that deals with unbounded ends. */
7204 ASSERT_UTF8_CACHE(cache);
7205 if (cache[1] == 0) {
7206 /* Cache is totally empty */
7209 } else if (cache[3] == 0) {
7210 if (byte > cache[1]) {
7211 /* New one is larger, so goes first. */
7212 cache[2] = cache[0];
7213 cache[3] = cache[1];
7221 #define THREEWAY_SQUARE(a,b,c,d) \
7222 ((float)((d) - (c))) * ((float)((d) - (c))) \
7223 + ((float)((c) - (b))) * ((float)((c) - (b))) \
7224 + ((float)((b) - (a))) * ((float)((b) - (a)))
7226 /* Cache has 2 slots in use, and we know three potential pairs.
7227 Keep the two that give the lowest RMS distance. Do the
7228 calculation in bytes simply because we always know the byte
7229 length. squareroot has the same ordering as the positive value,
7230 so don't bother with the actual square root. */
7231 if (byte > cache[1]) {
7232 /* New position is after the existing pair of pairs. */
7233 const float keep_earlier
7234 = THREEWAY_SQUARE(0, cache[3], byte, blen);
7235 const float keep_later
7236 = THREEWAY_SQUARE(0, cache[1], byte, blen);
7238 if (keep_later < keep_earlier) {
7239 cache[2] = cache[0];
7240 cache[3] = cache[1];
7249 else if (byte > cache[3]) {
7250 /* New position is between the existing pair of pairs. */
7251 const float keep_earlier
7252 = THREEWAY_SQUARE(0, cache[3], byte, blen);
7253 const float keep_later
7254 = THREEWAY_SQUARE(0, byte, cache[1], blen);
7256 if (keep_later < keep_earlier) {
7266 /* New position is before the existing pair of pairs. */
7267 const float keep_earlier
7268 = THREEWAY_SQUARE(0, byte, cache[3], blen);
7269 const float keep_later
7270 = THREEWAY_SQUARE(0, byte, cache[1], blen);
7272 if (keep_later < keep_earlier) {
7277 cache[0] = cache[2];
7278 cache[1] = cache[3];
7284 ASSERT_UTF8_CACHE(cache);
7287 /* We already know all of the way, now we may be able to walk back. The same
7288 assumption is made as in S_sv_pos_u2b_midway(), namely that walking
7289 backward is half the speed of walking forward. */
7291 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
7292 const U8 *end, STRLEN endu)
7294 const STRLEN forw = target - s;
7295 STRLEN backw = end - target;
7297 PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
7299 if (forw < 2 * backw) {
7300 return utf8_length(s, target);
7303 while (end > target) {
7305 while (UTF8_IS_CONTINUATION(*end)) {
7314 =for apidoc sv_pos_b2u_flags
7316 Converts the offset from a count of bytes from the start of the string, to
7317 a count of the equivalent number of UTF-8 chars. Handles type coercion.
7318 I<flags> is passed to C<SvPV_flags>, and usually should be
7319 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
7325 * sv_pos_b2u_flags() uses, like sv_pos_u2b_flags(), the mg_ptr of the
7326 * potential PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8
7331 Perl_sv_pos_b2u_flags(pTHX_ SV *const sv, STRLEN const offset, U32 flags)
7334 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
7340 PERL_ARGS_ASSERT_SV_POS_B2U_FLAGS;
7342 s = (const U8*)SvPV_flags(sv, blen, flags);
7345 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%"UVuf
7346 ", byte=%"UVuf, (UV)blen, (UV)offset);
7352 && SvTYPE(sv) >= SVt_PVMG
7353 && (mg = mg_find(sv, PERL_MAGIC_utf8)))
7356 STRLEN * const cache = (STRLEN *) mg->mg_ptr;
7357 if (cache[1] == offset) {
7358 /* An exact match. */
7361 if (cache[3] == offset) {
7362 /* An exact match. */
7366 if (cache[1] < offset) {
7367 /* We already know part of the way. */
7368 if (mg->mg_len != -1) {
7369 /* Actually, we know the end too. */
7371 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
7372 s + blen, mg->mg_len - cache[0]);
7374 len = cache[0] + utf8_length(s + cache[1], send);
7377 else if (cache[3] < offset) {
7378 /* We're between the two cached pairs, so we do the calculation
7379 offset by the byte/utf-8 positions for the earlier pair,
7380 then add the utf-8 characters from the string start to
7382 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
7383 s + cache[1], cache[0] - cache[2])
7387 else { /* cache[3] > offset */
7388 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
7392 ASSERT_UTF8_CACHE(cache);
7394 } else if (mg->mg_len != -1) {
7395 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
7399 if (!found || PL_utf8cache < 0) {
7400 const STRLEN real_len = utf8_length(s, send);
7402 if (found && PL_utf8cache < 0)
7403 assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv);
7409 utf8_mg_len_cache_update(sv, &mg, len);
7411 utf8_mg_pos_cache_update(sv, &mg, offset, len, blen);
7418 =for apidoc sv_pos_b2u
7420 Converts the value pointed to by offsetp from a count of bytes from the
7421 start of the string, to a count of the equivalent number of UTF-8 chars.
7422 Handles magic and type coercion.
7424 Use C<sv_pos_b2u_flags> in preference, which correctly handles strings
7431 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
7432 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
7437 Perl_sv_pos_b2u(pTHX_ SV *const sv, I32 *const offsetp)
7439 PERL_ARGS_ASSERT_SV_POS_B2U;
7444 *offsetp = (I32)sv_pos_b2u_flags(sv, (STRLEN)*offsetp,
7445 SV_GMAGIC|SV_CONST_RETURN);
7449 S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache,
7450 STRLEN real, SV *const sv)
7452 PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT;
7454 /* As this is debugging only code, save space by keeping this test here,
7455 rather than inlining it in all the callers. */
7456 if (from_cache == real)
7459 /* Need to turn the assertions off otherwise we may recurse infinitely
7460 while printing error messages. */
7461 SAVEI8(PL_utf8cache);
7463 Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf,
7464 func, (UV) from_cache, (UV) real, SVfARG(sv));
7470 Returns a boolean indicating whether the strings in the two SVs are
7471 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
7472 coerce its args to strings if necessary.
7474 =for apidoc sv_eq_flags
7476 Returns a boolean indicating whether the strings in the two SVs are
7477 identical. Is UTF-8 and 'use bytes' aware and coerces its args to strings
7478 if necessary. If the flags include SV_GMAGIC, it handles get-magic, too.
7484 Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
7492 SV* svrecode = NULL;
7499 /* if pv1 and pv2 are the same, second SvPV_const call may
7500 * invalidate pv1 (if we are handling magic), so we may need to
7502 if (sv1 == sv2 && flags & SV_GMAGIC
7503 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
7504 pv1 = SvPV_const(sv1, cur1);
7505 sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
7507 pv1 = SvPV_flags_const(sv1, cur1, flags);
7515 pv2 = SvPV_flags_const(sv2, cur2, flags);
7517 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7518 /* Differing utf8ness.
7519 * Do not UTF8size the comparands as a side-effect. */
7522 svrecode = newSVpvn(pv2, cur2);
7523 sv_recode_to_utf8(svrecode, PL_encoding);
7524 pv2 = SvPV_const(svrecode, cur2);
7527 svrecode = newSVpvn(pv1, cur1);
7528 sv_recode_to_utf8(svrecode, PL_encoding);
7529 pv1 = SvPV_const(svrecode, cur1);
7531 /* Now both are in UTF-8. */
7533 SvREFCNT_dec_NN(svrecode);
7539 /* sv1 is the UTF-8 one */
7540 return bytes_cmp_utf8((const U8*)pv2, cur2,
7541 (const U8*)pv1, cur1) == 0;
7544 /* sv2 is the UTF-8 one */
7545 return bytes_cmp_utf8((const U8*)pv1, cur1,
7546 (const U8*)pv2, cur2) == 0;
7552 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
7554 SvREFCNT_dec(svrecode);
7562 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7563 string in C<sv1> is less than, equal to, or greater than the string in
7564 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
7565 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
7567 =for apidoc sv_cmp_flags
7569 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7570 string in C<sv1> is less than, equal to, or greater than the string in
7571 C<sv2>. Is UTF-8 and 'use bytes' aware and will coerce its args to strings
7572 if necessary. If the flags include SV_GMAGIC, it handles get magic. See
7573 also C<sv_cmp_locale_flags>.
7579 Perl_sv_cmp(pTHX_ SV *const sv1, SV *const sv2)
7581 return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
7585 Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2,
7590 const char *pv1, *pv2;
7592 SV *svrecode = NULL;
7599 pv1 = SvPV_flags_const(sv1, cur1, flags);
7606 pv2 = SvPV_flags_const(sv2, cur2, flags);
7608 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7609 /* Differing utf8ness.
7610 * Do not UTF8size the comparands as a side-effect. */
7613 svrecode = newSVpvn(pv2, cur2);
7614 sv_recode_to_utf8(svrecode, PL_encoding);
7615 pv2 = SvPV_const(svrecode, cur2);
7618 const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2,
7619 (const U8*)pv1, cur1);
7620 return retval ? retval < 0 ? -1 : +1 : 0;
7625 svrecode = newSVpvn(pv1, cur1);
7626 sv_recode_to_utf8(svrecode, PL_encoding);
7627 pv1 = SvPV_const(svrecode, cur1);
7630 const int retval = bytes_cmp_utf8((const U8*)pv1, cur1,
7631 (const U8*)pv2, cur2);
7632 return retval ? retval < 0 ? -1 : +1 : 0;
7638 cmp = cur2 ? -1 : 0;
7642 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
7645 cmp = retval < 0 ? -1 : 1;
7646 } else if (cur1 == cur2) {
7649 cmp = cur1 < cur2 ? -1 : 1;
7653 SvREFCNT_dec(svrecode);
7659 =for apidoc sv_cmp_locale
7661 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7662 'use bytes' aware, handles get magic, and will coerce its args to strings
7663 if necessary. See also C<sv_cmp>.
7665 =for apidoc sv_cmp_locale_flags
7667 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7668 'use bytes' aware and will coerce its args to strings if necessary. If the
7669 flags contain SV_GMAGIC, it handles get magic. See also C<sv_cmp_flags>.
7675 Perl_sv_cmp_locale(pTHX_ SV *const sv1, SV *const sv2)
7677 return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
7681 Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2,
7685 #ifdef USE_LOCALE_COLLATE
7691 if (PL_collation_standard)
7695 pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
7697 pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
7699 if (!pv1 || !len1) {
7710 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
7713 return retval < 0 ? -1 : 1;
7716 * When the result of collation is equality, that doesn't mean
7717 * that there are no differences -- some locales exclude some
7718 * characters from consideration. So to avoid false equalities,
7719 * we use the raw string as a tiebreaker.
7725 #endif /* USE_LOCALE_COLLATE */
7727 return sv_cmp(sv1, sv2);
7731 #ifdef USE_LOCALE_COLLATE
7734 =for apidoc sv_collxfrm
7736 This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag. See
7737 C<sv_collxfrm_flags>.
7739 =for apidoc sv_collxfrm_flags
7741 Add Collate Transform magic to an SV if it doesn't already have it. If the
7742 flags contain SV_GMAGIC, it handles get-magic.
7744 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
7745 scalar data of the variable, but transformed to such a format that a normal
7746 memory comparison can be used to compare the data according to the locale
7753 Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
7758 PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
7760 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
7761 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
7767 Safefree(mg->mg_ptr);
7768 s = SvPV_flags_const(sv, len, flags);
7769 if ((xf = mem_collxfrm(s, len, &xlen))) {
7771 #ifdef PERL_OLD_COPY_ON_WRITE
7773 sv_force_normal_flags(sv, 0);
7775 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
7789 if (mg && mg->mg_ptr) {
7791 return mg->mg_ptr + sizeof(PL_collation_ix);
7799 #endif /* USE_LOCALE_COLLATE */
7802 S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7804 SV * const tsv = newSV(0);
7807 sv_gets(tsv, fp, 0);
7808 sv_utf8_upgrade_nomg(tsv);
7809 SvCUR_set(sv,append);
7812 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7816 S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7819 const STRLEN recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
7820 /* Grab the size of the record we're getting */
7821 char *buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7829 /* With a true, record-oriented file on VMS, we need to use read directly
7830 * to ensure that we respect RMS record boundaries. The user is responsible
7831 * for providing a PL_rs value that corresponds to the FAB$W_MRS (maximum
7832 * record size) field. N.B. This is likely to produce invalid results on
7833 * varying-width character data when a record ends mid-character.
7835 fd = PerlIO_fileno(fp);
7837 && PerlLIO_fstat(fd, &st) == 0
7838 && (st.st_fab_rfm == FAB$C_VAR
7839 || st.st_fab_rfm == FAB$C_VFC
7840 || st.st_fab_rfm == FAB$C_FIX)) {
7842 bytesread = PerlLIO_read(fd, buffer, recsize);
7844 else /* in-memory file from PerlIO::Scalar
7845 * or not a record-oriented file
7849 bytesread = PerlIO_read(fp, buffer, recsize);
7851 /* At this point, the logic in sv_get() means that sv will
7852 be treated as utf-8 if the handle is utf8.
7854 if (PerlIO_isutf8(fp) && bytesread > 0) {
7855 char *bend = buffer + bytesread;
7856 char *bufp = buffer;
7857 size_t charcount = 0;
7858 bool charstart = TRUE;
7861 while (charcount < recsize) {
7862 /* count accumulated characters */
7863 while (bufp < bend) {
7865 skip = UTF8SKIP(bufp);
7867 if (bufp + skip > bend) {
7868 /* partial at the end */
7879 if (charcount < recsize) {
7881 STRLEN bufp_offset = bufp - buffer;
7882 SSize_t morebytesread;
7884 /* originally I read enough to fill any incomplete
7885 character and the first byte of the next
7886 character if needed, but if there's many
7887 multi-byte encoded characters we're going to be
7888 making a read call for every character beyond
7889 the original read size.
7891 So instead, read the rest of the character if
7892 any, and enough bytes to match at least the
7893 start bytes for each character we're going to
7897 readsize = recsize - charcount;
7899 readsize = skip - (bend - bufp) + recsize - charcount - 1;
7900 buffer = SvGROW(sv, append + bytesread + readsize + 1) + append;
7901 bend = buffer + bytesread;
7902 morebytesread = PerlIO_read(fp, bend, readsize);
7903 if (morebytesread <= 0) {
7904 /* we're done, if we still have incomplete
7905 characters the check code in sv_gets() will
7908 I'd originally considered doing
7909 PerlIO_ungetc() on all but the lead
7910 character of the incomplete character, but
7911 read() doesn't do that, so I don't.
7916 /* prepare to scan some more */
7917 bytesread += morebytesread;
7918 bend = buffer + bytesread;
7919 bufp = buffer + bufp_offset;
7927 SvCUR_set(sv, bytesread + append);
7928 buffer[bytesread] = '\0';
7929 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7935 Get a line from the filehandle and store it into the SV, optionally
7936 appending to the currently-stored string. If C<append> is not 0, the
7937 line is appended to the SV instead of overwriting it. C<append> should
7938 be set to the byte offset that the appended string should start at
7939 in the SV (typically, C<SvCUR(sv)> is a suitable choice).
7945 Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7956 PERL_ARGS_ASSERT_SV_GETS;
7958 if (SvTHINKFIRST(sv))
7959 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
7960 /* XXX. If you make this PVIV, then copy on write can copy scalars read
7962 However, perlbench says it's slower, because the existing swipe code
7963 is faster than copy on write.
7964 Swings and roundabouts. */
7965 SvUPGRADE(sv, SVt_PV);
7968 if (PerlIO_isutf8(fp)) {
7970 sv_utf8_upgrade_nomg(sv);
7971 sv_pos_u2b(sv,&append,0);
7973 } else if (SvUTF8(sv)) {
7974 return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append);
7982 if (PerlIO_isutf8(fp))
7985 if (IN_PERL_COMPILETIME) {
7986 /* we always read code in line mode */
7990 else if (RsSNARF(PL_rs)) {
7991 /* If it is a regular disk file use size from stat() as estimate
7992 of amount we are going to read -- may result in mallocing
7993 more memory than we really need if the layers below reduce
7994 the size we read (e.g. CRLF or a gzip layer).
7997 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
7998 const Off_t offset = PerlIO_tell(fp);
7999 if (offset != (Off_t) -1 && st.st_size + append > offset) {
8000 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
8006 else if (RsRECORD(PL_rs)) {
8007 return S_sv_gets_read_record(aTHX_ sv, fp, append);
8009 else if (RsPARA(PL_rs)) {
8015 /* Get $/ i.e. PL_rs into same encoding as stream wants */
8016 if (PerlIO_isutf8(fp)) {
8017 rsptr = SvPVutf8(PL_rs, rslen);
8020 if (SvUTF8(PL_rs)) {
8021 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
8022 Perl_croak(aTHX_ "Wide character in $/");
8025 rsptr = SvPV_const(PL_rs, rslen);
8029 rslast = rslen ? rsptr[rslen - 1] : '\0';
8031 if (rspara) { /* have to do this both before and after */
8032 do { /* to make sure file boundaries work right */
8035 i = PerlIO_getc(fp);
8039 PerlIO_ungetc(fp,i);
8045 /* See if we know enough about I/O mechanism to cheat it ! */
8047 /* This used to be #ifdef test - it is made run-time test for ease
8048 of abstracting out stdio interface. One call should be cheap
8049 enough here - and may even be a macro allowing compile
8053 if (PerlIO_fast_gets(fp)) {
8056 * We're going to steal some values from the stdio struct
8057 * and put EVERYTHING in the innermost loop into registers.
8063 #if defined(VMS) && defined(PERLIO_IS_STDIO)
8064 /* An ungetc()d char is handled separately from the regular
8065 * buffer, so we getc() it back out and stuff it in the buffer.
8067 i = PerlIO_getc(fp);
8068 if (i == EOF) return 0;
8069 *(--((*fp)->_ptr)) = (unsigned char) i;
8073 /* Here is some breathtakingly efficient cheating */
8075 cnt = PerlIO_get_cnt(fp); /* get count into register */
8076 /* make sure we have the room */
8077 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
8078 /* Not room for all of it
8079 if we are looking for a separator and room for some
8081 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
8082 /* just process what we have room for */
8083 shortbuffered = cnt - SvLEN(sv) + append + 1;
8084 cnt -= shortbuffered;
8088 /* remember that cnt can be negative */
8089 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
8094 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
8095 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
8096 DEBUG_P(PerlIO_printf(Perl_debug_log,
8097 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
8098 DEBUG_P(PerlIO_printf(Perl_debug_log,
8099 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%zd, base=%"
8101 PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
8102 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
8107 while (cnt > 0) { /* this | eat */
8109 if ((*bp++ = *ptr++) == rslast) /* really | dust */
8110 goto thats_all_folks; /* screams | sed :-) */
8114 Copy(ptr, bp, cnt, char); /* this | eat */
8115 bp += cnt; /* screams | dust */
8116 ptr += cnt; /* louder | sed :-) */
8118 assert (!shortbuffered);
8119 goto cannot_be_shortbuffered;
8123 if (shortbuffered) { /* oh well, must extend */
8124 cnt = shortbuffered;
8126 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
8128 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
8129 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
8133 cannot_be_shortbuffered:
8134 DEBUG_P(PerlIO_printf(Perl_debug_log,
8135 "Screamer: going to getc, ptr=%"UVuf", cnt=%zd\n",
8137 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
8139 DEBUG_Pv(PerlIO_printf(Perl_debug_log,
8140 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf"\n",
8141 PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
8142 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
8144 /* This used to call 'filbuf' in stdio form, but as that behaves like
8145 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
8146 another abstraction. */
8147 i = PerlIO_getc(fp); /* get more characters */
8149 DEBUG_Pv(PerlIO_printf(Perl_debug_log,
8150 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf"\n",
8151 PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
8152 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
8154 cnt = PerlIO_get_cnt(fp);
8155 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
8156 DEBUG_P(PerlIO_printf(Perl_debug_log,
8157 "Screamer: after getc, ptr=%"UVuf", cnt=%zd\n",
8160 if (i == EOF) /* all done for ever? */
8161 goto thats_really_all_folks;
8163 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
8165 SvGROW(sv, bpx + cnt + 2);
8166 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
8168 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
8170 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
8171 goto thats_all_folks;
8175 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
8176 memNE((char*)bp - rslen, rsptr, rslen))
8177 goto screamer; /* go back to the fray */
8178 thats_really_all_folks:
8180 cnt += shortbuffered;
8181 DEBUG_P(PerlIO_printf(Perl_debug_log,
8182 "Screamer: quitting, ptr=%"UVuf", cnt=%zd\n",PTR2UV(ptr),cnt));
8183 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
8184 DEBUG_P(PerlIO_printf(Perl_debug_log,
8185 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf
8187 PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
8188 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
8190 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
8191 DEBUG_P(PerlIO_printf(Perl_debug_log,
8192 "Screamer: done, len=%ld, string=|%.*s|\n",
8193 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
8197 /*The big, slow, and stupid way. */
8198 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
8199 STDCHAR *buf = NULL;
8200 Newx(buf, 8192, STDCHAR);
8208 const STDCHAR * const bpe = buf + sizeof(buf);
8210 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
8211 ; /* keep reading */
8215 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
8216 /* Accommodate broken VAXC compiler, which applies U8 cast to
8217 * both args of ?: operator, causing EOF to change into 255
8220 i = (U8)buf[cnt - 1];
8226 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
8228 sv_catpvn_nomg(sv, (char *) buf, cnt);
8230 sv_setpvn(sv, (char *) buf, cnt); /* "nomg" is implied */
8232 if (i != EOF && /* joy */
8234 SvCUR(sv) < rslen ||
8235 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
8239 * If we're reading from a TTY and we get a short read,
8240 * indicating that the user hit his EOF character, we need
8241 * to notice it now, because if we try to read from the TTY
8242 * again, the EOF condition will disappear.
8244 * The comparison of cnt to sizeof(buf) is an optimization
8245 * that prevents unnecessary calls to feof().
8249 if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
8253 #ifdef USE_HEAP_INSTEAD_OF_STACK
8258 if (rspara) { /* have to do this both before and after */
8259 while (i != EOF) { /* to make sure file boundaries work right */
8260 i = PerlIO_getc(fp);
8262 PerlIO_ungetc(fp,i);
8268 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
8274 Auto-increment of the value in the SV, doing string to numeric conversion
8275 if necessary. Handles 'get' magic and operator overloading.
8281 Perl_sv_inc(pTHX_ SV *const sv)
8290 =for apidoc sv_inc_nomg
8292 Auto-increment of the value in the SV, doing string to numeric conversion
8293 if necessary. Handles operator overloading. Skips handling 'get' magic.
8299 Perl_sv_inc_nomg(pTHX_ SV *const sv)
8307 if (SvTHINKFIRST(sv)) {
8308 if (SvREADONLY(sv)) {
8309 Perl_croak_no_modify();
8313 if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg))
8315 i = PTR2IV(SvRV(sv));
8319 else sv_force_normal_flags(sv, 0);
8321 flags = SvFLAGS(sv);
8322 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
8323 /* It's (privately or publicly) a float, but not tested as an
8324 integer, so test it to see. */
8326 flags = SvFLAGS(sv);
8328 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
8329 /* It's publicly an integer, or privately an integer-not-float */
8330 #ifdef PERL_PRESERVE_IVUV
8334 if (SvUVX(sv) == UV_MAX)
8335 sv_setnv(sv, UV_MAX_P1);
8337 (void)SvIOK_only_UV(sv);
8338 SvUV_set(sv, SvUVX(sv) + 1);
8340 if (SvIVX(sv) == IV_MAX)
8341 sv_setuv(sv, (UV)IV_MAX + 1);
8343 (void)SvIOK_only(sv);
8344 SvIV_set(sv, SvIVX(sv) + 1);
8349 if (flags & SVp_NOK) {
8350 const NV was = SvNVX(sv);
8351 if (NV_OVERFLOWS_INTEGERS_AT &&
8352 was >= NV_OVERFLOWS_INTEGERS_AT) {
8353 /* diag_listed_as: Lost precision when %s %f by 1 */
8354 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
8355 "Lost precision when incrementing %" NVff " by 1",
8358 (void)SvNOK_only(sv);
8359 SvNV_set(sv, was + 1.0);
8363 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
8364 if ((flags & SVTYPEMASK) < SVt_PVIV)
8365 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
8366 (void)SvIOK_only(sv);
8371 while (isALPHA(*d)) d++;
8372 while (isDIGIT(*d)) d++;
8373 if (d < SvEND(sv)) {
8374 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
8375 #ifdef PERL_PRESERVE_IVUV
8376 /* Got to punt this as an integer if needs be, but we don't issue
8377 warnings. Probably ought to make the sv_iv_please() that does
8378 the conversion if possible, and silently. */
8379 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
8380 /* Need to try really hard to see if it's an integer.
8381 9.22337203685478e+18 is an integer.
8382 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
8383 so $a="9.22337203685478e+18"; $a+0; $a++
8384 needs to be the same as $a="9.22337203685478e+18"; $a++
8391 /* sv_2iv *should* have made this an NV */
8392 if (flags & SVp_NOK) {
8393 (void)SvNOK_only(sv);
8394 SvNV_set(sv, SvNVX(sv) + 1.0);
8397 /* I don't think we can get here. Maybe I should assert this
8398 And if we do get here I suspect that sv_setnv will croak. NWC
8400 #if defined(USE_LONG_DOUBLE)
8401 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",
8402 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8404 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
8405 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8408 #endif /* PERL_PRESERVE_IVUV */
8409 if (!numtype && ckWARN(WARN_NUMERIC))
8410 not_incrementable(sv);
8411 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
8415 while (d >= SvPVX_const(sv)) {
8423 /* MKS: The original code here died if letters weren't consecutive.
8424 * at least it didn't have to worry about non-C locales. The
8425 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
8426 * arranged in order (although not consecutively) and that only
8427 * [A-Za-z] are accepted by isALPHA in the C locale.
8429 if (*d != 'z' && *d != 'Z') {
8430 do { ++*d; } while (!isALPHA(*d));
8433 *(d--) -= 'z' - 'a';
8438 *(d--) -= 'z' - 'a' + 1;
8442 /* oh,oh, the number grew */
8443 SvGROW(sv, SvCUR(sv) + 2);
8444 SvCUR_set(sv, SvCUR(sv) + 1);
8445 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
8456 Auto-decrement of the value in the SV, doing string to numeric conversion
8457 if necessary. Handles 'get' magic and operator overloading.
8463 Perl_sv_dec(pTHX_ SV *const sv)
8473 =for apidoc sv_dec_nomg
8475 Auto-decrement of the value in the SV, doing string to numeric conversion
8476 if necessary. Handles operator overloading. Skips handling 'get' magic.
8482 Perl_sv_dec_nomg(pTHX_ SV *const sv)
8489 if (SvTHINKFIRST(sv)) {
8490 if (SvREADONLY(sv)) {
8491 Perl_croak_no_modify();
8495 if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg))
8497 i = PTR2IV(SvRV(sv));
8501 else sv_force_normal_flags(sv, 0);
8503 /* Unlike sv_inc we don't have to worry about string-never-numbers
8504 and keeping them magic. But we mustn't warn on punting */
8505 flags = SvFLAGS(sv);
8506 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
8507 /* It's publicly an integer, or privately an integer-not-float */
8508 #ifdef PERL_PRESERVE_IVUV
8512 if (SvUVX(sv) == 0) {
8513 (void)SvIOK_only(sv);
8517 (void)SvIOK_only_UV(sv);
8518 SvUV_set(sv, SvUVX(sv) - 1);
8521 if (SvIVX(sv) == IV_MIN) {
8522 sv_setnv(sv, (NV)IV_MIN);
8526 (void)SvIOK_only(sv);
8527 SvIV_set(sv, SvIVX(sv) - 1);
8532 if (flags & SVp_NOK) {
8535 const NV was = SvNVX(sv);
8536 if (NV_OVERFLOWS_INTEGERS_AT &&
8537 was <= -NV_OVERFLOWS_INTEGERS_AT) {
8538 /* diag_listed_as: Lost precision when %s %f by 1 */
8539 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
8540 "Lost precision when decrementing %" NVff " by 1",
8543 (void)SvNOK_only(sv);
8544 SvNV_set(sv, was - 1.0);
8548 if (!(flags & SVp_POK)) {
8549 if ((flags & SVTYPEMASK) < SVt_PVIV)
8550 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
8552 (void)SvIOK_only(sv);
8555 #ifdef PERL_PRESERVE_IVUV
8557 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
8558 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
8559 /* Need to try really hard to see if it's an integer.
8560 9.22337203685478e+18 is an integer.
8561 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
8562 so $a="9.22337203685478e+18"; $a+0; $a--
8563 needs to be the same as $a="9.22337203685478e+18"; $a--
8570 /* sv_2iv *should* have made this an NV */
8571 if (flags & SVp_NOK) {
8572 (void)SvNOK_only(sv);
8573 SvNV_set(sv, SvNVX(sv) - 1.0);
8576 /* I don't think we can get here. Maybe I should assert this
8577 And if we do get here I suspect that sv_setnv will croak. NWC
8579 #if defined(USE_LONG_DOUBLE)
8580 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",
8581 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8583 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
8584 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8588 #endif /* PERL_PRESERVE_IVUV */
8589 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
8592 /* this define is used to eliminate a chunk of duplicated but shared logic
8593 * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
8594 * used anywhere but here - yves
8596 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
8599 PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
8603 =for apidoc sv_mortalcopy
8605 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
8606 The new SV is marked as mortal. It will be destroyed "soon", either by an
8607 explicit call to FREETMPS, or by an implicit call at places such as
8608 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
8613 /* Make a string that will exist for the duration of the expression
8614 * evaluation. Actually, it may have to last longer than that, but
8615 * hopefully we won't free it until it has been assigned to a
8616 * permanent location. */
8619 Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags)
8624 if (flags & SV_GMAGIC)
8625 SvGETMAGIC(oldstr); /* before new_SV, in case it dies */
8627 sv_setsv_flags(sv,oldstr,flags & ~SV_GMAGIC);
8628 PUSH_EXTEND_MORTAL__SV_C(sv);
8634 =for apidoc sv_newmortal
8636 Creates a new null SV which is mortal. The reference count of the SV is
8637 set to 1. It will be destroyed "soon", either by an explicit call to
8638 FREETMPS, or by an implicit call at places such as statement boundaries.
8639 See also C<sv_mortalcopy> and C<sv_2mortal>.
8645 Perl_sv_newmortal(pTHX)
8651 SvFLAGS(sv) = SVs_TEMP;
8652 PUSH_EXTEND_MORTAL__SV_C(sv);
8658 =for apidoc newSVpvn_flags
8660 Creates a new SV and copies a string into it. The reference count for the
8661 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
8662 string. You are responsible for ensuring that the source string is at least
8663 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
8664 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
8665 If C<SVs_TEMP> is set, then C<sv_2mortal()> is called on the result before
8666 returning. If C<SVf_UTF8> is set, C<s>
8667 is considered to be in UTF-8 and the
8668 C<SVf_UTF8> flag will be set on the new SV.
8669 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
8671 #define newSVpvn_utf8(s, len, u) \
8672 newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
8678 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
8683 /* All the flags we don't support must be zero.
8684 And we're new code so I'm going to assert this from the start. */
8685 assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
8687 sv_setpvn(sv,s,len);
8689 /* This code used to do a sv_2mortal(), however we now unroll the call to
8690 * sv_2mortal() and do what it does ourselves here. Since we have asserted
8691 * that flags can only have the SVf_UTF8 and/or SVs_TEMP flags set above we
8692 * can use it to enable the sv flags directly (bypassing SvTEMP_on), which
8693 * in turn means we dont need to mask out the SVf_UTF8 flag below, which
8694 * means that we eliminate quite a few steps than it looks - Yves
8695 * (explaining patch by gfx) */
8697 SvFLAGS(sv) |= flags;
8699 if(flags & SVs_TEMP){
8700 PUSH_EXTEND_MORTAL__SV_C(sv);
8707 =for apidoc sv_2mortal
8709 Marks an existing SV as mortal. The SV will be destroyed "soon", either
8710 by an explicit call to FREETMPS, or by an implicit call at places such as
8711 statement boundaries. SvTEMP() is turned on which means that the SV's
8712 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
8713 and C<sv_mortalcopy>.
8719 Perl_sv_2mortal(pTHX_ SV *const sv)
8726 PUSH_EXTEND_MORTAL__SV_C(sv);
8734 Creates a new SV and copies a string into it. The reference count for the
8735 SV is set to 1. If C<len> is zero, Perl will compute the length using
8736 strlen(). For efficiency, consider using C<newSVpvn> instead.
8742 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
8748 sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
8753 =for apidoc newSVpvn
8755 Creates a new SV and copies a buffer into it, which may contain NUL characters
8756 (C<\0>) and other binary data. The reference count for the SV is set to 1.
8757 Note that if C<len> is zero, Perl will create a zero length (Perl) string. You
8758 are responsible for ensuring that the source buffer is at least
8759 C<len> bytes long. If the C<buffer> argument is NULL the new SV will be
8766 Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len)
8772 sv_setpvn(sv,buffer,len);
8777 =for apidoc newSVhek
8779 Creates a new SV from the hash key structure. It will generate scalars that
8780 point to the shared string table where possible. Returns a new (undefined)
8781 SV if the hek is NULL.
8787 Perl_newSVhek(pTHX_ const HEK *const hek)
8797 if (HEK_LEN(hek) == HEf_SVKEY) {
8798 return newSVsv(*(SV**)HEK_KEY(hek));
8800 const int flags = HEK_FLAGS(hek);
8801 if (flags & HVhek_WASUTF8) {
8803 Andreas would like keys he put in as utf8 to come back as utf8
8805 STRLEN utf8_len = HEK_LEN(hek);
8806 SV * const sv = newSV_type(SVt_PV);
8807 char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
8808 /* bytes_to_utf8() allocates a new string, which we can repurpose: */
8809 sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
8812 } else if (flags & HVhek_UNSHARED) {
8813 /* A hash that isn't using shared hash keys has to have
8814 the flag in every key so that we know not to try to call
8815 share_hek_hek on it. */
8817 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
8822 /* This will be overwhelminly the most common case. */
8824 /* Inline most of newSVpvn_share(), because share_hek_hek() is far
8825 more efficient than sharepvn(). */
8829 sv_upgrade(sv, SVt_PV);
8830 SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
8831 SvCUR_set(sv, HEK_LEN(hek));
8843 =for apidoc newSVpvn_share
8845 Creates a new SV with its SvPVX_const pointing to a shared string in the string
8846 table. If the string does not already exist in the table, it is
8847 created first. Turns on the SvIsCOW flag (or READONLY
8848 and FAKE in 5.16 and earlier). If the C<hash> parameter
8849 is non-zero, that value is used; otherwise the hash is computed.
8850 The string's hash can later be retrieved from the SV
8851 with the C<SvSHARED_HASH()> macro. The idea here is
8852 that as the string table is used for shared hash keys these strings will have
8853 SvPVX_const == HeKEY and hash lookup will avoid string compare.
8859 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
8863 bool is_utf8 = FALSE;
8864 const char *const orig_src = src;
8867 STRLEN tmplen = -len;
8869 /* See the note in hv.c:hv_fetch() --jhi */
8870 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
8874 PERL_HASH(hash, src, len);
8876 /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
8877 changes here, update it there too. */
8878 sv_upgrade(sv, SVt_PV);
8879 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
8886 if (src != orig_src)
8892 =for apidoc newSVpv_share
8894 Like C<newSVpvn_share>, but takes a nul-terminated string instead of a
8901 Perl_newSVpv_share(pTHX_ const char *src, U32 hash)
8903 return newSVpvn_share(src, strlen(src), hash);
8906 #if defined(PERL_IMPLICIT_CONTEXT)
8908 /* pTHX_ magic can't cope with varargs, so this is a no-context
8909 * version of the main function, (which may itself be aliased to us).
8910 * Don't access this version directly.
8914 Perl_newSVpvf_nocontext(const char *const pat, ...)
8920 PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
8922 va_start(args, pat);
8923 sv = vnewSVpvf(pat, &args);
8930 =for apidoc newSVpvf
8932 Creates a new SV and initializes it with the string formatted like
8939 Perl_newSVpvf(pTHX_ const char *const pat, ...)
8944 PERL_ARGS_ASSERT_NEWSVPVF;
8946 va_start(args, pat);
8947 sv = vnewSVpvf(pat, &args);
8952 /* backend for newSVpvf() and newSVpvf_nocontext() */
8955 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
8960 PERL_ARGS_ASSERT_VNEWSVPVF;
8963 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8970 Creates a new SV and copies a floating point value into it.
8971 The reference count for the SV is set to 1.
8977 Perl_newSVnv(pTHX_ const NV n)
8990 Creates a new SV and copies an integer into it. The reference count for the
8997 Perl_newSViv(pTHX_ const IV i)
9010 Creates a new SV and copies an unsigned integer into it.
9011 The reference count for the SV is set to 1.
9017 Perl_newSVuv(pTHX_ const UV u)
9028 =for apidoc newSV_type
9030 Creates a new SV, of the type specified. The reference count for the new SV
9037 Perl_newSV_type(pTHX_ const svtype type)
9042 sv_upgrade(sv, type);
9047 =for apidoc newRV_noinc
9049 Creates an RV wrapper for an SV. The reference count for the original
9050 SV is B<not> incremented.
9056 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
9059 SV *sv = newSV_type(SVt_IV);
9061 PERL_ARGS_ASSERT_NEWRV_NOINC;
9064 SvRV_set(sv, tmpRef);
9069 /* newRV_inc is the official function name to use now.
9070 * newRV_inc is in fact #defined to newRV in sv.h
9074 Perl_newRV(pTHX_ SV *const sv)
9078 PERL_ARGS_ASSERT_NEWRV;
9080 return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
9086 Creates a new SV which is an exact duplicate of the original SV.
9093 Perl_newSVsv(pTHX_ SV *const old)
9100 if (SvTYPE(old) == (svtype)SVTYPEMASK) {
9101 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
9104 /* Do this here, otherwise we leak the new SV if this croaks. */
9107 /* SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
9108 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
9109 sv_setsv_flags(sv, old, SV_NOSTEAL);
9114 =for apidoc sv_reset
9116 Underlying implementation for the C<reset> Perl function.
9117 Note that the perl-level function is vaguely deprecated.
9123 Perl_sv_reset(pTHX_ const char *s, HV *const stash)
9125 PERL_ARGS_ASSERT_SV_RESET;
9127 sv_resetpvn(*s ? s : NULL, strlen(s), stash);
9131 Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash)
9134 char todo[PERL_UCHAR_MAX+1];
9137 if (!stash || SvTYPE(stash) != SVt_PVHV)
9140 if (!s) { /* reset ?? searches */
9141 MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
9143 const U32 count = mg->mg_len / sizeof(PMOP**);
9144 PMOP **pmp = (PMOP**) mg->mg_ptr;
9145 PMOP *const *const end = pmp + count;
9149 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
9151 (*pmp)->op_pmflags &= ~PMf_USED;
9159 /* reset variables */
9161 if (!HvARRAY(stash))
9164 Zero(todo, 256, char);
9168 I32 i = (unsigned char)*s;
9172 max = (unsigned char)*s++;
9173 for ( ; i <= max; i++) {
9176 for (i = 0; i <= (I32) HvMAX(stash); i++) {
9178 for (entry = HvARRAY(stash)[i];
9180 entry = HeNEXT(entry))
9185 if (!todo[(U8)*HeKEY(entry)])
9187 gv = MUTABLE_GV(HeVAL(entry));
9189 if (sv && !SvREADONLY(sv)) {
9190 SV_CHECK_THINKFIRST_COW_DROP(sv);
9191 if (!isGV(sv)) SvOK_off(sv);
9196 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
9207 Using various gambits, try to get an IO from an SV: the IO slot if its a
9208 GV; or the recursive result if we're an RV; or the IO slot of the symbol
9209 named after the PV if we're a string.
9211 'Get' magic is ignored on the sv passed in, but will be called on
9212 C<SvRV(sv)> if sv is an RV.
9218 Perl_sv_2io(pTHX_ SV *const sv)
9223 PERL_ARGS_ASSERT_SV_2IO;
9225 switch (SvTYPE(sv)) {
9227 io = MUTABLE_IO(sv);
9231 if (isGV_with_GP(sv)) {
9232 gv = MUTABLE_GV(sv);
9235 Perl_croak(aTHX_ "Bad filehandle: %"HEKf,
9236 HEKfARG(GvNAME_HEK(gv)));
9242 Perl_croak(aTHX_ PL_no_usym, "filehandle");
9244 SvGETMAGIC(SvRV(sv));
9245 return sv_2io(SvRV(sv));
9247 gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO);
9254 if (SvGMAGICAL(sv)) {
9255 newsv = sv_newmortal();
9256 sv_setsv_nomg(newsv, sv);
9258 Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(newsv));
9268 Using various gambits, try to get a CV from an SV; in addition, try if
9269 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
9270 The flags in C<lref> are passed to gv_fetchsv.
9276 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
9282 PERL_ARGS_ASSERT_SV_2CV;
9289 switch (SvTYPE(sv)) {
9293 return MUTABLE_CV(sv);
9303 sv = amagic_deref_call(sv, to_cv_amg);
9306 if (SvTYPE(sv) == SVt_PVCV) {
9307 cv = MUTABLE_CV(sv);
9312 else if(SvGETMAGIC(sv), isGV_with_GP(sv))
9313 gv = MUTABLE_GV(sv);
9315 Perl_croak(aTHX_ "Not a subroutine reference");
9317 else if (isGV_with_GP(sv)) {
9318 gv = MUTABLE_GV(sv);
9321 gv = gv_fetchsv_nomg(sv, lref, SVt_PVCV);
9328 /* Some flags to gv_fetchsv mean don't really create the GV */
9329 if (!isGV_with_GP(gv)) {
9334 if (lref & ~GV_ADDMG && !GvCVu(gv)) {
9335 /* XXX this is probably not what they think they're getting.
9336 * It has the same effect as "sub name;", i.e. just a forward
9347 Returns true if the SV has a true value by Perl's rules.
9348 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
9349 instead use an in-line version.
9355 Perl_sv_true(pTHX_ SV *const sv)
9360 const XPV* const tXpv = (XPV*)SvANY(sv);
9362 (tXpv->xpv_cur > 1 ||
9363 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
9370 return SvIVX(sv) != 0;
9373 return SvNVX(sv) != 0.0;
9375 return sv_2bool(sv);
9381 =for apidoc sv_pvn_force
9383 Get a sensible string out of the SV somehow.
9384 A private implementation of the C<SvPV_force> macro for compilers which
9385 can't cope with complex macro expressions. Always use the macro instead.
9387 =for apidoc sv_pvn_force_flags
9389 Get a sensible string out of the SV somehow.
9390 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
9391 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
9392 implemented in terms of this function.
9393 You normally want to use the various wrapper macros instead: see
9394 C<SvPV_force> and C<SvPV_force_nomg>
9400 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
9404 PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
9406 if (flags & SV_GMAGIC) SvGETMAGIC(sv);
9407 if (SvTHINKFIRST(sv) && (!SvROK(sv) || SvREADONLY(sv)))
9408 sv_force_normal_flags(sv, 0);
9418 if (SvTYPE(sv) > SVt_PVLV
9419 || isGV_with_GP(sv))
9420 /* diag_listed_as: Can't coerce %s to %s in %s */
9421 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
9423 s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC);
9430 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
9433 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
9434 SvGROW(sv, len + 1);
9435 Move(s,SvPVX(sv),len,char);
9437 SvPVX(sv)[len] = '\0';
9440 SvPOK_on(sv); /* validate pointer */
9442 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
9443 PTR2UV(sv),SvPVX_const(sv)));
9446 (void)SvPOK_only_UTF8(sv);
9447 return SvPVX_mutable(sv);
9451 =for apidoc sv_pvbyten_force
9453 The backend for the C<SvPVbytex_force> macro. Always use the macro
9460 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
9462 PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
9464 sv_pvn_force(sv,lp);
9465 sv_utf8_downgrade(sv,0);
9471 =for apidoc sv_pvutf8n_force
9473 The backend for the C<SvPVutf8x_force> macro. Always use the macro
9480 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
9482 PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
9485 sv_utf8_upgrade_nomg(sv);
9491 =for apidoc sv_reftype
9493 Returns a string describing what the SV is a reference to.
9499 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
9501 PERL_ARGS_ASSERT_SV_REFTYPE;
9502 if (ob && SvOBJECT(sv)) {
9503 return SvPV_nolen_const(sv_ref(NULL, sv, ob));
9506 switch (SvTYPE(sv)) {
9521 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
9522 /* tied lvalues should appear to be
9523 * scalars for backwards compatibility */
9524 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
9525 ? "SCALAR" : "LVALUE");
9526 case SVt_PVAV: return "ARRAY";
9527 case SVt_PVHV: return "HASH";
9528 case SVt_PVCV: return "CODE";
9529 case SVt_PVGV: return (char *) (isGV_with_GP(sv)
9530 ? "GLOB" : "SCALAR");
9531 case SVt_PVFM: return "FORMAT";
9532 case SVt_PVIO: return "IO";
9533 case SVt_INVLIST: return "INVLIST";
9534 case SVt_REGEXP: return "REGEXP";
9535 default: return "UNKNOWN";
9543 Returns a SV describing what the SV passed in is a reference to.
9549 Perl_sv_ref(pTHX_ SV *dst, const SV *const sv, const int ob)
9551 PERL_ARGS_ASSERT_SV_REF;
9554 dst = sv_newmortal();
9556 if (ob && SvOBJECT(sv)) {
9557 HvNAME_get(SvSTASH(sv))
9558 ? sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)))
9559 : sv_setpvn(dst, "__ANON__", 8);
9562 const char * reftype = sv_reftype(sv, 0);
9563 sv_setpv(dst, reftype);
9569 =for apidoc sv_isobject
9571 Returns a boolean indicating whether the SV is an RV pointing to a blessed
9572 object. If the SV is not an RV, or if the object is not blessed, then this
9579 Perl_sv_isobject(pTHX_ SV *sv)
9595 Returns a boolean indicating whether the SV is blessed into the specified
9596 class. This does not check for subtypes; use C<sv_derived_from> to verify
9597 an inheritance relationship.
9603 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
9607 PERL_ARGS_ASSERT_SV_ISA;
9617 hvname = HvNAME_get(SvSTASH(sv));
9621 return strEQ(hvname, name);
9627 Creates a new SV for the existing RV, C<rv>, to point to. If C<rv> is not an
9628 RV then it will be upgraded to one. If C<classname> is non-null then the new
9629 SV will be blessed in the specified package. The new SV is returned and its
9630 reference count is 1. The reference count 1 is owned by C<rv>.
9636 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
9641 PERL_ARGS_ASSERT_NEWSVRV;
9645 SV_CHECK_THINKFIRST_COW_DROP(rv);
9647 if (SvTYPE(rv) >= SVt_PVMG) {
9648 const U32 refcnt = SvREFCNT(rv);
9652 SvREFCNT(rv) = refcnt;
9654 sv_upgrade(rv, SVt_IV);
9655 } else if (SvROK(rv)) {
9656 SvREFCNT_dec(SvRV(rv));
9658 prepare_SV_for_RV(rv);
9666 HV* const stash = gv_stashpv(classname, GV_ADD);
9667 (void)sv_bless(rv, stash);
9673 Perl_newSVavdefelem(pTHX_ AV *av, SSize_t ix, bool extendible)
9675 SV * const lv = newSV_type(SVt_PVLV);
9676 PERL_ARGS_ASSERT_NEWSVAVDEFELEM;
9678 sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
9679 LvTARG(lv) = SvREFCNT_inc_simple_NN(av);
9680 LvSTARGOFF(lv) = ix;
9681 LvTARGLEN(lv) = extendible ? 1 : (STRLEN)UV_MAX;
9686 =for apidoc sv_setref_pv
9688 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
9689 argument will be upgraded to an RV. That RV will be modified to point to
9690 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
9691 into the SV. The C<classname> argument indicates the package for the
9692 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9693 will have a reference count of 1, and the RV will be returned.
9695 Do not use with other Perl types such as HV, AV, SV, CV, because those
9696 objects will become corrupted by the pointer copy process.
9698 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
9704 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
9708 PERL_ARGS_ASSERT_SV_SETREF_PV;
9711 sv_setsv(rv, &PL_sv_undef);
9715 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
9720 =for apidoc sv_setref_iv
9722 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
9723 argument will be upgraded to an RV. That RV will be modified to point to
9724 the new SV. The C<classname> argument indicates the package for the
9725 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9726 will have a reference count of 1, and the RV will be returned.
9732 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
9734 PERL_ARGS_ASSERT_SV_SETREF_IV;
9736 sv_setiv(newSVrv(rv,classname), iv);
9741 =for apidoc sv_setref_uv
9743 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
9744 argument will be upgraded to an RV. That RV will be modified to point to
9745 the new SV. The C<classname> argument indicates the package for the
9746 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9747 will have a reference count of 1, and the RV will be returned.
9753 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
9755 PERL_ARGS_ASSERT_SV_SETREF_UV;
9757 sv_setuv(newSVrv(rv,classname), uv);
9762 =for apidoc sv_setref_nv
9764 Copies a double into a new SV, optionally blessing the SV. The C<rv>
9765 argument will be upgraded to an RV. That RV will be modified to point to
9766 the new SV. The C<classname> argument indicates the package for the
9767 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9768 will have a reference count of 1, and the RV will be returned.
9774 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
9776 PERL_ARGS_ASSERT_SV_SETREF_NV;
9778 sv_setnv(newSVrv(rv,classname), nv);
9783 =for apidoc sv_setref_pvn
9785 Copies a string into a new SV, optionally blessing the SV. The length of the
9786 string must be specified with C<n>. The C<rv> argument will be upgraded to
9787 an RV. That RV will be modified to point to the new SV. The C<classname>
9788 argument indicates the package for the blessing. Set C<classname> to
9789 C<NULL> to avoid the blessing. The new SV will have a reference count
9790 of 1, and the RV will be returned.
9792 Note that C<sv_setref_pv> copies the pointer while this copies the string.
9798 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
9799 const char *const pv, const STRLEN n)
9801 PERL_ARGS_ASSERT_SV_SETREF_PVN;
9803 sv_setpvn(newSVrv(rv,classname), pv, n);
9808 =for apidoc sv_bless
9810 Blesses an SV into a specified package. The SV must be an RV. The package
9811 must be designated by its stash (see C<gv_stashpv()>). The reference count
9812 of the SV is unaffected.
9818 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
9822 HV *oldstash = NULL;
9824 PERL_ARGS_ASSERT_SV_BLESS;
9828 Perl_croak(aTHX_ "Can't bless non-reference value");
9830 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
9831 if (SvREADONLY(tmpRef))
9832 Perl_croak_no_modify();
9833 if (SvOBJECT(tmpRef)) {
9834 oldstash = SvSTASH(tmpRef);
9837 SvOBJECT_on(tmpRef);
9838 SvUPGRADE(tmpRef, SVt_PVMG);
9839 SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
9840 SvREFCNT_dec(oldstash);
9842 if(SvSMAGICAL(tmpRef))
9843 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
9851 /* Downgrades a PVGV to a PVMG. If it's actually a PVLV, we leave the type
9852 * as it is after unglobbing it.
9855 PERL_STATIC_INLINE void
9856 S_sv_unglob(pTHX_ SV *const sv, U32 flags)
9861 SV * const temp = flags & SV_COW_DROP_PV ? NULL : sv_newmortal();
9863 PERL_ARGS_ASSERT_SV_UNGLOB;
9865 assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
9867 if (!(flags & SV_COW_DROP_PV))
9868 gv_efullname3(temp, MUTABLE_GV(sv), "*");
9871 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
9872 && HvNAME_get(stash))
9873 mro_method_changed_in(stash);
9874 gp_free(MUTABLE_GV(sv));
9877 sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
9881 if (GvNAME_HEK(sv)) {
9882 unshare_hek(GvNAME_HEK(sv));
9884 isGV_with_GP_off(sv);
9886 if(SvTYPE(sv) == SVt_PVGV) {
9887 /* need to keep SvANY(sv) in the right arena */
9888 xpvmg = new_XPVMG();
9889 StructCopy(SvANY(sv), xpvmg, XPVMG);
9890 del_XPVGV(SvANY(sv));
9893 SvFLAGS(sv) &= ~SVTYPEMASK;
9894 SvFLAGS(sv) |= SVt_PVMG;
9897 /* Intentionally not calling any local SET magic, as this isn't so much a
9898 set operation as merely an internal storage change. */
9899 if (flags & SV_COW_DROP_PV) SvOK_off(sv);
9900 else sv_setsv_flags(sv, temp, 0);
9902 if ((const GV *)sv == PL_last_in_gv)
9903 PL_last_in_gv = NULL;
9904 else if ((const GV *)sv == PL_statgv)
9909 =for apidoc sv_unref_flags
9911 Unsets the RV status of the SV, and decrements the reference count of
9912 whatever was being referenced by the RV. This can almost be thought of
9913 as a reversal of C<newSVrv>. The C<cflags> argument can contain
9914 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
9915 (otherwise the decrementing is conditional on the reference count being
9916 different from one or the reference being a readonly SV).
9923 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
9925 SV* const target = SvRV(ref);
9927 PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
9929 if (SvWEAKREF(ref)) {
9930 sv_del_backref(target, ref);
9932 SvRV_set(ref, NULL);
9935 SvRV_set(ref, NULL);
9937 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
9938 assigned to as BEGIN {$a = \"Foo"} will fail. */
9939 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
9940 SvREFCNT_dec_NN(target);
9941 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
9942 sv_2mortal(target); /* Schedule for freeing later */
9946 =for apidoc sv_untaint
9948 Untaint an SV. Use C<SvTAINTED_off> instead.
9954 Perl_sv_untaint(pTHX_ SV *const sv)
9956 PERL_ARGS_ASSERT_SV_UNTAINT;
9958 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9959 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9966 =for apidoc sv_tainted
9968 Test an SV for taintedness. Use C<SvTAINTED> instead.
9974 Perl_sv_tainted(pTHX_ SV *const sv)
9976 PERL_ARGS_ASSERT_SV_TAINTED;
9978 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9979 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9980 if (mg && (mg->mg_len & 1) )
9987 =for apidoc sv_setpviv
9989 Copies an integer into the given SV, also updating its string value.
9990 Does not handle 'set' magic. See C<sv_setpviv_mg>.
9996 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
9998 char buf[TYPE_CHARS(UV)];
10000 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
10002 PERL_ARGS_ASSERT_SV_SETPVIV;
10004 sv_setpvn(sv, ptr, ebuf - ptr);
10008 =for apidoc sv_setpviv_mg
10010 Like C<sv_setpviv>, but also handles 'set' magic.
10016 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
10018 PERL_ARGS_ASSERT_SV_SETPVIV_MG;
10020 sv_setpviv(sv, iv);
10024 #if defined(PERL_IMPLICIT_CONTEXT)
10026 /* pTHX_ magic can't cope with varargs, so this is a no-context
10027 * version of the main function, (which may itself be aliased to us).
10028 * Don't access this version directly.
10032 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
10037 PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
10039 va_start(args, pat);
10040 sv_vsetpvf(sv, pat, &args);
10044 /* pTHX_ magic can't cope with varargs, so this is a no-context
10045 * version of the main function, (which may itself be aliased to us).
10046 * Don't access this version directly.
10050 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
10055 PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
10057 va_start(args, pat);
10058 sv_vsetpvf_mg(sv, pat, &args);
10064 =for apidoc sv_setpvf
10066 Works like C<sv_catpvf> but copies the text into the SV instead of
10067 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
10073 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
10077 PERL_ARGS_ASSERT_SV_SETPVF;
10079 va_start(args, pat);
10080 sv_vsetpvf(sv, pat, &args);
10085 =for apidoc sv_vsetpvf
10087 Works like C<sv_vcatpvf> but copies the text into the SV instead of
10088 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
10090 Usually used via its frontend C<sv_setpvf>.
10096 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
10098 PERL_ARGS_ASSERT_SV_VSETPVF;
10100 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
10104 =for apidoc sv_setpvf_mg
10106 Like C<sv_setpvf>, but also handles 'set' magic.
10112 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
10116 PERL_ARGS_ASSERT_SV_SETPVF_MG;
10118 va_start(args, pat);
10119 sv_vsetpvf_mg(sv, pat, &args);
10124 =for apidoc sv_vsetpvf_mg
10126 Like C<sv_vsetpvf>, but also handles 'set' magic.
10128 Usually used via its frontend C<sv_setpvf_mg>.
10134 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
10136 PERL_ARGS_ASSERT_SV_VSETPVF_MG;
10138 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
10142 #if defined(PERL_IMPLICIT_CONTEXT)
10144 /* pTHX_ magic can't cope with varargs, so this is a no-context
10145 * version of the main function, (which may itself be aliased to us).
10146 * Don't access this version directly.
10150 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
10155 PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
10157 va_start(args, pat);
10158 sv_vcatpvf(sv, pat, &args);
10162 /* pTHX_ magic can't cope with varargs, so this is a no-context
10163 * version of the main function, (which may itself be aliased to us).
10164 * Don't access this version directly.
10168 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
10173 PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
10175 va_start(args, pat);
10176 sv_vcatpvf_mg(sv, pat, &args);
10182 =for apidoc sv_catpvf
10184 Processes its arguments like C<sprintf> and appends the formatted
10185 output to an SV. If the appended data contains "wide" characters
10186 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
10187 and characters >255 formatted with %c), the original SV might get
10188 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
10189 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
10190 valid UTF-8; if the original SV was bytes, the pattern should be too.
10195 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
10199 PERL_ARGS_ASSERT_SV_CATPVF;
10201 va_start(args, pat);
10202 sv_vcatpvf(sv, pat, &args);
10207 =for apidoc sv_vcatpvf
10209 Processes its arguments like C<vsprintf> and appends the formatted output
10210 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
10212 Usually used via its frontend C<sv_catpvf>.
10218 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
10220 PERL_ARGS_ASSERT_SV_VCATPVF;
10222 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
10226 =for apidoc sv_catpvf_mg
10228 Like C<sv_catpvf>, but also handles 'set' magic.
10234 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
10238 PERL_ARGS_ASSERT_SV_CATPVF_MG;
10240 va_start(args, pat);
10241 sv_vcatpvf_mg(sv, pat, &args);
10246 =for apidoc sv_vcatpvf_mg
10248 Like C<sv_vcatpvf>, but also handles 'set' magic.
10250 Usually used via its frontend C<sv_catpvf_mg>.
10256 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
10258 PERL_ARGS_ASSERT_SV_VCATPVF_MG;
10260 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
10265 =for apidoc sv_vsetpvfn
10267 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
10270 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
10276 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
10277 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
10279 PERL_ARGS_ASSERT_SV_VSETPVFN;
10282 sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, 0);
10287 * Warn of missing argument to sprintf, and then return a defined value
10288 * to avoid inappropriate "use of uninit" warnings [perl #71000].
10290 #define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
10292 S_vcatpvfn_missing_argument(pTHX) {
10293 if (ckWARN(WARN_MISSING)) {
10294 Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
10295 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
10302 S_expect_number(pTHX_ char **const pattern)
10307 PERL_ARGS_ASSERT_EXPECT_NUMBER;
10309 switch (**pattern) {
10310 case '1': case '2': case '3':
10311 case '4': case '5': case '6':
10312 case '7': case '8': case '9':
10313 var = *(*pattern)++ - '0';
10314 while (isDIGIT(**pattern)) {
10315 const I32 tmp = var * 10 + (*(*pattern)++ - '0');
10317 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
10325 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
10327 const int neg = nv < 0;
10330 PERL_ARGS_ASSERT_F0CONVERT;
10338 if (uv & 1 && uv == nv)
10339 uv--; /* Round to even */
10341 const unsigned dig = uv % 10;
10343 } while (uv /= 10);
10354 =for apidoc sv_vcatpvfn
10356 =for apidoc sv_vcatpvfn_flags
10358 Processes its arguments like C<vsprintf> and appends the formatted output
10359 to an SV. Uses an array of SVs if the C style variable argument list is
10360 missing (NULL). When running with taint checks enabled, indicates via
10361 C<maybe_tainted> if results are untrustworthy (often due to the use of
10364 If called as C<sv_vcatpvfn> or flags include C<SV_GMAGIC>, calls get magic.
10366 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
10371 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
10372 vecstr = (U8*)SvPV_const(vecsv,veclen);\
10373 vec_utf8 = DO_UTF8(vecsv);
10375 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
10378 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
10379 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
10381 PERL_ARGS_ASSERT_SV_VCATPVFN;
10383 sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC);
10387 Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
10388 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted,
10394 const char *patend;
10397 static const char nullstr[] = "(null)";
10399 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
10400 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
10402 /* Times 4: a decimal digit takes more than 3 binary digits.
10403 * NV_DIG: mantissa takes than many decimal digits.
10404 * Plus 32: Playing safe. */
10405 char ebuf[IV_DIG * 4 + NV_DIG + 32];
10406 /* large enough for "%#.#f" --chip */
10407 /* what about long double NVs? --jhi */
10408 #ifdef USE_LOCALE_NUMERIC
10409 SV* oldlocale = NULL;
10412 PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
10413 PERL_UNUSED_ARG(maybe_tainted);
10415 if (flags & SV_GMAGIC)
10418 /* no matter what, this is a string now */
10419 (void)SvPV_force_nomg(sv, origlen);
10421 /* special-case "", "%s", and "%-p" (SVf - see below) */
10424 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
10426 const char * const s = va_arg(*args, char*);
10427 sv_catpv_nomg(sv, s ? s : nullstr);
10429 else if (svix < svmax) {
10430 /* we want get magic on the source but not the target. sv_catsv can't do that, though */
10431 SvGETMAGIC(*svargs);
10432 sv_catsv_nomg(sv, *svargs);
10435 S_vcatpvfn_missing_argument(aTHX);
10438 if (args && patlen == 3 && pat[0] == '%' &&
10439 pat[1] == '-' && pat[2] == 'p') {
10440 argsv = MUTABLE_SV(va_arg(*args, void*));
10441 sv_catsv_nomg(sv, argsv);
10445 #ifndef USE_LONG_DOUBLE
10446 /* special-case "%.<number>[gf]" */
10447 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
10448 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
10449 unsigned digits = 0;
10453 while (*pp >= '0' && *pp <= '9')
10454 digits = 10 * digits + (*pp++ - '0');
10455 if (pp - pat == (int)patlen - 1 && svix < svmax) {
10456 const NV nv = SvNV(*svargs);
10458 /* Add check for digits != 0 because it seems that some
10459 gconverts are buggy in this case, and we don't yet have
10460 a Configure test for this. */
10461 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
10462 /* 0, point, slack */
10463 Gconvert(nv, (int)digits, 0, ebuf);
10464 sv_catpv_nomg(sv, ebuf);
10465 if (*ebuf) /* May return an empty string for digits==0 */
10468 } else if (!digits) {
10471 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
10472 sv_catpvn_nomg(sv, p, l);
10478 #endif /* !USE_LONG_DOUBLE */
10480 if (!args && svix < svmax && DO_UTF8(*svargs))
10483 patend = (char*)pat + patlen;
10484 for (p = (char*)pat; p < patend; p = q) {
10487 bool vectorize = FALSE;
10488 bool vectorarg = FALSE;
10489 bool vec_utf8 = FALSE;
10495 bool has_precis = FALSE;
10497 const I32 osvix = svix;
10498 bool is_utf8 = FALSE; /* is this item utf8? */
10499 #ifdef HAS_LDBL_SPRINTF_BUG
10500 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10501 with sfio - Allen <allens@cpan.org> */
10502 bool fix_ldbl_sprintf_bug = FALSE;
10506 U8 utf8buf[UTF8_MAXBYTES+1];
10507 STRLEN esignlen = 0;
10509 const char *eptr = NULL;
10510 const char *fmtstart;
10513 const U8 *vecstr = NULL;
10520 /* we need a long double target in case HAS_LONG_DOUBLE but
10521 not USE_LONG_DOUBLE
10523 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
10531 const char *dotstr = ".";
10532 STRLEN dotstrlen = 1;
10533 I32 efix = 0; /* explicit format parameter index */
10534 I32 ewix = 0; /* explicit width index */
10535 I32 epix = 0; /* explicit precision index */
10536 I32 evix = 0; /* explicit vector index */
10537 bool asterisk = FALSE;
10539 /* echo everything up to the next format specification */
10540 for (q = p; q < patend && *q != '%'; ++q) ;
10542 if (has_utf8 && !pat_utf8)
10543 sv_catpvn_nomg_utf8_upgrade(sv, p, q - p, nsv);
10545 sv_catpvn_nomg(sv, p, q - p);
10554 We allow format specification elements in this order:
10555 \d+\$ explicit format parameter index
10557 v|\*(\d+\$)?v vector with optional (optionally specified) arg
10558 0 flag (as above): repeated to allow "v02"
10559 \d+|\*(\d+\$)? width using optional (optionally specified) arg
10560 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
10562 [%bcdefginopsuxDFOUX] format (mandatory)
10567 As of perl5.9.3, printf format checking is on by default.
10568 Internally, perl uses %p formats to provide an escape to
10569 some extended formatting. This block deals with those
10570 extensions: if it does not match, (char*)q is reset and
10571 the normal format processing code is used.
10573 Currently defined extensions are:
10574 %p include pointer address (standard)
10575 %-p (SVf) include an SV (previously %_)
10576 %-<num>p include an SV with precision <num>
10578 %3p include a HEK with precision of 256
10579 %4p char* preceded by utf8 flag and length
10580 %<num>p (where num is 1 or > 4) reserved for future
10583 Robin Barker 2005-07-14 (but modified since)
10585 %1p (VDf) removed. RMB 2007-10-19
10592 else if (strnEQ(q, UTF8f, sizeof(UTF8f)-1)) { /* UTF8f */
10593 /* The argument has already gone through cBOOL, so the cast
10595 is_utf8 = (bool)va_arg(*args, int);
10596 elen = va_arg(*args, UV);
10597 eptr = va_arg(*args, char *);
10598 q += sizeof(UTF8f)-1;
10601 n = expect_number(&q);
10603 if (sv) { /* SVf */
10608 argsv = MUTABLE_SV(va_arg(*args, void*));
10609 eptr = SvPV_const(argsv, elen);
10610 if (DO_UTF8(argsv))
10614 else if (n==2 || n==3) { /* HEKf */
10615 HEK * const hek = va_arg(*args, HEK *);
10616 eptr = HEK_KEY(hek);
10617 elen = HEK_LEN(hek);
10618 if (HEK_UTF8(hek)) is_utf8 = TRUE;
10619 if (n==3) precis = 256, has_precis = TRUE;
10623 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
10624 "internal %%<num>p might conflict with future printf extensions");
10630 if ( (width = expect_number(&q)) ) {
10645 if (plus == '+' && *q == ' ') /* '+' over ' ' */
10674 if ( (ewix = expect_number(&q)) )
10683 if ((vectorarg = asterisk)) {
10696 width = expect_number(&q);
10699 if (vectorize && vectorarg) {
10700 /* vectorizing, but not with the default "." */
10702 vecsv = va_arg(*args, SV*);
10704 vecsv = (evix > 0 && evix <= svmax)
10705 ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
10707 vecsv = svix < svmax
10708 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10710 dotstr = SvPV_const(vecsv, dotstrlen);
10711 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
10712 bad with tied or overloaded values that return UTF8. */
10713 if (DO_UTF8(vecsv))
10715 else if (has_utf8) {
10716 vecsv = sv_mortalcopy(vecsv);
10717 sv_utf8_upgrade(vecsv);
10718 dotstr = SvPV_const(vecsv, dotstrlen);
10725 i = va_arg(*args, int);
10727 i = (ewix ? ewix <= svmax : svix < svmax) ?
10728 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10730 width = (i < 0) ? -i : i;
10740 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
10742 /* XXX: todo, support specified precision parameter */
10746 i = va_arg(*args, int);
10748 i = (ewix ? ewix <= svmax : svix < svmax)
10749 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10751 has_precis = !(i < 0);
10755 while (isDIGIT(*q))
10756 precis = precis * 10 + (*q++ - '0');
10765 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
10766 vecsv = svargs[efix ? efix-1 : svix++];
10767 vecstr = (U8*)SvPV_const(vecsv,veclen);
10768 vec_utf8 = DO_UTF8(vecsv);
10770 /* if this is a version object, we need to convert
10771 * back into v-string notation and then let the
10772 * vectorize happen normally
10774 if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) {
10775 if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
10776 Perl_ck_warner_d(aTHX_ packWARN(WARN_PRINTF),
10777 "vector argument not supported with alpha versions");
10780 vecsv = sv_newmortal();
10781 scan_vstring((char *)vecstr, (char *)vecstr + veclen,
10783 vecstr = (U8*)SvPV_const(vecsv, veclen);
10784 vec_utf8 = DO_UTF8(vecsv);
10798 case 'I': /* Ix, I32x, and I64x */
10799 # ifdef USE_64_BIT_INT
10800 if (q[1] == '6' && q[2] == '4') {
10806 if (q[1] == '3' && q[2] == '2') {
10810 # ifdef USE_64_BIT_INT
10816 #if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)
10828 #if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)
10829 if (*q == 'l') { /* lld, llf */
10838 if (*++q == 'h') { /* hhd, hhu */
10867 if (!vectorize && !args) {
10869 const I32 i = efix-1;
10870 argsv = (i >= 0 && i < svmax)
10871 ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
10873 argsv = (svix >= 0 && svix < svmax)
10874 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10878 switch (c = *q++) {
10885 uv = (args) ? va_arg(*args, int) : SvIV(argsv);
10887 (!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv)))
10889 eptr = (char*)utf8buf;
10890 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
10904 eptr = va_arg(*args, char*);
10906 elen = strlen(eptr);
10908 eptr = (char *)nullstr;
10909 elen = sizeof nullstr - 1;
10913 eptr = SvPV_const(argsv, elen);
10914 if (DO_UTF8(argsv)) {
10915 STRLEN old_precis = precis;
10916 if (has_precis && precis < elen) {
10917 STRLEN ulen = sv_or_pv_len_utf8(argsv, eptr, elen);
10918 STRLEN p = precis > ulen ? ulen : precis;
10919 precis = sv_or_pv_pos_u2b(argsv, eptr, p, 0);
10920 /* sticks at end */
10922 if (width) { /* fudge width (can't fudge elen) */
10923 if (has_precis && precis < elen)
10924 width += precis - old_precis;
10927 elen - sv_or_pv_len_utf8(argsv,eptr,elen);
10934 if (has_precis && precis < elen)
10941 if (alt || vectorize)
10943 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
10964 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10973 esignbuf[esignlen++] = plus;
10977 case 'c': iv = (char)va_arg(*args, int); break;
10978 case 'h': iv = (short)va_arg(*args, int); break;
10979 case 'l': iv = va_arg(*args, long); break;
10980 case 'V': iv = va_arg(*args, IV); break;
10981 case 'z': iv = va_arg(*args, SSize_t); break;
10982 case 't': iv = va_arg(*args, ptrdiff_t); break;
10983 default: iv = va_arg(*args, int); break;
10985 case 'j': iv = va_arg(*args, intmax_t); break;
10989 iv = va_arg(*args, Quad_t); break;
10996 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
10998 case 'c': iv = (char)tiv; break;
10999 case 'h': iv = (short)tiv; break;
11000 case 'l': iv = (long)tiv; break;
11002 default: iv = tiv; break;
11005 iv = (Quad_t)tiv; break;
11011 if ( !vectorize ) /* we already set uv above */
11016 esignbuf[esignlen++] = plus;
11020 esignbuf[esignlen++] = '-';
11064 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
11075 case 'c': uv = (unsigned char)va_arg(*args, unsigned); break;
11076 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
11077 case 'l': uv = va_arg(*args, unsigned long); break;
11078 case 'V': uv = va_arg(*args, UV); break;
11079 case 'z': uv = va_arg(*args, Size_t); break;
11080 case 't': uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */
11082 case 'j': uv = va_arg(*args, uintmax_t); break;
11084 default: uv = va_arg(*args, unsigned); break;
11087 uv = va_arg(*args, Uquad_t); break;
11094 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
11096 case 'c': uv = (unsigned char)tuv; break;
11097 case 'h': uv = (unsigned short)tuv; break;
11098 case 'l': uv = (unsigned long)tuv; break;
11100 default: uv = tuv; break;
11103 uv = (Uquad_t)tuv; break;
11112 char *ptr = ebuf + sizeof ebuf;
11113 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
11119 p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
11123 } while (uv >>= 4);
11125 esignbuf[esignlen++] = '0';
11126 esignbuf[esignlen++] = c; /* 'x' or 'X' */
11132 *--ptr = '0' + dig;
11133 } while (uv >>= 3);
11134 if (alt && *ptr != '0')
11140 *--ptr = '0' + dig;
11141 } while (uv >>= 1);
11143 esignbuf[esignlen++] = '0';
11144 esignbuf[esignlen++] = c;
11147 default: /* it had better be ten or less */
11150 *--ptr = '0' + dig;
11151 } while (uv /= base);
11154 elen = (ebuf + sizeof ebuf) - ptr;
11158 zeros = precis - elen;
11159 else if (precis == 0 && elen == 1 && *eptr == '0'
11160 && !(base == 8 && alt)) /* "%#.0o" prints "0" */
11163 /* a precision nullifies the 0 flag. */
11170 /* FLOATING POINT */
11173 c = 'f'; /* maybe %F isn't supported here */
11175 case 'e': case 'E':
11177 case 'g': case 'G':
11181 /* This is evil, but floating point is even more evil */
11183 /* for SV-style calling, we can only get NV
11184 for C-style calling, we assume %f is double;
11185 for simplicity we allow any of %Lf, %llf, %qf for long double
11189 #if defined(USE_LONG_DOUBLE)
11193 /* [perl #20339] - we should accept and ignore %lf rather than die */
11197 #if defined(USE_LONG_DOUBLE)
11198 intsize = args ? 0 : 'q';
11202 #if defined(HAS_LONG_DOUBLE)
11215 /* now we need (long double) if intsize == 'q', else (double) */
11217 #if LONG_DOUBLESIZE > DOUBLESIZE
11219 va_arg(*args, long double) :
11220 va_arg(*args, double)
11222 va_arg(*args, double)
11227 /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
11228 else. frexp() has some unspecified behaviour for those three */
11229 if (c != 'e' && c != 'E' && (nv * 0) == 0) {
11231 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
11232 will cast our (long double) to (double) */
11233 (void)Perl_frexp(nv, &i);
11234 if (i == PERL_INT_MIN)
11235 Perl_die(aTHX_ "panic: frexp");
11237 need = BIT_DIGITS(i);
11239 need += has_precis ? precis : 6; /* known default */
11244 #ifdef HAS_LDBL_SPRINTF_BUG
11245 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
11246 with sfio - Allen <allens@cpan.org> */
11249 # define MY_DBL_MAX DBL_MAX
11250 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
11251 # if DOUBLESIZE >= 8
11252 # define MY_DBL_MAX 1.7976931348623157E+308L
11254 # define MY_DBL_MAX 3.40282347E+38L
11258 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
11259 # define MY_DBL_MAX_BUG 1L
11261 # define MY_DBL_MAX_BUG MY_DBL_MAX
11265 # define MY_DBL_MIN DBL_MIN
11266 # else /* XXX guessing! -Allen */
11267 # if DOUBLESIZE >= 8
11268 # define MY_DBL_MIN 2.2250738585072014E-308L
11270 # define MY_DBL_MIN 1.17549435E-38L
11274 if ((intsize == 'q') && (c == 'f') &&
11275 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
11276 (need < DBL_DIG)) {
11277 /* it's going to be short enough that
11278 * long double precision is not needed */
11280 if ((nv <= 0L) && (nv >= -0L))
11281 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
11283 /* would use Perl_fp_class as a double-check but not
11284 * functional on IRIX - see perl.h comments */
11286 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
11287 /* It's within the range that a double can represent */
11288 #if defined(DBL_MAX) && !defined(DBL_MIN)
11289 if ((nv >= ((long double)1/DBL_MAX)) ||
11290 (nv <= (-(long double)1/DBL_MAX)))
11292 fix_ldbl_sprintf_bug = TRUE;
11295 if (fix_ldbl_sprintf_bug == TRUE) {
11305 # undef MY_DBL_MAX_BUG
11308 #endif /* HAS_LDBL_SPRINTF_BUG */
11310 need += 20; /* fudge factor */
11311 if (PL_efloatsize < need) {
11312 Safefree(PL_efloatbuf);
11313 PL_efloatsize = need + 20; /* more fudge */
11314 Newx(PL_efloatbuf, PL_efloatsize, char);
11315 PL_efloatbuf[0] = '\0';
11318 if ( !(width || left || plus || alt) && fill != '0'
11319 && has_precis && intsize != 'q' ) { /* Shortcuts */
11320 /* See earlier comment about buggy Gconvert when digits,
11322 if ( c == 'g' && precis) {
11323 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
11324 /* May return an empty string for digits==0 */
11325 if (*PL_efloatbuf) {
11326 elen = strlen(PL_efloatbuf);
11327 goto float_converted;
11329 } else if ( c == 'f' && !precis) {
11330 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
11335 char *ptr = ebuf + sizeof ebuf;
11338 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
11339 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
11340 if (intsize == 'q') {
11341 /* Copy the one or more characters in a long double
11342 * format before the 'base' ([efgEFG]) character to
11343 * the format string. */
11344 static char const prifldbl[] = PERL_PRIfldbl;
11345 char const *p = prifldbl + sizeof(prifldbl) - 3;
11346 while (p >= prifldbl) { *--ptr = *p--; }
11351 do { *--ptr = '0' + (base % 10); } while (base /= 10);
11356 do { *--ptr = '0' + (base % 10); } while (base /= 10);
11368 /* No taint. Otherwise we are in the strange situation
11369 * where printf() taints but print($float) doesn't.
11372 #ifdef USE_LOCALE_NUMERIC
11373 if (! PL_numeric_standard && ! IN_SOME_LOCALE_FORM) {
11375 /* We use a mortal SV, so that any failures (such as if
11376 * warnings are made fatal) won't leak */
11377 char *oldlocale_string = setlocale(LC_NUMERIC, NULL);
11378 oldlocale = newSVpvn_flags(oldlocale_string,
11379 strlen(oldlocale_string),
11381 PL_numeric_standard = TRUE;
11382 setlocale(LC_NUMERIC, "C");
11386 #if defined(HAS_LONG_DOUBLE)
11387 elen = ((intsize == 'q')
11388 ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
11389 : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
11391 elen = my_sprintf(PL_efloatbuf, ptr, nv);
11395 eptr = PL_efloatbuf;
11397 #ifdef USE_LOCALE_NUMERIC
11398 if (PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
11399 && instr(eptr, SvPVX_const(PL_numeric_radix_sv)))
11412 i = SvCUR(sv) - origlen;
11415 case 'c': *(va_arg(*args, char*)) = i; break;
11416 case 'h': *(va_arg(*args, short*)) = i; break;
11417 default: *(va_arg(*args, int*)) = i; break;
11418 case 'l': *(va_arg(*args, long*)) = i; break;
11419 case 'V': *(va_arg(*args, IV*)) = i; break;
11420 case 'z': *(va_arg(*args, SSize_t*)) = i; break;
11421 case 't': *(va_arg(*args, ptrdiff_t*)) = i; break;
11423 case 'j': *(va_arg(*args, intmax_t*)) = i; break;
11427 *(va_arg(*args, Quad_t*)) = i; break;
11434 sv_setuv_mg(argsv, has_utf8 ? (UV)sv_len_utf8(sv) : (UV)i);
11435 continue; /* not "break" */
11442 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
11443 && ckWARN(WARN_PRINTF))
11445 SV * const msg = sv_newmortal();
11446 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
11447 (PL_op->op_type == OP_PRTF) ? "" : "s");
11448 if (fmtstart < patend) {
11449 const char * const fmtend = q < patend ? q : patend;
11451 sv_catpvs(msg, "\"%");
11452 for (f = fmtstart; f < fmtend; f++) {
11454 sv_catpvn_nomg(msg, f, 1);
11456 Perl_sv_catpvf(aTHX_ msg,
11457 "\\%03"UVof, (UV)*f & 0xFF);
11460 sv_catpvs(msg, "\"");
11462 sv_catpvs(msg, "end of string");
11464 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
11467 /* output mangled stuff ... */
11473 /* ... right here, because formatting flags should not apply */
11474 SvGROW(sv, SvCUR(sv) + elen + 1);
11476 Copy(eptr, p, elen, char);
11479 SvCUR_set(sv, p - SvPVX_const(sv));
11481 continue; /* not "break" */
11484 if (is_utf8 != has_utf8) {
11487 sv_utf8_upgrade(sv);
11490 const STRLEN old_elen = elen;
11491 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
11492 sv_utf8_upgrade(nsv);
11493 eptr = SvPVX_const(nsv);
11496 if (width) { /* fudge width (can't fudge elen) */
11497 width += elen - old_elen;
11503 have = esignlen + zeros + elen;
11505 croak_memory_wrap();
11507 need = (have > width ? have : width);
11510 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
11511 croak_memory_wrap();
11512 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
11514 if (esignlen && fill == '0') {
11516 for (i = 0; i < (int)esignlen; i++)
11517 *p++ = esignbuf[i];
11519 if (gap && !left) {
11520 memset(p, fill, gap);
11523 if (esignlen && fill != '0') {
11525 for (i = 0; i < (int)esignlen; i++)
11526 *p++ = esignbuf[i];
11530 for (i = zeros; i; i--)
11534 Copy(eptr, p, elen, char);
11538 memset(p, ' ', gap);
11543 Copy(dotstr, p, dotstrlen, char);
11547 vectorize = FALSE; /* done iterating over vecstr */
11554 SvCUR_set(sv, p - SvPVX_const(sv));
11562 #ifdef USE_LOCALE_NUMERIC /* Done outside loop, so don't have to save/restore
11565 setlocale(LC_NUMERIC, SvPVX(oldlocale));
11566 PL_numeric_standard = FALSE;
11571 /* =========================================================================
11573 =head1 Cloning an interpreter
11575 All the macros and functions in this section are for the private use of
11576 the main function, perl_clone().
11578 The foo_dup() functions make an exact copy of an existing foo thingy.
11579 During the course of a cloning, a hash table is used to map old addresses
11580 to new addresses. The table is created and manipulated with the
11581 ptr_table_* functions.
11585 * =========================================================================*/
11588 #if defined(USE_ITHREADS)
11590 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
11591 #ifndef GpREFCNT_inc
11592 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
11596 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
11597 that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
11598 If this changes, please unmerge ss_dup.
11599 Likewise, sv_dup_inc_multiple() relies on this fact. */
11600 #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup_inc(s,t))
11601 #define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t))
11602 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
11603 #define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t))
11604 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
11605 #define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t))
11606 #define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t))
11607 #define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t))
11608 #define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t))
11609 #define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t))
11610 #define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t))
11611 #define SAVEPV(p) ((p) ? savepv(p) : NULL)
11612 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
11614 /* clone a parser */
11617 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
11621 PERL_ARGS_ASSERT_PARSER_DUP;
11626 /* look for it in the table first */
11627 parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
11631 /* create anew and remember what it is */
11632 Newxz(parser, 1, yy_parser);
11633 ptr_table_store(PL_ptr_table, proto, parser);
11635 /* XXX these not yet duped */
11636 parser->old_parser = NULL;
11637 parser->stack = NULL;
11639 parser->stack_size = 0;
11640 /* XXX parser->stack->state = 0; */
11642 /* XXX eventually, just Copy() most of the parser struct ? */
11644 parser->lex_brackets = proto->lex_brackets;
11645 parser->lex_casemods = proto->lex_casemods;
11646 parser->lex_brackstack = savepvn(proto->lex_brackstack,
11647 (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
11648 parser->lex_casestack = savepvn(proto->lex_casestack,
11649 (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
11650 parser->lex_defer = proto->lex_defer;
11651 parser->lex_dojoin = proto->lex_dojoin;
11652 parser->lex_expect = proto->lex_expect;
11653 parser->lex_formbrack = proto->lex_formbrack;
11654 parser->lex_inpat = proto->lex_inpat;
11655 parser->lex_inwhat = proto->lex_inwhat;
11656 parser->lex_op = proto->lex_op;
11657 parser->lex_repl = sv_dup_inc(proto->lex_repl, param);
11658 parser->lex_starts = proto->lex_starts;
11659 parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param);
11660 parser->multi_close = proto->multi_close;
11661 parser->multi_open = proto->multi_open;
11662 parser->multi_start = proto->multi_start;
11663 parser->multi_end = proto->multi_end;
11664 parser->preambled = proto->preambled;
11665 parser->sublex_info = proto->sublex_info; /* XXX not quite right */
11666 parser->linestr = sv_dup_inc(proto->linestr, param);
11667 parser->expect = proto->expect;
11668 parser->copline = proto->copline;
11669 parser->last_lop_op = proto->last_lop_op;
11670 parser->lex_state = proto->lex_state;
11671 parser->rsfp = fp_dup(proto->rsfp, '<', param);
11672 /* rsfp_filters entries have fake IoDIRP() */
11673 parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
11674 parser->in_my = proto->in_my;
11675 parser->in_my_stash = hv_dup(proto->in_my_stash, param);
11676 parser->error_count = proto->error_count;
11679 parser->linestr = sv_dup_inc(proto->linestr, param);
11682 char * const ols = SvPVX(proto->linestr);
11683 char * const ls = SvPVX(parser->linestr);
11685 parser->bufptr = ls + (proto->bufptr >= ols ?
11686 proto->bufptr - ols : 0);
11687 parser->oldbufptr = ls + (proto->oldbufptr >= ols ?
11688 proto->oldbufptr - ols : 0);
11689 parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
11690 proto->oldoldbufptr - ols : 0);
11691 parser->linestart = ls + (proto->linestart >= ols ?
11692 proto->linestart - ols : 0);
11693 parser->last_uni = ls + (proto->last_uni >= ols ?
11694 proto->last_uni - ols : 0);
11695 parser->last_lop = ls + (proto->last_lop >= ols ?
11696 proto->last_lop - ols : 0);
11698 parser->bufend = ls + SvCUR(parser->linestr);
11701 Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
11705 parser->endwhite = proto->endwhite;
11706 parser->faketokens = proto->faketokens;
11707 parser->lasttoke = proto->lasttoke;
11708 parser->nextwhite = proto->nextwhite;
11709 parser->realtokenstart = proto->realtokenstart;
11710 parser->skipwhite = proto->skipwhite;
11711 parser->thisclose = proto->thisclose;
11712 parser->thismad = proto->thismad;
11713 parser->thisopen = proto->thisopen;
11714 parser->thisstuff = proto->thisstuff;
11715 parser->thistoken = proto->thistoken;
11716 parser->thiswhite = proto->thiswhite;
11718 Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
11719 parser->curforce = proto->curforce;
11721 Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
11722 Copy(proto->nexttype, parser->nexttype, 5, I32);
11723 parser->nexttoke = proto->nexttoke;
11726 /* XXX should clone saved_curcop here, but we aren't passed
11727 * proto_perl; so do it in perl_clone_using instead */
11733 /* duplicate a file handle */
11736 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
11740 PERL_ARGS_ASSERT_FP_DUP;
11741 PERL_UNUSED_ARG(type);
11744 return (PerlIO*)NULL;
11746 /* look for it in the table first */
11747 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
11751 /* create anew and remember what it is */
11752 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
11753 ptr_table_store(PL_ptr_table, fp, ret);
11757 /* duplicate a directory handle */
11760 Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
11766 const Direntry_t *dirent;
11767 char smallbuf[256];
11773 PERL_UNUSED_CONTEXT;
11774 PERL_ARGS_ASSERT_DIRP_DUP;
11779 /* look for it in the table first */
11780 ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
11786 PERL_UNUSED_ARG(param);
11790 /* open the current directory (so we can switch back) */
11791 if (!(pwd = PerlDir_open("."))) return (DIR *)NULL;
11793 /* chdir to our dir handle and open the present working directory */
11794 if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) {
11795 PerlDir_close(pwd);
11796 return (DIR *)NULL;
11798 /* Now we should have two dir handles pointing to the same dir. */
11800 /* Be nice to the calling code and chdir back to where we were. */
11801 fchdir(my_dirfd(pwd)); /* If this fails, then what? */
11803 /* We have no need of the pwd handle any more. */
11804 PerlDir_close(pwd);
11807 # define d_namlen(d) (d)->d_namlen
11809 # define d_namlen(d) strlen((d)->d_name)
11811 /* Iterate once through dp, to get the file name at the current posi-
11812 tion. Then step back. */
11813 pos = PerlDir_tell(dp);
11814 if ((dirent = PerlDir_read(dp))) {
11815 len = d_namlen(dirent);
11816 if (len <= sizeof smallbuf) name = smallbuf;
11817 else Newx(name, len, char);
11818 Move(dirent->d_name, name, len, char);
11820 PerlDir_seek(dp, pos);
11822 /* Iterate through the new dir handle, till we find a file with the
11824 if (!dirent) /* just before the end */
11826 pos = PerlDir_tell(ret);
11827 if (PerlDir_read(ret)) continue; /* not there yet */
11828 PerlDir_seek(ret, pos); /* step back */
11832 const long pos0 = PerlDir_tell(ret);
11834 pos = PerlDir_tell(ret);
11835 if ((dirent = PerlDir_read(ret))) {
11836 if (len == d_namlen(dirent)
11837 && memEQ(name, dirent->d_name, len)) {
11839 PerlDir_seek(ret, pos); /* step back */
11842 /* else we are not there yet; keep iterating */
11844 else { /* This is not meant to happen. The best we can do is
11845 reset the iterator to the beginning. */
11846 PerlDir_seek(ret, pos0);
11853 if (name && name != smallbuf)
11858 ret = win32_dirp_dup(dp, param);
11861 /* pop it in the pointer table */
11863 ptr_table_store(PL_ptr_table, dp, ret);
11868 /* duplicate a typeglob */
11871 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
11875 PERL_ARGS_ASSERT_GP_DUP;
11879 /* look for it in the table first */
11880 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
11884 /* create anew and remember what it is */
11886 ptr_table_store(PL_ptr_table, gp, ret);
11889 /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
11890 on Newxz() to do this for us. */
11891 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
11892 ret->gp_io = io_dup_inc(gp->gp_io, param);
11893 ret->gp_form = cv_dup_inc(gp->gp_form, param);
11894 ret->gp_av = av_dup_inc(gp->gp_av, param);
11895 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
11896 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
11897 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
11898 ret->gp_cvgen = gp->gp_cvgen;
11899 ret->gp_line = gp->gp_line;
11900 ret->gp_file_hek = hek_dup(gp->gp_file_hek, param);
11904 /* duplicate a chain of magic */
11907 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
11909 MAGIC *mgret = NULL;
11910 MAGIC **mgprev_p = &mgret;
11912 PERL_ARGS_ASSERT_MG_DUP;
11914 for (; mg; mg = mg->mg_moremagic) {
11917 if ((param->flags & CLONEf_JOIN_IN)
11918 && mg->mg_type == PERL_MAGIC_backref)
11919 /* when joining, we let the individual SVs add themselves to
11920 * backref as needed. */
11923 Newx(nmg, 1, MAGIC);
11925 mgprev_p = &(nmg->mg_moremagic);
11927 /* There was a comment "XXX copy dynamic vtable?" but as we don't have
11928 dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
11929 from the original commit adding Perl_mg_dup() - revision 4538.
11930 Similarly there is the annotation "XXX random ptr?" next to the
11931 assignment to nmg->mg_ptr. */
11934 /* FIXME for plugins
11935 if (nmg->mg_type == PERL_MAGIC_qr) {
11936 nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
11940 nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
11941 ? nmg->mg_type == PERL_MAGIC_backref
11942 /* The backref AV has its reference
11943 * count deliberately bumped by 1 */
11944 ? SvREFCNT_inc(av_dup_inc((const AV *)
11945 nmg->mg_obj, param))
11946 : sv_dup_inc(nmg->mg_obj, param)
11947 : sv_dup(nmg->mg_obj, param);
11949 if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
11950 if (nmg->mg_len > 0) {
11951 nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
11952 if (nmg->mg_type == PERL_MAGIC_overload_table &&
11953 AMT_AMAGIC((AMT*)nmg->mg_ptr))
11955 AMT * const namtp = (AMT*)nmg->mg_ptr;
11956 sv_dup_inc_multiple((SV**)(namtp->table),
11957 (SV**)(namtp->table), NofAMmeth, param);
11960 else if (nmg->mg_len == HEf_SVKEY)
11961 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
11963 if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
11964 nmg->mg_virtual->svt_dup(aTHX_ nmg, param);
11970 #endif /* USE_ITHREADS */
11972 struct ptr_tbl_arena {
11973 struct ptr_tbl_arena *next;
11974 struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers. */
11977 /* create a new pointer-mapping table */
11980 Perl_ptr_table_new(pTHX)
11983 PERL_UNUSED_CONTEXT;
11985 Newx(tbl, 1, PTR_TBL_t);
11986 tbl->tbl_max = 511;
11987 tbl->tbl_items = 0;
11988 tbl->tbl_arena = NULL;
11989 tbl->tbl_arena_next = NULL;
11990 tbl->tbl_arena_end = NULL;
11991 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
11995 #define PTR_TABLE_HASH(ptr) \
11996 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
11998 /* map an existing pointer using a table */
12000 STATIC PTR_TBL_ENT_t *
12001 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
12003 PTR_TBL_ENT_t *tblent;
12004 const UV hash = PTR_TABLE_HASH(sv);
12006 PERL_ARGS_ASSERT_PTR_TABLE_FIND;
12008 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
12009 for (; tblent; tblent = tblent->next) {
12010 if (tblent->oldval == sv)
12017 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
12019 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
12021 PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
12022 PERL_UNUSED_CONTEXT;
12024 return tblent ? tblent->newval : NULL;
12027 /* add a new entry to a pointer-mapping table */
12030 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
12032 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
12034 PERL_ARGS_ASSERT_PTR_TABLE_STORE;
12035 PERL_UNUSED_CONTEXT;
12038 tblent->newval = newsv;
12040 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
12042 if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
12043 struct ptr_tbl_arena *new_arena;
12045 Newx(new_arena, 1, struct ptr_tbl_arena);
12046 new_arena->next = tbl->tbl_arena;
12047 tbl->tbl_arena = new_arena;
12048 tbl->tbl_arena_next = new_arena->array;
12049 tbl->tbl_arena_end = new_arena->array
12050 + sizeof(new_arena->array) / sizeof(new_arena->array[0]);
12053 tblent = tbl->tbl_arena_next++;
12055 tblent->oldval = oldsv;
12056 tblent->newval = newsv;
12057 tblent->next = tbl->tbl_ary[entry];
12058 tbl->tbl_ary[entry] = tblent;
12060 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
12061 ptr_table_split(tbl);
12065 /* double the hash bucket size of an existing ptr table */
12068 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
12070 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
12071 const UV oldsize = tbl->tbl_max + 1;
12072 UV newsize = oldsize * 2;
12075 PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
12076 PERL_UNUSED_CONTEXT;
12078 Renew(ary, newsize, PTR_TBL_ENT_t*);
12079 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
12080 tbl->tbl_max = --newsize;
12081 tbl->tbl_ary = ary;
12082 for (i=0; i < oldsize; i++, ary++) {
12083 PTR_TBL_ENT_t **entp = ary;
12084 PTR_TBL_ENT_t *ent = *ary;
12085 PTR_TBL_ENT_t **curentp;
12088 curentp = ary + oldsize;
12090 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
12092 ent->next = *curentp;
12102 /* remove all the entries from a ptr table */
12103 /* Deprecated - will be removed post 5.14 */
12106 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
12108 if (tbl && tbl->tbl_items) {
12109 struct ptr_tbl_arena *arena = tbl->tbl_arena;
12111 Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
12114 struct ptr_tbl_arena *next = arena->next;
12120 tbl->tbl_items = 0;
12121 tbl->tbl_arena = NULL;
12122 tbl->tbl_arena_next = NULL;
12123 tbl->tbl_arena_end = NULL;
12127 /* clear and free a ptr table */
12130 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
12132 struct ptr_tbl_arena *arena;
12138 arena = tbl->tbl_arena;
12141 struct ptr_tbl_arena *next = arena->next;
12147 Safefree(tbl->tbl_ary);
12151 #if defined(USE_ITHREADS)
12154 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
12156 PERL_ARGS_ASSERT_RVPV_DUP;
12158 assert(!isREGEXP(sstr));
12160 if (SvWEAKREF(sstr)) {
12161 SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
12162 if (param->flags & CLONEf_JOIN_IN) {
12163 /* if joining, we add any back references individually rather
12164 * than copying the whole backref array */
12165 Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
12169 SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
12171 else if (SvPVX_const(sstr)) {
12172 /* Has something there */
12174 /* Normal PV - clone whole allocated space */
12175 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
12176 /* sstr may not be that normal, but actually copy on write.
12177 But we are a true, independent SV, so: */
12181 /* Special case - not normally malloced for some reason */
12182 if (isGV_with_GP(sstr)) {
12183 /* Don't need to do anything here. */
12185 else if ((SvIsCOW(sstr))) {
12186 /* A "shared" PV - clone it as "shared" PV */
12188 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
12192 /* Some other special case - random pointer */
12193 SvPV_set(dstr, (char *) SvPVX_const(sstr));
12198 /* Copy the NULL */
12199 SvPV_set(dstr, NULL);
12203 /* duplicate a list of SVs. source and dest may point to the same memory. */
12205 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
12206 SSize_t items, CLONE_PARAMS *const param)
12208 PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
12210 while (items-- > 0) {
12211 *dest++ = sv_dup_inc(*source++, param);
12217 /* duplicate an SV of any type (including AV, HV etc) */
12220 S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12225 PERL_ARGS_ASSERT_SV_DUP_COMMON;
12227 if (SvTYPE(sstr) == (svtype)SVTYPEMASK) {
12228 #ifdef DEBUG_LEAKING_SCALARS_ABORT
12233 /* look for it in the table first */
12234 dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
12238 if(param->flags & CLONEf_JOIN_IN) {
12239 /** We are joining here so we don't want do clone
12240 something that is bad **/
12241 if (SvTYPE(sstr) == SVt_PVHV) {
12242 const HEK * const hvname = HvNAME_HEK(sstr);
12244 /** don't clone stashes if they already exist **/
12245 dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
12246 HEK_UTF8(hvname) ? SVf_UTF8 : 0));
12247 ptr_table_store(PL_ptr_table, sstr, dstr);
12251 else if (SvTYPE(sstr) == SVt_PVGV && !SvFAKE(sstr)) {
12252 HV *stash = GvSTASH(sstr);
12253 const HEK * hvname;
12254 if (stash && (hvname = HvNAME_HEK(stash))) {
12255 /** don't clone GVs if they already exist **/
12257 stash = gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname),
12258 HEK_UTF8(hvname) ? SVf_UTF8 : 0);
12260 stash, GvNAME(sstr),
12266 if (svp && *svp && SvTYPE(*svp) == SVt_PVGV) {
12267 ptr_table_store(PL_ptr_table, sstr, *svp);
12274 /* create anew and remember what it is */
12277 #ifdef DEBUG_LEAKING_SCALARS
12278 dstr->sv_debug_optype = sstr->sv_debug_optype;
12279 dstr->sv_debug_line = sstr->sv_debug_line;
12280 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
12281 dstr->sv_debug_parent = (SV*)sstr;
12282 FREE_SV_DEBUG_FILE(dstr);
12283 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
12286 ptr_table_store(PL_ptr_table, sstr, dstr);
12289 SvFLAGS(dstr) = SvFLAGS(sstr);
12290 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
12291 SvREFCNT(dstr) = 0; /* must be before any other dups! */
12294 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
12295 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
12296 (void*)PL_watch_pvx, SvPVX_const(sstr));
12299 /* don't clone objects whose class has asked us not to */
12300 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
12305 switch (SvTYPE(sstr)) {
12307 SvANY(dstr) = NULL;
12310 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
12312 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
12314 SvIV_set(dstr, SvIVX(sstr));
12318 SvANY(dstr) = new_XNV();
12319 SvNV_set(dstr, SvNVX(sstr));
12323 /* These are all the types that need complex bodies allocating. */
12325 const svtype sv_type = SvTYPE(sstr);
12326 const struct body_details *const sv_type_details
12327 = bodies_by_type + sv_type;
12331 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
12347 assert(sv_type_details->body_size);
12348 if (sv_type_details->arena) {
12349 new_body_inline(new_body, sv_type);
12351 = (void*)((char*)new_body - sv_type_details->offset);
12353 new_body = new_NOARENA(sv_type_details);
12357 SvANY(dstr) = new_body;
12360 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
12361 ((char*)SvANY(dstr)) + sv_type_details->offset,
12362 sv_type_details->copy, char);
12364 Copy(((char*)SvANY(sstr)),
12365 ((char*)SvANY(dstr)),
12366 sv_type_details->body_size + sv_type_details->offset, char);
12369 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
12370 && !isGV_with_GP(dstr)
12372 && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
12373 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
12375 /* The Copy above means that all the source (unduplicated) pointers
12376 are now in the destination. We can check the flags and the
12377 pointers in either, but it's possible that there's less cache
12378 missing by always going for the destination.
12379 FIXME - instrument and check that assumption */
12380 if (sv_type >= SVt_PVMG) {
12381 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
12382 SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
12383 } else if (sv_type == SVt_PVAV && AvPAD_NAMELIST(dstr)) {
12385 } else if (SvMAGIC(dstr))
12386 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
12387 if (SvOBJECT(dstr) && SvSTASH(dstr))
12388 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
12389 else SvSTASH_set(dstr, 0); /* don't copy DESTROY cache */
12392 /* The cast silences a GCC warning about unhandled types. */
12393 switch ((int)sv_type) {
12404 /* FIXME for plugins */
12405 dstr->sv_u.svu_rx = ((REGEXP *)dstr)->sv_any;
12406 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
12409 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
12410 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
12411 LvTARG(dstr) = dstr;
12412 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
12413 LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
12415 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
12416 if (isREGEXP(sstr)) goto duprex;
12418 /* non-GP case already handled above */
12419 if(isGV_with_GP(sstr)) {
12420 GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
12421 /* Don't call sv_add_backref here as it's going to be
12422 created as part of the magic cloning of the symbol
12423 table--unless this is during a join and the stash
12424 is not actually being cloned. */
12425 /* Danger Will Robinson - GvGP(dstr) isn't initialised
12426 at the point of this comment. */
12427 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
12428 if (param->flags & CLONEf_JOIN_IN)
12429 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
12430 GvGP_set(dstr, gp_dup(GvGP(sstr), param));
12431 (void)GpREFCNT_inc(GvGP(dstr));
12435 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
12436 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
12437 /* I have no idea why fake dirp (rsfps)
12438 should be treated differently but otherwise
12439 we end up with leaks -- sky*/
12440 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
12441 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
12442 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
12444 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
12445 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
12446 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
12447 if (IoDIRP(dstr)) {
12448 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr), param);
12451 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
12453 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(dstr), param);
12455 if (IoOFP(dstr) == IoIFP(sstr))
12456 IoOFP(dstr) = IoIFP(dstr);
12458 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
12459 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
12460 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
12461 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
12464 /* avoid cloning an empty array */
12465 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
12466 SV **dst_ary, **src_ary;
12467 SSize_t items = AvFILLp((const AV *)sstr) + 1;
12469 src_ary = AvARRAY((const AV *)sstr);
12470 Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
12471 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
12472 AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
12473 AvALLOC((const AV *)dstr) = dst_ary;
12474 if (AvREAL((const AV *)sstr)) {
12475 dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
12479 while (items-- > 0)
12480 *dst_ary++ = sv_dup(*src_ary++, param);
12482 items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
12483 while (items-- > 0) {
12484 *dst_ary++ = &PL_sv_undef;
12488 AvARRAY(MUTABLE_AV(dstr)) = NULL;
12489 AvALLOC((const AV *)dstr) = (SV**)NULL;
12490 AvMAX( (const AV *)dstr) = -1;
12491 AvFILLp((const AV *)dstr) = -1;
12495 if (HvARRAY((const HV *)sstr)) {
12497 const bool sharekeys = !!HvSHAREKEYS(sstr);
12498 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
12499 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
12501 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
12502 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
12504 HvARRAY(dstr) = (HE**)darray;
12505 while (i <= sxhv->xhv_max) {
12506 const HE * const source = HvARRAY(sstr)[i];
12507 HvARRAY(dstr)[i] = source
12508 ? he_dup(source, sharekeys, param) : 0;
12512 const struct xpvhv_aux * const saux = HvAUX(sstr);
12513 struct xpvhv_aux * const daux = HvAUX(dstr);
12514 /* This flag isn't copied. */
12517 if (saux->xhv_name_count) {
12518 HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
12520 = saux->xhv_name_count < 0
12521 ? -saux->xhv_name_count
12522 : saux->xhv_name_count;
12523 HEK **shekp = sname + count;
12525 Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *);
12526 dhekp = daux->xhv_name_u.xhvnameu_names + count;
12527 while (shekp-- > sname) {
12529 *dhekp = hek_dup(*shekp, param);
12533 daux->xhv_name_u.xhvnameu_name
12534 = hek_dup(saux->xhv_name_u.xhvnameu_name,
12537 daux->xhv_name_count = saux->xhv_name_count;
12539 daux->xhv_fill_lazy = saux->xhv_fill_lazy;
12540 daux->xhv_riter = saux->xhv_riter;
12541 daux->xhv_eiter = saux->xhv_eiter
12542 ? he_dup(saux->xhv_eiter,
12543 cBOOL(HvSHAREKEYS(sstr)), param) : 0;
12544 /* backref array needs refcnt=2; see sv_add_backref */
12545 daux->xhv_backreferences =
12546 (param->flags & CLONEf_JOIN_IN)
12547 /* when joining, we let the individual GVs and
12548 * CVs add themselves to backref as
12549 * needed. This avoids pulling in stuff
12550 * that isn't required, and simplifies the
12551 * case where stashes aren't cloned back
12552 * if they already exist in the parent
12555 : saux->xhv_backreferences
12556 ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
12557 ? MUTABLE_AV(SvREFCNT_inc(
12558 sv_dup_inc((const SV *)
12559 saux->xhv_backreferences, param)))
12560 : MUTABLE_AV(sv_dup((const SV *)
12561 saux->xhv_backreferences, param))
12564 daux->xhv_mro_meta = saux->xhv_mro_meta
12565 ? mro_meta_dup(saux->xhv_mro_meta, param)
12568 /* Record stashes for possible cloning in Perl_clone(). */
12570 av_push(param->stashes, dstr);
12574 HvARRAY(MUTABLE_HV(dstr)) = NULL;
12577 if (!(param->flags & CLONEf_COPY_STACKS)) {
12582 /* NOTE: not refcounted */
12583 SvANY(MUTABLE_CV(dstr))->xcv_stash =
12584 hv_dup(CvSTASH(dstr), param);
12585 if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
12586 Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
12587 if (!CvISXSUB(dstr)) {
12589 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
12591 CvSLABBED_off(dstr);
12592 } else if (CvCONST(dstr)) {
12593 CvXSUBANY(dstr).any_ptr =
12594 sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
12596 assert(!CvSLABBED(dstr));
12597 if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr));
12599 SvANY((CV *)dstr)->xcv_gv_u.xcv_hek =
12600 share_hek_hek(CvNAME_HEK((CV *)sstr));
12601 /* don't dup if copying back - CvGV isn't refcounted, so the
12602 * duped GV may never be freed. A bit of a hack! DAPM */
12604 SvANY(MUTABLE_CV(dstr))->xcv_gv_u.xcv_gv =
12606 ? gv_dup_inc(CvGV(sstr), param)
12607 : (param->flags & CLONEf_JOIN_IN)
12609 : gv_dup(CvGV(sstr), param);
12611 CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
12613 CvWEAKOUTSIDE(sstr)
12614 ? cv_dup( CvOUTSIDE(dstr), param)
12615 : cv_dup_inc(CvOUTSIDE(dstr), param);
12625 Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12627 PERL_ARGS_ASSERT_SV_DUP_INC;
12628 return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL;
12632 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12634 SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
12635 PERL_ARGS_ASSERT_SV_DUP;
12637 /* Track every SV that (at least initially) had a reference count of 0.
12638 We need to do this by holding an actual reference to it in this array.
12639 If we attempt to cheat, turn AvREAL_off(), and store only pointers
12640 (akin to the stashes hash, and the perl stack), we come unstuck if
12641 a weak reference (or other SV legitimately SvREFCNT() == 0 for this
12642 thread) is manipulated in a CLONE method, because CLONE runs before the
12643 unreferenced array is walked to find SVs still with SvREFCNT() == 0
12644 (and fix things up by giving each a reference via the temps stack).
12645 Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
12646 then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
12647 before the walk of unreferenced happens and a reference to that is SV
12648 added to the temps stack. At which point we have the same SV considered
12649 to be in use, and free to be re-used. Not good.
12651 if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
12652 assert(param->unreferenced);
12653 av_push(param->unreferenced, SvREFCNT_inc(dstr));
12659 /* duplicate a context */
12662 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
12664 PERL_CONTEXT *ncxs;
12666 PERL_ARGS_ASSERT_CX_DUP;
12669 return (PERL_CONTEXT*)NULL;
12671 /* look for it in the table first */
12672 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
12676 /* create anew and remember what it is */
12677 Newx(ncxs, max + 1, PERL_CONTEXT);
12678 ptr_table_store(PL_ptr_table, cxs, ncxs);
12679 Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
12682 PERL_CONTEXT * const ncx = &ncxs[ix];
12683 if (CxTYPE(ncx) == CXt_SUBST) {
12684 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
12687 ncx->blk_oldcop = (COP*)any_dup(ncx->blk_oldcop, param->proto_perl);
12688 switch (CxTYPE(ncx)) {
12690 ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
12691 ? cv_dup_inc(ncx->blk_sub.cv, param)
12692 : cv_dup(ncx->blk_sub.cv,param));
12693 ncx->blk_sub.argarray = (CxHASARGS(ncx)
12694 ? av_dup_inc(ncx->blk_sub.argarray,
12697 ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,
12699 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
12700 ncx->blk_sub.oldcomppad);
12703 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
12705 ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
12706 ncx->blk_eval.cv = cv_dup(ncx->blk_eval.cv, param);
12708 case CXt_LOOP_LAZYSV:
12709 ncx->blk_loop.state_u.lazysv.end
12710 = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
12711 /* We are taking advantage of av_dup_inc and sv_dup_inc
12712 actually being the same function, and order equivalence of
12714 We can assert the later [but only at run time :-(] */
12715 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
12716 (void *) &ncx->blk_loop.state_u.lazysv.cur);
12718 ncx->blk_loop.state_u.ary.ary
12719 = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
12720 case CXt_LOOP_LAZYIV:
12721 case CXt_LOOP_PLAIN:
12722 if (CxPADLOOP(ncx)) {
12723 ncx->blk_loop.itervar_u.oldcomppad
12724 = (PAD*)ptr_table_fetch(PL_ptr_table,
12725 ncx->blk_loop.itervar_u.oldcomppad);
12727 ncx->blk_loop.itervar_u.gv
12728 = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
12733 ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param);
12734 ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param);
12735 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
12750 /* duplicate a stack info structure */
12753 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
12757 PERL_ARGS_ASSERT_SI_DUP;
12760 return (PERL_SI*)NULL;
12762 /* look for it in the table first */
12763 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
12767 /* create anew and remember what it is */
12768 Newxz(nsi, 1, PERL_SI);
12769 ptr_table_store(PL_ptr_table, si, nsi);
12771 nsi->si_stack = av_dup_inc(si->si_stack, param);
12772 nsi->si_cxix = si->si_cxix;
12773 nsi->si_cxmax = si->si_cxmax;
12774 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
12775 nsi->si_type = si->si_type;
12776 nsi->si_prev = si_dup(si->si_prev, param);
12777 nsi->si_next = si_dup(si->si_next, param);
12778 nsi->si_markoff = si->si_markoff;
12783 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
12784 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
12785 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
12786 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
12787 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
12788 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
12789 #define POPUV(ss,ix) ((ss)[--(ix)].any_uv)
12790 #define TOPUV(ss,ix) ((ss)[ix].any_uv)
12791 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
12792 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
12793 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
12794 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
12795 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
12796 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
12797 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
12798 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
12801 #define pv_dup_inc(p) SAVEPV(p)
12802 #define pv_dup(p) SAVEPV(p)
12803 #define svp_dup_inc(p,pp) any_dup(p,pp)
12805 /* map any object to the new equivent - either something in the
12806 * ptr table, or something in the interpreter structure
12810 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
12814 PERL_ARGS_ASSERT_ANY_DUP;
12817 return (void*)NULL;
12819 /* look for it in the table first */
12820 ret = ptr_table_fetch(PL_ptr_table, v);
12824 /* see if it is part of the interpreter structure */
12825 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
12826 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
12834 /* duplicate the save stack */
12837 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
12840 ANY * const ss = proto_perl->Isavestack;
12841 const I32 max = proto_perl->Isavestack_max;
12842 I32 ix = proto_perl->Isavestack_ix;
12855 void (*dptr) (void*);
12856 void (*dxptr) (pTHX_ void*);
12858 PERL_ARGS_ASSERT_SS_DUP;
12860 Newxz(nss, max, ANY);
12863 const UV uv = POPUV(ss,ix);
12864 const U8 type = (U8)uv & SAVE_MASK;
12866 TOPUV(nss,ix) = uv;
12868 case SAVEt_CLEARSV:
12869 case SAVEt_CLEARPADRANGE:
12871 case SAVEt_HELEM: /* hash element */
12872 sv = (const SV *)POPPTR(ss,ix);
12873 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12875 case SAVEt_ITEM: /* normal string */
12876 case SAVEt_GVSV: /* scalar slot in GV */
12877 case SAVEt_SV: /* scalar reference */
12878 sv = (const SV *)POPPTR(ss,ix);
12879 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12882 case SAVEt_MORTALIZESV:
12883 case SAVEt_READONLY_OFF:
12884 sv = (const SV *)POPPTR(ss,ix);
12885 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12887 case SAVEt_SHARED_PVREF: /* char* in shared space */
12888 c = (char*)POPPTR(ss,ix);
12889 TOPPTR(nss,ix) = savesharedpv(c);
12890 ptr = POPPTR(ss,ix);
12891 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12893 case SAVEt_GENERIC_SVREF: /* generic sv */
12894 case SAVEt_SVREF: /* scalar reference */
12895 sv = (const SV *)POPPTR(ss,ix);
12896 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12897 ptr = POPPTR(ss,ix);
12898 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
12900 case SAVEt_GVSLOT: /* any slot in GV */
12901 sv = (const SV *)POPPTR(ss,ix);
12902 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12903 ptr = POPPTR(ss,ix);
12904 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
12905 sv = (const SV *)POPPTR(ss,ix);
12906 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12908 case SAVEt_HV: /* hash reference */
12909 case SAVEt_AV: /* array reference */
12910 sv = (const SV *) POPPTR(ss,ix);
12911 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12913 case SAVEt_COMPPAD:
12915 sv = (const SV *) POPPTR(ss,ix);
12916 TOPPTR(nss,ix) = sv_dup(sv, param);
12918 case SAVEt_INT: /* int reference */
12919 ptr = POPPTR(ss,ix);
12920 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12921 intval = (int)POPINT(ss,ix);
12922 TOPINT(nss,ix) = intval;
12924 case SAVEt_LONG: /* long reference */
12925 ptr = POPPTR(ss,ix);
12926 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12927 longval = (long)POPLONG(ss,ix);
12928 TOPLONG(nss,ix) = longval;
12930 case SAVEt_I32: /* I32 reference */
12931 ptr = POPPTR(ss,ix);
12932 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12934 TOPINT(nss,ix) = i;
12936 case SAVEt_IV: /* IV reference */
12937 case SAVEt_STRLEN: /* STRLEN/size_t ref */
12938 ptr = POPPTR(ss,ix);
12939 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12941 TOPIV(nss,ix) = iv;
12943 case SAVEt_HPTR: /* HV* reference */
12944 case SAVEt_APTR: /* AV* reference */
12945 case SAVEt_SPTR: /* SV* reference */
12946 ptr = POPPTR(ss,ix);
12947 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12948 sv = (const SV *)POPPTR(ss,ix);
12949 TOPPTR(nss,ix) = sv_dup(sv, param);
12951 case SAVEt_VPTR: /* random* reference */
12952 ptr = POPPTR(ss,ix);
12953 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12955 case SAVEt_INT_SMALL:
12956 case SAVEt_I32_SMALL:
12957 case SAVEt_I16: /* I16 reference */
12958 case SAVEt_I8: /* I8 reference */
12960 ptr = POPPTR(ss,ix);
12961 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12963 case SAVEt_GENERIC_PVREF: /* generic char* */
12964 case SAVEt_PPTR: /* char* reference */
12965 ptr = POPPTR(ss,ix);
12966 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12967 c = (char*)POPPTR(ss,ix);
12968 TOPPTR(nss,ix) = pv_dup(c);
12970 case SAVEt_GP: /* scalar reference */
12971 gp = (GP*)POPPTR(ss,ix);
12972 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
12973 (void)GpREFCNT_inc(gp);
12974 gv = (const GV *)POPPTR(ss,ix);
12975 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
12978 ptr = POPPTR(ss,ix);
12979 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
12980 /* these are assumed to be refcounted properly */
12982 switch (((OP*)ptr)->op_type) {
12984 case OP_LEAVESUBLV:
12988 case OP_LEAVEWRITE:
12989 TOPPTR(nss,ix) = ptr;
12992 (void) OpREFCNT_inc(o);
12996 TOPPTR(nss,ix) = NULL;
13001 TOPPTR(nss,ix) = NULL;
13003 case SAVEt_FREECOPHH:
13004 ptr = POPPTR(ss,ix);
13005 TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr);
13007 case SAVEt_ADELETE:
13008 av = (const AV *)POPPTR(ss,ix);
13009 TOPPTR(nss,ix) = av_dup_inc(av, param);
13011 TOPINT(nss,ix) = i;
13014 hv = (const HV *)POPPTR(ss,ix);
13015 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
13017 TOPINT(nss,ix) = i;
13020 c = (char*)POPPTR(ss,ix);
13021 TOPPTR(nss,ix) = pv_dup_inc(c);
13023 case SAVEt_STACK_POS: /* Position on Perl stack */
13025 TOPINT(nss,ix) = i;
13027 case SAVEt_DESTRUCTOR:
13028 ptr = POPPTR(ss,ix);
13029 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
13030 dptr = POPDPTR(ss,ix);
13031 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
13032 any_dup(FPTR2DPTR(void *, dptr),
13035 case SAVEt_DESTRUCTOR_X:
13036 ptr = POPPTR(ss,ix);
13037 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
13038 dxptr = POPDXPTR(ss,ix);
13039 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
13040 any_dup(FPTR2DPTR(void *, dxptr),
13043 case SAVEt_REGCONTEXT:
13045 ix -= uv >> SAVE_TIGHT_SHIFT;
13047 case SAVEt_AELEM: /* array element */
13048 sv = (const SV *)POPPTR(ss,ix);
13049 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
13051 TOPINT(nss,ix) = i;
13052 av = (const AV *)POPPTR(ss,ix);
13053 TOPPTR(nss,ix) = av_dup_inc(av, param);
13056 ptr = POPPTR(ss,ix);
13057 TOPPTR(nss,ix) = ptr;
13060 ptr = POPPTR(ss,ix);
13061 ptr = cophh_copy((COPHH*)ptr);
13062 TOPPTR(nss,ix) = ptr;
13064 TOPINT(nss,ix) = i;
13065 if (i & HINT_LOCALIZE_HH) {
13066 hv = (const HV *)POPPTR(ss,ix);
13067 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
13070 case SAVEt_PADSV_AND_MORTALIZE:
13071 longval = (long)POPLONG(ss,ix);
13072 TOPLONG(nss,ix) = longval;
13073 ptr = POPPTR(ss,ix);
13074 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
13075 sv = (const SV *)POPPTR(ss,ix);
13076 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
13078 case SAVEt_SET_SVFLAGS:
13080 TOPINT(nss,ix) = i;
13082 TOPINT(nss,ix) = i;
13083 sv = (const SV *)POPPTR(ss,ix);
13084 TOPPTR(nss,ix) = sv_dup(sv, param);
13086 case SAVEt_COMPILE_WARNINGS:
13087 ptr = POPPTR(ss,ix);
13088 TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
13091 ptr = POPPTR(ss,ix);
13092 TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
13096 "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
13104 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
13105 * flag to the result. This is done for each stash before cloning starts,
13106 * so we know which stashes want their objects cloned */
13109 do_mark_cloneable_stash(pTHX_ SV *const sv)
13111 const HEK * const hvname = HvNAME_HEK((const HV *)sv);
13113 GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
13114 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
13115 if (cloner && GvCV(cloner)) {
13122 mXPUSHs(newSVhek(hvname));
13124 call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
13131 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
13139 =for apidoc perl_clone
13141 Create and return a new interpreter by cloning the current one.
13143 perl_clone takes these flags as parameters:
13145 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
13146 without it we only clone the data and zero the stacks,
13147 with it we copy the stacks and the new perl interpreter is
13148 ready to run at the exact same point as the previous one.
13149 The pseudo-fork code uses COPY_STACKS while the
13150 threads->create doesn't.
13152 CLONEf_KEEP_PTR_TABLE -
13153 perl_clone keeps a ptr_table with the pointer of the old
13154 variable as a key and the new variable as a value,
13155 this allows it to check if something has been cloned and not
13156 clone it again but rather just use the value and increase the
13157 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
13158 the ptr_table using the function
13159 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
13160 reason to keep it around is if you want to dup some of your own
13161 variable who are outside the graph perl scans, example of this
13162 code is in threads.xs create.
13164 CLONEf_CLONE_HOST -
13165 This is a win32 thing, it is ignored on unix, it tells perls
13166 win32host code (which is c++) to clone itself, this is needed on
13167 win32 if you want to run two threads at the same time,
13168 if you just want to do some stuff in a separate perl interpreter
13169 and then throw it away and return to the original one,
13170 you don't need to do anything.
13175 /* XXX the above needs expanding by someone who actually understands it ! */
13176 EXTERN_C PerlInterpreter *
13177 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
13180 perl_clone(PerlInterpreter *proto_perl, UV flags)
13183 #ifdef PERL_IMPLICIT_SYS
13185 PERL_ARGS_ASSERT_PERL_CLONE;
13187 /* perlhost.h so we need to call into it
13188 to clone the host, CPerlHost should have a c interface, sky */
13190 if (flags & CLONEf_CLONE_HOST) {
13191 return perl_clone_host(proto_perl,flags);
13193 return perl_clone_using(proto_perl, flags,
13195 proto_perl->IMemShared,
13196 proto_perl->IMemParse,
13198 proto_perl->IStdIO,
13202 proto_perl->IProc);
13206 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
13207 struct IPerlMem* ipM, struct IPerlMem* ipMS,
13208 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
13209 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
13210 struct IPerlDir* ipD, struct IPerlSock* ipS,
13211 struct IPerlProc* ipP)
13213 /* XXX many of the string copies here can be optimized if they're
13214 * constants; they need to be allocated as common memory and just
13215 * their pointers copied. */
13218 CLONE_PARAMS clone_params;
13219 CLONE_PARAMS* const param = &clone_params;
13221 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
13223 PERL_ARGS_ASSERT_PERL_CLONE_USING;
13224 #else /* !PERL_IMPLICIT_SYS */
13226 CLONE_PARAMS clone_params;
13227 CLONE_PARAMS* param = &clone_params;
13228 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
13230 PERL_ARGS_ASSERT_PERL_CLONE;
13231 #endif /* PERL_IMPLICIT_SYS */
13233 /* for each stash, determine whether its objects should be cloned */
13234 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
13235 PERL_SET_THX(my_perl);
13238 PoisonNew(my_perl, 1, PerlInterpreter);
13241 PL_defstash = NULL; /* may be used by perl malloc() */
13244 PL_scopestack_name = 0;
13246 PL_savestack_ix = 0;
13247 PL_savestack_max = -1;
13248 PL_sig_pending = 0;
13250 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
13251 # ifdef DEBUG_LEAKING_SCALARS
13252 PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
13254 #else /* !DEBUGGING */
13255 Zero(my_perl, 1, PerlInterpreter);
13256 #endif /* DEBUGGING */
13258 #ifdef PERL_IMPLICIT_SYS
13259 /* host pointers */
13261 PL_MemShared = ipMS;
13262 PL_MemParse = ipMP;
13269 #endif /* PERL_IMPLICIT_SYS */
13272 param->flags = flags;
13273 /* Nothing in the core code uses this, but we make it available to
13274 extensions (using mg_dup). */
13275 param->proto_perl = proto_perl;
13276 /* Likely nothing will use this, but it is initialised to be consistent
13277 with Perl_clone_params_new(). */
13278 param->new_perl = my_perl;
13279 param->unreferenced = NULL;
13282 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
13284 PL_body_arenas = NULL;
13285 Zero(&PL_body_roots, 1, PL_body_roots);
13289 PL_sv_arenaroot = NULL;
13291 PL_debug = proto_perl->Idebug;
13293 /* dbargs array probably holds garbage */
13296 PL_compiling = proto_perl->Icompiling;
13298 /* pseudo environmental stuff */
13299 PL_origargc = proto_perl->Iorigargc;
13300 PL_origargv = proto_perl->Iorigargv;
13302 #if !NO_TAINT_SUPPORT
13303 /* Set tainting stuff before PerlIO_debug can possibly get called */
13304 PL_tainting = proto_perl->Itainting;
13305 PL_taint_warn = proto_perl->Itaint_warn;
13307 PL_tainting = FALSE;
13308 PL_taint_warn = FALSE;
13311 PL_minus_c = proto_perl->Iminus_c;
13313 PL_localpatches = proto_perl->Ilocalpatches;
13314 PL_splitstr = proto_perl->Isplitstr;
13315 PL_minus_n = proto_perl->Iminus_n;
13316 PL_minus_p = proto_perl->Iminus_p;
13317 PL_minus_l = proto_perl->Iminus_l;
13318 PL_minus_a = proto_perl->Iminus_a;
13319 PL_minus_E = proto_perl->Iminus_E;
13320 PL_minus_F = proto_perl->Iminus_F;
13321 PL_doswitches = proto_perl->Idoswitches;
13322 PL_dowarn = proto_perl->Idowarn;
13323 #ifdef PERL_SAWAMPERSAND
13324 PL_sawampersand = proto_perl->Isawampersand;
13326 PL_unsafe = proto_perl->Iunsafe;
13327 PL_perldb = proto_perl->Iperldb;
13328 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
13329 PL_exit_flags = proto_perl->Iexit_flags;
13331 /* XXX time(&PL_basetime) when asked for? */
13332 PL_basetime = proto_perl->Ibasetime;
13334 PL_maxsysfd = proto_perl->Imaxsysfd;
13335 PL_statusvalue = proto_perl->Istatusvalue;
13337 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
13339 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
13342 /* RE engine related */
13343 PL_regmatch_slab = NULL;
13344 PL_reg_curpm = NULL;
13346 PL_sub_generation = proto_perl->Isub_generation;
13348 /* funky return mechanisms */
13349 PL_forkprocess = proto_perl->Iforkprocess;
13351 /* internal state */
13352 PL_maxo = proto_perl->Imaxo;
13354 PL_main_start = proto_perl->Imain_start;
13355 PL_eval_root = proto_perl->Ieval_root;
13356 PL_eval_start = proto_perl->Ieval_start;
13358 PL_filemode = proto_perl->Ifilemode;
13359 PL_lastfd = proto_perl->Ilastfd;
13360 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
13363 PL_gensym = proto_perl->Igensym;
13365 PL_laststatval = proto_perl->Ilaststatval;
13366 PL_laststype = proto_perl->Ilaststype;
13369 PL_profiledata = NULL;
13371 PL_generation = proto_perl->Igeneration;
13373 PL_in_clean_objs = proto_perl->Iin_clean_objs;
13374 PL_in_clean_all = proto_perl->Iin_clean_all;
13376 PL_delaymagic_uid = proto_perl->Idelaymagic_uid;
13377 PL_delaymagic_euid = proto_perl->Idelaymagic_euid;
13378 PL_delaymagic_gid = proto_perl->Idelaymagic_gid;
13379 PL_delaymagic_egid = proto_perl->Idelaymagic_egid;
13380 PL_nomemok = proto_perl->Inomemok;
13381 PL_an = proto_perl->Ian;
13382 PL_evalseq = proto_perl->Ievalseq;
13383 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
13384 PL_origalen = proto_perl->Iorigalen;
13386 PL_sighandlerp = proto_perl->Isighandlerp;
13388 PL_runops = proto_perl->Irunops;
13390 PL_subline = proto_perl->Isubline;
13393 PL_cryptseen = proto_perl->Icryptseen;
13396 #ifdef USE_LOCALE_COLLATE
13397 PL_collation_ix = proto_perl->Icollation_ix;
13398 PL_collation_standard = proto_perl->Icollation_standard;
13399 PL_collxfrm_base = proto_perl->Icollxfrm_base;
13400 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
13401 #endif /* USE_LOCALE_COLLATE */
13403 #ifdef USE_LOCALE_NUMERIC
13404 PL_numeric_standard = proto_perl->Inumeric_standard;
13405 PL_numeric_local = proto_perl->Inumeric_local;
13406 #endif /* !USE_LOCALE_NUMERIC */
13408 /* Did the locale setup indicate UTF-8? */
13409 PL_utf8locale = proto_perl->Iutf8locale;
13410 /* Unicode features (see perlrun/-C) */
13411 PL_unicode = proto_perl->Iunicode;
13413 /* Pre-5.8 signals control */
13414 PL_signals = proto_perl->Isignals;
13416 /* times() ticks per second */
13417 PL_clocktick = proto_perl->Iclocktick;
13419 /* Recursion stopper for PerlIO_find_layer */
13420 PL_in_load_module = proto_perl->Iin_load_module;
13422 /* sort() routine */
13423 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
13425 /* Not really needed/useful since the reenrant_retint is "volatile",
13426 * but do it for consistency's sake. */
13427 PL_reentrant_retint = proto_perl->Ireentrant_retint;
13429 /* Hooks to shared SVs and locks. */
13430 PL_sharehook = proto_perl->Isharehook;
13431 PL_lockhook = proto_perl->Ilockhook;
13432 PL_unlockhook = proto_perl->Iunlockhook;
13433 PL_threadhook = proto_perl->Ithreadhook;
13434 PL_destroyhook = proto_perl->Idestroyhook;
13435 PL_signalhook = proto_perl->Isignalhook;
13437 PL_globhook = proto_perl->Iglobhook;
13440 PL_last_swash_hv = NULL; /* reinits on demand */
13441 PL_last_swash_klen = 0;
13442 PL_last_swash_key[0]= '\0';
13443 PL_last_swash_tmps = (U8*)NULL;
13444 PL_last_swash_slen = 0;
13446 PL_srand_called = proto_perl->Isrand_called;
13447 Copy(&(proto_perl->Irandom_state), &PL_random_state, 1, PL_RANDOM_STATE_TYPE);
13449 if (flags & CLONEf_COPY_STACKS) {
13450 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
13451 PL_tmps_ix = proto_perl->Itmps_ix;
13452 PL_tmps_max = proto_perl->Itmps_max;
13453 PL_tmps_floor = proto_perl->Itmps_floor;
13455 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
13456 * NOTE: unlike the others! */
13457 PL_scopestack_ix = proto_perl->Iscopestack_ix;
13458 PL_scopestack_max = proto_perl->Iscopestack_max;
13460 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
13461 * NOTE: unlike the others! */
13462 PL_savestack_ix = proto_perl->Isavestack_ix;
13463 PL_savestack_max = proto_perl->Isavestack_max;
13466 PL_start_env = proto_perl->Istart_env; /* XXXXXX */
13467 PL_top_env = &PL_start_env;
13469 PL_op = proto_perl->Iop;
13472 PL_Xpv = (XPV*)NULL;
13473 my_perl->Ina = proto_perl->Ina;
13475 PL_statbuf = proto_perl->Istatbuf;
13476 PL_statcache = proto_perl->Istatcache;
13479 PL_timesbuf = proto_perl->Itimesbuf;
13482 #if !NO_TAINT_SUPPORT
13483 PL_tainted = proto_perl->Itainted;
13485 PL_tainted = FALSE;
13487 PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
13489 PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
13491 PL_restartjmpenv = proto_perl->Irestartjmpenv;
13492 PL_restartop = proto_perl->Irestartop;
13493 PL_in_eval = proto_perl->Iin_eval;
13494 PL_delaymagic = proto_perl->Idelaymagic;
13495 PL_phase = proto_perl->Iphase;
13496 PL_localizing = proto_perl->Ilocalizing;
13498 PL_hv_fetch_ent_mh = NULL;
13499 PL_modcount = proto_perl->Imodcount;
13500 PL_lastgotoprobe = NULL;
13501 PL_dumpindent = proto_perl->Idumpindent;
13503 PL_efloatbuf = NULL; /* reinits on demand */
13504 PL_efloatsize = 0; /* reinits on demand */
13508 PL_colorset = 0; /* reinits PL_colors[] */
13509 /*PL_colors[6] = {0,0,0,0,0,0};*/
13511 /* Pluggable optimizer */
13512 PL_peepp = proto_perl->Ipeepp;
13513 PL_rpeepp = proto_perl->Irpeepp;
13514 /* op_free() hook */
13515 PL_opfreehook = proto_perl->Iopfreehook;
13517 #ifdef USE_REENTRANT_API
13518 /* XXX: things like -Dm will segfault here in perlio, but doing
13519 * PERL_SET_CONTEXT(proto_perl);
13520 * breaks too many other things
13522 Perl_reentrant_init(aTHX);
13525 /* create SV map for pointer relocation */
13526 PL_ptr_table = ptr_table_new();
13528 /* initialize these special pointers as early as possible */
13530 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
13531 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
13532 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
13534 /* create (a non-shared!) shared string table */
13535 PL_strtab = newHV();
13536 HvSHAREKEYS_off(PL_strtab);
13537 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
13538 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
13540 Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*);
13542 /* This PV will be free'd special way so must set it same way op.c does */
13543 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
13544 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
13546 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
13547 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
13548 CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling)));
13549 PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
13551 param->stashes = newAV(); /* Setup array of objects to call clone on */
13552 /* This makes no difference to the implementation, as it always pushes
13553 and shifts pointers to other SVs without changing their reference
13554 count, with the array becoming empty before it is freed. However, it
13555 makes it conceptually clear what is going on, and will avoid some
13556 work inside av.c, filling slots between AvFILL() and AvMAX() with
13557 &PL_sv_undef, and SvREFCNT_dec()ing those. */
13558 AvREAL_off(param->stashes);
13560 if (!(flags & CLONEf_COPY_STACKS)) {
13561 param->unreferenced = newAV();
13564 #ifdef PERLIO_LAYERS
13565 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
13566 PerlIO_clone(aTHX_ proto_perl, param);
13569 PL_envgv = gv_dup_inc(proto_perl->Ienvgv, param);
13570 PL_incgv = gv_dup_inc(proto_perl->Iincgv, param);
13571 PL_hintgv = gv_dup_inc(proto_perl->Ihintgv, param);
13572 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
13573 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
13574 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
13577 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
13578 PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param);
13579 PL_inplace = SAVEPV(proto_perl->Iinplace);
13580 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
13582 /* magical thingies */
13584 PL_encoding = sv_dup(proto_perl->Iencoding, param);
13586 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
13587 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
13588 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
13591 /* Clone the regex array */
13592 /* ORANGE FIXME for plugins, probably in the SV dup code.
13593 newSViv(PTR2IV(CALLREGDUPE(
13594 INT2PTR(REGEXP *, SvIVX(regex)), param))))
13596 PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
13597 PL_regex_pad = AvARRAY(PL_regex_padav);
13599 PL_stashpadmax = proto_perl->Istashpadmax;
13600 PL_stashpadix = proto_perl->Istashpadix ;
13601 Newx(PL_stashpad, PL_stashpadmax, HV *);
13604 for (; o < PL_stashpadmax; ++o)
13605 PL_stashpad[o] = hv_dup(proto_perl->Istashpad[o], param);
13608 /* shortcuts to various I/O objects */
13609 PL_ofsgv = gv_dup_inc(proto_perl->Iofsgv, param);
13610 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
13611 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
13612 PL_defgv = gv_dup(proto_perl->Idefgv, param);
13613 PL_argvgv = gv_dup_inc(proto_perl->Iargvgv, param);
13614 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
13615 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
13617 /* shortcuts to regexp stuff */
13618 PL_replgv = gv_dup_inc(proto_perl->Ireplgv, param);
13620 /* shortcuts to misc objects */
13621 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
13623 /* shortcuts to debugging objects */
13624 PL_DBgv = gv_dup_inc(proto_perl->IDBgv, param);
13625 PL_DBline = gv_dup_inc(proto_perl->IDBline, param);
13626 PL_DBsub = gv_dup_inc(proto_perl->IDBsub, param);
13627 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
13628 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
13629 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
13631 /* symbol tables */
13632 PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
13633 PL_curstash = hv_dup_inc(proto_perl->Icurstash, param);
13634 PL_debstash = hv_dup(proto_perl->Idebstash, param);
13635 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
13636 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
13638 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
13639 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
13640 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
13641 PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
13642 PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
13643 PL_endav = av_dup_inc(proto_perl->Iendav, param);
13644 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
13645 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
13647 PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
13649 /* subprocess state */
13650 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
13652 if (proto_perl->Iop_mask)
13653 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
13656 /* PL_asserting = proto_perl->Iasserting; */
13658 /* current interpreter roots */
13659 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
13661 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
13664 /* runtime control stuff */
13665 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
13667 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
13669 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
13671 /* interpreter atexit processing */
13672 PL_exitlistlen = proto_perl->Iexitlistlen;
13673 if (PL_exitlistlen) {
13674 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
13675 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
13678 PL_exitlist = (PerlExitListEntry*)NULL;
13680 PL_my_cxt_size = proto_perl->Imy_cxt_size;
13681 if (PL_my_cxt_size) {
13682 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
13683 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
13684 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
13685 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
13686 Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
13690 PL_my_cxt_list = (void**)NULL;
13691 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
13692 PL_my_cxt_keys = (const char**)NULL;
13695 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
13696 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
13697 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
13698 PL_custom_ops = hv_dup_inc(proto_perl->Icustom_ops, param);
13700 PL_compcv = cv_dup(proto_perl->Icompcv, param);
13702 PAD_CLONE_VARS(proto_perl, param);
13704 #ifdef HAVE_INTERP_INTERN
13705 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
13708 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
13710 #ifdef PERL_USES_PL_PIDSTATUS
13711 PL_pidstatus = newHV(); /* XXX flag for cloning? */
13713 PL_osname = SAVEPV(proto_perl->Iosname);
13714 PL_parser = parser_dup(proto_perl->Iparser, param);
13716 /* XXX this only works if the saved cop has already been cloned */
13717 if (proto_perl->Iparser) {
13718 PL_parser->saved_curcop = (COP*)any_dup(
13719 proto_perl->Iparser->saved_curcop,
13723 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
13725 #ifdef USE_LOCALE_COLLATE
13726 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
13727 #endif /* USE_LOCALE_COLLATE */
13729 #ifdef USE_LOCALE_NUMERIC
13730 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
13731 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
13732 #endif /* !USE_LOCALE_NUMERIC */
13734 /* Unicode inversion lists */
13735 PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
13736 PL_UpperLatin1 = sv_dup_inc(proto_perl->IUpperLatin1, param);
13737 PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param);
13739 PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param);
13740 PL_HasMultiCharFold= sv_dup_inc(proto_perl->IHasMultiCharFold, param);
13742 /* utf8 character class swashes */
13743 for (i = 0; i < POSIX_SWASH_COUNT; i++) {
13744 PL_utf8_swash_ptrs[i] = sv_dup_inc(proto_perl->Iutf8_swash_ptrs[i], param);
13746 for (i = 0; i < POSIX_CC_COUNT; i++) {
13747 PL_Posix_ptrs[i] = sv_dup_inc(proto_perl->IPosix_ptrs[i], param);
13748 PL_L1Posix_ptrs[i] = sv_dup_inc(proto_perl->IL1Posix_ptrs[i], param);
13749 PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param);
13751 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
13752 PL_utf8_X_regular_begin = sv_dup_inc(proto_perl->Iutf8_X_regular_begin, param);
13753 PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
13754 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
13755 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
13756 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
13757 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
13758 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
13759 PL_utf8_xidstart = sv_dup_inc(proto_perl->Iutf8_xidstart, param);
13760 PL_utf8_perl_idstart = sv_dup_inc(proto_perl->Iutf8_perl_idstart, param);
13761 PL_utf8_perl_idcont = sv_dup_inc(proto_perl->Iutf8_perl_idcont, param);
13762 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
13763 PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param);
13764 PL_utf8_foldable = sv_dup_inc(proto_perl->Iutf8_foldable, param);
13765 PL_utf8_charname_begin = sv_dup_inc(proto_perl->Iutf8_charname_begin, param);
13766 PL_utf8_charname_continue = sv_dup_inc(proto_perl->Iutf8_charname_continue, param);
13768 if (proto_perl->Ipsig_pend) {
13769 Newxz(PL_psig_pend, SIG_SIZE, int);
13772 PL_psig_pend = (int*)NULL;
13775 if (proto_perl->Ipsig_name) {
13776 Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
13777 sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
13779 PL_psig_ptr = PL_psig_name + SIG_SIZE;
13782 PL_psig_ptr = (SV**)NULL;
13783 PL_psig_name = (SV**)NULL;
13786 if (flags & CLONEf_COPY_STACKS) {
13787 Newx(PL_tmps_stack, PL_tmps_max, SV*);
13788 sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
13789 PL_tmps_ix+1, param);
13791 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
13792 i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
13793 Newxz(PL_markstack, i, I32);
13794 PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
13795 - proto_perl->Imarkstack);
13796 PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
13797 - proto_perl->Imarkstack);
13798 Copy(proto_perl->Imarkstack, PL_markstack,
13799 PL_markstack_ptr - PL_markstack + 1, I32);
13801 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
13802 * NOTE: unlike the others! */
13803 Newxz(PL_scopestack, PL_scopestack_max, I32);
13804 Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
13807 Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
13808 Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
13810 /* reset stack AV to correct length before its duped via
13811 * PL_curstackinfo */
13812 AvFILLp(proto_perl->Icurstack) =
13813 proto_perl->Istack_sp - proto_perl->Istack_base;
13815 /* NOTE: si_dup() looks at PL_markstack */
13816 PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
13818 /* PL_curstack = PL_curstackinfo->si_stack; */
13819 PL_curstack = av_dup(proto_perl->Icurstack, param);
13820 PL_mainstack = av_dup(proto_perl->Imainstack, param);
13822 /* next PUSHs() etc. set *(PL_stack_sp+1) */
13823 PL_stack_base = AvARRAY(PL_curstack);
13824 PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp
13825 - proto_perl->Istack_base);
13826 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
13828 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
13829 PL_savestack = ss_dup(proto_perl, param);
13833 ENTER; /* perl_destruct() wants to LEAVE; */
13836 PL_statgv = gv_dup(proto_perl->Istatgv, param);
13837 PL_statname = sv_dup_inc(proto_perl->Istatname, param);
13839 PL_rs = sv_dup_inc(proto_perl->Irs, param);
13840 PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
13841 PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
13842 PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
13843 PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
13844 PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
13846 PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
13848 PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
13849 PL_firstgv = gv_dup_inc(proto_perl->Ifirstgv, param);
13850 PL_secondgv = gv_dup_inc(proto_perl->Isecondgv, param);
13852 PL_stashcache = newHV();
13854 PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
13855 proto_perl->Iwatchaddr);
13856 PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
13857 if (PL_debug && PL_watchaddr) {
13858 PerlIO_printf(Perl_debug_log,
13859 "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
13860 PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
13861 PTR2UV(PL_watchok));
13864 PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
13865 PL_blockhooks = av_dup_inc(proto_perl->Iblockhooks, param);
13866 PL_utf8_foldclosures = hv_dup_inc(proto_perl->Iutf8_foldclosures, param);
13868 /* Call the ->CLONE method, if it exists, for each of the stashes
13869 identified by sv_dup() above.
13871 while(av_len(param->stashes) != -1) {
13872 HV* const stash = MUTABLE_HV(av_shift(param->stashes));
13873 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
13874 if (cloner && GvCV(cloner)) {
13879 mXPUSHs(newSVhek(HvNAME_HEK(stash)));
13881 call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
13887 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
13888 ptr_table_free(PL_ptr_table);
13889 PL_ptr_table = NULL;
13892 if (!(flags & CLONEf_COPY_STACKS)) {
13893 unreferenced_to_tmp_stack(param->unreferenced);
13896 SvREFCNT_dec(param->stashes);
13898 /* orphaned? eg threads->new inside BEGIN or use */
13899 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
13900 SvREFCNT_inc_simple_void(PL_compcv);
13901 SAVEFREESV(PL_compcv);
13908 S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
13910 PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK;
13912 if (AvFILLp(unreferenced) > -1) {
13913 SV **svp = AvARRAY(unreferenced);
13914 SV **const last = svp + AvFILLp(unreferenced);
13918 if (SvREFCNT(*svp) == 1)
13920 } while (++svp <= last);
13922 EXTEND_MORTAL(count);
13923 svp = AvARRAY(unreferenced);
13926 if (SvREFCNT(*svp) == 1) {
13927 /* Our reference is the only one to this SV. This means that
13928 in this thread, the scalar effectively has a 0 reference.
13929 That doesn't work (cleanup never happens), so donate our
13930 reference to it onto the save stack. */
13931 PL_tmps_stack[++PL_tmps_ix] = *svp;
13933 /* As an optimisation, because we are already walking the
13934 entire array, instead of above doing either
13935 SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
13936 release our reference to the scalar, so that at the end of
13937 the array owns zero references to the scalars it happens to
13938 point to. We are effectively converting the array from
13939 AvREAL() on to AvREAL() off. This saves the av_clear()
13940 (triggered by the SvREFCNT_dec(unreferenced) below) from
13941 walking the array a second time. */
13942 SvREFCNT_dec(*svp);
13945 } while (++svp <= last);
13946 AvREAL_off(unreferenced);
13948 SvREFCNT_dec_NN(unreferenced);
13952 Perl_clone_params_del(CLONE_PARAMS *param)
13954 /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT
13956 PerlInterpreter *const to = param->new_perl;
13958 PerlInterpreter *const was = PERL_GET_THX;
13960 PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
13966 SvREFCNT_dec(param->stashes);
13967 if (param->unreferenced)
13968 unreferenced_to_tmp_stack(param->unreferenced);
13978 Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
13981 /* Need to play this game, as newAV() can call safesysmalloc(), and that
13982 does a dTHX; to get the context from thread local storage.
13983 FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
13984 a version that passes in my_perl. */
13985 PerlInterpreter *const was = PERL_GET_THX;
13986 CLONE_PARAMS *param;
13988 PERL_ARGS_ASSERT_CLONE_PARAMS_NEW;
13994 /* Given that we've set the context, we can do this unshared. */
13995 Newx(param, 1, CLONE_PARAMS);
13998 param->proto_perl = from;
13999 param->new_perl = to;
14000 param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
14001 AvREAL_off(param->stashes);
14002 param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
14010 #endif /* USE_ITHREADS */
14013 Perl_init_constants(pTHX)
14015 SvREFCNT(&PL_sv_undef) = SvREFCNT_IMMORTAL;
14016 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
14017 SvANY(&PL_sv_undef) = NULL;
14019 SvANY(&PL_sv_no) = new_XPVNV();
14020 SvREFCNT(&PL_sv_no) = SvREFCNT_IMMORTAL;
14021 SvFLAGS(&PL_sv_no) = SVt_PVNV|SVf_READONLY
14022 |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
14025 SvANY(&PL_sv_yes) = new_XPVNV();
14026 SvREFCNT(&PL_sv_yes) = SvREFCNT_IMMORTAL;
14027 SvFLAGS(&PL_sv_yes) = SVt_PVNV|SVf_READONLY
14028 |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
14031 SvPV_set(&PL_sv_no, (char*)PL_No);
14032 SvCUR_set(&PL_sv_no, 0);
14033 SvLEN_set(&PL_sv_no, 0);
14034 SvIV_set(&PL_sv_no, 0);
14035 SvNV_set(&PL_sv_no, 0);
14037 SvPV_set(&PL_sv_yes, (char*)PL_Yes);
14038 SvCUR_set(&PL_sv_yes, 1);
14039 SvLEN_set(&PL_sv_yes, 0);
14040 SvIV_set(&PL_sv_yes, 1);
14041 SvNV_set(&PL_sv_yes, 1);
14045 =head1 Unicode Support
14047 =for apidoc sv_recode_to_utf8
14049 The encoding is assumed to be an Encode object, on entry the PV
14050 of the sv is assumed to be octets in that encoding, and the sv
14051 will be converted into Unicode (and UTF-8).
14053 If the sv already is UTF-8 (or if it is not POK), or if the encoding
14054 is not a reference, nothing is done to the sv. If the encoding is not
14055 an C<Encode::XS> Encoding object, bad things will happen.
14056 (See F<lib/encoding.pm> and L<Encode>.)
14058 The PV of the sv is returned.
14063 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
14067 PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
14069 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
14083 Passing sv_yes is wrong - it needs to be or'ed set of constants
14084 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
14085 remove converted chars from source.
14087 Both will default the value - let them.
14089 XPUSHs(&PL_sv_yes);
14092 call_method("decode", G_SCALAR);
14096 s = SvPV_const(uni, len);
14097 if (s != SvPVX_const(sv)) {
14098 SvGROW(sv, len + 1);
14099 Move(s, SvPVX(sv), len + 1, char);
14100 SvCUR_set(sv, len);
14104 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
14105 /* clear pos and any utf8 cache */
14106 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
14109 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
14110 magic_setutf8(sv,mg); /* clear UTF8 cache */
14115 return SvPOKp(sv) ? SvPVX(sv) : NULL;
14119 =for apidoc sv_cat_decode
14121 The encoding is assumed to be an Encode object, the PV of the ssv is
14122 assumed to be octets in that encoding and decoding the input starts
14123 from the position which (PV + *offset) pointed to. The dsv will be
14124 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
14125 when the string tstr appears in decoding output or the input ends on
14126 the PV of the ssv. The value which the offset points will be modified
14127 to the last input position on the ssv.
14129 Returns TRUE if the terminator was found, else returns FALSE.
14134 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
14135 SV *ssv, int *offset, char *tstr, int tlen)
14140 PERL_ARGS_ASSERT_SV_CAT_DECODE;
14142 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
14153 offsv = newSViv(*offset);
14155 mPUSHp(tstr, tlen);
14157 call_method("cat_decode", G_SCALAR);
14159 ret = SvTRUE(TOPs);
14160 *offset = SvIV(offsv);
14166 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
14171 /* ---------------------------------------------------------------------
14173 * support functions for report_uninit()
14176 /* the maxiumum size of array or hash where we will scan looking
14177 * for the undefined element that triggered the warning */
14179 #define FUV_MAX_SEARCH_SIZE 1000
14181 /* Look for an entry in the hash whose value has the same SV as val;
14182 * If so, return a mortal copy of the key. */
14185 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
14191 PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
14193 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
14194 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
14197 array = HvARRAY(hv);
14199 for (i=HvMAX(hv); i>=0; i--) {
14201 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
14202 if (HeVAL(entry) != val)
14204 if ( HeVAL(entry) == &PL_sv_undef ||
14205 HeVAL(entry) == &PL_sv_placeholder)
14209 if (HeKLEN(entry) == HEf_SVKEY)
14210 return sv_mortalcopy(HeKEY_sv(entry));
14211 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
14217 /* Look for an entry in the array whose value has the same SV as val;
14218 * If so, return the index, otherwise return -1. */
14221 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
14225 PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
14227 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
14228 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
14231 if (val != &PL_sv_undef) {
14232 SV ** const svp = AvARRAY(av);
14235 for (i=AvFILLp(av); i>=0; i--)
14242 /* varname(): return the name of a variable, optionally with a subscript.
14243 * If gv is non-zero, use the name of that global, along with gvtype (one
14244 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
14245 * targ. Depending on the value of the subscript_type flag, return:
14248 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
14249 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
14250 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
14251 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
14254 Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
14255 const SV *const keyname, I32 aindex, int subscript_type)
14258 SV * const name = sv_newmortal();
14259 if (gv && isGV(gv)) {
14261 buffer[0] = gvtype;
14264 /* as gv_fullname4(), but add literal '^' for $^FOO names */
14266 gv_fullname4(name, gv, buffer, 0);
14268 if ((unsigned int)SvPVX(name)[1] <= 26) {
14270 buffer[1] = SvPVX(name)[1] + 'A' - 1;
14272 /* Swap the 1 unprintable control character for the 2 byte pretty
14273 version - ie substr($name, 1, 1) = $buffer; */
14274 sv_insert(name, 1, 1, buffer, 2);
14278 CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL);
14282 assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
14284 if (!cv || !CvPADLIST(cv))
14286 av = *PadlistARRAY(CvPADLIST(cv));
14287 sv = *av_fetch(av, targ, FALSE);
14288 sv_setsv_flags(name, sv, 0);
14291 if (subscript_type == FUV_SUBSCRIPT_HASH) {
14292 SV * const sv = newSV(0);
14293 *SvPVX(name) = '$';
14294 Perl_sv_catpvf(aTHX_ name, "{%s}",
14295 pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL,
14296 PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT ));
14297 SvREFCNT_dec_NN(sv);
14299 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
14300 *SvPVX(name) = '$';
14301 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
14303 else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
14304 /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
14305 Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
14313 =for apidoc find_uninit_var
14315 Find the name of the undefined variable (if any) that caused the operator
14316 to issue a "Use of uninitialized value" warning.
14317 If match is true, only return a name if its value matches uninit_sv.
14318 So roughly speaking, if a unary operator (such as OP_COS) generates a
14319 warning, then following the direct child of the op may yield an
14320 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
14321 other hand, with OP_ADD there are two branches to follow, so we only print
14322 the variable name if we get an exact match.
14324 The name is returned as a mortal SV.
14326 Assumes that PL_op is the op that originally triggered the error, and that
14327 PL_comppad/PL_curpad points to the currently executing pad.
14333 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
14339 const OP *o, *o2, *kid;
14341 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
14342 uninit_sv == &PL_sv_placeholder)))
14345 switch (obase->op_type) {
14352 const bool pad = ( obase->op_type == OP_PADAV
14353 || obase->op_type == OP_PADHV
14354 || obase->op_type == OP_PADRANGE
14357 const bool hash = ( obase->op_type == OP_PADHV
14358 || obase->op_type == OP_RV2HV
14359 || (obase->op_type == OP_PADRANGE
14360 && SvTYPE(PAD_SVl(obase->op_targ)) == SVt_PVHV)
14364 int subscript_type = FUV_SUBSCRIPT_WITHIN;
14366 if (pad) { /* @lex, %lex */
14367 sv = PAD_SVl(obase->op_targ);
14371 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
14372 /* @global, %global */
14373 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
14376 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
14378 else if (obase == PL_op) /* @{expr}, %{expr} */
14379 return find_uninit_var(cUNOPx(obase)->op_first,
14381 else /* @{expr}, %{expr} as a sub-expression */
14385 /* attempt to find a match within the aggregate */
14387 keysv = find_hash_subscript((const HV*)sv, uninit_sv);
14389 subscript_type = FUV_SUBSCRIPT_HASH;
14392 index = find_array_subscript((const AV *)sv, uninit_sv);
14394 subscript_type = FUV_SUBSCRIPT_ARRAY;
14397 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
14400 return varname(gv, hash ? '%' : '@', obase->op_targ,
14401 keysv, index, subscript_type);
14405 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
14407 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
14408 if (!gv || !GvSTASH(gv))
14410 if (match && (GvSV(gv) != uninit_sv))
14412 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
14415 return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1);
14418 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
14420 return varname(NULL, '$', obase->op_targ,
14421 NULL, 0, FUV_SUBSCRIPT_NONE);
14424 gv = cGVOPx_gv(obase);
14425 if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv))
14427 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
14429 case OP_AELEMFAST_LEX:
14432 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
14433 if (!av || SvRMAGICAL(av))
14435 svp = av_fetch(av, (I32)obase->op_private, FALSE);
14436 if (!svp || *svp != uninit_sv)
14439 return varname(NULL, '$', obase->op_targ,
14440 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
14443 gv = cGVOPx_gv(obase);
14448 AV *const av = GvAV(gv);
14449 if (!av || SvRMAGICAL(av))
14451 svp = av_fetch(av, (I32)obase->op_private, FALSE);
14452 if (!svp || *svp != uninit_sv)
14455 return varname(gv, '$', 0,
14456 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
14461 o = cUNOPx(obase)->op_first;
14462 if (!o || o->op_type != OP_NULL ||
14463 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
14465 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
14470 bool negate = FALSE;
14472 if (PL_op == obase)
14473 /* $a[uninit_expr] or $h{uninit_expr} */
14474 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
14477 o = cBINOPx(obase)->op_first;
14478 kid = cBINOPx(obase)->op_last;
14480 /* get the av or hv, and optionally the gv */
14482 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
14483 sv = PAD_SV(o->op_targ);
14485 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
14486 && cUNOPo->op_first->op_type == OP_GV)
14488 gv = cGVOPx_gv(cUNOPo->op_first);
14492 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
14497 if (kid && kid->op_type == OP_NEGATE) {
14499 kid = cUNOPx(kid)->op_first;
14502 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
14503 /* index is constant */
14506 kidsv = sv_2mortal(newSVpvs("-"));
14507 sv_catsv(kidsv, cSVOPx_sv(kid));
14510 kidsv = cSVOPx_sv(kid);
14514 if (obase->op_type == OP_HELEM) {
14515 HE* he = hv_fetch_ent(MUTABLE_HV(sv), kidsv, 0, 0);
14516 if (!he || HeVAL(he) != uninit_sv)
14520 SV * const opsv = cSVOPx_sv(kid);
14521 const IV opsviv = SvIV(opsv);
14522 SV * const * const svp = av_fetch(MUTABLE_AV(sv),
14523 negate ? - opsviv : opsviv,
14525 if (!svp || *svp != uninit_sv)
14529 if (obase->op_type == OP_HELEM)
14530 return varname(gv, '%', o->op_targ,
14531 kidsv, 0, FUV_SUBSCRIPT_HASH);
14533 return varname(gv, '@', o->op_targ, NULL,
14534 negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)),
14535 FUV_SUBSCRIPT_ARRAY);
14538 /* index is an expression;
14539 * attempt to find a match within the aggregate */
14540 if (obase->op_type == OP_HELEM) {
14541 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
14543 return varname(gv, '%', o->op_targ,
14544 keysv, 0, FUV_SUBSCRIPT_HASH);
14548 = find_array_subscript((const AV *)sv, uninit_sv);
14550 return varname(gv, '@', o->op_targ,
14551 NULL, index, FUV_SUBSCRIPT_ARRAY);
14556 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
14558 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
14564 /* only examine RHS */
14565 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
14568 o = cUNOPx(obase)->op_first;
14569 if ( o->op_type == OP_PUSHMARK
14570 || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)
14574 if (!o->op_sibling) {
14575 /* one-arg version of open is highly magical */
14577 if (o->op_type == OP_GV) { /* open FOO; */
14579 if (match && GvSV(gv) != uninit_sv)
14581 return varname(gv, '$', 0,
14582 NULL, 0, FUV_SUBSCRIPT_NONE);
14584 /* other possibilities not handled are:
14585 * open $x; or open my $x; should return '${*$x}'
14586 * open expr; should return '$'.expr ideally
14592 /* ops where $_ may be an implicit arg */
14597 if ( !(obase->op_flags & OPf_STACKED)) {
14598 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
14599 ? PAD_SVl(obase->op_targ)
14602 sv = sv_newmortal();
14603 sv_setpvs(sv, "$_");
14612 match = 1; /* print etc can return undef on defined args */
14613 /* skip filehandle as it can't produce 'undef' warning */
14614 o = cUNOPx(obase)->op_first;
14615 if ((obase->op_flags & OPf_STACKED)
14617 ( o->op_type == OP_PUSHMARK
14618 || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)))
14619 o = o->op_sibling->op_sibling;
14623 case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
14624 case OP_CUSTOM: /* XS or custom code could trigger random warnings */
14626 /* the following ops are capable of returning PL_sv_undef even for
14627 * defined arg(s) */
14646 case OP_GETPEERNAME:
14694 case OP_SMARTMATCH:
14703 /* XXX tmp hack: these two may call an XS sub, and currently
14704 XS subs don't have a SUB entry on the context stack, so CV and
14705 pad determination goes wrong, and BAD things happen. So, just
14706 don't try to determine the value under those circumstances.
14707 Need a better fix at dome point. DAPM 11/2007 */
14713 GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
14714 if (gv && GvSV(gv) == uninit_sv)
14715 return newSVpvs_flags("$.", SVs_TEMP);
14720 /* def-ness of rval pos() is independent of the def-ness of its arg */
14721 if ( !(obase->op_flags & OPf_MOD))
14726 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
14727 return newSVpvs_flags("${$/}", SVs_TEMP);
14732 if (!(obase->op_flags & OPf_KIDS))
14734 o = cUNOPx(obase)->op_first;
14740 /* This loop checks all the kid ops, skipping any that cannot pos-
14741 * sibly be responsible for the uninitialized value; i.e., defined
14742 * constants and ops that return nothing. If there is only one op
14743 * left that is not skipped, then we *know* it is responsible for
14744 * the uninitialized value. If there is more than one op left, we
14745 * have to look for an exact match in the while() loop below.
14746 * Note that we skip padrange, because the individual pad ops that
14747 * it replaced are still in the tree, so we work on them instead.
14750 for (kid=o; kid; kid = kid->op_sibling) {
14752 const OPCODE type = kid->op_type;
14753 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
14754 || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
14755 || (type == OP_PUSHMARK)
14756 || (type == OP_PADRANGE)
14760 if (o2) { /* more than one found */
14767 return find_uninit_var(o2, uninit_sv, match);
14769 /* scan all args */
14771 sv = find_uninit_var(o, uninit_sv, 1);
14783 =for apidoc report_uninit
14785 Print appropriate "Use of uninitialized variable" warning.
14791 Perl_report_uninit(pTHX_ const SV *uninit_sv)
14795 SV* varname = NULL;
14796 if (uninit_sv && PL_curpad) {
14797 varname = find_uninit_var(PL_op, uninit_sv,0);
14799 sv_insert(varname, 0, 0, " ", 1);
14801 /* diag_listed_as: Use of uninitialized value%s */
14802 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
14803 SVfARG(varname ? varname : &PL_sv_no),
14804 " in ", OP_DESC(PL_op));
14807 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
14813 * c-indentation-style: bsd
14814 * c-basic-offset: 4
14815 * indent-tabs-mode: nil
14818 * ex: set ts=8 sts=4 sw=4 et: