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)
47 /* Missing proto on LynxOS */
48 char *gconvert(double, int, int, char *);
51 #ifdef PERL_UTF8_CACHE_ASSERT
52 /* if adding more checks watch out for the following tests:
53 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
54 * lib/utf8.t lib/Unicode/Collate/t/index.t
57 # define ASSERT_UTF8_CACHE(cache) \
58 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
59 assert((cache)[2] <= (cache)[3]); \
60 assert((cache)[3] <= (cache)[1]);} \
63 # define ASSERT_UTF8_CACHE(cache) NOOP
66 #ifdef PERL_OLD_COPY_ON_WRITE
67 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
68 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
69 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
73 /* ============================================================================
75 =head1 Allocation and deallocation of SVs.
77 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
78 sv, av, hv...) contains type and reference count information, and for
79 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
80 contains fields specific to each type. Some types store all they need
81 in the head, so don't have a body.
83 In all but the most memory-paranoid configurations (ex: PURIFY), heads
84 and bodies are allocated out of arenas, which by default are
85 approximately 4K chunks of memory parcelled up into N heads or bodies.
86 Sv-bodies are allocated by their sv-type, guaranteeing size
87 consistency needed to allocate safely from arrays.
89 For SV-heads, the first slot in each arena is reserved, and holds a
90 link to the next arena, some flags, and a note of the number of slots.
91 Snaked through each arena chain is a linked list of free items; when
92 this becomes empty, an extra arena is allocated and divided up into N
93 items which are threaded into the free list.
95 SV-bodies are similar, but they use arena-sets by default, which
96 separate the link and info from the arena itself, and reclaim the 1st
97 slot in the arena. SV-bodies are further described later.
99 The following global variables are associated with arenas:
101 PL_sv_arenaroot pointer to list of SV arenas
102 PL_sv_root pointer to list of free SV structures
104 PL_body_arenas head of linked-list of body arenas
105 PL_body_roots[] array of pointers to list of free bodies of svtype
106 arrays are indexed by the svtype needed
108 A few special SV heads are not allocated from an arena, but are
109 instead directly created in the interpreter structure, eg PL_sv_undef.
110 The size of arenas can be changed from the default by setting
111 PERL_ARENA_SIZE appropriately at compile time.
113 The SV arena serves the secondary purpose of allowing still-live SVs
114 to be located and destroyed during final cleanup.
116 At the lowest level, the macros new_SV() and del_SV() grab and free
117 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
118 to return the SV to the free list with error checking.) new_SV() calls
119 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
120 SVs in the free list have their SvTYPE field set to all ones.
122 At the time of very final cleanup, sv_free_arenas() is called from
123 perl_destruct() to physically free all the arenas allocated since the
124 start of the interpreter.
126 The function visit() scans the SV arenas list, and calls a specified
127 function for each SV it finds which is still live - ie which has an SvTYPE
128 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
129 following functions (specified as [function that calls visit()] / [function
130 called by visit() for each SV]):
132 sv_report_used() / do_report_used()
133 dump all remaining SVs (debugging aid)
135 sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
136 do_clean_named_io_objs()
137 Attempt to free all objects pointed to by RVs,
138 and try to do the same for all objects indirectly
139 referenced by typeglobs too. Called once from
140 perl_destruct(), prior to calling sv_clean_all()
143 sv_clean_all() / do_clean_all()
144 SvREFCNT_dec(sv) each remaining SV, possibly
145 triggering an sv_free(). It also sets the
146 SVf_BREAK flag on the SV to indicate that the
147 refcnt has been artificially lowered, and thus
148 stopping sv_free() from giving spurious warnings
149 about SVs which unexpectedly have a refcnt
150 of zero. called repeatedly from perl_destruct()
151 until there are no SVs left.
153 =head2 Arena allocator API Summary
155 Private API to rest of sv.c
159 new_XPVNV(), del_XPVGV(),
164 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
168 * ========================================================================= */
171 * "A time to plant, and a time to uproot what was planted..."
175 # define MEM_LOG_NEW_SV(sv, file, line, func) \
176 Perl_mem_log_new_sv(sv, file, line, func)
177 # define MEM_LOG_DEL_SV(sv, file, line, func) \
178 Perl_mem_log_del_sv(sv, file, line, func)
180 # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP
181 # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP
184 #ifdef DEBUG_LEAKING_SCALARS
185 # define FREE_SV_DEBUG_FILE(sv) Safefree((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 ? savepv(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 register const SV * const svend = &sva[SvREFCNT(sva)];
415 for (sv = sva + 1; sv < svend; ++sv) {
416 if (SvTYPE(sv) != 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) != 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(target);
483 /* XXX Might want to check arrays, etc. */
487 /* clear any slots in a GV which hold objects - except IO;
488 * called by sv_clean_objs() for each live GV */
491 do_clean_named_objs(pTHX_ SV *const sv)
495 assert(SvTYPE(sv) == SVt_PVGV);
496 assert(isGV_with_GP(sv));
500 /* freeing GP entries may indirectly free the current GV;
501 * hold onto it while we mess with the GP slots */
504 if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
505 DEBUG_D((PerlIO_printf(Perl_debug_log,
506 "Cleaning named glob SV object:\n "), sv_dump(obj)));
510 if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
511 DEBUG_D((PerlIO_printf(Perl_debug_log,
512 "Cleaning named glob AV object:\n "), sv_dump(obj)));
516 if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
517 DEBUG_D((PerlIO_printf(Perl_debug_log,
518 "Cleaning named glob HV object:\n "), sv_dump(obj)));
522 if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
523 DEBUG_D((PerlIO_printf(Perl_debug_log,
524 "Cleaning named glob CV object:\n "), sv_dump(obj)));
528 SvREFCNT_dec(sv); /* undo the inc above */
531 /* clear any IO slots in a GV which hold objects (except stderr, defout);
532 * called by sv_clean_objs() for each live GV */
535 do_clean_named_io_objs(pTHX_ SV *const sv)
539 assert(SvTYPE(sv) == SVt_PVGV);
540 assert(isGV_with_GP(sv));
541 if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
545 if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
546 DEBUG_D((PerlIO_printf(Perl_debug_log,
547 "Cleaning named glob IO object:\n "), sv_dump(obj)));
551 SvREFCNT_dec(sv); /* undo the inc above */
554 /* Void wrapper to pass to visit() */
557 do_curse(pTHX_ SV * const sv) {
558 if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
559 || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
566 =for apidoc sv_clean_objs
568 Attempt to destroy all objects not yet freed
574 Perl_sv_clean_objs(pTHX)
578 PL_in_clean_objs = TRUE;
579 visit(do_clean_objs, SVf_ROK, SVf_ROK);
580 /* Some barnacles may yet remain, clinging to typeglobs.
581 * Run the non-IO destructors first: they may want to output
582 * error messages, close files etc */
583 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
584 visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
585 /* And if there are some very tenacious barnacles clinging to arrays,
586 closures, or what have you.... */
587 /* XXX This line breaks Tk and Gtk2. See [perl #82542].
588 visit(do_curse, SVs_OBJECT, SVs_OBJECT);
590 olddef = PL_defoutgv;
591 PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
592 if (olddef && isGV_with_GP(olddef))
593 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
594 olderr = PL_stderrgv;
595 PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
596 if (olderr && isGV_with_GP(olderr))
597 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
598 SvREFCNT_dec(olddef);
599 PL_in_clean_objs = FALSE;
602 /* called by sv_clean_all() for each live SV */
605 do_clean_all(pTHX_ SV *const sv)
608 if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
609 /* don't clean pid table and strtab */
612 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
613 SvFLAGS(sv) |= SVf_BREAK;
618 =for apidoc sv_clean_all
620 Decrement the refcnt of each remaining SV, possibly triggering a
621 cleanup. This function may have to be called multiple times to free
622 SVs which are in complex self-referential hierarchies.
628 Perl_sv_clean_all(pTHX)
632 PL_in_clean_all = TRUE;
633 cleaned = visit(do_clean_all, 0,0);
638 ARENASETS: a meta-arena implementation which separates arena-info
639 into struct arena_set, which contains an array of struct
640 arena_descs, each holding info for a single arena. By separating
641 the meta-info from the arena, we recover the 1st slot, formerly
642 borrowed for list management. The arena_set is about the size of an
643 arena, avoiding the needless malloc overhead of a naive linked-list.
645 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
646 memory in the last arena-set (1/2 on average). In trade, we get
647 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
648 smaller types). The recovery of the wasted space allows use of
649 small arenas for large, rare body types, by changing array* fields
650 in body_details_by_type[] below.
653 char *arena; /* the raw storage, allocated aligned */
654 size_t size; /* its size ~4k typ */
655 svtype utype; /* bodytype stored in arena */
660 /* Get the maximum number of elements in set[] such that struct arena_set
661 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
662 therefore likely to be 1 aligned memory page. */
664 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
665 - 2 * sizeof(int)) / sizeof (struct arena_desc))
668 struct arena_set* next;
669 unsigned int set_size; /* ie ARENAS_PER_SET */
670 unsigned int curr; /* index of next available arena-desc */
671 struct arena_desc set[ARENAS_PER_SET];
675 =for apidoc sv_free_arenas
677 Deallocate the memory used by all arenas. Note that all the individual SV
678 heads and bodies within the arenas must already have been freed.
683 Perl_sv_free_arenas(pTHX)
690 /* Free arenas here, but be careful about fake ones. (We assume
691 contiguity of the fake ones with the corresponding real ones.) */
693 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
694 svanext = MUTABLE_SV(SvANY(sva));
695 while (svanext && SvFAKE(svanext))
696 svanext = MUTABLE_SV(SvANY(svanext));
703 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
706 struct arena_set *current = aroot;
709 assert(aroot->set[i].arena);
710 Safefree(aroot->set[i].arena);
718 i = PERL_ARENA_ROOTS_SIZE;
720 PL_body_roots[i] = 0;
727 Here are mid-level routines that manage the allocation of bodies out
728 of the various arenas. There are 5 kinds of arenas:
730 1. SV-head arenas, which are discussed and handled above
731 2. regular body arenas
732 3. arenas for reduced-size bodies
735 Arena types 2 & 3 are chained by body-type off an array of
736 arena-root pointers, which is indexed by svtype. Some of the
737 larger/less used body types are malloced singly, since a large
738 unused block of them is wasteful. Also, several svtypes dont have
739 bodies; the data fits into the sv-head itself. The arena-root
740 pointer thus has a few unused root-pointers (which may be hijacked
741 later for arena types 4,5)
743 3 differs from 2 as an optimization; some body types have several
744 unused fields in the front of the structure (which are kept in-place
745 for consistency). These bodies can be allocated in smaller chunks,
746 because the leading fields arent accessed. Pointers to such bodies
747 are decremented to point at the unused 'ghost' memory, knowing that
748 the pointers are used with offsets to the real memory.
751 =head1 SV-Body Allocation
753 Allocation of SV-bodies is similar to SV-heads, differing as follows;
754 the allocation mechanism is used for many body types, so is somewhat
755 more complicated, it uses arena-sets, and has no need for still-live
758 At the outermost level, (new|del)_X*V macros return bodies of the
759 appropriate type. These macros call either (new|del)_body_type or
760 (new|del)_body_allocated macro pairs, depending on specifics of the
761 type. Most body types use the former pair, the latter pair is used to
762 allocate body types with "ghost fields".
764 "ghost fields" are fields that are unused in certain types, and
765 consequently don't need to actually exist. They are declared because
766 they're part of a "base type", which allows use of functions as
767 methods. The simplest examples are AVs and HVs, 2 aggregate types
768 which don't use the fields which support SCALAR semantics.
770 For these types, the arenas are carved up into appropriately sized
771 chunks, we thus avoid wasted memory for those unaccessed members.
772 When bodies are allocated, we adjust the pointer back in memory by the
773 size of the part not allocated, so it's as if we allocated the full
774 structure. (But things will all go boom if you write to the part that
775 is "not there", because you'll be overwriting the last members of the
776 preceding structure in memory.)
778 We calculate the correction using the STRUCT_OFFSET macro on the first
779 member present. If the allocated structure is smaller (no initial NV
780 actually allocated) then the net effect is to subtract the size of the NV
781 from the pointer, to return a new pointer as if an initial NV were actually
782 allocated. (We were using structures named *_allocated for this, but
783 this turned out to be a subtle bug, because a structure without an NV
784 could have a lower alignment constraint, but the compiler is allowed to
785 optimised accesses based on the alignment constraint of the actual pointer
786 to the full structure, for example, using a single 64 bit load instruction
787 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
789 This is the same trick as was used for NV and IV bodies. Ironically it
790 doesn't need to be used for NV bodies any more, because NV is now at
791 the start of the structure. IV bodies don't need it either, because
792 they are no longer allocated.
794 In turn, the new_body_* allocators call S_new_body(), which invokes
795 new_body_inline macro, which takes a lock, and takes a body off the
796 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
797 necessary to refresh an empty list. Then the lock is released, and
798 the body is returned.
800 Perl_more_bodies allocates a new arena, and carves it up into an array of N
801 bodies, which it strings into a linked list. It looks up arena-size
802 and body-size from the body_details table described below, thus
803 supporting the multiple body-types.
805 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
806 the (new|del)_X*V macros are mapped directly to malloc/free.
808 For each sv-type, struct body_details bodies_by_type[] carries
809 parameters which control these aspects of SV handling:
811 Arena_size determines whether arenas are used for this body type, and if
812 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
813 zero, forcing individual mallocs and frees.
815 Body_size determines how big a body is, and therefore how many fit into
816 each arena. Offset carries the body-pointer adjustment needed for
817 "ghost fields", and is used in *_allocated macros.
819 But its main purpose is to parameterize info needed in
820 Perl_sv_upgrade(). The info here dramatically simplifies the function
821 vs the implementation in 5.8.8, making it table-driven. All fields
822 are used for this, except for arena_size.
824 For the sv-types that have no bodies, arenas are not used, so those
825 PL_body_roots[sv_type] are unused, and can be overloaded. In
826 something of a special case, SVt_NULL is borrowed for HE arenas;
827 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
828 bodies_by_type[SVt_NULL] slot is not used, as the table is not
833 struct body_details {
834 U8 body_size; /* Size to allocate */
835 U8 copy; /* Size of structure to copy (may be shorter) */
837 unsigned int type : 4; /* We have space for a sanity check. */
838 unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
839 unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
840 unsigned int arena : 1; /* Allocated from an arena */
841 size_t arena_size; /* Size of arena to allocate */
849 /* With -DPURFIY we allocate everything directly, and don't use arenas.
850 This seems a rather elegant way to simplify some of the code below. */
851 #define HASARENA FALSE
853 #define HASARENA TRUE
855 #define NOARENA FALSE
857 /* Size the arenas to exactly fit a given number of bodies. A count
858 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
859 simplifying the default. If count > 0, the arena is sized to fit
860 only that many bodies, allowing arenas to be used for large, rare
861 bodies (XPVFM, XPVIO) without undue waste. The arena size is
862 limited by PERL_ARENA_SIZE, so we can safely oversize the
865 #define FIT_ARENA0(body_size) \
866 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
867 #define FIT_ARENAn(count,body_size) \
868 ( count * body_size <= PERL_ARENA_SIZE) \
869 ? count * body_size \
870 : FIT_ARENA0 (body_size)
871 #define FIT_ARENA(count,body_size) \
873 ? FIT_ARENAn (count, body_size) \
874 : FIT_ARENA0 (body_size)
876 /* Calculate the length to copy. Specifically work out the length less any
877 final padding the compiler needed to add. See the comment in sv_upgrade
878 for why copying the padding proved to be a bug. */
880 #define copy_length(type, last_member) \
881 STRUCT_OFFSET(type, last_member) \
882 + sizeof (((type*)SvANY((const SV *)0))->last_member)
884 static const struct body_details bodies_by_type[] = {
885 /* HEs use this offset for their arena. */
886 { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
888 /* The bind placeholder pretends to be an RV for now.
889 Also it's marked as "can't upgrade" to stop anyone using it before it's
891 { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
893 /* IVs are in the head, so the allocation size is 0. */
895 sizeof(IV), /* This is used to copy out the IV body. */
896 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
897 NOARENA /* IVS don't need an arena */, 0
900 /* 8 bytes on most ILP32 with IEEE doubles */
901 { sizeof(NV), sizeof(NV),
902 STRUCT_OFFSET(XPVNV, xnv_u),
903 SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
905 /* 8 bytes on most ILP32 with IEEE doubles */
906 { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
907 copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
908 + STRUCT_OFFSET(XPV, xpv_cur),
909 SVt_PV, FALSE, NONV, HASARENA,
910 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
913 { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
914 copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
915 + STRUCT_OFFSET(XPV, xpv_cur),
916 SVt_PVIV, FALSE, NONV, HASARENA,
917 FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
920 { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
921 copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
922 + STRUCT_OFFSET(XPV, xpv_cur),
923 SVt_PVNV, FALSE, HADNV, HASARENA,
924 FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
927 { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
928 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
934 SVt_REGEXP, FALSE, NONV, HASARENA,
935 FIT_ARENA(0, sizeof(regexp))
939 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
940 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
943 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
944 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
947 copy_length(XPVAV, xav_alloc),
949 SVt_PVAV, TRUE, NONV, HASARENA,
950 FIT_ARENA(0, sizeof(XPVAV)) },
953 copy_length(XPVHV, xhv_max),
955 SVt_PVHV, TRUE, NONV, HASARENA,
956 FIT_ARENA(0, sizeof(XPVHV)) },
962 SVt_PVCV, TRUE, NONV, HASARENA,
963 FIT_ARENA(0, sizeof(XPVCV)) },
968 SVt_PVFM, TRUE, NONV, NOARENA,
969 FIT_ARENA(20, sizeof(XPVFM)) },
971 /* XPVIO is 84 bytes, fits 48x */
975 SVt_PVIO, TRUE, NONV, HASARENA,
976 FIT_ARENA(24, sizeof(XPVIO)) },
979 #define new_body_allocated(sv_type) \
980 (void *)((char *)S_new_body(aTHX_ sv_type) \
981 - bodies_by_type[sv_type].offset)
983 /* return a thing to the free list */
985 #define del_body(thing, root) \
987 void ** const thing_copy = (void **)thing; \
988 *thing_copy = *root; \
989 *root = (void*)thing_copy; \
994 #define new_XNV() safemalloc(sizeof(XPVNV))
995 #define new_XPVNV() safemalloc(sizeof(XPVNV))
996 #define new_XPVMG() safemalloc(sizeof(XPVMG))
998 #define del_XPVGV(p) safefree(p)
1002 #define new_XNV() new_body_allocated(SVt_NV)
1003 #define new_XPVNV() new_body_allocated(SVt_PVNV)
1004 #define new_XPVMG() new_body_allocated(SVt_PVMG)
1006 #define del_XPVGV(p) del_body(p + bodies_by_type[SVt_PVGV].offset, \
1007 &PL_body_roots[SVt_PVGV])
1011 /* no arena for you! */
1013 #define new_NOARENA(details) \
1014 safemalloc((details)->body_size + (details)->offset)
1015 #define new_NOARENAZ(details) \
1016 safecalloc((details)->body_size + (details)->offset, 1)
1019 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
1020 const size_t arena_size)
1023 void ** const root = &PL_body_roots[sv_type];
1024 struct arena_desc *adesc;
1025 struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1029 const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1030 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1031 static bool done_sanity_check;
1033 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1034 * variables like done_sanity_check. */
1035 if (!done_sanity_check) {
1036 unsigned int i = SVt_LAST;
1038 done_sanity_check = TRUE;
1041 assert (bodies_by_type[i].type == i);
1047 /* may need new arena-set to hold new arena */
1048 if (!aroot || aroot->curr >= aroot->set_size) {
1049 struct arena_set *newroot;
1050 Newxz(newroot, 1, struct arena_set);
1051 newroot->set_size = ARENAS_PER_SET;
1052 newroot->next = aroot;
1054 PL_body_arenas = (void *) newroot;
1055 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1058 /* ok, now have arena-set with at least 1 empty/available arena-desc */
1059 curr = aroot->curr++;
1060 adesc = &(aroot->set[curr]);
1061 assert(!adesc->arena);
1063 Newx(adesc->arena, good_arena_size, char);
1064 adesc->size = good_arena_size;
1065 adesc->utype = sv_type;
1066 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
1067 curr, (void*)adesc->arena, (UV)good_arena_size));
1069 start = (char *) adesc->arena;
1071 /* Get the address of the byte after the end of the last body we can fit.
1072 Remember, this is integer division: */
1073 end = start + good_arena_size / body_size * body_size;
1075 /* computed count doesn't reflect the 1st slot reservation */
1076 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1077 DEBUG_m(PerlIO_printf(Perl_debug_log,
1078 "arena %p end %p arena-size %d (from %d) type %d "
1080 (void*)start, (void*)end, (int)good_arena_size,
1081 (int)arena_size, sv_type, (int)body_size,
1082 (int)good_arena_size / (int)body_size));
1084 DEBUG_m(PerlIO_printf(Perl_debug_log,
1085 "arena %p end %p arena-size %d type %d size %d ct %d\n",
1086 (void*)start, (void*)end,
1087 (int)arena_size, sv_type, (int)body_size,
1088 (int)good_arena_size / (int)body_size));
1090 *root = (void *)start;
1093 /* Where the next body would start: */
1094 char * const next = start + body_size;
1097 /* This is the last body: */
1098 assert(next == end);
1100 *(void **)start = 0;
1104 *(void**) start = (void *)next;
1109 /* grab a new thing from the free list, allocating more if necessary.
1110 The inline version is used for speed in hot routines, and the
1111 function using it serves the rest (unless PURIFY).
1113 #define new_body_inline(xpv, sv_type) \
1115 void ** const r3wt = &PL_body_roots[sv_type]; \
1116 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
1117 ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1118 bodies_by_type[sv_type].body_size,\
1119 bodies_by_type[sv_type].arena_size)); \
1120 *(r3wt) = *(void**)(xpv); \
1126 S_new_body(pTHX_ const svtype sv_type)
1130 new_body_inline(xpv, sv_type);
1136 static const struct body_details fake_rv =
1137 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1140 =for apidoc sv_upgrade
1142 Upgrade an SV to a more complex form. Generally adds a new body type to the
1143 SV, then copies across as much information as possible from the old body.
1144 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1150 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1155 const svtype old_type = SvTYPE(sv);
1156 const struct body_details *new_type_details;
1157 const struct body_details *old_type_details
1158 = bodies_by_type + old_type;
1159 SV *referant = NULL;
1161 PERL_ARGS_ASSERT_SV_UPGRADE;
1163 if (old_type == new_type)
1166 /* This clause was purposefully added ahead of the early return above to
1167 the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1168 inference by Nick I-S that it would fix other troublesome cases. See
1169 changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1171 Given that shared hash key scalars are no longer PVIV, but PV, there is
1172 no longer need to unshare so as to free up the IVX slot for its proper
1173 purpose. So it's safe to move the early return earlier. */
1175 if (new_type != SVt_PV && SvIsCOW(sv)) {
1176 sv_force_normal_flags(sv, 0);
1179 old_body = SvANY(sv);
1181 /* Copying structures onto other structures that have been neatly zeroed
1182 has a subtle gotcha. Consider XPVMG
1184 +------+------+------+------+------+-------+-------+
1185 | NV | CUR | LEN | IV | MAGIC | STASH |
1186 +------+------+------+------+------+-------+-------+
1187 0 4 8 12 16 20 24 28
1189 where NVs are aligned to 8 bytes, so that sizeof that structure is
1190 actually 32 bytes long, with 4 bytes of padding at the end:
1192 +------+------+------+------+------+-------+-------+------+
1193 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1194 +------+------+------+------+------+-------+-------+------+
1195 0 4 8 12 16 20 24 28 32
1197 so what happens if you allocate memory for this structure:
1199 +------+------+------+------+------+-------+-------+------+------+...
1200 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1201 +------+------+------+------+------+-------+-------+------+------+...
1202 0 4 8 12 16 20 24 28 32 36
1204 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1205 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1206 started out as zero once, but it's quite possible that it isn't. So now,
1207 rather than a nicely zeroed GP, you have it pointing somewhere random.
1210 (In fact, GP ends up pointing at a previous GP structure, because the
1211 principle cause of the padding in XPVMG getting garbage is a copy of
1212 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1213 this happens to be moot because XPVGV has been re-ordered, with GP
1214 no longer after STASH)
1216 So we are careful and work out the size of used parts of all the
1224 referant = SvRV(sv);
1225 old_type_details = &fake_rv;
1226 if (new_type == SVt_NV)
1227 new_type = SVt_PVNV;
1229 if (new_type < SVt_PVIV) {
1230 new_type = (new_type == SVt_NV)
1231 ? SVt_PVNV : SVt_PVIV;
1236 if (new_type < SVt_PVNV) {
1237 new_type = SVt_PVNV;
1241 assert(new_type > SVt_PV);
1242 assert(SVt_IV < SVt_PV);
1243 assert(SVt_NV < SVt_PV);
1250 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1251 there's no way that it can be safely upgraded, because perl.c
1252 expects to Safefree(SvANY(PL_mess_sv)) */
1253 assert(sv != PL_mess_sv);
1254 /* This flag bit is used to mean other things in other scalar types.
1255 Given that it only has meaning inside the pad, it shouldn't be set
1256 on anything that can get upgraded. */
1257 assert(!SvPAD_TYPED(sv));
1260 if (old_type_details->cant_upgrade)
1261 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1262 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1265 if (old_type > new_type)
1266 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1267 (int)old_type, (int)new_type);
1269 new_type_details = bodies_by_type + new_type;
1271 SvFLAGS(sv) &= ~SVTYPEMASK;
1272 SvFLAGS(sv) |= new_type;
1274 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1275 the return statements above will have triggered. */
1276 assert (new_type != SVt_NULL);
1279 assert(old_type == SVt_NULL);
1280 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1284 assert(old_type == SVt_NULL);
1285 SvANY(sv) = new_XNV();
1290 assert(new_type_details->body_size);
1293 assert(new_type_details->arena);
1294 assert(new_type_details->arena_size);
1295 /* This points to the start of the allocated area. */
1296 new_body_inline(new_body, new_type);
1297 Zero(new_body, new_type_details->body_size, char);
1298 new_body = ((char *)new_body) - new_type_details->offset;
1300 /* We always allocated the full length item with PURIFY. To do this
1301 we fake things so that arena is false for all 16 types.. */
1302 new_body = new_NOARENAZ(new_type_details);
1304 SvANY(sv) = new_body;
1305 if (new_type == SVt_PVAV) {
1309 if (old_type_details->body_size) {
1312 /* It will have been zeroed when the new body was allocated.
1313 Lets not write to it, in case it confuses a write-back
1319 #ifndef NODEFAULT_SHAREKEYS
1320 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1322 HvMAX(sv) = 7; /* (start with 8 buckets) */
1325 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1326 The target created by newSVrv also is, and it can have magic.
1327 However, it never has SvPVX set.
1329 if (old_type == SVt_IV) {
1331 } else if (old_type >= SVt_PV) {
1332 assert(SvPVX_const(sv) == 0);
1335 if (old_type >= SVt_PVMG) {
1336 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1337 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1339 sv->sv_u.svu_array = NULL; /* or svu_hash */
1345 /* This ensures that SvTHINKFIRST(sv) is true, and hence that
1346 sv_force_normal_flags(sv) is called. */
1349 /* XXX Is this still needed? Was it ever needed? Surely as there is
1350 no route from NV to PVIV, NOK can never be true */
1351 assert(!SvNOKp(sv));
1362 assert(new_type_details->body_size);
1363 /* We always allocated the full length item with PURIFY. To do this
1364 we fake things so that arena is false for all 16 types.. */
1365 if(new_type_details->arena) {
1366 /* This points to the start of the allocated area. */
1367 new_body_inline(new_body, new_type);
1368 Zero(new_body, new_type_details->body_size, char);
1369 new_body = ((char *)new_body) - new_type_details->offset;
1371 new_body = new_NOARENAZ(new_type_details);
1373 SvANY(sv) = new_body;
1375 if (old_type_details->copy) {
1376 /* There is now the potential for an upgrade from something without
1377 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1378 int offset = old_type_details->offset;
1379 int length = old_type_details->copy;
1381 if (new_type_details->offset > old_type_details->offset) {
1382 const int difference
1383 = new_type_details->offset - old_type_details->offset;
1384 offset += difference;
1385 length -= difference;
1387 assert (length >= 0);
1389 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1393 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1394 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1395 * correct 0.0 for us. Otherwise, if the old body didn't have an
1396 * NV slot, but the new one does, then we need to initialise the
1397 * freshly created NV slot with whatever the correct bit pattern is
1399 if (old_type_details->zero_nv && !new_type_details->zero_nv
1400 && !isGV_with_GP(sv))
1404 if (new_type == SVt_PVIO) {
1405 IO * const io = MUTABLE_IO(sv);
1406 GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1409 /* Clear the stashcache because a new IO could overrule a package
1411 hv_clear(PL_stashcache);
1413 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1414 IoPAGE_LEN(sv) = 60;
1416 if (old_type < SVt_PV) {
1417 /* referant will be NULL unless the old type was SVt_IV emulating
1419 sv->sv_u.svu_rv = referant;
1423 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1424 (unsigned long)new_type);
1427 if (old_type > SVt_IV) {
1431 /* Note that there is an assumption that all bodies of types that
1432 can be upgraded came from arenas. Only the more complex non-
1433 upgradable types are allowed to be directly malloc()ed. */
1434 assert(old_type_details->arena);
1435 del_body((void*)((char*)old_body + old_type_details->offset),
1436 &PL_body_roots[old_type]);
1442 =for apidoc sv_backoff
1444 Remove any string offset. You should normally use the C<SvOOK_off> macro
1451 Perl_sv_backoff(pTHX_ register SV *const sv)
1454 const char * const s = SvPVX_const(sv);
1456 PERL_ARGS_ASSERT_SV_BACKOFF;
1457 PERL_UNUSED_CONTEXT;
1460 assert(SvTYPE(sv) != SVt_PVHV);
1461 assert(SvTYPE(sv) != SVt_PVAV);
1463 SvOOK_offset(sv, delta);
1465 SvLEN_set(sv, SvLEN(sv) + delta);
1466 SvPV_set(sv, SvPVX(sv) - delta);
1467 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1468 SvFLAGS(sv) &= ~SVf_OOK;
1475 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1476 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1477 Use the C<SvGROW> wrapper instead.
1483 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1487 PERL_ARGS_ASSERT_SV_GROW;
1489 if (PL_madskills && newlen >= 0x100000) {
1490 PerlIO_printf(Perl_debug_log,
1491 "Allocation too large: %"UVxf"\n", (UV)newlen);
1493 #ifdef HAS_64K_LIMIT
1494 if (newlen >= 0x10000) {
1495 PerlIO_printf(Perl_debug_log,
1496 "Allocation too large: %"UVxf"\n", (UV)newlen);
1499 #endif /* HAS_64K_LIMIT */
1502 if (SvTYPE(sv) < SVt_PV) {
1503 sv_upgrade(sv, SVt_PV);
1504 s = SvPVX_mutable(sv);
1506 else if (SvOOK(sv)) { /* pv is offset? */
1508 s = SvPVX_mutable(sv);
1509 if (newlen > SvLEN(sv))
1510 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1511 #ifdef HAS_64K_LIMIT
1512 if (newlen >= 0x10000)
1517 s = SvPVX_mutable(sv);
1519 if (newlen > SvLEN(sv)) { /* need more room? */
1520 STRLEN minlen = SvCUR(sv);
1521 minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1522 if (newlen < minlen)
1524 #ifndef Perl_safesysmalloc_size
1525 newlen = PERL_STRLEN_ROUNDUP(newlen);
1527 if (SvLEN(sv) && s) {
1528 s = (char*)saferealloc(s, newlen);
1531 s = (char*)safemalloc(newlen);
1532 if (SvPVX_const(sv) && SvCUR(sv)) {
1533 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1537 #ifdef Perl_safesysmalloc_size
1538 /* Do this here, do it once, do it right, and then we will never get
1539 called back into sv_grow() unless there really is some growing
1541 SvLEN_set(sv, Perl_safesysmalloc_size(s));
1543 SvLEN_set(sv, newlen);
1550 =for apidoc sv_setiv
1552 Copies an integer into the given SV, upgrading first if necessary.
1553 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1559 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1563 PERL_ARGS_ASSERT_SV_SETIV;
1565 SV_CHECK_THINKFIRST_COW_DROP(sv);
1566 switch (SvTYPE(sv)) {
1569 sv_upgrade(sv, SVt_IV);
1572 sv_upgrade(sv, SVt_PVIV);
1576 if (!isGV_with_GP(sv))
1583 /* diag_listed_as: Can't coerce %s to %s in %s */
1584 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1588 (void)SvIOK_only(sv); /* validate number */
1594 =for apidoc sv_setiv_mg
1596 Like C<sv_setiv>, but also handles 'set' magic.
1602 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1604 PERL_ARGS_ASSERT_SV_SETIV_MG;
1611 =for apidoc sv_setuv
1613 Copies an unsigned integer into the given SV, upgrading first if necessary.
1614 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1620 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1622 PERL_ARGS_ASSERT_SV_SETUV;
1624 /* With these two if statements:
1625 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1628 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1630 If you wish to remove them, please benchmark to see what the effect is
1632 if (u <= (UV)IV_MAX) {
1633 sv_setiv(sv, (IV)u);
1642 =for apidoc sv_setuv_mg
1644 Like C<sv_setuv>, but also handles 'set' magic.
1650 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1652 PERL_ARGS_ASSERT_SV_SETUV_MG;
1659 =for apidoc sv_setnv
1661 Copies a double into the given SV, upgrading first if necessary.
1662 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1668 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1672 PERL_ARGS_ASSERT_SV_SETNV;
1674 SV_CHECK_THINKFIRST_COW_DROP(sv);
1675 switch (SvTYPE(sv)) {
1678 sv_upgrade(sv, SVt_NV);
1682 sv_upgrade(sv, SVt_PVNV);
1686 if (!isGV_with_GP(sv))
1693 /* diag_listed_as: Can't coerce %s to %s in %s */
1694 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1699 (void)SvNOK_only(sv); /* validate number */
1704 =for apidoc sv_setnv_mg
1706 Like C<sv_setnv>, but also handles 'set' magic.
1712 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1714 PERL_ARGS_ASSERT_SV_SETNV_MG;
1720 /* Print an "isn't numeric" warning, using a cleaned-up,
1721 * printable version of the offending string
1725 S_not_a_number(pTHX_ SV *const sv)
1732 PERL_ARGS_ASSERT_NOT_A_NUMBER;
1735 dsv = newSVpvs_flags("", SVs_TEMP);
1736 pv = sv_uni_display(dsv, sv, 10, 0);
1739 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1740 /* each *s can expand to 4 chars + "...\0",
1741 i.e. need room for 8 chars */
1743 const char *s = SvPVX_const(sv);
1744 const char * const end = s + SvCUR(sv);
1745 for ( ; s < end && d < limit; s++ ) {
1747 if (ch & 128 && !isPRINT_LC(ch)) {
1756 else if (ch == '\r') {
1760 else if (ch == '\f') {
1764 else if (ch == '\\') {
1768 else if (ch == '\0') {
1772 else if (isPRINT_LC(ch))
1789 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1790 "Argument \"%s\" isn't numeric in %s", pv,
1793 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1794 "Argument \"%s\" isn't numeric", pv);
1798 =for apidoc looks_like_number
1800 Test if the content of an SV looks like a number (or is a number).
1801 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1802 non-numeric warning), even if your atof() doesn't grok them.
1808 Perl_looks_like_number(pTHX_ SV *const sv)
1810 register const char *sbegin;
1813 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1816 sbegin = SvPVX_const(sv);
1819 else if (SvPOKp(sv))
1820 sbegin = SvPV_const(sv, len);
1822 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1823 return grok_number(sbegin, len, NULL);
1827 S_glob_2number(pTHX_ GV * const gv)
1829 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1830 SV *const buffer = sv_newmortal();
1832 PERL_ARGS_ASSERT_GLOB_2NUMBER;
1834 /* FAKE globs can get coerced, so need to turn this off temporarily if it
1837 gv_efullname3(buffer, gv, "*");
1838 SvFLAGS(gv) |= wasfake;
1840 /* We know that all GVs stringify to something that is not-a-number,
1841 so no need to test that. */
1842 if (ckWARN(WARN_NUMERIC))
1843 not_a_number(buffer);
1844 /* We just want something true to return, so that S_sv_2iuv_common
1845 can tail call us and return true. */
1849 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1850 until proven guilty, assume that things are not that bad... */
1855 As 64 bit platforms often have an NV that doesn't preserve all bits of
1856 an IV (an assumption perl has been based on to date) it becomes necessary
1857 to remove the assumption that the NV always carries enough precision to
1858 recreate the IV whenever needed, and that the NV is the canonical form.
1859 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1860 precision as a side effect of conversion (which would lead to insanity
1861 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1862 1) to distinguish between IV/UV/NV slots that have cached a valid
1863 conversion where precision was lost and IV/UV/NV slots that have a
1864 valid conversion which has lost no precision
1865 2) to ensure that if a numeric conversion to one form is requested that
1866 would lose precision, the precise conversion (or differently
1867 imprecise conversion) is also performed and cached, to prevent
1868 requests for different numeric formats on the same SV causing
1869 lossy conversion chains. (lossless conversion chains are perfectly
1874 SvIOKp is true if the IV slot contains a valid value
1875 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1876 SvNOKp is true if the NV slot contains a valid value
1877 SvNOK is true only if the NV value is accurate
1880 while converting from PV to NV, check to see if converting that NV to an
1881 IV(or UV) would lose accuracy over a direct conversion from PV to
1882 IV(or UV). If it would, cache both conversions, return NV, but mark
1883 SV as IOK NOKp (ie not NOK).
1885 While converting from PV to IV, check to see if converting that IV to an
1886 NV would lose accuracy over a direct conversion from PV to NV. If it
1887 would, cache both conversions, flag similarly.
1889 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1890 correctly because if IV & NV were set NV *always* overruled.
1891 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1892 changes - now IV and NV together means that the two are interchangeable:
1893 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1895 The benefit of this is that operations such as pp_add know that if
1896 SvIOK is true for both left and right operands, then integer addition
1897 can be used instead of floating point (for cases where the result won't
1898 overflow). Before, floating point was always used, which could lead to
1899 loss of precision compared with integer addition.
1901 * making IV and NV equal status should make maths accurate on 64 bit
1903 * may speed up maths somewhat if pp_add and friends start to use
1904 integers when possible instead of fp. (Hopefully the overhead in
1905 looking for SvIOK and checking for overflow will not outweigh the
1906 fp to integer speedup)
1907 * will slow down integer operations (callers of SvIV) on "inaccurate"
1908 values, as the change from SvIOK to SvIOKp will cause a call into
1909 sv_2iv each time rather than a macro access direct to the IV slot
1910 * should speed up number->string conversion on integers as IV is
1911 favoured when IV and NV are equally accurate
1913 ####################################################################
1914 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1915 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1916 On the other hand, SvUOK is true iff UV.
1917 ####################################################################
1919 Your mileage will vary depending your CPU's relative fp to integer
1923 #ifndef NV_PRESERVES_UV
1924 # define IS_NUMBER_UNDERFLOW_IV 1
1925 # define IS_NUMBER_UNDERFLOW_UV 2
1926 # define IS_NUMBER_IV_AND_UV 2
1927 # define IS_NUMBER_OVERFLOW_IV 4
1928 # define IS_NUMBER_OVERFLOW_UV 5
1930 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1932 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1934 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1942 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1944 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));
1945 if (SvNVX(sv) < (NV)IV_MIN) {
1946 (void)SvIOKp_on(sv);
1948 SvIV_set(sv, IV_MIN);
1949 return IS_NUMBER_UNDERFLOW_IV;
1951 if (SvNVX(sv) > (NV)UV_MAX) {
1952 (void)SvIOKp_on(sv);
1955 SvUV_set(sv, UV_MAX);
1956 return IS_NUMBER_OVERFLOW_UV;
1958 (void)SvIOKp_on(sv);
1960 /* Can't use strtol etc to convert this string. (See truth table in
1962 if (SvNVX(sv) <= (UV)IV_MAX) {
1963 SvIV_set(sv, I_V(SvNVX(sv)));
1964 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1965 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1967 /* Integer is imprecise. NOK, IOKp */
1969 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1972 SvUV_set(sv, U_V(SvNVX(sv)));
1973 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1974 if (SvUVX(sv) == UV_MAX) {
1975 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1976 possibly be preserved by NV. Hence, it must be overflow.
1978 return IS_NUMBER_OVERFLOW_UV;
1980 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1982 /* Integer is imprecise. NOK, IOKp */
1984 return IS_NUMBER_OVERFLOW_IV;
1986 #endif /* !NV_PRESERVES_UV*/
1989 S_sv_2iuv_common(pTHX_ SV *const sv)
1993 PERL_ARGS_ASSERT_SV_2IUV_COMMON;
1996 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1997 * without also getting a cached IV/UV from it at the same time
1998 * (ie PV->NV conversion should detect loss of accuracy and cache
1999 * IV or UV at same time to avoid this. */
2000 /* IV-over-UV optimisation - choose to cache IV if possible */
2002 if (SvTYPE(sv) == SVt_NV)
2003 sv_upgrade(sv, SVt_PVNV);
2005 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2006 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2007 certainly cast into the IV range at IV_MAX, whereas the correct
2008 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2010 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2011 if (Perl_isnan(SvNVX(sv))) {
2017 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2018 SvIV_set(sv, I_V(SvNVX(sv)));
2019 if (SvNVX(sv) == (NV) SvIVX(sv)
2020 #ifndef NV_PRESERVES_UV
2021 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2022 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2023 /* Don't flag it as "accurately an integer" if the number
2024 came from a (by definition imprecise) NV operation, and
2025 we're outside the range of NV integer precision */
2029 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2031 /* scalar has trailing garbage, eg "42a" */
2033 DEBUG_c(PerlIO_printf(Perl_debug_log,
2034 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2040 /* IV not precise. No need to convert from PV, as NV
2041 conversion would already have cached IV if it detected
2042 that PV->IV would be better than PV->NV->IV
2043 flags already correct - don't set public IOK. */
2044 DEBUG_c(PerlIO_printf(Perl_debug_log,
2045 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2050 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2051 but the cast (NV)IV_MIN rounds to a the value less (more
2052 negative) than IV_MIN which happens to be equal to SvNVX ??
2053 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2054 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2055 (NV)UVX == NVX are both true, but the values differ. :-(
2056 Hopefully for 2s complement IV_MIN is something like
2057 0x8000000000000000 which will be exact. NWC */
2060 SvUV_set(sv, U_V(SvNVX(sv)));
2062 (SvNVX(sv) == (NV) SvUVX(sv))
2063 #ifndef NV_PRESERVES_UV
2064 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2065 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2066 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2067 /* Don't flag it as "accurately an integer" if the number
2068 came from a (by definition imprecise) NV operation, and
2069 we're outside the range of NV integer precision */
2075 DEBUG_c(PerlIO_printf(Perl_debug_log,
2076 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2082 else if (SvPOKp(sv) && SvLEN(sv)) {
2084 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2085 /* We want to avoid a possible problem when we cache an IV/ a UV which
2086 may be later translated to an NV, and the resulting NV is not
2087 the same as the direct translation of the initial string
2088 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2089 be careful to ensure that the value with the .456 is around if the
2090 NV value is requested in the future).
2092 This means that if we cache such an IV/a UV, we need to cache the
2093 NV as well. Moreover, we trade speed for space, and do not
2094 cache the NV if we are sure it's not needed.
2097 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2098 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2099 == IS_NUMBER_IN_UV) {
2100 /* It's definitely an integer, only upgrade to PVIV */
2101 if (SvTYPE(sv) < SVt_PVIV)
2102 sv_upgrade(sv, SVt_PVIV);
2104 } else if (SvTYPE(sv) < SVt_PVNV)
2105 sv_upgrade(sv, SVt_PVNV);
2107 /* If NVs preserve UVs then we only use the UV value if we know that
2108 we aren't going to call atof() below. If NVs don't preserve UVs
2109 then the value returned may have more precision than atof() will
2110 return, even though value isn't perfectly accurate. */
2111 if ((numtype & (IS_NUMBER_IN_UV
2112 #ifdef NV_PRESERVES_UV
2115 )) == IS_NUMBER_IN_UV) {
2116 /* This won't turn off the public IOK flag if it was set above */
2117 (void)SvIOKp_on(sv);
2119 if (!(numtype & IS_NUMBER_NEG)) {
2121 if (value <= (UV)IV_MAX) {
2122 SvIV_set(sv, (IV)value);
2124 /* it didn't overflow, and it was positive. */
2125 SvUV_set(sv, value);
2129 /* 2s complement assumption */
2130 if (value <= (UV)IV_MIN) {
2131 SvIV_set(sv, -(IV)value);
2133 /* Too negative for an IV. This is a double upgrade, but
2134 I'm assuming it will be rare. */
2135 if (SvTYPE(sv) < SVt_PVNV)
2136 sv_upgrade(sv, SVt_PVNV);
2140 SvNV_set(sv, -(NV)value);
2141 SvIV_set(sv, IV_MIN);
2145 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2146 will be in the previous block to set the IV slot, and the next
2147 block to set the NV slot. So no else here. */
2149 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2150 != IS_NUMBER_IN_UV) {
2151 /* It wasn't an (integer that doesn't overflow the UV). */
2152 SvNV_set(sv, Atof(SvPVX_const(sv)));
2154 if (! numtype && ckWARN(WARN_NUMERIC))
2157 #if defined(USE_LONG_DOUBLE)
2158 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2159 PTR2UV(sv), SvNVX(sv)));
2161 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2162 PTR2UV(sv), SvNVX(sv)));
2165 #ifdef NV_PRESERVES_UV
2166 (void)SvIOKp_on(sv);
2168 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2169 SvIV_set(sv, I_V(SvNVX(sv)));
2170 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2173 NOOP; /* Integer is imprecise. NOK, IOKp */
2175 /* UV will not work better than IV */
2177 if (SvNVX(sv) > (NV)UV_MAX) {
2179 /* Integer is inaccurate. NOK, IOKp, is UV */
2180 SvUV_set(sv, UV_MAX);
2182 SvUV_set(sv, U_V(SvNVX(sv)));
2183 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2184 NV preservse UV so can do correct comparison. */
2185 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2188 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
2193 #else /* NV_PRESERVES_UV */
2194 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2195 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2196 /* The IV/UV slot will have been set from value returned by
2197 grok_number above. The NV slot has just been set using
2200 assert (SvIOKp(sv));
2202 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2203 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2204 /* Small enough to preserve all bits. */
2205 (void)SvIOKp_on(sv);
2207 SvIV_set(sv, I_V(SvNVX(sv)));
2208 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2210 /* Assumption: first non-preserved integer is < IV_MAX,
2211 this NV is in the preserved range, therefore: */
2212 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2214 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);
2218 0 0 already failed to read UV.
2219 0 1 already failed to read UV.
2220 1 0 you won't get here in this case. IV/UV
2221 slot set, public IOK, Atof() unneeded.
2222 1 1 already read UV.
2223 so there's no point in sv_2iuv_non_preserve() attempting
2224 to use atol, strtol, strtoul etc. */
2226 sv_2iuv_non_preserve (sv, numtype);
2228 sv_2iuv_non_preserve (sv);
2232 #endif /* NV_PRESERVES_UV */
2233 /* It might be more code efficient to go through the entire logic above
2234 and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2235 gets complex and potentially buggy, so more programmer efficient
2236 to do it this way, by turning off the public flags: */
2238 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2242 if (isGV_with_GP(sv))
2243 return glob_2number(MUTABLE_GV(sv));
2245 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2246 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2249 if (SvTYPE(sv) < SVt_IV)
2250 /* Typically the caller expects that sv_any is not NULL now. */
2251 sv_upgrade(sv, SVt_IV);
2252 /* Return 0 from the caller. */
2259 =for apidoc sv_2iv_flags
2261 Return the integer value of an SV, doing any necessary string
2262 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2263 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2269 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2274 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2275 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2276 cache IVs just in case. In practice it seems that they never
2277 actually anywhere accessible by user Perl code, let alone get used
2278 in anything other than a string context. */
2279 if (flags & SV_GMAGIC)
2284 return I_V(SvNVX(sv));
2286 if (SvPOKp(sv) && SvLEN(sv)) {
2289 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2291 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2292 == IS_NUMBER_IN_UV) {
2293 /* It's definitely an integer */
2294 if (numtype & IS_NUMBER_NEG) {
2295 if (value < (UV)IV_MIN)
2298 if (value < (UV)IV_MAX)
2303 if (ckWARN(WARN_NUMERIC))
2306 return I_V(Atof(SvPVX_const(sv)));
2311 assert(SvTYPE(sv) >= SVt_PVMG);
2312 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2313 } else if (SvTHINKFIRST(sv)) {
2318 if (flags & SV_SKIP_OVERLOAD)
2320 tmpstr = AMG_CALLunary(sv, numer_amg);
2321 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2322 return SvIV(tmpstr);
2325 return PTR2IV(SvRV(sv));
2328 sv_force_normal_flags(sv, 0);
2330 if (SvREADONLY(sv) && !SvOK(sv)) {
2331 if (ckWARN(WARN_UNINITIALIZED))
2337 if (S_sv_2iuv_common(aTHX_ sv))
2340 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2341 PTR2UV(sv),SvIVX(sv)));
2342 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2346 =for apidoc sv_2uv_flags
2348 Return the unsigned integer value of an SV, doing any necessary string
2349 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2350 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2356 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2361 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2362 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2363 cache IVs just in case. */
2364 if (flags & SV_GMAGIC)
2369 return U_V(SvNVX(sv));
2370 if (SvPOKp(sv) && SvLEN(sv)) {
2373 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2375 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2376 == IS_NUMBER_IN_UV) {
2377 /* It's definitely an integer */
2378 if (!(numtype & IS_NUMBER_NEG))
2382 if (ckWARN(WARN_NUMERIC))
2385 return U_V(Atof(SvPVX_const(sv)));
2390 assert(SvTYPE(sv) >= SVt_PVMG);
2391 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2392 } else if (SvTHINKFIRST(sv)) {
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 sv_force_normal_flags(sv, 0);
2409 if (SvREADONLY(sv) && !SvOK(sv)) {
2410 if (ckWARN(WARN_UNINITIALIZED))
2416 if (S_sv_2iuv_common(aTHX_ sv))
2420 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2421 PTR2UV(sv),SvUVX(sv)));
2422 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2426 =for apidoc sv_2nv_flags
2428 Return the num value of an SV, doing any necessary string or integer
2429 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2430 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2436 Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
2441 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2442 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2443 cache IVs just in case. */
2444 if (flags & SV_GMAGIC)
2448 if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2449 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2450 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2452 return Atof(SvPVX_const(sv));
2456 return (NV)SvUVX(sv);
2458 return (NV)SvIVX(sv);
2463 assert(SvTYPE(sv) >= SVt_PVMG);
2464 /* This falls through to the report_uninit near the end of the
2466 } else if (SvTHINKFIRST(sv)) {
2471 if (flags & SV_SKIP_OVERLOAD)
2473 tmpstr = AMG_CALLunary(sv, numer_amg);
2474 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2475 return SvNV(tmpstr);
2478 return PTR2NV(SvRV(sv));
2481 sv_force_normal_flags(sv, 0);
2483 if (SvREADONLY(sv) && !SvOK(sv)) {
2484 if (ckWARN(WARN_UNINITIALIZED))
2489 if (SvTYPE(sv) < SVt_NV) {
2490 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2491 sv_upgrade(sv, SVt_NV);
2492 #ifdef USE_LONG_DOUBLE
2494 STORE_NUMERIC_LOCAL_SET_STANDARD();
2495 PerlIO_printf(Perl_debug_log,
2496 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2497 PTR2UV(sv), SvNVX(sv));
2498 RESTORE_NUMERIC_LOCAL();
2502 STORE_NUMERIC_LOCAL_SET_STANDARD();
2503 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2504 PTR2UV(sv), SvNVX(sv));
2505 RESTORE_NUMERIC_LOCAL();
2509 else if (SvTYPE(sv) < SVt_PVNV)
2510 sv_upgrade(sv, SVt_PVNV);
2515 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2516 #ifdef NV_PRESERVES_UV
2522 /* Only set the public NV OK flag if this NV preserves the IV */
2523 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2525 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2526 : (SvIVX(sv) == I_V(SvNVX(sv))))
2532 else if (SvPOKp(sv) && SvLEN(sv)) {
2534 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2535 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2537 #ifdef NV_PRESERVES_UV
2538 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2539 == IS_NUMBER_IN_UV) {
2540 /* It's definitely an integer */
2541 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2543 SvNV_set(sv, Atof(SvPVX_const(sv)));
2549 SvNV_set(sv, Atof(SvPVX_const(sv)));
2550 /* Only set the public NV OK flag if this NV preserves the value in
2551 the PV at least as well as an IV/UV would.
2552 Not sure how to do this 100% reliably. */
2553 /* if that shift count is out of range then Configure's test is
2554 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2556 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2557 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2558 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2559 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2560 /* Can't use strtol etc to convert this string, so don't try.
2561 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2564 /* value has been set. It may not be precise. */
2565 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2566 /* 2s complement assumption for (UV)IV_MIN */
2567 SvNOK_on(sv); /* Integer is too negative. */
2572 if (numtype & IS_NUMBER_NEG) {
2573 SvIV_set(sv, -(IV)value);
2574 } else if (value <= (UV)IV_MAX) {
2575 SvIV_set(sv, (IV)value);
2577 SvUV_set(sv, value);
2581 if (numtype & IS_NUMBER_NOT_INT) {
2582 /* I believe that even if the original PV had decimals,
2583 they are lost beyond the limit of the FP precision.
2584 However, neither is canonical, so both only get p
2585 flags. NWC, 2000/11/25 */
2586 /* Both already have p flags, so do nothing */
2588 const NV nv = SvNVX(sv);
2589 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2590 if (SvIVX(sv) == I_V(nv)) {
2593 /* It had no "." so it must be integer. */
2597 /* between IV_MAX and NV(UV_MAX).
2598 Could be slightly > UV_MAX */
2600 if (numtype & IS_NUMBER_NOT_INT) {
2601 /* UV and NV both imprecise. */
2603 const UV nv_as_uv = U_V(nv);
2605 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2614 /* It might be more code efficient to go through the entire logic above
2615 and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2616 gets complex and potentially buggy, so more programmer efficient
2617 to do it this way, by turning off the public flags: */
2619 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2620 #endif /* NV_PRESERVES_UV */
2623 if (isGV_with_GP(sv)) {
2624 glob_2number(MUTABLE_GV(sv));
2628 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2630 assert (SvTYPE(sv) >= SVt_NV);
2631 /* Typically the caller expects that sv_any is not NULL now. */
2632 /* XXX Ilya implies that this is a bug in callers that assume this
2633 and ideally should be fixed. */
2636 #if defined(USE_LONG_DOUBLE)
2638 STORE_NUMERIC_LOCAL_SET_STANDARD();
2639 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2640 PTR2UV(sv), SvNVX(sv));
2641 RESTORE_NUMERIC_LOCAL();
2645 STORE_NUMERIC_LOCAL_SET_STANDARD();
2646 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2647 PTR2UV(sv), SvNVX(sv));
2648 RESTORE_NUMERIC_LOCAL();
2657 Return an SV with the numeric value of the source SV, doing any necessary
2658 reference or overload conversion. You must use the C<SvNUM(sv)> macro to
2659 access this function.
2665 Perl_sv_2num(pTHX_ register SV *const sv)
2667 PERL_ARGS_ASSERT_SV_2NUM;
2672 SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2673 TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2674 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2675 return sv_2num(tmpsv);
2677 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2680 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2681 * UV as a string towards the end of buf, and return pointers to start and
2684 * We assume that buf is at least TYPE_CHARS(UV) long.
2688 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2690 char *ptr = buf + TYPE_CHARS(UV);
2691 char * const ebuf = ptr;
2694 PERL_ARGS_ASSERT_UIV_2BUF;
2706 *--ptr = '0' + (char)(uv % 10);
2715 =for apidoc sv_2pv_flags
2717 Returns a pointer to the string value of an SV, and sets *lp to its length.
2718 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2720 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2721 usually end up here too.
2727 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2737 if (SvGMAGICAL(sv)) {
2738 if (flags & SV_GMAGIC)
2743 if (flags & SV_MUTABLE_RETURN)
2744 return SvPVX_mutable(sv);
2745 if (flags & SV_CONST_RETURN)
2746 return (char *)SvPVX_const(sv);
2749 if (SvIOKp(sv) || SvNOKp(sv)) {
2750 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2755 ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2756 : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2757 } else if(SvNVX(sv) == 0.0) {
2762 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2769 SvUPGRADE(sv, SVt_PV);
2772 s = SvGROW_mutable(sv, len + 1);
2775 return (char*)memcpy(s, tbuf, len + 1);
2781 assert(SvTYPE(sv) >= SVt_PVMG);
2782 /* This falls through to the report_uninit near the end of the
2784 } else if (SvTHINKFIRST(sv)) {
2789 if (flags & SV_SKIP_OVERLOAD)
2791 tmpstr = AMG_CALLunary(sv, string_amg);
2792 TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2793 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2795 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2799 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2800 if (flags & SV_CONST_RETURN) {
2801 pv = (char *) SvPVX_const(tmpstr);
2803 pv = (flags & SV_MUTABLE_RETURN)
2804 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2807 *lp = SvCUR(tmpstr);
2809 pv = sv_2pv_flags(tmpstr, lp, flags);
2822 SV *const referent = SvRV(sv);
2826 retval = buffer = savepvn("NULLREF", len);
2827 } else if (SvTYPE(referent) == SVt_REGEXP) {
2828 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2833 /* If the regex is UTF-8 we want the containing scalar to
2834 have an UTF-8 flag too */
2840 if ((seen_evals = RX_SEEN_EVALS(re)))
2841 PL_reginterp_cnt += seen_evals;
2844 *lp = RX_WRAPLEN(re);
2846 return RX_WRAPPED(re);
2848 const char *const typestr = sv_reftype(referent, 0);
2849 const STRLEN typelen = strlen(typestr);
2850 UV addr = PTR2UV(referent);
2851 const char *stashname = NULL;
2852 STRLEN stashnamelen = 0; /* hush, gcc */
2853 const char *buffer_end;
2855 if (SvOBJECT(referent)) {
2856 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2859 stashname = HEK_KEY(name);
2860 stashnamelen = HEK_LEN(name);
2862 if (HEK_UTF8(name)) {
2868 stashname = "__ANON__";
2871 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2872 + 2 * sizeof(UV) + 2 /* )\0 */;
2874 len = typelen + 3 /* (0x */
2875 + 2 * sizeof(UV) + 2 /* )\0 */;
2878 Newx(buffer, len, char);
2879 buffer_end = retval = buffer + len;
2881 /* Working backwards */
2885 *--retval = PL_hexdigit[addr & 15];
2886 } while (addr >>= 4);
2892 memcpy(retval, typestr, typelen);
2896 retval -= stashnamelen;
2897 memcpy(retval, stashname, stashnamelen);
2899 /* retval may not necessarily have reached the start of the
2901 assert (retval >= buffer);
2903 len = buffer_end - retval - 1; /* -1 for that \0 */
2911 if (SvREADONLY(sv) && !SvOK(sv)) {
2914 if (flags & SV_UNDEF_RETURNS_NULL)
2916 if (ckWARN(WARN_UNINITIALIZED))
2921 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2922 /* I'm assuming that if both IV and NV are equally valid then
2923 converting the IV is going to be more efficient */
2924 const U32 isUIOK = SvIsUV(sv);
2925 char buf[TYPE_CHARS(UV)];
2929 if (SvTYPE(sv) < SVt_PVIV)
2930 sv_upgrade(sv, SVt_PVIV);
2931 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2933 /* inlined from sv_setpvn */
2934 s = SvGROW_mutable(sv, len + 1);
2935 Move(ptr, s, len, char);
2939 else if (SvNOKp(sv)) {
2940 if (SvTYPE(sv) < SVt_PVNV)
2941 sv_upgrade(sv, SVt_PVNV);
2942 if (SvNVX(sv) == 0.0) {
2943 s = SvGROW_mutable(sv, 2);
2948 /* The +20 is pure guesswork. Configure test needed. --jhi */
2949 s = SvGROW_mutable(sv, NV_DIG + 20);
2950 /* some Xenix systems wipe out errno here */
2951 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2961 if (isGV_with_GP(sv)) {
2962 GV *const gv = MUTABLE_GV(sv);
2963 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
2964 SV *const buffer = sv_newmortal();
2966 /* FAKE globs can get coerced, so need to turn this off temporarily
2969 gv_efullname3(buffer, gv, "*");
2970 SvFLAGS(gv) |= wasfake;
2972 if (SvPOK(buffer)) {
2974 *lp = SvCUR(buffer);
2976 return SvPVX(buffer);
2987 if (flags & SV_UNDEF_RETURNS_NULL)
2989 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2991 if (SvTYPE(sv) < SVt_PV)
2992 /* Typically the caller expects that sv_any is not NULL now. */
2993 sv_upgrade(sv, SVt_PV);
2997 const STRLEN len = s - SvPVX_const(sv);
3003 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3004 PTR2UV(sv),SvPVX_const(sv)));
3005 if (flags & SV_CONST_RETURN)
3006 return (char *)SvPVX_const(sv);
3007 if (flags & SV_MUTABLE_RETURN)
3008 return SvPVX_mutable(sv);
3013 =for apidoc sv_copypv
3015 Copies a stringified representation of the source SV into the
3016 destination SV. Automatically performs any necessary mg_get and
3017 coercion of numeric values into strings. Guaranteed to preserve
3018 UTF8 flag even from overloaded objects. Similar in nature to
3019 sv_2pv[_flags] but operates directly on an SV instead of just the
3020 string. Mostly uses sv_2pv_flags to do its work, except when that
3021 would lose the UTF-8'ness of the PV.
3027 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
3030 const char * const s = SvPV_const(ssv,len);
3032 PERL_ARGS_ASSERT_SV_COPYPV;
3034 sv_setpvn(dsv,s,len);
3042 =for apidoc sv_2pvbyte
3044 Return a pointer to the byte-encoded representation of the SV, and set *lp
3045 to its length. May cause the SV to be downgraded from UTF-8 as a
3048 Usually accessed via the C<SvPVbyte> macro.
3054 Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
3056 PERL_ARGS_ASSERT_SV_2PVBYTE;
3059 sv_utf8_downgrade(sv,0);
3060 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3064 =for apidoc sv_2pvutf8
3066 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3067 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3069 Usually accessed via the C<SvPVutf8> macro.
3075 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
3077 PERL_ARGS_ASSERT_SV_2PVUTF8;
3079 sv_utf8_upgrade(sv);
3080 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3085 =for apidoc sv_2bool
3087 This macro is only used by sv_true() or its macro equivalent, and only if
3088 the latter's argument is neither SvPOK, SvIOK nor SvNOK.
3089 It calls sv_2bool_flags with the SV_GMAGIC flag.
3091 =for apidoc sv_2bool_flags
3093 This function is only used by sv_true() and friends, and only if
3094 the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags
3095 contain SV_GMAGIC, then it does an mg_get() first.
3102 Perl_sv_2bool_flags(pTHX_ register SV *const sv, const I32 flags)
3106 PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3108 if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3114 SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3115 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3116 return cBOOL(SvTRUE(tmpsv));
3118 return SvRV(sv) != 0;
3121 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3123 (*sv->sv_u.svu_pv > '0' ||
3124 Xpvtmp->xpv_cur > 1 ||
3125 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3132 return SvIVX(sv) != 0;
3135 return SvNVX(sv) != 0.0;
3137 if (isGV_with_GP(sv))
3147 =for apidoc sv_utf8_upgrade
3149 Converts the PV of an SV to its UTF-8-encoded form.
3150 Forces the SV to string form if it is not already.
3151 Will C<mg_get> on C<sv> if appropriate.
3152 Always sets the SvUTF8 flag to avoid future validity checks even
3153 if the whole string is the same in UTF-8 as not.
3154 Returns the number of bytes in the converted string
3156 This is not as a general purpose byte encoding to Unicode interface:
3157 use the Encode extension for that.
3159 =for apidoc sv_utf8_upgrade_nomg
3161 Like sv_utf8_upgrade, but doesn't do magic on C<sv>
3163 =for apidoc sv_utf8_upgrade_flags
3165 Converts the PV of an SV to its UTF-8-encoded form.
3166 Forces the SV to string form if it is not already.
3167 Always sets the SvUTF8 flag to avoid future validity checks even
3168 if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set,
3169 will C<mg_get> on C<sv> if appropriate, else not.
3170 Returns the number of bytes in the converted string
3171 C<sv_utf8_upgrade> and
3172 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3174 This is not as a general purpose byte encoding to Unicode interface:
3175 use the Encode extension for that.
3179 The grow version is currently not externally documented. It adds a parameter,
3180 extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3181 have free after it upon return. This allows the caller to reserve extra space
3182 that it intends to fill, to avoid extra grows.
3184 Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3185 which can be used to tell this function to not first check to see if there are
3186 any characters that are different in UTF-8 (variant characters) which would
3187 force it to allocate a new string to sv, but to assume there are. Typically
3188 this flag is used by a routine that has already parsed the string to find that
3189 there are such characters, and passes this information on so that the work
3190 doesn't have to be repeated.
3192 (One might think that the calling routine could pass in the position of the
3193 first such variant, so it wouldn't have to be found again. But that is not the
3194 case, because typically when the caller is likely to use this flag, it won't be
3195 calling this routine unless it finds something that won't fit into a byte.
3196 Otherwise it tries to not upgrade and just use bytes. But some things that
3197 do fit into a byte are variants in utf8, and the caller may not have been
3198 keeping track of these.)
3200 If the routine itself changes the string, it adds a trailing NUL. Such a NUL
3201 isn't guaranteed due to having other routines do the work in some input cases,
3202 or if the input is already flagged as being in utf8.
3204 The speed of this could perhaps be improved for many cases if someone wanted to
3205 write a fast function that counts the number of variant characters in a string,
3206 especially if it could return the position of the first one.
3211 Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
3215 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3217 if (sv == &PL_sv_undef)
3221 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3222 (void) sv_2pv_flags(sv,&len, flags);
3224 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3228 (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3233 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3238 sv_force_normal_flags(sv, 0);
3241 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3242 sv_recode_to_utf8(sv, PL_encoding);
3243 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3247 if (SvCUR(sv) == 0) {
3248 if (extra) SvGROW(sv, extra);
3249 } else { /* Assume Latin-1/EBCDIC */
3250 /* This function could be much more efficient if we
3251 * had a FLAG in SVs to signal if there are any variant
3252 * chars in the PV. Given that there isn't such a flag
3253 * make the loop as fast as possible (although there are certainly ways
3254 * to speed this up, eg. through vectorization) */
3255 U8 * s = (U8 *) SvPVX_const(sv);
3256 U8 * e = (U8 *) SvEND(sv);
3258 STRLEN two_byte_count = 0;
3260 if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3262 /* See if really will need to convert to utf8. We mustn't rely on our
3263 * incoming SV being well formed and having a trailing '\0', as certain
3264 * code in pp_formline can send us partially built SVs. */
3268 if (NATIVE_IS_INVARIANT(ch)) continue;
3270 t--; /* t already incremented; re-point to first variant */
3275 /* utf8 conversion not needed because all are invariants. Mark as
3276 * UTF-8 even if no variant - saves scanning loop */
3282 /* Here, the string should be converted to utf8, either because of an
3283 * input flag (two_byte_count = 0), or because a character that
3284 * requires 2 bytes was found (two_byte_count = 1). t points either to
3285 * the beginning of the string (if we didn't examine anything), or to
3286 * the first variant. In either case, everything from s to t - 1 will
3287 * occupy only 1 byte each on output.
3289 * There are two main ways to convert. One is to create a new string
3290 * and go through the input starting from the beginning, appending each
3291 * converted value onto the new string as we go along. It's probably
3292 * best to allocate enough space in the string for the worst possible
3293 * case rather than possibly running out of space and having to
3294 * reallocate and then copy what we've done so far. Since everything
3295 * from s to t - 1 is invariant, the destination can be initialized
3296 * with these using a fast memory copy
3298 * The other way is to figure out exactly how big the string should be
3299 * by parsing the entire input. Then you don't have to make it big
3300 * enough to handle the worst possible case, and more importantly, if
3301 * the string you already have is large enough, you don't have to
3302 * allocate a new string, you can copy the last character in the input
3303 * string to the final position(s) that will be occupied by the
3304 * converted string and go backwards, stopping at t, since everything
3305 * before that is invariant.
3307 * There are advantages and disadvantages to each method.
3309 * In the first method, we can allocate a new string, do the memory
3310 * copy from the s to t - 1, and then proceed through the rest of the
3311 * string byte-by-byte.
3313 * In the second method, we proceed through the rest of the input
3314 * string just calculating how big the converted string will be. Then
3315 * there are two cases:
3316 * 1) if the string has enough extra space to handle the converted
3317 * value. We go backwards through the string, converting until we
3318 * get to the position we are at now, and then stop. If this
3319 * position is far enough along in the string, this method is
3320 * faster than the other method. If the memory copy were the same
3321 * speed as the byte-by-byte loop, that position would be about
3322 * half-way, as at the half-way mark, parsing to the end and back
3323 * is one complete string's parse, the same amount as starting
3324 * over and going all the way through. Actually, it would be
3325 * somewhat less than half-way, as it's faster to just count bytes
3326 * than to also copy, and we don't have the overhead of allocating
3327 * a new string, changing the scalar to use it, and freeing the
3328 * existing one. But if the memory copy is fast, the break-even
3329 * point is somewhere after half way. The counting loop could be
3330 * sped up by vectorization, etc, to move the break-even point
3331 * further towards the beginning.
3332 * 2) if the string doesn't have enough space to handle the converted
3333 * value. A new string will have to be allocated, and one might
3334 * as well, given that, start from the beginning doing the first
3335 * method. We've spent extra time parsing the string and in
3336 * exchange all we've gotten is that we know precisely how big to
3337 * make the new one. Perl is more optimized for time than space,
3338 * so this case is a loser.
3339 * So what I've decided to do is not use the 2nd method unless it is
3340 * guaranteed that a new string won't have to be allocated, assuming
3341 * the worst case. I also decided not to put any more conditions on it
3342 * than this, for now. It seems likely that, since the worst case is
3343 * twice as big as the unknown portion of the string (plus 1), we won't
3344 * be guaranteed enough space, causing us to go to the first method,
3345 * unless the string is short, or the first variant character is near
3346 * the end of it. In either of these cases, it seems best to use the
3347 * 2nd method. The only circumstance I can think of where this would
3348 * be really slower is if the string had once had much more data in it
3349 * than it does now, but there is still a substantial amount in it */
3352 STRLEN invariant_head = t - s;
3353 STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3354 if (SvLEN(sv) < size) {
3356 /* Here, have decided to allocate a new string */
3361 Newx(dst, size, U8);
3363 /* If no known invariants at the beginning of the input string,
3364 * set so starts from there. Otherwise, can use memory copy to
3365 * get up to where we are now, and then start from here */
3367 if (invariant_head <= 0) {
3370 Copy(s, dst, invariant_head, char);
3371 d = dst + invariant_head;
3375 const UV uv = NATIVE8_TO_UNI(*t++);
3376 if (UNI_IS_INVARIANT(uv))
3377 *d++ = (U8)UNI_TO_NATIVE(uv);
3379 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
3380 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
3384 SvPV_free(sv); /* No longer using pre-existing string */
3385 SvPV_set(sv, (char*)dst);
3386 SvCUR_set(sv, d - dst);
3387 SvLEN_set(sv, size);
3390 /* Here, have decided to get the exact size of the string.
3391 * Currently this happens only when we know that there is
3392 * guaranteed enough space to fit the converted string, so
3393 * don't have to worry about growing. If two_byte_count is 0,
3394 * then t points to the first byte of the string which hasn't
3395 * been examined yet. Otherwise two_byte_count is 1, and t
3396 * points to the first byte in the string that will expand to
3397 * two. Depending on this, start examining at t or 1 after t.
3400 U8 *d = t + two_byte_count;
3403 /* Count up the remaining bytes that expand to two */
3406 const U8 chr = *d++;
3407 if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
3410 /* The string will expand by just the number of bytes that
3411 * occupy two positions. But we are one afterwards because of
3412 * the increment just above. This is the place to put the
3413 * trailing NUL, and to set the length before we decrement */
3415 d += two_byte_count;
3416 SvCUR_set(sv, d - s);
3420 /* Having decremented d, it points to the position to put the
3421 * very last byte of the expanded string. Go backwards through
3422 * the string, copying and expanding as we go, stopping when we
3423 * get to the part that is invariant the rest of the way down */
3427 const U8 ch = NATIVE8_TO_UNI(*e--);
3428 if (UNI_IS_INVARIANT(ch)) {
3429 *d-- = UNI_TO_NATIVE(ch);
3431 *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
3432 *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
3439 /* Mark as UTF-8 even if no variant - saves scanning loop */
3445 =for apidoc sv_utf8_downgrade
3447 Attempts to convert the PV of an SV from characters to bytes.
3448 If the PV contains a character that cannot fit
3449 in a byte, this conversion will fail;
3450 in this case, either returns false or, if C<fail_ok> is not
3453 This is not as a general purpose Unicode to byte encoding interface:
3454 use the Encode extension for that.
3460 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3464 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3466 if (SvPOKp(sv) && SvUTF8(sv)) {
3472 sv_force_normal_flags(sv, 0);
3474 s = (U8 *) SvPV(sv, len);
3475 if (!utf8_to_bytes(s, &len)) {
3480 Perl_croak(aTHX_ "Wide character in %s",
3483 Perl_croak(aTHX_ "Wide character");
3494 =for apidoc sv_utf8_encode
3496 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3497 flag off so that it looks like octets again.
3503 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3505 PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3508 sv_force_normal_flags(sv, 0);
3510 if (SvREADONLY(sv)) {
3511 Perl_croak_no_modify(aTHX);
3513 (void) sv_utf8_upgrade(sv);
3518 =for apidoc sv_utf8_decode
3520 If the PV of the SV is an octet sequence in UTF-8
3521 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3522 so that it looks like a character. If the PV contains only single-byte
3523 characters, the C<SvUTF8> flag stays being off.
3524 Scans PV for validity and returns false if the PV is invalid UTF-8.
3530 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3532 PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3538 /* The octets may have got themselves encoded - get them back as
3541 if (!sv_utf8_downgrade(sv, TRUE))
3544 /* it is actually just a matter of turning the utf8 flag on, but
3545 * we want to make sure everything inside is valid utf8 first.
3547 c = (const U8 *) SvPVX_const(sv);
3548 if (!is_utf8_string(c, SvCUR(sv)+1))
3550 e = (const U8 *) SvEND(sv);
3553 if (!UTF8_IS_INVARIANT(ch)) {
3563 =for apidoc sv_setsv
3565 Copies the contents of the source SV C<ssv> into the destination SV
3566 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3567 function if the source SV needs to be reused. Does not handle 'set' magic.
3568 Loosely speaking, it performs a copy-by-value, obliterating any previous
3569 content of the destination.
3571 You probably want to use one of the assortment of wrappers, such as
3572 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3573 C<SvSetMagicSV_nosteal>.
3575 =for apidoc sv_setsv_flags
3577 Copies the contents of the source SV C<ssv> into the destination SV
3578 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3579 function if the source SV needs to be reused. Does not handle 'set' magic.
3580 Loosely speaking, it performs a copy-by-value, obliterating any previous
3581 content of the destination.
3582 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3583 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3584 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3585 and C<sv_setsv_nomg> are implemented in terms of this function.
3587 You probably want to use one of the assortment of wrappers, such as
3588 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3589 C<SvSetMagicSV_nosteal>.
3591 This is the primary function for copying scalars, and most other
3592 copy-ish functions and macros use this underneath.
3598 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3600 I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3601 HV *old_stash = NULL;
3603 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3605 if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3606 const char * const name = GvNAME(sstr);
3607 const STRLEN len = GvNAMELEN(sstr);
3609 if (dtype >= SVt_PV) {
3615 SvUPGRADE(dstr, SVt_PVGV);
3616 (void)SvOK_off(dstr);
3617 /* FIXME - why are we doing this, then turning it off and on again
3619 isGV_with_GP_on(dstr);
3621 GvSTASH(dstr) = GvSTASH(sstr);
3623 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3624 gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD);
3625 SvFAKE_on(dstr); /* can coerce to non-glob */
3628 if(GvGP(MUTABLE_GV(sstr))) {
3629 /* If source has method cache entry, clear it */
3631 SvREFCNT_dec(GvCV(sstr));
3632 GvCV_set(sstr, NULL);
3635 /* If source has a real method, then a method is
3638 GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3644 /* If dest already had a real method, that's a change as well */
3646 !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3647 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3652 /* We don’t need to check the name of the destination if it was not a
3653 glob to begin with. */
3654 if(dtype == SVt_PVGV) {
3655 const char * const name = GvNAME((const GV *)dstr);
3658 /* The stash may have been detached from the symbol table, so
3660 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3661 && GvAV((const GV *)sstr)
3665 const STRLEN len = GvNAMELEN(dstr);
3666 if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
3669 /* Set aside the old stash, so we can reset isa caches on
3671 if((old_stash = GvHV(dstr)))
3672 /* Make sure we do not lose it early. */
3673 SvREFCNT_inc_simple_void_NN(
3674 sv_2mortal((SV *)old_stash)
3680 gp_free(MUTABLE_GV(dstr));
3681 isGV_with_GP_off(dstr);
3682 (void)SvOK_off(dstr);
3683 isGV_with_GP_on(dstr);
3684 GvINTRO_off(dstr); /* one-shot flag */
3685 GvGP_set(dstr, gp_ref(GvGP(sstr)));
3686 if (SvTAINTED(sstr))
3688 if (GvIMPORTED(dstr) != GVf_IMPORTED
3689 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3691 GvIMPORTED_on(dstr);
3694 if(mro_changes == 2) {
3696 SV * const sref = (SV *)GvAV((const GV *)dstr);
3697 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3698 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3699 AV * const ary = newAV();
3700 av_push(ary, mg->mg_obj); /* takes the refcount */
3701 mg->mg_obj = (SV *)ary;
3703 av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3705 else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3706 mro_isa_changed_in(GvSTASH(dstr));
3708 else if(mro_changes == 3) {
3709 HV * const stash = GvHV(dstr);
3710 if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3716 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3721 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3723 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3725 const int intro = GvINTRO(dstr);
3728 const U32 stype = SvTYPE(sref);
3730 PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3733 GvINTRO_off(dstr); /* one-shot flag */
3734 GvLINE(dstr) = CopLINE(PL_curcop);
3735 GvEGV(dstr) = MUTABLE_GV(dstr);
3740 location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
3741 import_flag = GVf_IMPORTED_CV;
3744 location = (SV **) &GvHV(dstr);
3745 import_flag = GVf_IMPORTED_HV;
3748 location = (SV **) &GvAV(dstr);
3749 import_flag = GVf_IMPORTED_AV;
3752 location = (SV **) &GvIOp(dstr);
3755 location = (SV **) &GvFORM(dstr);
3758 location = &GvSV(dstr);
3759 import_flag = GVf_IMPORTED_SV;
3762 if (stype == SVt_PVCV) {
3763 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3764 if (GvCVGEN(dstr)) {
3765 SvREFCNT_dec(GvCV(dstr));
3766 GvCV_set(dstr, NULL);
3767 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3770 SAVEGENERICSV(*location);
3774 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3775 CV* const cv = MUTABLE_CV(*location);
3777 if (!GvCVGEN((const GV *)dstr) &&
3778 (CvROOT(cv) || CvXSUB(cv)))
3780 /* Redefining a sub - warning is mandatory if
3781 it was a const and its value changed. */
3782 if (CvCONST(cv) && CvCONST((const CV *)sref)
3784 == cv_const_sv((const CV *)sref)) {
3786 /* They are 2 constant subroutines generated from
3787 the same constant. This probably means that
3788 they are really the "same" proxy subroutine
3789 instantiated in 2 places. Most likely this is
3790 when a constant is exported twice. Don't warn.
3793 else if (ckWARN(WARN_REDEFINE)
3795 && (!CvCONST((const CV *)sref)
3796 || sv_cmp(cv_const_sv(cv),
3797 cv_const_sv((const CV *)
3799 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3802 ? "Constant subroutine %s::%s redefined"
3803 : "Subroutine %s::%s redefined"),
3804 HvNAME_get(GvSTASH((const GV *)dstr)),
3805 GvENAME(MUTABLE_GV(dstr)));
3809 cv_ckproto_len(cv, (const GV *)dstr,
3810 SvPOK(sref) ? SvPVX_const(sref) : NULL,
3811 SvPOK(sref) ? SvCUR(sref) : 0);
3813 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3814 GvASSUMECV_on(dstr);
3815 if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3818 if (import_flag && !(GvFLAGS(dstr) & import_flag)
3819 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3820 GvFLAGS(dstr) |= import_flag;
3822 if (stype == SVt_PVHV) {
3823 const char * const name = GvNAME((GV*)dstr);
3824 const STRLEN len = GvNAMELEN(dstr);
3826 len > 1 && name[len-2] == ':' && name[len-1] == ':'
3827 && (!dref || HvENAME_get(dref))
3830 (HV *)sref, (HV *)dref,
3836 stype == SVt_PVAV && sref != dref
3837 && strEQ(GvNAME((GV*)dstr), "ISA")
3838 /* The stash may have been detached from the symbol table, so
3839 check its name before doing anything. */
3840 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3843 MAGIC * const omg = dref && SvSMAGICAL(dref)
3844 ? mg_find(dref, PERL_MAGIC_isa)
3846 if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3847 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3848 AV * const ary = newAV();
3849 av_push(ary, mg->mg_obj); /* takes the refcount */
3850 mg->mg_obj = (SV *)ary;
3853 if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
3854 SV **svp = AvARRAY((AV *)omg->mg_obj);
3855 I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
3859 SvREFCNT_inc_simple_NN(*svp++)
3865 SvREFCNT_inc_simple_NN(omg->mg_obj)
3869 av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
3874 sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
3876 mg = mg_find(sref, PERL_MAGIC_isa);
3878 /* Since the *ISA assignment could have affected more than
3879 one stash, don’t call mro_isa_changed_in directly, but let
3880 magic_clearisa do it for us, as it already has the logic for
3881 dealing with globs vs arrays of globs. */
3883 Perl_magic_clearisa(aTHX_ NULL, mg);
3888 if (SvTAINTED(sstr))
3894 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3897 register U32 sflags;
3899 register svtype stype;
3901 PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3906 if (SvIS_FREED(dstr)) {
3907 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3908 " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3910 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3912 sstr = &PL_sv_undef;
3913 if (SvIS_FREED(sstr)) {
3914 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3915 (void*)sstr, (void*)dstr);
3917 stype = SvTYPE(sstr);
3918 dtype = SvTYPE(dstr);
3920 (void)SvAMAGIC_off(dstr);
3923 /* need to nuke the magic */
3927 /* There's a lot of redundancy below but we're going for speed here */
3932 if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
3933 (void)SvOK_off(dstr);
3941 sv_upgrade(dstr, SVt_IV);
3945 sv_upgrade(dstr, SVt_PVIV);
3949 goto end_of_first_switch;
3951 (void)SvIOK_only(dstr);
3952 SvIV_set(dstr, SvIVX(sstr));
3955 /* SvTAINTED can only be true if the SV has taint magic, which in
3956 turn means that the SV type is PVMG (or greater). This is the
3957 case statement for SVt_IV, so this cannot be true (whatever gcov
3959 assert(!SvTAINTED(sstr));
3964 if (dtype < SVt_PV && dtype != SVt_IV)
3965 sv_upgrade(dstr, SVt_IV);
3973 sv_upgrade(dstr, SVt_NV);
3977 sv_upgrade(dstr, SVt_PVNV);
3981 goto end_of_first_switch;
3983 SvNV_set(dstr, SvNVX(sstr));
3984 (void)SvNOK_only(dstr);
3985 /* SvTAINTED can only be true if the SV has taint magic, which in
3986 turn means that the SV type is PVMG (or greater). This is the
3987 case statement for SVt_NV, so this cannot be true (whatever gcov
3989 assert(!SvTAINTED(sstr));
3995 #ifdef PERL_OLD_COPY_ON_WRITE
3996 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3997 if (dtype < SVt_PVIV)
3998 sv_upgrade(dstr, SVt_PVIV);
4005 sv_upgrade(dstr, SVt_PV);
4008 if (dtype < SVt_PVIV)
4009 sv_upgrade(dstr, SVt_PVIV);
4012 if (dtype < SVt_PVNV)
4013 sv_upgrade(dstr, SVt_PVNV);
4017 const char * const type = sv_reftype(sstr,0);
4019 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4021 Perl_croak(aTHX_ "Bizarre copy of %s", type);
4026 if (dtype < SVt_REGEXP)
4027 sv_upgrade(dstr, SVt_REGEXP);
4030 /* case SVt_BIND: */
4033 /* SvVALID means that this PVGV is playing at being an FBM. */
4036 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4038 if (SvTYPE(sstr) != stype)
4039 stype = SvTYPE(sstr);
4041 if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4042 glob_assign_glob(dstr, sstr, dtype);
4045 if (stype == SVt_PVLV)
4046 SvUPGRADE(dstr, SVt_PVNV);
4048 SvUPGRADE(dstr, (svtype)stype);
4050 end_of_first_switch:
4052 /* dstr may have been upgraded. */
4053 dtype = SvTYPE(dstr);
4054 sflags = SvFLAGS(sstr);
4056 if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
4057 /* Assigning to a subroutine sets the prototype. */
4060 const char *const ptr = SvPV_const(sstr, len);
4062 SvGROW(dstr, len + 1);
4063 Copy(ptr, SvPVX(dstr), len + 1, char);
4064 SvCUR_set(dstr, len);
4066 SvFLAGS(dstr) |= sflags & SVf_UTF8;
4070 } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
4071 const char * const type = sv_reftype(dstr,0);
4073 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4075 Perl_croak(aTHX_ "Cannot copy to %s", type);
4076 } else if (sflags & SVf_ROK) {
4077 if (isGV_with_GP(dstr)
4078 && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4081 if (GvIMPORTED(dstr) != GVf_IMPORTED
4082 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4084 GvIMPORTED_on(dstr);
4089 glob_assign_glob(dstr, sstr, dtype);
4093 if (dtype >= SVt_PV) {
4094 if (isGV_with_GP(dstr)) {
4095 glob_assign_ref(dstr, sstr);
4098 if (SvPVX_const(dstr)) {
4104 (void)SvOK_off(dstr);
4105 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4106 SvFLAGS(dstr) |= sflags & SVf_ROK;
4107 assert(!(sflags & SVp_NOK));
4108 assert(!(sflags & SVp_IOK));
4109 assert(!(sflags & SVf_NOK));
4110 assert(!(sflags & SVf_IOK));
4112 else if (isGV_with_GP(dstr)) {
4113 if (!(sflags & SVf_OK)) {
4114 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4115 "Undefined value assigned to typeglob");
4118 GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
4119 if (dstr != (const SV *)gv) {
4120 const char * const name = GvNAME((const GV *)dstr);
4121 const STRLEN len = GvNAMELEN(dstr);
4122 HV *old_stash = NULL;
4123 bool reset_isa = FALSE;
4124 if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
4125 /* Set aside the old stash, so we can reset isa caches
4126 on its subclasses. */
4127 if((old_stash = GvHV(dstr))) {
4128 /* Make sure we do not lose it early. */
4129 SvREFCNT_inc_simple_void_NN(
4130 sv_2mortal((SV *)old_stash)
4137 gp_free(MUTABLE_GV(dstr));
4138 GvGP_set(dstr, gp_ref(GvGP(gv)));
4141 HV * const stash = GvHV(dstr);
4143 old_stash ? (HV *)HvENAME_get(old_stash) : stash
4153 else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) {
4154 reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4156 else if (sflags & SVp_POK) {
4160 * Check to see if we can just swipe the string. If so, it's a
4161 * possible small lose on short strings, but a big win on long ones.
4162 * It might even be a win on short strings if SvPVX_const(dstr)
4163 * has to be allocated and SvPVX_const(sstr) has to be freed.
4164 * Likewise if we can set up COW rather than doing an actual copy, we
4165 * drop to the else clause, as the swipe code and the COW setup code
4166 * have much in common.
4169 /* Whichever path we take through the next code, we want this true,
4170 and doing it now facilitates the COW check. */
4171 (void)SvPOK_only(dstr);
4174 /* If we're already COW then this clause is not true, and if COW
4175 is allowed then we drop down to the else and make dest COW
4176 with us. If caller hasn't said that we're allowed to COW
4177 shared hash keys then we don't do the COW setup, even if the
4178 source scalar is a shared hash key scalar. */
4179 (((flags & SV_COW_SHARED_HASH_KEYS)
4180 ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
4181 : 1 /* If making a COW copy is forbidden then the behaviour we
4182 desire is as if the source SV isn't actually already
4183 COW, even if it is. So we act as if the source flags
4184 are not COW, rather than actually testing them. */
4186 #ifndef PERL_OLD_COPY_ON_WRITE
4187 /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
4188 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
4189 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
4190 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
4191 but in turn, it's somewhat dead code, never expected to go
4192 live, but more kept as a placeholder on how to do it better
4193 in a newer implementation. */
4194 /* If we are COW and dstr is a suitable target then we drop down
4195 into the else and make dest a COW of us. */
4196 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4201 (sflags & SVs_TEMP) && /* slated for free anyway? */
4202 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4203 (!(flags & SV_NOSTEAL)) &&
4204 /* and we're allowed to steal temps */
4205 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4206 SvLEN(sstr)) /* and really is a string */
4207 #ifdef PERL_OLD_COPY_ON_WRITE
4208 && ((flags & SV_COW_SHARED_HASH_KEYS)
4209 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4210 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4211 && SvTYPE(sstr) >= SVt_PVIV && SvTYPE(sstr) != SVt_PVFM))
4215 /* Failed the swipe test, and it's not a shared hash key either.
4216 Have to copy the string. */
4217 STRLEN len = SvCUR(sstr);
4218 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4219 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4220 SvCUR_set(dstr, len);
4221 *SvEND(dstr) = '\0';
4223 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4225 /* Either it's a shared hash key, or it's suitable for
4226 copy-on-write or we can swipe the string. */
4228 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4232 #ifdef PERL_OLD_COPY_ON_WRITE
4234 if ((sflags & (SVf_FAKE | SVf_READONLY))
4235 != (SVf_FAKE | SVf_READONLY)) {
4236 SvREADONLY_on(sstr);
4238 /* Make the source SV into a loop of 1.
4239 (about to become 2) */
4240 SV_COW_NEXT_SV_SET(sstr, sstr);
4244 /* Initial code is common. */
4245 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4250 /* making another shared SV. */
4251 STRLEN cur = SvCUR(sstr);
4252 STRLEN len = SvLEN(sstr);
4253 #ifdef PERL_OLD_COPY_ON_WRITE
4255 assert (SvTYPE(dstr) >= SVt_PVIV);
4256 /* SvIsCOW_normal */
4257 /* splice us in between source and next-after-source. */
4258 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4259 SV_COW_NEXT_SV_SET(sstr, dstr);
4260 SvPV_set(dstr, SvPVX_mutable(sstr));
4264 /* SvIsCOW_shared_hash */
4265 DEBUG_C(PerlIO_printf(Perl_debug_log,
4266 "Copy on write: Sharing hash\n"));
4268 assert (SvTYPE(dstr) >= SVt_PV);
4270 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4272 SvLEN_set(dstr, len);
4273 SvCUR_set(dstr, cur);
4274 SvREADONLY_on(dstr);
4278 { /* Passes the swipe test. */
4279 SvPV_set(dstr, SvPVX_mutable(sstr));
4280 SvLEN_set(dstr, SvLEN(sstr));
4281 SvCUR_set(dstr, SvCUR(sstr));
4284 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4285 SvPV_set(sstr, NULL);
4291 if (sflags & SVp_NOK) {
4292 SvNV_set(dstr, SvNVX(sstr));
4294 if (sflags & SVp_IOK) {
4295 SvIV_set(dstr, SvIVX(sstr));
4296 /* Must do this otherwise some other overloaded use of 0x80000000
4297 gets confused. I guess SVpbm_VALID */
4298 if (sflags & SVf_IVisUV)
4301 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4303 const MAGIC * const smg = SvVSTRING_mg(sstr);
4305 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4306 smg->mg_ptr, smg->mg_len);
4307 SvRMAGICAL_on(dstr);
4311 else if (sflags & (SVp_IOK|SVp_NOK)) {
4312 (void)SvOK_off(dstr);
4313 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4314 if (sflags & SVp_IOK) {
4315 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4316 SvIV_set(dstr, SvIVX(sstr));
4318 if (sflags & SVp_NOK) {
4319 SvNV_set(dstr, SvNVX(sstr));
4323 if (isGV_with_GP(sstr)) {
4324 /* This stringification rule for globs is spread in 3 places.
4325 This feels bad. FIXME. */
4326 const U32 wasfake = sflags & SVf_FAKE;
4328 /* FAKE globs can get coerced, so need to turn this off
4329 temporarily if it is on. */
4331 gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4332 SvFLAGS(sstr) |= wasfake;
4335 (void)SvOK_off(dstr);
4337 if (SvTAINTED(sstr))
4342 =for apidoc sv_setsv_mg
4344 Like C<sv_setsv>, but also handles 'set' magic.
4350 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4352 PERL_ARGS_ASSERT_SV_SETSV_MG;
4354 sv_setsv(dstr,sstr);
4358 #ifdef PERL_OLD_COPY_ON_WRITE
4360 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4362 STRLEN cur = SvCUR(sstr);
4363 STRLEN len = SvLEN(sstr);
4364 register char *new_pv;
4366 PERL_ARGS_ASSERT_SV_SETSV_COW;
4369 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4370 (void*)sstr, (void*)dstr);
4377 if (SvTHINKFIRST(dstr))
4378 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4379 else if (SvPVX_const(dstr))
4380 Safefree(SvPVX_const(dstr));
4384 SvUPGRADE(dstr, SVt_PVIV);
4386 assert (SvPOK(sstr));
4387 assert (SvPOKp(sstr));
4388 assert (!SvIOK(sstr));
4389 assert (!SvIOKp(sstr));
4390 assert (!SvNOK(sstr));
4391 assert (!SvNOKp(sstr));
4393 if (SvIsCOW(sstr)) {
4395 if (SvLEN(sstr) == 0) {
4396 /* source is a COW shared hash key. */
4397 DEBUG_C(PerlIO_printf(Perl_debug_log,
4398 "Fast copy on write: Sharing hash\n"));
4399 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4402 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4404 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4405 SvUPGRADE(sstr, SVt_PVIV);
4406 SvREADONLY_on(sstr);
4408 DEBUG_C(PerlIO_printf(Perl_debug_log,
4409 "Fast copy on write: Converting sstr to COW\n"));
4410 SV_COW_NEXT_SV_SET(dstr, sstr);
4412 SV_COW_NEXT_SV_SET(sstr, dstr);
4413 new_pv = SvPVX_mutable(sstr);
4416 SvPV_set(dstr, new_pv);
4417 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4420 SvLEN_set(dstr, len);
4421 SvCUR_set(dstr, cur);
4430 =for apidoc sv_setpvn
4432 Copies a string into an SV. The C<len> parameter indicates the number of
4433 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4434 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4440 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4443 register char *dptr;
4445 PERL_ARGS_ASSERT_SV_SETPVN;
4447 SV_CHECK_THINKFIRST_COW_DROP(sv);
4453 /* len is STRLEN which is unsigned, need to copy to signed */
4456 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4458 SvUPGRADE(sv, SVt_PV);
4460 dptr = SvGROW(sv, len + 1);
4461 Move(ptr,dptr,len,char);
4464 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4469 =for apidoc sv_setpvn_mg
4471 Like C<sv_setpvn>, but also handles 'set' magic.
4477 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4479 PERL_ARGS_ASSERT_SV_SETPVN_MG;
4481 sv_setpvn(sv,ptr,len);
4486 =for apidoc sv_setpv
4488 Copies a string into an SV. The string must be null-terminated. Does not
4489 handle 'set' magic. See C<sv_setpv_mg>.
4495 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4498 register STRLEN len;
4500 PERL_ARGS_ASSERT_SV_SETPV;
4502 SV_CHECK_THINKFIRST_COW_DROP(sv);
4508 SvUPGRADE(sv, SVt_PV);
4510 SvGROW(sv, len + 1);
4511 Move(ptr,SvPVX(sv),len+1,char);
4513 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4518 =for apidoc sv_setpv_mg
4520 Like C<sv_setpv>, but also handles 'set' magic.
4526 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4528 PERL_ARGS_ASSERT_SV_SETPV_MG;
4535 =for apidoc sv_usepvn_flags
4537 Tells an SV to use C<ptr> to find its string value. Normally the
4538 string is stored inside the SV but sv_usepvn allows the SV to use an
4539 outside string. The C<ptr> should point to memory that was allocated
4540 by C<malloc>. The string length, C<len>, must be supplied. By default
4541 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4542 so that pointer should not be freed or used by the programmer after
4543 giving it to sv_usepvn, and neither should any pointers from "behind"
4544 that pointer (e.g. ptr + 1) be used.
4546 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4547 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4548 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4549 C<len>, and already meets the requirements for storing in C<SvPVX>)
4555 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4560 PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4562 SV_CHECK_THINKFIRST_COW_DROP(sv);
4563 SvUPGRADE(sv, SVt_PV);
4566 if (flags & SV_SMAGIC)
4570 if (SvPVX_const(sv))
4574 if (flags & SV_HAS_TRAILING_NUL)
4575 assert(ptr[len] == '\0');
4578 allocate = (flags & SV_HAS_TRAILING_NUL)
4580 #ifdef Perl_safesysmalloc_size
4583 PERL_STRLEN_ROUNDUP(len + 1);
4585 if (flags & SV_HAS_TRAILING_NUL) {
4586 /* It's long enough - do nothing.
4587 Specifically Perl_newCONSTSUB is relying on this. */
4590 /* Force a move to shake out bugs in callers. */
4591 char *new_ptr = (char*)safemalloc(allocate);
4592 Copy(ptr, new_ptr, len, char);
4593 PoisonFree(ptr,len,char);
4597 ptr = (char*) saferealloc (ptr, allocate);
4600 #ifdef Perl_safesysmalloc_size
4601 SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4603 SvLEN_set(sv, allocate);
4607 if (!(flags & SV_HAS_TRAILING_NUL)) {
4610 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4612 if (flags & SV_SMAGIC)
4616 #ifdef PERL_OLD_COPY_ON_WRITE
4617 /* Need to do this *after* making the SV normal, as we need the buffer
4618 pointer to remain valid until after we've copied it. If we let go too early,
4619 another thread could invalidate it by unsharing last of the same hash key
4620 (which it can do by means other than releasing copy-on-write Svs)
4621 or by changing the other copy-on-write SVs in the loop. */
4623 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4625 PERL_ARGS_ASSERT_SV_RELEASE_COW;
4627 { /* this SV was SvIsCOW_normal(sv) */
4628 /* we need to find the SV pointing to us. */
4629 SV *current = SV_COW_NEXT_SV(after);
4631 if (current == sv) {
4632 /* The SV we point to points back to us (there were only two of us
4634 Hence other SV is no longer copy on write either. */
4636 SvREADONLY_off(after);
4638 /* We need to follow the pointers around the loop. */
4640 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4643 /* don't loop forever if the structure is bust, and we have
4644 a pointer into a closed loop. */
4645 assert (current != after);
4646 assert (SvPVX_const(current) == pvx);
4648 /* Make the SV before us point to the SV after us. */
4649 SV_COW_NEXT_SV_SET(current, after);
4655 =for apidoc sv_force_normal_flags
4657 Undo various types of fakery on an SV: if the PV is a shared string, make
4658 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4659 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4660 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4661 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4662 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4663 set to some other value.) In addition, the C<flags> parameter gets passed to
4664 C<sv_unref_flags()> when unreffing. C<sv_force_normal> calls this function
4665 with flags set to 0.
4671 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4675 PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4677 #ifdef PERL_OLD_COPY_ON_WRITE
4678 if (SvREADONLY(sv)) {
4680 const char * const pvx = SvPVX_const(sv);
4681 const STRLEN len = SvLEN(sv);
4682 const STRLEN cur = SvCUR(sv);
4683 /* next COW sv in the loop. If len is 0 then this is a shared-hash
4684 key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4685 we'll fail an assertion. */
4686 SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4689 PerlIO_printf(Perl_debug_log,
4690 "Copy on write: Force normal %ld\n",
4696 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4699 if (flags & SV_COW_DROP_PV) {
4700 /* OK, so we don't need to copy our buffer. */
4703 SvGROW(sv, cur + 1);
4704 Move(pvx,SvPVX(sv),cur,char);
4709 sv_release_COW(sv, pvx, next);
4711 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4717 else if (IN_PERL_RUNTIME)
4718 Perl_croak_no_modify(aTHX);
4721 if (SvREADONLY(sv)) {
4723 const char * const pvx = SvPVX_const(sv);
4724 const STRLEN len = SvCUR(sv);
4729 SvGROW(sv, len + 1);
4730 Move(pvx,SvPVX(sv),len,char);
4732 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4734 else if (IN_PERL_RUNTIME)
4735 Perl_croak_no_modify(aTHX);
4739 sv_unref_flags(sv, flags);
4740 else if (SvFAKE(sv) && isGV_with_GP(sv))
4742 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
4743 /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
4744 to sv_unglob. We only need it here, so inline it. */
4745 const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
4746 SV *const temp = newSV_type(new_type);
4747 void *const temp_p = SvANY(sv);
4749 if (new_type == SVt_PVMG) {
4750 SvMAGIC_set(temp, SvMAGIC(sv));
4751 SvMAGIC_set(sv, NULL);
4752 SvSTASH_set(temp, SvSTASH(sv));
4753 SvSTASH_set(sv, NULL);
4755 SvCUR_set(temp, SvCUR(sv));
4756 /* Remember that SvPVX is in the head, not the body. */
4758 SvLEN_set(temp, SvLEN(sv));
4759 /* This signals "buffer is owned by someone else" in sv_clear,
4760 which is the least effort way to stop it freeing the buffer.
4762 SvLEN_set(sv, SvLEN(sv)+1);
4764 /* Their buffer is already owned by someone else. */
4765 SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv));
4766 SvLEN_set(temp, SvCUR(sv)+1);
4769 /* Now swap the rest of the bodies. */
4771 SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK);
4772 SvFLAGS(sv) |= new_type;
4773 SvANY(sv) = SvANY(temp);
4775 SvFLAGS(temp) &= ~(SVTYPEMASK);
4776 SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
4777 SvANY(temp) = temp_p;
4786 Efficient removal of characters from the beginning of the string buffer.
4787 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4788 the string buffer. The C<ptr> becomes the first character of the adjusted
4789 string. Uses the "OOK hack".
4790 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4791 refer to the same chunk of data.
4797 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4803 const U8 *real_start;
4807 PERL_ARGS_ASSERT_SV_CHOP;
4809 if (!ptr || !SvPOKp(sv))
4811 delta = ptr - SvPVX_const(sv);
4813 /* Nothing to do. */
4816 /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
4817 nothing uses the value of ptr any more. */
4818 max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4819 if (ptr <= SvPVX_const(sv))
4820 Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4821 ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4822 SV_CHECK_THINKFIRST(sv);
4823 if (delta > max_delta)
4824 Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
4825 SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
4826 SvPVX_const(sv) + max_delta);
4829 if (!SvLEN(sv)) { /* make copy of shared string */
4830 const char *pvx = SvPVX_const(sv);
4831 const STRLEN len = SvCUR(sv);
4832 SvGROW(sv, len + 1);
4833 Move(pvx,SvPVX(sv),len,char);
4836 SvFLAGS(sv) |= SVf_OOK;
4839 SvOOK_offset(sv, old_delta);
4841 SvLEN_set(sv, SvLEN(sv) - delta);
4842 SvCUR_set(sv, SvCUR(sv) - delta);
4843 SvPV_set(sv, SvPVX(sv) + delta);
4845 p = (U8 *)SvPVX_const(sv);
4850 real_start = p - delta;
4854 if (delta < 0x100) {
4858 p -= sizeof(STRLEN);
4859 Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4863 /* Fill the preceding buffer with sentinals to verify that no-one is
4865 while (p > real_start) {
4873 =for apidoc sv_catpvn
4875 Concatenates the string onto the end of the string which is in the SV. The
4876 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4877 status set, then the bytes appended should be valid UTF-8.
4878 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4880 =for apidoc sv_catpvn_flags
4882 Concatenates the string onto the end of the string which is in the SV. The
4883 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4884 status set, then the bytes appended should be valid UTF-8.
4885 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4886 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4887 in terms of this function.
4893 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4897 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4899 PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4901 SvGROW(dsv, dlen + slen + 1);
4903 sstr = SvPVX_const(dsv);
4904 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4905 SvCUR_set(dsv, SvCUR(dsv) + slen);
4907 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4909 if (flags & SV_SMAGIC)
4914 =for apidoc sv_catsv
4916 Concatenates the string from SV C<ssv> onto the end of the string in
4917 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4918 not 'set' magic. See C<sv_catsv_mg>.
4920 =for apidoc sv_catsv_flags
4922 Concatenates the string from SV C<ssv> onto the end of the string in
4923 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4924 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4925 and C<sv_catsv_nomg> are implemented in terms of this function.
4930 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4934 PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4938 const char *spv = SvPV_flags_const(ssv, slen, flags);
4940 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4941 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4942 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4943 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4944 dsv->sv_flags doesn't have that bit set.
4945 Andy Dougherty 12 Oct 2001
4947 const I32 sutf8 = DO_UTF8(ssv);
4950 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4952 dutf8 = DO_UTF8(dsv);
4954 if (dutf8 != sutf8) {
4956 /* Not modifying source SV, so taking a temporary copy. */
4957 SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
4959 sv_utf8_upgrade(csv);
4960 spv = SvPV_const(csv, slen);
4963 /* Leave enough space for the cat that's about to happen */
4964 sv_utf8_upgrade_flags_grow(dsv, 0, slen);
4966 sv_catpvn_nomg(dsv, spv, slen);
4969 if (flags & SV_SMAGIC)
4974 =for apidoc sv_catpv
4976 Concatenates the string onto the end of the string which is in the SV.
4977 If the SV has the UTF-8 status set, then the bytes appended should be
4978 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4983 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
4986 register STRLEN len;
4990 PERL_ARGS_ASSERT_SV_CATPV;
4994 junk = SvPV_force(sv, tlen);
4996 SvGROW(sv, tlen + len + 1);
4998 ptr = SvPVX_const(sv);
4999 Move(ptr,SvPVX(sv)+tlen,len+1,char);
5000 SvCUR_set(sv, SvCUR(sv) + len);
5001 (void)SvPOK_only_UTF8(sv); /* validate pointer */
5006 =for apidoc sv_catpv_flags
5008 Concatenates the string onto the end of the string which is in the SV.
5009 If the SV has the UTF-8 status set, then the bytes appended should
5010 be valid UTF-8. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get>
5011 on the SVs if appropriate, else not.
5017 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
5019 PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5020 sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
5024 =for apidoc sv_catpv_mg
5026 Like C<sv_catpv>, but also handles 'set' magic.
5032 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
5034 PERL_ARGS_ASSERT_SV_CATPV_MG;
5043 Creates a new SV. A non-zero C<len> parameter indicates the number of
5044 bytes of preallocated string space the SV should have. An extra byte for a
5045 trailing NUL is also reserved. (SvPOK is not set for the SV even if string
5046 space is allocated.) The reference count for the new SV is set to 1.
5048 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
5049 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5050 This aid has been superseded by a new build option, PERL_MEM_LOG (see
5051 L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
5052 modules supporting older perls.
5058 Perl_newSV(pTHX_ const STRLEN len)
5065 sv_upgrade(sv, SVt_PV);
5066 SvGROW(sv, len + 1);
5071 =for apidoc sv_magicext
5073 Adds magic to an SV, upgrading it if necessary. Applies the
5074 supplied vtable and returns a pointer to the magic added.
5076 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5077 In particular, you can add magic to SvREADONLY SVs, and add more than
5078 one instance of the same 'how'.
5080 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5081 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5082 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5083 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5085 (This is now used as a subroutine by C<sv_magic>.)
5090 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
5091 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5096 PERL_ARGS_ASSERT_SV_MAGICEXT;
5098 SvUPGRADE(sv, SVt_PVMG);
5099 Newxz(mg, 1, MAGIC);
5100 mg->mg_moremagic = SvMAGIC(sv);
5101 SvMAGIC_set(sv, mg);
5103 /* Sometimes a magic contains a reference loop, where the sv and
5104 object refer to each other. To prevent a reference loop that
5105 would prevent such objects being freed, we look for such loops
5106 and if we find one we avoid incrementing the object refcount.
5108 Note we cannot do this to avoid self-tie loops as intervening RV must
5109 have its REFCNT incremented to keep it in existence.
5112 if (!obj || obj == sv ||
5113 how == PERL_MAGIC_arylen ||
5114 how == PERL_MAGIC_symtab ||
5115 (SvTYPE(obj) == SVt_PVGV &&
5116 (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5117 || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5118 || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5123 mg->mg_obj = SvREFCNT_inc_simple(obj);
5124 mg->mg_flags |= MGf_REFCOUNTED;
5127 /* Normal self-ties simply pass a null object, and instead of
5128 using mg_obj directly, use the SvTIED_obj macro to produce a
5129 new RV as needed. For glob "self-ties", we are tieing the PVIO
5130 with an RV obj pointing to the glob containing the PVIO. In
5131 this case, to avoid a reference loop, we need to weaken the
5135 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5136 obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5142 mg->mg_len = namlen;
5145 mg->mg_ptr = savepvn(name, namlen);
5146 else if (namlen == HEf_SVKEY) {
5147 /* Yes, this is casting away const. This is only for the case of
5148 HEf_SVKEY. I think we need to document this aberation of the
5149 constness of the API, rather than making name non-const, as
5150 that change propagating outwards a long way. */
5151 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5153 mg->mg_ptr = (char *) name;
5155 mg->mg_virtual = (MGVTBL *) vtable;
5159 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5164 =for apidoc sv_magic
5166 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
5167 then adds a new magic item of type C<how> to the head of the magic list.
5169 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5170 handling of the C<name> and C<namlen> arguments.
5172 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5173 to add more than one instance of the same 'how'.
5179 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
5180 const char *const name, const I32 namlen)
5183 const MGVTBL *vtable;
5186 PERL_ARGS_ASSERT_SV_MAGIC;
5188 #ifdef PERL_OLD_COPY_ON_WRITE
5190 sv_force_normal_flags(sv, 0);
5192 if (SvREADONLY(sv)) {
5194 /* its okay to attach magic to shared strings; the subsequent
5195 * upgrade to PVMG will unshare the string */
5196 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
5199 && how != PERL_MAGIC_regex_global
5200 && how != PERL_MAGIC_bm
5201 && how != PERL_MAGIC_fm
5202 && how != PERL_MAGIC_sv
5203 && how != PERL_MAGIC_backref
5206 Perl_croak_no_modify(aTHX);
5209 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5210 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5211 /* sv_magic() refuses to add a magic of the same 'how' as an
5214 if (how == PERL_MAGIC_taint) {
5216 /* Any scalar which already had taint magic on which someone
5217 (erroneously?) did SvIOK_on() or similar will now be
5218 incorrectly sporting public "OK" flags. */
5219 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5227 vtable = &PL_vtbl_sv;
5229 case PERL_MAGIC_overload:
5230 vtable = &PL_vtbl_amagic;
5232 case PERL_MAGIC_overload_elem:
5233 vtable = &PL_vtbl_amagicelem;
5235 case PERL_MAGIC_overload_table:
5236 vtable = &PL_vtbl_ovrld;
5239 vtable = &PL_vtbl_bm;
5241 case PERL_MAGIC_regdata:
5242 vtable = &PL_vtbl_regdata;
5244 case PERL_MAGIC_regdatum:
5245 vtable = &PL_vtbl_regdatum;
5247 case PERL_MAGIC_env:
5248 vtable = &PL_vtbl_env;
5251 vtable = &PL_vtbl_fm;
5253 case PERL_MAGIC_envelem:
5254 vtable = &PL_vtbl_envelem;
5256 case PERL_MAGIC_regex_global:
5257 vtable = &PL_vtbl_mglob;
5259 case PERL_MAGIC_isa:
5260 vtable = &PL_vtbl_isa;
5262 case PERL_MAGIC_isaelem:
5263 vtable = &PL_vtbl_isaelem;
5265 case PERL_MAGIC_nkeys:
5266 vtable = &PL_vtbl_nkeys;
5268 case PERL_MAGIC_dbfile:
5271 case PERL_MAGIC_dbline:
5272 vtable = &PL_vtbl_dbline;
5274 #ifdef USE_LOCALE_COLLATE
5275 case PERL_MAGIC_collxfrm:
5276 vtable = &PL_vtbl_collxfrm;
5278 #endif /* USE_LOCALE_COLLATE */
5279 case PERL_MAGIC_tied:
5280 vtable = &PL_vtbl_pack;
5282 case PERL_MAGIC_tiedelem:
5283 case PERL_MAGIC_tiedscalar:
5284 vtable = &PL_vtbl_packelem;
5287 vtable = &PL_vtbl_regexp;
5289 case PERL_MAGIC_sig:
5290 vtable = &PL_vtbl_sig;
5292 case PERL_MAGIC_sigelem:
5293 vtable = &PL_vtbl_sigelem;
5295 case PERL_MAGIC_taint:
5296 vtable = &PL_vtbl_taint;
5298 case PERL_MAGIC_uvar:
5299 vtable = &PL_vtbl_uvar;
5301 case PERL_MAGIC_vec:
5302 vtable = &PL_vtbl_vec;
5304 case PERL_MAGIC_arylen_p:
5305 case PERL_MAGIC_rhash:
5306 case PERL_MAGIC_symtab:
5307 case PERL_MAGIC_vstring:
5308 case PERL_MAGIC_checkcall:
5311 case PERL_MAGIC_utf8:
5312 vtable = &PL_vtbl_utf8;
5314 case PERL_MAGIC_substr:
5315 vtable = &PL_vtbl_substr;
5317 case PERL_MAGIC_defelem:
5318 vtable = &PL_vtbl_defelem;
5320 case PERL_MAGIC_arylen:
5321 vtable = &PL_vtbl_arylen;
5323 case PERL_MAGIC_pos:
5324 vtable = &PL_vtbl_pos;
5326 case PERL_MAGIC_backref:
5327 vtable = &PL_vtbl_backref;
5329 case PERL_MAGIC_hintselem:
5330 vtable = &PL_vtbl_hintselem;
5332 case PERL_MAGIC_hints:
5333 vtable = &PL_vtbl_hints;
5335 case PERL_MAGIC_ext:
5336 /* Reserved for use by extensions not perl internals. */
5337 /* Useful for attaching extension internal data to perl vars. */
5338 /* Note that multiple extensions may clash if magical scalars */
5339 /* etc holding private data from one are passed to another. */
5343 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5346 /* Rest of work is done else where */
5347 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5350 case PERL_MAGIC_taint:
5353 case PERL_MAGIC_ext:
5354 case PERL_MAGIC_dbfile:
5361 S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
5368 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5370 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5371 for (mg = *mgp; mg; mg = *mgp) {
5372 const MGVTBL* const virt = mg->mg_virtual;
5373 if (mg->mg_type == type && (!flags || virt == vtbl)) {
5374 *mgp = mg->mg_moremagic;
5375 if (virt && virt->svt_free)
5376 virt->svt_free(aTHX_ sv, mg);
5377 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5379 Safefree(mg->mg_ptr);
5380 else if (mg->mg_len == HEf_SVKEY)
5381 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5382 else if (mg->mg_type == PERL_MAGIC_utf8)
5383 Safefree(mg->mg_ptr);
5385 if (mg->mg_flags & MGf_REFCOUNTED)
5386 SvREFCNT_dec(mg->mg_obj);
5390 mgp = &mg->mg_moremagic;
5393 if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */
5394 mg_magical(sv); /* else fix the flags now */
5398 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5404 =for apidoc sv_unmagic
5406 Removes all magic of type C<type> from an SV.
5412 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5414 PERL_ARGS_ASSERT_SV_UNMAGIC;
5415 return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
5419 =for apidoc sv_unmagicext
5421 Removes all magic of type C<type> with the specified C<vtbl> from an SV.
5427 Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
5429 PERL_ARGS_ASSERT_SV_UNMAGICEXT;
5430 return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
5434 =for apidoc sv_rvweaken
5436 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5437 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5438 push a back-reference to this RV onto the array of backreferences
5439 associated with that magic. If the RV is magical, set magic will be
5440 called after the RV is cleared.
5446 Perl_sv_rvweaken(pTHX_ SV *const sv)
5450 PERL_ARGS_ASSERT_SV_RVWEAKEN;
5452 if (!SvOK(sv)) /* let undefs pass */
5455 Perl_croak(aTHX_ "Can't weaken a nonreference");
5456 else if (SvWEAKREF(sv)) {
5457 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5461 Perl_sv_add_backref(aTHX_ tsv, sv);
5467 /* Give tsv backref magic if it hasn't already got it, then push a
5468 * back-reference to sv onto the array associated with the backref magic.
5470 * As an optimisation, if there's only one backref and it's not an AV,
5471 * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5472 * allocate an AV. (Whether the slot holds an AV tells us whether this is
5475 * If an HV's backref is stored in magic, it is moved back to HvAUX.
5478 /* A discussion about the backreferences array and its refcount:
5480 * The AV holding the backreferences is pointed to either as the mg_obj of
5481 * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
5482 * structure, from the xhv_backreferences field. (A HV without hv_aux will
5483 * have the standard magic instead.) The array is created with a refcount
5484 * of 2. This means that if during global destruction the array gets
5485 * picked on before its parent to have its refcount decremented by the
5486 * random zapper, it won't actually be freed, meaning it's still there for
5487 * when its parent gets freed.
5489 * When the parent SV is freed, the extra ref is killed by
5490 * Perl_sv_kill_backrefs. The other ref is killed, in the case of magic,
5491 * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5493 * When a single backref SV is stored directly, it is not reference
5498 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5505 PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5507 /* find slot to store array or singleton backref */
5509 if (SvTYPE(tsv) == SVt_PVHV) {
5510 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5513 if ((mg = mg_find(tsv, PERL_MAGIC_backref))) {
5514 /* Aha. They've got it stowed in magic instead.
5515 * Move it back to xhv_backreferences */
5517 /* Stop mg_free decreasing the reference count. */
5519 /* Stop mg_free even calling the destructor, given that
5520 there's no AV to free up. */
5522 sv_unmagic(tsv, PERL_MAGIC_backref);
5528 (SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL))))
5530 sv_magic(tsv, NULL, PERL_MAGIC_backref, NULL, 0);
5531 mg = mg_find(tsv, PERL_MAGIC_backref);
5533 svp = &(mg->mg_obj);
5536 /* create or retrieve the array */
5538 if ( (!*svp && SvTYPE(sv) == SVt_PVAV)
5539 || (*svp && SvTYPE(*svp) != SVt_PVAV)
5544 SvREFCNT_inc_simple_void(av);
5545 /* av now has a refcnt of 2; see discussion above */
5547 /* move single existing backref to the array */
5549 AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5553 mg->mg_flags |= MGf_REFCOUNTED;
5556 av = MUTABLE_AV(*svp);
5559 /* optimisation: store single backref directly in HvAUX or mg_obj */
5563 /* push new backref */
5564 assert(SvTYPE(av) == SVt_PVAV);
5565 if (AvFILLp(av) >= AvMAX(av)) {
5566 av_extend(av, AvFILLp(av)+1);
5568 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5571 /* delete a back-reference to ourselves from the backref magic associated
5572 * with the SV we point to.
5576 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5581 PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5583 if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
5584 svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5586 if (!svp || !*svp) {
5588 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5589 svp = mg ? &(mg->mg_obj) : NULL;
5593 Perl_croak(aTHX_ "panic: del_backref");
5595 if (SvTYPE(*svp) == SVt_PVAV) {
5599 AV * const av = (AV*)*svp;
5601 assert(!SvIS_FREED(av));
5605 /* for an SV with N weak references to it, if all those
5606 * weak refs are deleted, then sv_del_backref will be called
5607 * N times and O(N^2) compares will be done within the backref
5608 * array. To ameliorate this potential slowness, we:
5609 * 1) make sure this code is as tight as possible;
5610 * 2) when looking for SV, look for it at both the head and tail of the
5611 * array first before searching the rest, since some create/destroy
5612 * patterns will cause the backrefs to be freed in order.
5619 SV **p = &svp[fill];
5620 SV *const topsv = *p;
5627 /* We weren't the last entry.
5628 An unordered list has this property that you
5629 can take the last element off the end to fill
5630 the hole, and it's still an unordered list :-)
5636 break; /* should only be one */
5643 AvFILLp(av) = fill-1;
5646 /* optimisation: only a single backref, stored directly */
5648 Perl_croak(aTHX_ "panic: del_backref");
5655 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5661 PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5666 is_array = (SvTYPE(av) == SVt_PVAV);
5668 assert(!SvIS_FREED(av));
5671 last = svp + AvFILLp(av);
5674 /* optimisation: only a single backref, stored directly */
5680 while (svp <= last) {
5682 SV *const referrer = *svp;
5683 if (SvWEAKREF(referrer)) {
5684 /* XXX Should we check that it hasn't changed? */
5685 assert(SvROK(referrer));
5686 SvRV_set(referrer, 0);
5688 SvWEAKREF_off(referrer);
5689 SvSETMAGIC(referrer);
5690 } else if (SvTYPE(referrer) == SVt_PVGV ||
5691 SvTYPE(referrer) == SVt_PVLV) {
5692 assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
5693 /* You lookin' at me? */
5694 assert(GvSTASH(referrer));
5695 assert(GvSTASH(referrer) == (const HV *)sv);
5696 GvSTASH(referrer) = 0;
5697 } else if (SvTYPE(referrer) == SVt_PVCV ||
5698 SvTYPE(referrer) == SVt_PVFM) {
5699 if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
5700 /* You lookin' at me? */
5701 assert(CvSTASH(referrer));
5702 assert(CvSTASH(referrer) == (const HV *)sv);
5703 SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
5706 assert(SvTYPE(sv) == SVt_PVGV);
5707 /* You lookin' at me? */
5708 assert(CvGV(referrer));
5709 assert(CvGV(referrer) == (const GV *)sv);
5710 anonymise_cv_maybe(MUTABLE_GV(sv),
5711 MUTABLE_CV(referrer));
5716 "panic: magic_killbackrefs (flags=%"UVxf")",
5717 (UV)SvFLAGS(referrer));
5728 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5734 =for apidoc sv_insert
5736 Inserts a string at the specified offset/length within the SV. Similar to
5737 the Perl substr() function. Handles get magic.
5739 =for apidoc sv_insert_flags
5741 Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
5747 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5752 register char *midend;
5753 register char *bigend;
5757 PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5760 Perl_croak(aTHX_ "Can't modify non-existent substring");
5761 SvPV_force_flags(bigstr, curlen, flags);
5762 (void)SvPOK_only_UTF8(bigstr);
5763 if (offset + len > curlen) {
5764 SvGROW(bigstr, offset+len+1);
5765 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5766 SvCUR_set(bigstr, offset+len);
5770 i = littlelen - len;
5771 if (i > 0) { /* string might grow */
5772 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5773 mid = big + offset + len;
5774 midend = bigend = big + SvCUR(bigstr);
5777 while (midend > mid) /* shove everything down */
5778 *--bigend = *--midend;
5779 Move(little,big+offset,littlelen,char);
5780 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5785 Move(little,SvPVX(bigstr)+offset,len,char);
5790 big = SvPVX(bigstr);
5793 bigend = big + SvCUR(bigstr);
5795 if (midend > bigend)
5796 Perl_croak(aTHX_ "panic: sv_insert");
5798 if (mid - big > bigend - midend) { /* faster to shorten from end */
5800 Move(little, mid, littlelen,char);
5803 i = bigend - midend;
5805 Move(midend, mid, i,char);
5809 SvCUR_set(bigstr, mid - big);
5811 else if ((i = mid - big)) { /* faster from front */
5812 midend -= littlelen;
5814 Move(big, midend - i, i, char);
5815 sv_chop(bigstr,midend-i);
5817 Move(little, mid, littlelen,char);
5819 else if (littlelen) {
5820 midend -= littlelen;
5821 sv_chop(bigstr,midend);
5822 Move(little,midend,littlelen,char);
5825 sv_chop(bigstr,midend);
5831 =for apidoc sv_replace
5833 Make the first argument a copy of the second, then delete the original.
5834 The target SV physically takes over ownership of the body of the source SV
5835 and inherits its flags; however, the target keeps any magic it owns,
5836 and any magic in the source is discarded.
5837 Note that this is a rather specialist SV copying operation; most of the
5838 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5844 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5847 const U32 refcnt = SvREFCNT(sv);
5849 PERL_ARGS_ASSERT_SV_REPLACE;
5851 SV_CHECK_THINKFIRST_COW_DROP(sv);
5852 if (SvREFCNT(nsv) != 1) {
5853 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
5854 " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
5856 if (SvMAGICAL(sv)) {
5860 sv_upgrade(nsv, SVt_PVMG);
5861 SvMAGIC_set(nsv, SvMAGIC(sv));
5862 SvFLAGS(nsv) |= SvMAGICAL(sv);
5864 SvMAGIC_set(sv, NULL);
5868 assert(!SvREFCNT(sv));
5869 #ifdef DEBUG_LEAKING_SCALARS
5870 sv->sv_flags = nsv->sv_flags;
5871 sv->sv_any = nsv->sv_any;
5872 sv->sv_refcnt = nsv->sv_refcnt;
5873 sv->sv_u = nsv->sv_u;
5875 StructCopy(nsv,sv,SV);
5877 if(SvTYPE(sv) == SVt_IV) {
5879 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5883 #ifdef PERL_OLD_COPY_ON_WRITE
5884 if (SvIsCOW_normal(nsv)) {
5885 /* We need to follow the pointers around the loop to make the
5886 previous SV point to sv, rather than nsv. */
5889 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5892 assert(SvPVX_const(current) == SvPVX_const(nsv));
5894 /* Make the SV before us point to the SV after us. */
5896 PerlIO_printf(Perl_debug_log, "previous is\n");
5898 PerlIO_printf(Perl_debug_log,
5899 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5900 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5902 SV_COW_NEXT_SV_SET(current, sv);
5905 SvREFCNT(sv) = refcnt;
5906 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5911 /* We're about to free a GV which has a CV that refers back to us.
5912 * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
5916 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
5922 PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
5925 assert(SvREFCNT(gv) == 0);
5926 assert(isGV(gv) && isGV_with_GP(gv));
5928 assert(!CvANON(cv));
5929 assert(CvGV(cv) == gv);
5931 /* will the CV shortly be freed by gp_free() ? */
5932 if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
5933 SvANY(cv)->xcv_gv = NULL;
5937 /* if not, anonymise: */
5938 stash = GvSTASH(gv) ? HvNAME(GvSTASH(gv)) : NULL;
5939 gvname = Perl_newSVpvf(aTHX_ "%s::__ANON__",
5940 stash ? stash : "__ANON__");
5941 anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
5942 SvREFCNT_dec(gvname);
5946 SvANY(cv)->xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
5951 =for apidoc sv_clear
5953 Clear an SV: call any destructors, free up any memory used by the body,
5954 and free the body itself. The SV's head is I<not> freed, although
5955 its type is set to all 1's so that it won't inadvertently be assumed
5956 to be live during global destruction etc.
5957 This function should only be called when REFCNT is zero. Most of the time
5958 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5965 Perl_sv_clear(pTHX_ SV *const orig_sv)
5970 const struct body_details *sv_type_details;
5973 register SV *sv = orig_sv;
5975 PERL_ARGS_ASSERT_SV_CLEAR;
5977 /* within this loop, sv is the SV currently being freed, and
5978 * iter_sv is the most recent AV or whatever that's being iterated
5979 * over to provide more SVs */
5985 assert(SvREFCNT(sv) == 0);
5986 assert(SvTYPE(sv) != SVTYPEMASK);
5988 if (type <= SVt_IV) {
5989 /* See the comment in sv.h about the collusion between this
5990 * early return and the overloading of the NULL slots in the
5994 SvFLAGS(sv) &= SVf_BREAK;
5995 SvFLAGS(sv) |= SVTYPEMASK;
6000 if (!curse(sv, 1)) goto get_next_sv;
6002 if (type >= SVt_PVMG) {
6003 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
6004 SvREFCNT_dec(SvOURSTASH(sv));
6005 } else if (SvMAGIC(sv))
6007 if (type == SVt_PVMG && SvPAD_TYPED(sv))
6008 SvREFCNT_dec(SvSTASH(sv));
6011 /* case SVt_BIND: */
6014 IoIFP(sv) != PerlIO_stdin() &&
6015 IoIFP(sv) != PerlIO_stdout() &&
6016 IoIFP(sv) != PerlIO_stderr() &&
6017 !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6019 io_close(MUTABLE_IO(sv), FALSE);
6021 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6022 PerlDir_close(IoDIRP(sv));
6023 IoDIRP(sv) = (DIR*)NULL;
6024 Safefree(IoTOP_NAME(sv));
6025 Safefree(IoFMT_NAME(sv));
6026 Safefree(IoBOTTOM_NAME(sv));
6029 /* FIXME for plugins */
6030 pregfree2((REGEXP*) sv);
6034 cv_undef(MUTABLE_CV(sv));
6035 /* If we're in a stash, we don't own a reference to it.
6036 * However it does have a back reference to us, which needs to
6038 if ((stash = CvSTASH(sv)))
6039 sv_del_backref(MUTABLE_SV(stash), sv);
6042 if (PL_last_swash_hv == (const HV *)sv) {
6043 PL_last_swash_hv = NULL;
6045 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
6046 Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6050 AV* av = MUTABLE_AV(sv);
6051 if (PL_comppad == av) {
6055 if (AvREAL(av) && AvFILLp(av) > -1) {
6056 next_sv = AvARRAY(av)[AvFILLp(av)--];
6057 /* save old iter_sv in top-most slot of AV,
6058 * and pray that it doesn't get wiped in the meantime */
6059 AvARRAY(av)[AvMAX(av)] = iter_sv;
6061 goto get_next_sv; /* process this new sv */
6063 Safefree(AvALLOC(av));
6068 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
6069 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
6070 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
6071 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
6073 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
6074 SvREFCNT_dec(LvTARG(sv));
6076 if (isGV_with_GP(sv)) {
6077 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
6078 && HvENAME_get(stash))
6079 mro_method_changed_in(stash);
6080 gp_free(MUTABLE_GV(sv));
6082 unshare_hek(GvNAME_HEK(sv));
6083 /* If we're in a stash, we don't own a reference to it.
6084 * However it does have a back reference to us, which
6085 * needs to be cleared. */
6086 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
6087 sv_del_backref(MUTABLE_SV(stash), sv);
6089 /* FIXME. There are probably more unreferenced pointers to SVs
6090 * in the interpreter struct that we should check and tidy in
6091 * a similar fashion to this: */
6092 if ((const GV *)sv == PL_last_in_gv)
6093 PL_last_in_gv = NULL;
6099 /* Don't bother with SvOOK_off(sv); as we're only going to
6103 SvOOK_offset(sv, offset);
6104 SvPV_set(sv, SvPVX_mutable(sv) - offset);
6105 /* Don't even bother with turning off the OOK flag. */
6110 SV * const target = SvRV(sv);
6112 sv_del_backref(target, sv);
6117 #ifdef PERL_OLD_COPY_ON_WRITE
6118 else if (SvPVX_const(sv)
6119 && !(SvTYPE(sv) == SVt_PVIO
6120 && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6124 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6128 sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
6130 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6134 } else if (SvLEN(sv)) {
6135 Safefree(SvPVX_const(sv));
6139 else if (SvPVX_const(sv) && SvLEN(sv)
6140 && !(SvTYPE(sv) == SVt_PVIO
6141 && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6142 Safefree(SvPVX_mutable(sv));
6143 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
6144 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
6155 SvFLAGS(sv) &= SVf_BREAK;
6156 SvFLAGS(sv) |= SVTYPEMASK;
6158 sv_type_details = bodies_by_type + type;
6159 if (sv_type_details->arena) {
6160 del_body(((char *)SvANY(sv) + sv_type_details->offset),
6161 &PL_body_roots[type]);
6163 else if (sv_type_details->body_size) {
6164 safefree(SvANY(sv));
6168 /* caller is responsible for freeing the head of the original sv */
6169 if (sv != orig_sv && !SvREFCNT(sv))
6172 /* grab and free next sv, if any */
6180 else if (!iter_sv) {
6182 } else if (SvTYPE(iter_sv) == SVt_PVAV) {
6183 AV *const av = (AV*)iter_sv;
6184 if (AvFILLp(av) > -1) {
6185 sv = AvARRAY(av)[AvFILLp(av)--];
6187 else { /* no more elements of current AV to free */
6190 /* restore previous value, squirrelled away */
6191 iter_sv = AvARRAY(av)[AvMAX(av)];
6192 Safefree(AvALLOC(av));
6197 /* unrolled SvREFCNT_dec and sv_free2 follows: */
6201 if (!SvREFCNT(sv)) {
6205 if (--(SvREFCNT(sv)))
6209 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6210 "Attempt to free temp prematurely: SV 0x%"UVxf
6211 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6215 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6216 /* make sure SvREFCNT(sv)==0 happens very seldom */
6217 SvREFCNT(sv) = (~(U32)0)/2;
6226 /* This routine curses the sv itself, not the object referenced by sv. So
6227 sv does not have to be ROK. */
6230 S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
6233 PERL_ARGS_ASSERT_CURSE;
6234 assert(SvOBJECT(sv));
6236 if (PL_defstash && /* Still have a symbol table? */
6243 stash = SvSTASH(sv);
6244 destructor = StashHANDLER(stash,DESTROY);
6246 /* A constant subroutine can have no side effects, so
6247 don't bother calling it. */
6248 && !CvCONST(destructor)
6249 /* Don't bother calling an empty destructor */
6250 && (CvISXSUB(destructor)
6251 || (CvSTART(destructor)
6252 && (CvSTART(destructor)->op_next->op_type
6255 SV* const tmpref = newRV(sv);
6256 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
6258 PUSHSTACKi(PERLSI_DESTROY);
6263 call_sv(MUTABLE_SV(destructor),
6264 G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
6268 if(SvREFCNT(tmpref) < 2) {
6269 /* tmpref is not kept alive! */
6271 SvRV_set(tmpref, NULL);
6274 SvREFCNT_dec(tmpref);
6276 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
6279 if (check_refcnt && SvREFCNT(sv)) {
6280 if (PL_in_clean_objs)
6282 "DESTROY created new reference to dead object '%s'",
6284 /* DESTROY gave object new lease on life */
6290 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
6291 SvOBJECT_off(sv); /* Curse the object. */
6292 if (SvTYPE(sv) != SVt_PVIO)
6293 --PL_sv_objcount;/* XXX Might want something more general */
6299 =for apidoc sv_newref
6301 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
6308 Perl_sv_newref(pTHX_ SV *const sv)
6310 PERL_UNUSED_CONTEXT;
6319 Decrement an SV's reference count, and if it drops to zero, call
6320 C<sv_clear> to invoke destructors and free up any memory used by
6321 the body; finally, deallocate the SV's head itself.
6322 Normally called via a wrapper macro C<SvREFCNT_dec>.
6328 Perl_sv_free(pTHX_ SV *const sv)
6333 if (SvREFCNT(sv) == 0) {
6334 if (SvFLAGS(sv) & SVf_BREAK)
6335 /* this SV's refcnt has been artificially decremented to
6336 * trigger cleanup */
6338 if (PL_in_clean_all) /* All is fair */
6340 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6341 /* make sure SvREFCNT(sv)==0 happens very seldom */
6342 SvREFCNT(sv) = (~(U32)0)/2;
6345 if (ckWARN_d(WARN_INTERNAL)) {
6346 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
6347 Perl_dump_sv_child(aTHX_ sv);
6349 #ifdef DEBUG_LEAKING_SCALARS
6352 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6353 if (PL_warnhook == PERL_WARNHOOK_FATAL
6354 || ckDEAD(packWARN(WARN_INTERNAL))) {
6355 /* Don't let Perl_warner cause us to escape our fate: */
6359 /* This may not return: */
6360 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6361 "Attempt to free unreferenced scalar: SV 0x%"UVxf
6362 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6365 #ifdef DEBUG_LEAKING_SCALARS_ABORT
6370 if (--(SvREFCNT(sv)) > 0)
6372 Perl_sv_free2(aTHX_ sv);
6376 Perl_sv_free2(pTHX_ SV *const sv)
6380 PERL_ARGS_ASSERT_SV_FREE2;
6384 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
6385 "Attempt to free temp prematurely: SV 0x%"UVxf
6386 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6390 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6391 /* make sure SvREFCNT(sv)==0 happens very seldom */
6392 SvREFCNT(sv) = (~(U32)0)/2;
6403 Returns the length of the string in the SV. Handles magic and type
6404 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
6410 Perl_sv_len(pTHX_ register SV *const sv)
6418 len = mg_length(sv);
6420 (void)SvPV_const(sv, len);
6425 =for apidoc sv_len_utf8
6427 Returns the number of characters in the string in an SV, counting wide
6428 UTF-8 bytes as a single character. Handles magic and type coercion.
6434 * The length is cached in PERL_MAGIC_utf8, in the mg_len field. Also the
6435 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
6436 * (Note that the mg_len is not the length of the mg_ptr field.
6437 * This allows the cache to store the character length of the string without
6438 * needing to malloc() extra storage to attach to the mg_ptr.)
6443 Perl_sv_len_utf8(pTHX_ register SV *const sv)
6449 return mg_length(sv);
6453 const U8 *s = (U8*)SvPV_const(sv, len);
6457 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
6459 if (mg && (mg->mg_len != -1 || mg->mg_ptr)) {
6460 if (mg->mg_len != -1)
6463 /* We can use the offset cache for a headstart.
6464 The longer value is stored in the first pair. */
6465 STRLEN *cache = (STRLEN *) mg->mg_ptr;
6467 ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1],
6471 if (PL_utf8cache < 0) {
6472 const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
6473 assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv);
6477 ulen = Perl_utf8_length(aTHX_ s, s + len);
6478 utf8_mg_len_cache_update(sv, &mg, ulen);
6482 return Perl_utf8_length(aTHX_ s, s + len);
6486 /* Walk forwards to find the byte corresponding to the passed in UTF-8
6489 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
6490 STRLEN *const uoffset_p, bool *const at_end)
6492 const U8 *s = start;
6493 STRLEN uoffset = *uoffset_p;
6495 PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
6497 while (s < send && uoffset) {
6504 else if (s > send) {
6506 /* This is the existing behaviour. Possibly it should be a croak, as
6507 it's actually a bounds error */
6510 *uoffset_p -= uoffset;
6514 /* Given the length of the string in both bytes and UTF-8 characters, decide
6515 whether to walk forwards or backwards to find the byte corresponding to
6516 the passed in UTF-8 offset. */
6518 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
6519 STRLEN uoffset, const STRLEN uend)
6521 STRLEN backw = uend - uoffset;
6523 PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
6525 if (uoffset < 2 * backw) {
6526 /* The assumption is that going forwards is twice the speed of going
6527 forward (that's where the 2 * backw comes from).
6528 (The real figure of course depends on the UTF-8 data.) */
6529 const U8 *s = start;
6531 while (s < send && uoffset--)
6541 while (UTF8_IS_CONTINUATION(*send))
6544 return send - start;
6547 /* For the string representation of the given scalar, find the byte
6548 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0
6549 give another position in the string, *before* the sought offset, which
6550 (which is always true, as 0, 0 is a valid pair of positions), which should
6551 help reduce the amount of linear searching.
6552 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
6553 will be used to reduce the amount of linear searching. The cache will be
6554 created if necessary, and the found value offered to it for update. */
6556 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
6557 const U8 *const send, STRLEN uoffset,
6558 STRLEN uoffset0, STRLEN boffset0)
6560 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
6562 bool at_end = FALSE;
6564 PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
6566 assert (uoffset >= uoffset0);
6573 && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
6574 (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
6575 if ((*mgp)->mg_ptr) {
6576 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
6577 if (cache[0] == uoffset) {
6578 /* An exact match. */
6581 if (cache[2] == uoffset) {
6582 /* An exact match. */
6586 if (cache[0] < uoffset) {
6587 /* The cache already knows part of the way. */
6588 if (cache[0] > uoffset0) {
6589 /* The cache knows more than the passed in pair */
6590 uoffset0 = cache[0];
6591 boffset0 = cache[1];
6593 if ((*mgp)->mg_len != -1) {
6594 /* And we know the end too. */
6596 + sv_pos_u2b_midway(start + boffset0, send,
6598 (*mgp)->mg_len - uoffset0);
6600 uoffset -= uoffset0;
6602 + sv_pos_u2b_forwards(start + boffset0,
6603 send, &uoffset, &at_end);
6604 uoffset += uoffset0;
6607 else if (cache[2] < uoffset) {
6608 /* We're between the two cache entries. */
6609 if (cache[2] > uoffset0) {
6610 /* and the cache knows more than the passed in pair */
6611 uoffset0 = cache[2];
6612 boffset0 = cache[3];
6616 + sv_pos_u2b_midway(start + boffset0,
6619 cache[0] - uoffset0);
6622 + sv_pos_u2b_midway(start + boffset0,
6625 cache[2] - uoffset0);
6629 else if ((*mgp)->mg_len != -1) {
6630 /* If we can take advantage of a passed in offset, do so. */
6631 /* In fact, offset0 is either 0, or less than offset, so don't
6632 need to worry about the other possibility. */
6634 + sv_pos_u2b_midway(start + boffset0, send,
6636 (*mgp)->mg_len - uoffset0);
6641 if (!found || PL_utf8cache < 0) {
6642 STRLEN real_boffset;
6643 uoffset -= uoffset0;
6644 real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0,
6645 send, &uoffset, &at_end);
6646 uoffset += uoffset0;
6648 if (found && PL_utf8cache < 0)
6649 assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset,
6651 boffset = real_boffset;
6656 utf8_mg_len_cache_update(sv, mgp, uoffset);
6658 utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
6665 =for apidoc sv_pos_u2b_flags
6667 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6668 the start of the string, to a count of the equivalent number of bytes; if
6669 lenp is non-zero, it does the same to lenp, but this time starting from
6670 the offset, rather than from the start of the string. Handles type coercion.
6671 I<flags> is passed to C<SvPV_flags>, and usually should be
6672 C<SV_GMAGIC|SV_CONST_RETURN> to handle magic.
6678 * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential
6679 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6680 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6685 Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp,
6692 PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS;
6694 start = (U8*)SvPV_flags(sv, len, flags);
6696 const U8 * const send = start + len;
6698 boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0);
6701 && *lenp /* don't bother doing work for 0, as its bytes equivalent
6702 is 0, and *lenp is already set to that. */) {
6703 /* Convert the relative offset to absolute. */
6704 const STRLEN uoffset2 = uoffset + *lenp;
6705 const STRLEN boffset2
6706 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6707 uoffset, boffset) - boffset;
6721 =for apidoc sv_pos_u2b
6723 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6724 the start of the string, to a count of the equivalent number of bytes; if
6725 lenp is non-zero, it does the same to lenp, but this time starting from
6726 the offset, rather than from the start of the string. Handles magic and
6729 Use C<sv_pos_u2b_flags> in preference, which correctly handles strings longer
6736 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6737 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6738 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
6742 /* This function is subject to size and sign problems */
6745 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
6747 PERL_ARGS_ASSERT_SV_POS_U2B;
6750 STRLEN ulen = (STRLEN)*lenp;
6751 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen,
6752 SV_GMAGIC|SV_CONST_RETURN);
6755 *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL,
6756 SV_GMAGIC|SV_CONST_RETURN);
6761 S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp,
6764 PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE;
6768 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6769 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6770 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
6774 (*mgp)->mg_len = ulen;
6775 /* For now, treat "overflowed" as "still unknown". See RT #72924. */
6776 if (ulen != (STRLEN) (*mgp)->mg_len)
6777 (*mgp)->mg_len = -1;
6780 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6781 byte length pairing. The (byte) length of the total SV is passed in too,
6782 as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6783 may not have updated SvCUR, so we can't rely on reading it directly.
6785 The proffered utf8/byte length pairing isn't used if the cache already has
6786 two pairs, and swapping either for the proffered pair would increase the
6787 RMS of the intervals between known byte offsets.
6789 The cache itself consists of 4 STRLEN values
6790 0: larger UTF-8 offset
6791 1: corresponding byte offset
6792 2: smaller UTF-8 offset
6793 3: corresponding byte offset
6795 Unused cache pairs have the value 0, 0.
6796 Keeping the cache "backwards" means that the invariant of
6797 cache[0] >= cache[2] is maintained even with empty slots, which means that
6798 the code that uses it doesn't need to worry if only 1 entry has actually
6799 been set to non-zero. It also makes the "position beyond the end of the
6800 cache" logic much simpler, as the first slot is always the one to start
6804 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6805 const STRLEN utf8, const STRLEN blen)
6809 PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6814 if (!*mgp && (SvTYPE(sv) < SVt_PVMG ||
6815 !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
6816 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6818 (*mgp)->mg_len = -1;
6822 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6823 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6824 (*mgp)->mg_ptr = (char *) cache;
6828 if (PL_utf8cache < 0 && SvPOKp(sv)) {
6829 /* SvPOKp() because it's possible that sv has string overloading, and
6830 therefore is a reference, hence SvPVX() is actually a pointer.
6831 This cures the (very real) symptoms of RT 69422, but I'm not actually
6832 sure whether we should even be caching the results of UTF-8
6833 operations on overloading, given that nothing stops overloading
6834 returning a different value every time it's called. */
6835 const U8 *start = (const U8 *) SvPVX_const(sv);
6836 const STRLEN realutf8 = utf8_length(start, start + byte);
6838 assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8,
6842 /* Cache is held with the later position first, to simplify the code
6843 that deals with unbounded ends. */
6845 ASSERT_UTF8_CACHE(cache);
6846 if (cache[1] == 0) {
6847 /* Cache is totally empty */
6850 } else if (cache[3] == 0) {
6851 if (byte > cache[1]) {
6852 /* New one is larger, so goes first. */
6853 cache[2] = cache[0];
6854 cache[3] = cache[1];
6862 #define THREEWAY_SQUARE(a,b,c,d) \
6863 ((float)((d) - (c))) * ((float)((d) - (c))) \
6864 + ((float)((c) - (b))) * ((float)((c) - (b))) \
6865 + ((float)((b) - (a))) * ((float)((b) - (a)))
6867 /* Cache has 2 slots in use, and we know three potential pairs.
6868 Keep the two that give the lowest RMS distance. Do the
6869 calculation in bytes simply because we always know the byte
6870 length. squareroot has the same ordering as the positive value,
6871 so don't bother with the actual square root. */
6872 const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6873 if (byte > cache[1]) {
6874 /* New position is after the existing pair of pairs. */
6875 const float keep_earlier
6876 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6877 const float keep_later
6878 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6880 if (keep_later < keep_earlier) {
6881 if (keep_later < existing) {
6882 cache[2] = cache[0];
6883 cache[3] = cache[1];
6889 if (keep_earlier < existing) {
6895 else if (byte > cache[3]) {
6896 /* New position is between the existing pair of pairs. */
6897 const float keep_earlier
6898 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6899 const float keep_later
6900 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6902 if (keep_later < keep_earlier) {
6903 if (keep_later < existing) {
6909 if (keep_earlier < existing) {
6916 /* New position is before the existing pair of pairs. */
6917 const float keep_earlier
6918 = THREEWAY_SQUARE(0, byte, cache[3], blen);
6919 const float keep_later
6920 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6922 if (keep_later < keep_earlier) {
6923 if (keep_later < existing) {
6929 if (keep_earlier < existing) {
6930 cache[0] = cache[2];
6931 cache[1] = cache[3];
6938 ASSERT_UTF8_CACHE(cache);
6941 /* We already know all of the way, now we may be able to walk back. The same
6942 assumption is made as in S_sv_pos_u2b_midway(), namely that walking
6943 backward is half the speed of walking forward. */
6945 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
6946 const U8 *end, STRLEN endu)
6948 const STRLEN forw = target - s;
6949 STRLEN backw = end - target;
6951 PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
6953 if (forw < 2 * backw) {
6954 return utf8_length(s, target);
6957 while (end > target) {
6959 while (UTF8_IS_CONTINUATION(*end)) {
6968 =for apidoc sv_pos_b2u
6970 Converts the value pointed to by offsetp from a count of bytes from the
6971 start of the string, to a count of the equivalent number of UTF-8 chars.
6972 Handles magic and type coercion.
6978 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6979 * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and
6984 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
6987 const STRLEN byte = *offsetp;
6988 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
6994 PERL_ARGS_ASSERT_SV_POS_B2U;
6999 s = (const U8*)SvPV_const(sv, blen);
7002 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
7008 && SvTYPE(sv) >= SVt_PVMG
7009 && (mg = mg_find(sv, PERL_MAGIC_utf8)))
7012 STRLEN * const cache = (STRLEN *) mg->mg_ptr;
7013 if (cache[1] == byte) {
7014 /* An exact match. */
7015 *offsetp = cache[0];
7018 if (cache[3] == byte) {
7019 /* An exact match. */
7020 *offsetp = cache[2];
7024 if (cache[1] < byte) {
7025 /* We already know part of the way. */
7026 if (mg->mg_len != -1) {
7027 /* Actually, we know the end too. */
7029 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
7030 s + blen, mg->mg_len - cache[0]);
7032 len = cache[0] + utf8_length(s + cache[1], send);
7035 else if (cache[3] < byte) {
7036 /* We're between the two cached pairs, so we do the calculation
7037 offset by the byte/utf-8 positions for the earlier pair,
7038 then add the utf-8 characters from the string start to
7040 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
7041 s + cache[1], cache[0] - cache[2])
7045 else { /* cache[3] > byte */
7046 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
7050 ASSERT_UTF8_CACHE(cache);
7052 } else if (mg->mg_len != -1) {
7053 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
7057 if (!found || PL_utf8cache < 0) {
7058 const STRLEN real_len = utf8_length(s, send);
7060 if (found && PL_utf8cache < 0)
7061 assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv);
7068 utf8_mg_len_cache_update(sv, &mg, len);
7070 utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
7075 S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache,
7076 STRLEN real, SV *const sv)
7078 PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT;
7080 /* As this is debugging only code, save space by keeping this test here,
7081 rather than inlining it in all the callers. */
7082 if (from_cache == real)
7085 /* Need to turn the assertions off otherwise we may recurse infinitely
7086 while printing error messages. */
7087 SAVEI8(PL_utf8cache);
7089 Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf,
7090 func, (UV) from_cache, (UV) real, SVfARG(sv));
7096 Returns a boolean indicating whether the strings in the two SVs are
7097 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
7098 coerce its args to strings if necessary.
7100 =for apidoc sv_eq_flags
7102 Returns a boolean indicating whether the strings in the two SVs are
7103 identical. Is UTF-8 and 'use bytes' aware and coerces its args to strings
7104 if necessary. If the flags include SV_GMAGIC, it handles get-magic, too.
7110 Perl_sv_eq_flags(pTHX_ register SV *sv1, register SV *sv2, const U32 flags)
7119 SV* svrecode = NULL;
7126 /* if pv1 and pv2 are the same, second SvPV_const call may
7127 * invalidate pv1 (if we are handling magic), so we may need to
7129 if (sv1 == sv2 && flags & SV_GMAGIC
7130 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
7131 pv1 = SvPV_const(sv1, cur1);
7132 sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
7134 pv1 = SvPV_flags_const(sv1, cur1, flags);
7142 pv2 = SvPV_flags_const(sv2, cur2, flags);
7144 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7145 /* Differing utf8ness.
7146 * Do not UTF8size the comparands as a side-effect. */
7149 svrecode = newSVpvn(pv2, cur2);
7150 sv_recode_to_utf8(svrecode, PL_encoding);
7151 pv2 = SvPV_const(svrecode, cur2);
7154 svrecode = newSVpvn(pv1, cur1);
7155 sv_recode_to_utf8(svrecode, PL_encoding);
7156 pv1 = SvPV_const(svrecode, cur1);
7158 /* Now both are in UTF-8. */
7160 SvREFCNT_dec(svrecode);
7166 /* sv1 is the UTF-8 one */
7167 return bytes_cmp_utf8((const U8*)pv2, cur2,
7168 (const U8*)pv1, cur1) == 0;
7171 /* sv2 is the UTF-8 one */
7172 return bytes_cmp_utf8((const U8*)pv1, cur1,
7173 (const U8*)pv2, cur2) == 0;
7179 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
7181 SvREFCNT_dec(svrecode);
7191 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7192 string in C<sv1> is less than, equal to, or greater than the string in
7193 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
7194 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
7196 =for apidoc sv_cmp_flags
7198 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
7199 string in C<sv1> is less than, equal to, or greater than the string in
7200 C<sv2>. Is UTF-8 and 'use bytes' aware and will coerce its args to strings
7201 if necessary. If the flags include SV_GMAGIC, it handles get magic. See
7202 also C<sv_cmp_locale_flags>.
7208 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
7210 return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
7214 Perl_sv_cmp_flags(pTHX_ register SV *const sv1, register SV *const sv2,
7219 const char *pv1, *pv2;
7222 SV *svrecode = NULL;
7229 pv1 = SvPV_flags_const(sv1, cur1, flags);
7236 pv2 = SvPV_flags_const(sv2, cur2, flags);
7238 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
7239 /* Differing utf8ness.
7240 * Do not UTF8size the comparands as a side-effect. */
7243 svrecode = newSVpvn(pv2, cur2);
7244 sv_recode_to_utf8(svrecode, PL_encoding);
7245 pv2 = SvPV_const(svrecode, cur2);
7248 const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2,
7249 (const U8*)pv1, cur1);
7250 return retval ? retval < 0 ? -1 : +1 : 0;
7255 svrecode = newSVpvn(pv1, cur1);
7256 sv_recode_to_utf8(svrecode, PL_encoding);
7257 pv1 = SvPV_const(svrecode, cur1);
7260 const int retval = bytes_cmp_utf8((const U8*)pv1, cur1,
7261 (const U8*)pv2, cur2);
7262 return retval ? retval < 0 ? -1 : +1 : 0;
7268 cmp = cur2 ? -1 : 0;
7272 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
7275 cmp = retval < 0 ? -1 : 1;
7276 } else if (cur1 == cur2) {
7279 cmp = cur1 < cur2 ? -1 : 1;
7283 SvREFCNT_dec(svrecode);
7291 =for apidoc sv_cmp_locale
7293 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7294 'use bytes' aware, handles get magic, and will coerce its args to strings
7295 if necessary. See also C<sv_cmp>.
7297 =for apidoc sv_cmp_locale_flags
7299 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
7300 'use bytes' aware and will coerce its args to strings if necessary. If the
7301 flags contain SV_GMAGIC, it handles get magic. See also C<sv_cmp_flags>.
7307 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
7309 return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
7313 Perl_sv_cmp_locale_flags(pTHX_ register SV *const sv1, register SV *const sv2,
7317 #ifdef USE_LOCALE_COLLATE
7323 if (PL_collation_standard)
7327 pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
7329 pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
7331 if (!pv1 || !len1) {
7342 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
7345 return retval < 0 ? -1 : 1;
7348 * When the result of collation is equality, that doesn't mean
7349 * that there are no differences -- some locales exclude some
7350 * characters from consideration. So to avoid false equalities,
7351 * we use the raw string as a tiebreaker.
7357 #endif /* USE_LOCALE_COLLATE */
7359 return sv_cmp(sv1, sv2);
7363 #ifdef USE_LOCALE_COLLATE
7366 =for apidoc sv_collxfrm
7368 This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag. See
7369 C<sv_collxfrm_flags>.
7371 =for apidoc sv_collxfrm_flags
7373 Add Collate Transform magic to an SV if it doesn't already have it. If the
7374 flags contain SV_GMAGIC, it handles get-magic.
7376 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
7377 scalar data of the variable, but transformed to such a format that a normal
7378 memory comparison can be used to compare the data according to the locale
7385 Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
7390 PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
7392 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
7393 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
7399 Safefree(mg->mg_ptr);
7400 s = SvPV_flags_const(sv, len, flags);
7401 if ((xf = mem_collxfrm(s, len, &xlen))) {
7403 #ifdef PERL_OLD_COPY_ON_WRITE
7405 sv_force_normal_flags(sv, 0);
7407 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
7421 if (mg && mg->mg_ptr) {
7423 return mg->mg_ptr + sizeof(PL_collation_ix);
7431 #endif /* USE_LOCALE_COLLATE */
7434 S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7436 SV * const tsv = newSV(0);
7439 sv_gets(tsv, fp, 0);
7440 sv_utf8_upgrade_nomg(tsv);
7441 SvCUR_set(sv,append);
7444 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7448 S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
7451 const U32 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
7452 /* Grab the size of the record we're getting */
7453 char *const buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7460 /* VMS wants read instead of fread, because fread doesn't respect */
7461 /* RMS record boundaries. This is not necessarily a good thing to be */
7462 /* doing, but we've got no other real choice - except avoid stdio
7463 as implementation - perhaps write a :vms layer ?
7465 fd = PerlIO_fileno(fp);
7467 bytesread = PerlLIO_read(fd, buffer, recsize);
7469 else /* in-memory file from PerlIO::Scalar */
7472 bytesread = PerlIO_read(fp, buffer, recsize);
7477 SvCUR_set(sv, bytesread + append);
7478 buffer[bytesread] = '\0';
7479 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7485 Get a line from the filehandle and store it into the SV, optionally
7486 appending to the currently-stored string.
7492 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
7497 register STDCHAR rslast;
7498 register STDCHAR *bp;
7503 PERL_ARGS_ASSERT_SV_GETS;
7505 if (SvTHINKFIRST(sv))
7506 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
7507 /* XXX. If you make this PVIV, then copy on write can copy scalars read
7509 However, perlbench says it's slower, because the existing swipe code
7510 is faster than copy on write.
7511 Swings and roundabouts. */
7512 SvUPGRADE(sv, SVt_PV);
7517 if (PerlIO_isutf8(fp)) {
7519 sv_utf8_upgrade_nomg(sv);
7520 sv_pos_u2b(sv,&append,0);
7522 } else if (SvUTF8(sv)) {
7523 return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append);
7531 if (PerlIO_isutf8(fp))
7534 if (IN_PERL_COMPILETIME) {
7535 /* we always read code in line mode */
7539 else if (RsSNARF(PL_rs)) {
7540 /* If it is a regular disk file use size from stat() as estimate
7541 of amount we are going to read -- may result in mallocing
7542 more memory than we really need if the layers below reduce
7543 the size we read (e.g. CRLF or a gzip layer).
7546 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
7547 const Off_t offset = PerlIO_tell(fp);
7548 if (offset != (Off_t) -1 && st.st_size + append > offset) {
7549 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
7555 else if (RsRECORD(PL_rs)) {
7556 return S_sv_gets_read_record(aTHX_ sv, fp, append);
7558 else if (RsPARA(PL_rs)) {
7564 /* Get $/ i.e. PL_rs into same encoding as stream wants */
7565 if (PerlIO_isutf8(fp)) {
7566 rsptr = SvPVutf8(PL_rs, rslen);
7569 if (SvUTF8(PL_rs)) {
7570 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
7571 Perl_croak(aTHX_ "Wide character in $/");
7574 rsptr = SvPV_const(PL_rs, rslen);
7578 rslast = rslen ? rsptr[rslen - 1] : '\0';
7580 if (rspara) { /* have to do this both before and after */
7581 do { /* to make sure file boundaries work right */
7584 i = PerlIO_getc(fp);
7588 PerlIO_ungetc(fp,i);
7594 /* See if we know enough about I/O mechanism to cheat it ! */
7596 /* This used to be #ifdef test - it is made run-time test for ease
7597 of abstracting out stdio interface. One call should be cheap
7598 enough here - and may even be a macro allowing compile
7602 if (PerlIO_fast_gets(fp)) {
7605 * We're going to steal some values from the stdio struct
7606 * and put EVERYTHING in the innermost loop into registers.
7608 register STDCHAR *ptr;
7612 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7613 /* An ungetc()d char is handled separately from the regular
7614 * buffer, so we getc() it back out and stuff it in the buffer.
7616 i = PerlIO_getc(fp);
7617 if (i == EOF) return 0;
7618 *(--((*fp)->_ptr)) = (unsigned char) i;
7622 /* Here is some breathtakingly efficient cheating */
7624 cnt = PerlIO_get_cnt(fp); /* get count into register */
7625 /* make sure we have the room */
7626 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7627 /* Not room for all of it
7628 if we are looking for a separator and room for some
7630 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7631 /* just process what we have room for */
7632 shortbuffered = cnt - SvLEN(sv) + append + 1;
7633 cnt -= shortbuffered;
7637 /* remember that cnt can be negative */
7638 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7643 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
7644 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7645 DEBUG_P(PerlIO_printf(Perl_debug_log,
7646 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7647 DEBUG_P(PerlIO_printf(Perl_debug_log,
7648 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7649 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7650 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7655 while (cnt > 0) { /* this | eat */
7657 if ((*bp++ = *ptr++) == rslast) /* really | dust */
7658 goto thats_all_folks; /* screams | sed :-) */
7662 Copy(ptr, bp, cnt, char); /* this | eat */
7663 bp += cnt; /* screams | dust */
7664 ptr += cnt; /* louder | sed :-) */
7666 assert (!shortbuffered);
7667 goto cannot_be_shortbuffered;
7671 if (shortbuffered) { /* oh well, must extend */
7672 cnt = shortbuffered;
7674 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7676 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7677 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7681 cannot_be_shortbuffered:
7682 DEBUG_P(PerlIO_printf(Perl_debug_log,
7683 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7684 PTR2UV(ptr),(long)cnt));
7685 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7687 DEBUG_Pv(PerlIO_printf(Perl_debug_log,
7688 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7689 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7690 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7692 /* This used to call 'filbuf' in stdio form, but as that behaves like
7693 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7694 another abstraction. */
7695 i = PerlIO_getc(fp); /* get more characters */
7697 DEBUG_Pv(PerlIO_printf(Perl_debug_log,
7698 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7699 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7700 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7702 cnt = PerlIO_get_cnt(fp);
7703 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
7704 DEBUG_P(PerlIO_printf(Perl_debug_log,
7705 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7707 if (i == EOF) /* all done for ever? */
7708 goto thats_really_all_folks;
7710 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7712 SvGROW(sv, bpx + cnt + 2);
7713 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7715 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
7717 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
7718 goto thats_all_folks;
7722 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
7723 memNE((char*)bp - rslen, rsptr, rslen))
7724 goto screamer; /* go back to the fray */
7725 thats_really_all_folks:
7727 cnt += shortbuffered;
7728 DEBUG_P(PerlIO_printf(Perl_debug_log,
7729 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7730 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
7731 DEBUG_P(PerlIO_printf(Perl_debug_log,
7732 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7733 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7734 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7736 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
7737 DEBUG_P(PerlIO_printf(Perl_debug_log,
7738 "Screamer: done, len=%ld, string=|%.*s|\n",
7739 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
7743 /*The big, slow, and stupid way. */
7744 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
7745 STDCHAR *buf = NULL;
7746 Newx(buf, 8192, STDCHAR);
7754 register const STDCHAR * const bpe = buf + sizeof(buf);
7756 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7757 ; /* keep reading */
7761 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7762 /* Accommodate broken VAXC compiler, which applies U8 cast to
7763 * both args of ?: operator, causing EOF to change into 255
7766 i = (U8)buf[cnt - 1];
7772 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
7774 sv_catpvn(sv, (char *) buf, cnt);
7776 sv_setpvn(sv, (char *) buf, cnt);
7778 if (i != EOF && /* joy */
7780 SvCUR(sv) < rslen ||
7781 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7785 * If we're reading from a TTY and we get a short read,
7786 * indicating that the user hit his EOF character, we need
7787 * to notice it now, because if we try to read from the TTY
7788 * again, the EOF condition will disappear.
7790 * The comparison of cnt to sizeof(buf) is an optimization
7791 * that prevents unnecessary calls to feof().
7795 if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
7799 #ifdef USE_HEAP_INSTEAD_OF_STACK
7804 if (rspara) { /* have to do this both before and after */
7805 while (i != EOF) { /* to make sure file boundaries work right */
7806 i = PerlIO_getc(fp);
7808 PerlIO_ungetc(fp,i);
7814 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
7820 Auto-increment of the value in the SV, doing string to numeric conversion
7821 if necessary. Handles 'get' magic and operator overloading.
7827 Perl_sv_inc(pTHX_ register SV *const sv)
7836 =for apidoc sv_inc_nomg
7838 Auto-increment of the value in the SV, doing string to numeric conversion
7839 if necessary. Handles operator overloading. Skips handling 'get' magic.
7845 Perl_sv_inc_nomg(pTHX_ register SV *const sv)
7853 if (SvTHINKFIRST(sv)) {
7855 sv_force_normal_flags(sv, 0);
7856 if (SvREADONLY(sv)) {
7857 if (IN_PERL_RUNTIME)
7858 Perl_croak_no_modify(aTHX);
7862 if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg))
7864 i = PTR2IV(SvRV(sv));
7869 flags = SvFLAGS(sv);
7870 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7871 /* It's (privately or publicly) a float, but not tested as an
7872 integer, so test it to see. */
7874 flags = SvFLAGS(sv);
7876 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7877 /* It's publicly an integer, or privately an integer-not-float */
7878 #ifdef PERL_PRESERVE_IVUV
7882 if (SvUVX(sv) == UV_MAX)
7883 sv_setnv(sv, UV_MAX_P1);
7885 (void)SvIOK_only_UV(sv);
7886 SvUV_set(sv, SvUVX(sv) + 1);
7888 if (SvIVX(sv) == IV_MAX)
7889 sv_setuv(sv, (UV)IV_MAX + 1);
7891 (void)SvIOK_only(sv);
7892 SvIV_set(sv, SvIVX(sv) + 1);
7897 if (flags & SVp_NOK) {
7898 const NV was = SvNVX(sv);
7899 if (NV_OVERFLOWS_INTEGERS_AT &&
7900 was >= NV_OVERFLOWS_INTEGERS_AT) {
7901 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
7902 "Lost precision when incrementing %" NVff " by 1",
7905 (void)SvNOK_only(sv);
7906 SvNV_set(sv, was + 1.0);
7910 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
7911 if ((flags & SVTYPEMASK) < SVt_PVIV)
7912 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
7913 (void)SvIOK_only(sv);
7918 while (isALPHA(*d)) d++;
7919 while (isDIGIT(*d)) d++;
7920 if (d < SvEND(sv)) {
7921 #ifdef PERL_PRESERVE_IVUV
7922 /* Got to punt this as an integer if needs be, but we don't issue
7923 warnings. Probably ought to make the sv_iv_please() that does
7924 the conversion if possible, and silently. */
7925 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7926 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7927 /* Need to try really hard to see if it's an integer.
7928 9.22337203685478e+18 is an integer.
7929 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7930 so $a="9.22337203685478e+18"; $a+0; $a++
7931 needs to be the same as $a="9.22337203685478e+18"; $a++
7938 /* sv_2iv *should* have made this an NV */
7939 if (flags & SVp_NOK) {
7940 (void)SvNOK_only(sv);
7941 SvNV_set(sv, SvNVX(sv) + 1.0);
7944 /* I don't think we can get here. Maybe I should assert this
7945 And if we do get here I suspect that sv_setnv will croak. NWC
7947 #if defined(USE_LONG_DOUBLE)
7948 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",
7949 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7951 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7952 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7955 #endif /* PERL_PRESERVE_IVUV */
7956 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
7960 while (d >= SvPVX_const(sv)) {
7968 /* MKS: The original code here died if letters weren't consecutive.
7969 * at least it didn't have to worry about non-C locales. The
7970 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7971 * arranged in order (although not consecutively) and that only
7972 * [A-Za-z] are accepted by isALPHA in the C locale.
7974 if (*d != 'z' && *d != 'Z') {
7975 do { ++*d; } while (!isALPHA(*d));
7978 *(d--) -= 'z' - 'a';
7983 *(d--) -= 'z' - 'a' + 1;
7987 /* oh,oh, the number grew */
7988 SvGROW(sv, SvCUR(sv) + 2);
7989 SvCUR_set(sv, SvCUR(sv) + 1);
7990 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
8001 Auto-decrement of the value in the SV, doing string to numeric conversion
8002 if necessary. Handles 'get' magic and operator overloading.
8008 Perl_sv_dec(pTHX_ register SV *const sv)
8018 =for apidoc sv_dec_nomg
8020 Auto-decrement of the value in the SV, doing string to numeric conversion
8021 if necessary. Handles operator overloading. Skips handling 'get' magic.
8027 Perl_sv_dec_nomg(pTHX_ register SV *const sv)
8034 if (SvTHINKFIRST(sv)) {
8036 sv_force_normal_flags(sv, 0);
8037 if (SvREADONLY(sv)) {
8038 if (IN_PERL_RUNTIME)
8039 Perl_croak_no_modify(aTHX);
8043 if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg))
8045 i = PTR2IV(SvRV(sv));
8050 /* Unlike sv_inc we don't have to worry about string-never-numbers
8051 and keeping them magic. But we mustn't warn on punting */
8052 flags = SvFLAGS(sv);
8053 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
8054 /* It's publicly an integer, or privately an integer-not-float */
8055 #ifdef PERL_PRESERVE_IVUV
8059 if (SvUVX(sv) == 0) {
8060 (void)SvIOK_only(sv);
8064 (void)SvIOK_only_UV(sv);
8065 SvUV_set(sv, SvUVX(sv) - 1);
8068 if (SvIVX(sv) == IV_MIN) {
8069 sv_setnv(sv, (NV)IV_MIN);
8073 (void)SvIOK_only(sv);
8074 SvIV_set(sv, SvIVX(sv) - 1);
8079 if (flags & SVp_NOK) {
8082 const NV was = SvNVX(sv);
8083 if (NV_OVERFLOWS_INTEGERS_AT &&
8084 was <= -NV_OVERFLOWS_INTEGERS_AT) {
8085 Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
8086 "Lost precision when decrementing %" NVff " by 1",
8089 (void)SvNOK_only(sv);
8090 SvNV_set(sv, was - 1.0);
8094 if (!(flags & SVp_POK)) {
8095 if ((flags & SVTYPEMASK) < SVt_PVIV)
8096 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
8098 (void)SvIOK_only(sv);
8101 #ifdef PERL_PRESERVE_IVUV
8103 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
8104 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
8105 /* Need to try really hard to see if it's an integer.
8106 9.22337203685478e+18 is an integer.
8107 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
8108 so $a="9.22337203685478e+18"; $a+0; $a--
8109 needs to be the same as $a="9.22337203685478e+18"; $a--
8116 /* sv_2iv *should* have made this an NV */
8117 if (flags & SVp_NOK) {
8118 (void)SvNOK_only(sv);
8119 SvNV_set(sv, SvNVX(sv) - 1.0);
8122 /* I don't think we can get here. Maybe I should assert this
8123 And if we do get here I suspect that sv_setnv will croak. NWC
8125 #if defined(USE_LONG_DOUBLE)
8126 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",
8127 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8129 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
8130 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
8134 #endif /* PERL_PRESERVE_IVUV */
8135 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
8138 /* this define is used to eliminate a chunk of duplicated but shared logic
8139 * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be
8140 * used anywhere but here - yves
8142 #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \
8145 PL_tmps_stack[++PL_tmps_ix] = (AnSv); \
8149 =for apidoc sv_mortalcopy
8151 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
8152 The new SV is marked as mortal. It will be destroyed "soon", either by an
8153 explicit call to FREETMPS, or by an implicit call at places such as
8154 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
8159 /* Make a string that will exist for the duration of the expression
8160 * evaluation. Actually, it may have to last longer than that, but
8161 * hopefully we won't free it until it has been assigned to a
8162 * permanent location. */
8165 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
8171 sv_setsv(sv,oldstr);
8172 PUSH_EXTEND_MORTAL__SV_C(sv);
8178 =for apidoc sv_newmortal
8180 Creates a new null SV which is mortal. The reference count of the SV is
8181 set to 1. It will be destroyed "soon", either by an explicit call to
8182 FREETMPS, or by an implicit call at places such as statement boundaries.
8183 See also C<sv_mortalcopy> and C<sv_2mortal>.
8189 Perl_sv_newmortal(pTHX)
8195 SvFLAGS(sv) = SVs_TEMP;
8196 PUSH_EXTEND_MORTAL__SV_C(sv);
8202 =for apidoc newSVpvn_flags
8204 Creates a new SV and copies a string into it. The reference count for the
8205 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
8206 string. You are responsible for ensuring that the source string is at least
8207 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
8208 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
8209 If C<SVs_TEMP> is set, then C<sv_2mortal()> is called on the result before
8210 returning. If C<SVf_UTF8> is set, C<s> is considered to be in UTF-8 and the
8211 C<SVf_UTF8> flag will be set on the new SV.
8212 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
8214 #define newSVpvn_utf8(s, len, u) \
8215 newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
8221 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
8226 /* All the flags we don't support must be zero.
8227 And we're new code so I'm going to assert this from the start. */
8228 assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
8230 sv_setpvn(sv,s,len);
8232 /* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal()
8233 * and do what it does ourselves here.
8234 * Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags
8235 * set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which
8236 * in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we
8237 * eliminate quite a few steps than it looks - Yves (explaining patch by gfx)
8240 SvFLAGS(sv) |= flags;
8242 if(flags & SVs_TEMP){
8243 PUSH_EXTEND_MORTAL__SV_C(sv);
8250 =for apidoc sv_2mortal
8252 Marks an existing SV as mortal. The SV will be destroyed "soon", either
8253 by an explicit call to FREETMPS, or by an implicit call at places such as
8254 statement boundaries. SvTEMP() is turned on which means that the SV's
8255 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
8256 and C<sv_mortalcopy>.
8262 Perl_sv_2mortal(pTHX_ register SV *const sv)
8267 if (SvREADONLY(sv) && SvIMMORTAL(sv))
8269 PUSH_EXTEND_MORTAL__SV_C(sv);
8277 Creates a new SV and copies a string into it. The reference count for the
8278 SV is set to 1. If C<len> is zero, Perl will compute the length using
8279 strlen(). For efficiency, consider using C<newSVpvn> instead.
8285 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
8291 sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
8296 =for apidoc newSVpvn
8298 Creates a new SV and copies a string into it. The reference count for the
8299 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
8300 string. You are responsible for ensuring that the source string is at least
8301 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
8307 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
8313 sv_setpvn(sv,s,len);
8318 =for apidoc newSVhek
8320 Creates a new SV from the hash key structure. It will generate scalars that
8321 point to the shared string table where possible. Returns a new (undefined)
8322 SV if the hek is NULL.
8328 Perl_newSVhek(pTHX_ const HEK *const hek)
8338 if (HEK_LEN(hek) == HEf_SVKEY) {
8339 return newSVsv(*(SV**)HEK_KEY(hek));
8341 const int flags = HEK_FLAGS(hek);
8342 if (flags & HVhek_WASUTF8) {
8344 Andreas would like keys he put in as utf8 to come back as utf8
8346 STRLEN utf8_len = HEK_LEN(hek);
8347 SV * const sv = newSV_type(SVt_PV);
8348 char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
8349 /* bytes_to_utf8() allocates a new string, which we can repurpose: */
8350 sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
8353 } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
8354 /* We don't have a pointer to the hv, so we have to replicate the
8355 flag into every HEK. This hv is using custom a hasing
8356 algorithm. Hence we can't return a shared string scalar, as
8357 that would contain the (wrong) hash value, and might get passed
8358 into an hv routine with a regular hash.
8359 Similarly, a hash that isn't using shared hash keys has to have
8360 the flag in every key so that we know not to try to call
8361 share_hek_kek on it. */
8363 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
8368 /* This will be overwhelminly the most common case. */
8370 /* Inline most of newSVpvn_share(), because share_hek_hek() is far
8371 more efficient than sharepvn(). */
8375 sv_upgrade(sv, SVt_PV);
8376 SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
8377 SvCUR_set(sv, HEK_LEN(hek));
8390 =for apidoc newSVpvn_share
8392 Creates a new SV with its SvPVX_const pointing to a shared string in the string
8393 table. If the string does not already exist in the table, it is created
8394 first. Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
8395 value is used; otherwise the hash is computed. The string's hash can be later
8396 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
8397 that as the string table is used for shared hash keys these strings will have
8398 SvPVX_const == HeKEY and hash lookup will avoid string compare.
8404 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
8408 bool is_utf8 = FALSE;
8409 const char *const orig_src = src;
8412 STRLEN tmplen = -len;
8414 /* See the note in hv.c:hv_fetch() --jhi */
8415 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
8419 PERL_HASH(hash, src, len);
8421 /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
8422 changes here, update it there too. */
8423 sv_upgrade(sv, SVt_PV);
8424 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
8432 if (src != orig_src)
8438 =for apidoc newSVpv_share
8440 Like C<newSVpvn_share>, but takes a nul-terminated string instead of a
8447 Perl_newSVpv_share(pTHX_ const char *src, U32 hash)
8449 return newSVpvn_share(src, strlen(src), hash);
8452 #if defined(PERL_IMPLICIT_CONTEXT)
8454 /* pTHX_ magic can't cope with varargs, so this is a no-context
8455 * version of the main function, (which may itself be aliased to us).
8456 * Don't access this version directly.
8460 Perl_newSVpvf_nocontext(const char *const pat, ...)
8466 PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
8468 va_start(args, pat);
8469 sv = vnewSVpvf(pat, &args);
8476 =for apidoc newSVpvf
8478 Creates a new SV and initializes it with the string formatted like
8485 Perl_newSVpvf(pTHX_ const char *const pat, ...)
8490 PERL_ARGS_ASSERT_NEWSVPVF;
8492 va_start(args, pat);
8493 sv = vnewSVpvf(pat, &args);
8498 /* backend for newSVpvf() and newSVpvf_nocontext() */
8501 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
8506 PERL_ARGS_ASSERT_VNEWSVPVF;
8509 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8516 Creates a new SV and copies a floating point value into it.
8517 The reference count for the SV is set to 1.
8523 Perl_newSVnv(pTHX_ const NV n)
8536 Creates a new SV and copies an integer into it. The reference count for the
8543 Perl_newSViv(pTHX_ const IV i)
8556 Creates a new SV and copies an unsigned integer into it.
8557 The reference count for the SV is set to 1.
8563 Perl_newSVuv(pTHX_ const UV u)
8574 =for apidoc newSV_type
8576 Creates a new SV, of the type specified. The reference count for the new SV
8583 Perl_newSV_type(pTHX_ const svtype type)
8588 sv_upgrade(sv, type);
8593 =for apidoc newRV_noinc
8595 Creates an RV wrapper for an SV. The reference count for the original
8596 SV is B<not> incremented.
8602 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
8605 register SV *sv = newSV_type(SVt_IV);
8607 PERL_ARGS_ASSERT_NEWRV_NOINC;
8610 SvRV_set(sv, tmpRef);
8615 /* newRV_inc is the official function name to use now.
8616 * newRV_inc is in fact #defined to newRV in sv.h
8620 Perl_newRV(pTHX_ SV *const sv)
8624 PERL_ARGS_ASSERT_NEWRV;
8626 return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
8632 Creates a new SV which is an exact duplicate of the original SV.
8639 Perl_newSVsv(pTHX_ register SV *const old)
8646 if (SvTYPE(old) == SVTYPEMASK) {
8647 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
8651 /* SV_GMAGIC is the default for sv_setv()
8652 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
8653 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
8654 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
8659 =for apidoc sv_reset
8661 Underlying implementation for the C<reset> Perl function.
8662 Note that the perl-level function is vaguely deprecated.
8668 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
8671 char todo[PERL_UCHAR_MAX+1];
8673 PERL_ARGS_ASSERT_SV_RESET;
8678 if (!*s) { /* reset ?? searches */
8679 MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
8681 const U32 count = mg->mg_len / sizeof(PMOP**);
8682 PMOP **pmp = (PMOP**) mg->mg_ptr;
8683 PMOP *const *const end = pmp + count;
8687 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
8689 (*pmp)->op_pmflags &= ~PMf_USED;
8697 /* reset variables */
8699 if (!HvARRAY(stash))
8702 Zero(todo, 256, char);
8705 I32 i = (unsigned char)*s;
8709 max = (unsigned char)*s++;
8710 for ( ; i <= max; i++) {
8713 for (i = 0; i <= (I32) HvMAX(stash); i++) {
8715 for (entry = HvARRAY(stash)[i];
8717 entry = HeNEXT(entry))
8722 if (!todo[(U8)*HeKEY(entry)])
8724 gv = MUTABLE_GV(HeVAL(entry));
8727 if (SvTHINKFIRST(sv)) {
8728 if (!SvREADONLY(sv) && SvROK(sv))
8730 /* XXX Is this continue a bug? Why should THINKFIRST
8731 exempt us from resetting arrays and hashes? */
8735 if (SvTYPE(sv) >= SVt_PV) {
8737 if (SvPVX_const(sv) != NULL)
8745 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
8747 Perl_die(aTHX_ "Can't reset %%ENV on this system");
8750 # if defined(USE_ENVIRON_ARRAY)
8753 # endif /* USE_ENVIRON_ARRAY */
8764 Using various gambits, try to get an IO from an SV: the IO slot if its a
8765 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8766 named after the PV if we're a string.
8772 Perl_sv_2io(pTHX_ SV *const sv)
8777 PERL_ARGS_ASSERT_SV_2IO;
8779 switch (SvTYPE(sv)) {
8781 io = MUTABLE_IO(sv);
8785 if (isGV_with_GP(sv)) {
8786 gv = MUTABLE_GV(sv);
8789 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8795 Perl_croak(aTHX_ PL_no_usym, "filehandle");
8797 return sv_2io(SvRV(sv));
8798 gv = gv_fetchsv(sv, 0, SVt_PVIO);
8804 Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
8813 Using various gambits, try to get a CV from an SV; in addition, try if
8814 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8815 The flags in C<lref> are passed to gv_fetchsv.
8821 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
8827 PERL_ARGS_ASSERT_SV_2CV;
8834 switch (SvTYPE(sv)) {
8838 return MUTABLE_CV(sv);
8845 if (isGV_with_GP(sv)) {
8846 gv = MUTABLE_GV(sv);
8857 sv = amagic_deref_call(sv, to_cv_amg);
8858 /* At this point I'd like to do SPAGAIN, but really I need to
8859 force it upon my callers. Hmmm. This is a mess... */
8862 if (SvTYPE(sv) == SVt_PVCV) {
8863 cv = MUTABLE_CV(sv);
8868 else if(isGV_with_GP(sv))
8869 gv = MUTABLE_GV(sv);
8871 Perl_croak(aTHX_ "Not a subroutine reference");
8873 else if (isGV_with_GP(sv)) {
8875 gv = MUTABLE_GV(sv);
8878 gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
8884 /* Some flags to gv_fetchsv mean don't really create the GV */
8885 if (!isGV_with_GP(gv)) {
8891 if (lref && !GvCVu(gv)) {
8895 gv_efullname3(tmpsv, gv, NULL);
8896 /* XXX this is probably not what they think they're getting.
8897 * It has the same effect as "sub name;", i.e. just a forward
8899 newSUB(start_subparse(FALSE, 0),
8900 newSVOP(OP_CONST, 0, tmpsv),
8904 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8905 SVfARG(SvOK(sv) ? sv : &PL_sv_no));
8914 Returns true if the SV has a true value by Perl's rules.
8915 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8916 instead use an in-line version.
8922 Perl_sv_true(pTHX_ register SV *const sv)
8927 register const XPV* const tXpv = (XPV*)SvANY(sv);
8929 (tXpv->xpv_cur > 1 ||
8930 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
8937 return SvIVX(sv) != 0;
8940 return SvNVX(sv) != 0.0;
8942 return sv_2bool(sv);
8948 =for apidoc sv_pvn_force
8950 Get a sensible string out of the SV somehow.
8951 A private implementation of the C<SvPV_force> macro for compilers which
8952 can't cope with complex macro expressions. Always use the macro instead.
8954 =for apidoc sv_pvn_force_flags
8956 Get a sensible string out of the SV somehow.
8957 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8958 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8959 implemented in terms of this function.
8960 You normally want to use the various wrapper macros instead: see
8961 C<SvPV_force> and C<SvPV_force_nomg>
8967 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
8971 PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
8973 if (SvTHINKFIRST(sv) && !SvROK(sv))
8974 sv_force_normal_flags(sv, 0);
8984 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
8985 const char * const ref = sv_reftype(sv,0);
8987 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
8988 ref, OP_DESC(PL_op));
8990 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
8992 if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
8993 || isGV_with_GP(sv))
8994 /* diag_listed_as: Can't coerce %s to %s in %s */
8995 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8997 s = sv_2pv_flags(sv, &len, flags);
9001 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
9004 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
9005 SvGROW(sv, len + 1);
9006 Move(s,SvPVX(sv),len,char);
9008 SvPVX(sv)[len] = '\0';
9011 SvPOK_on(sv); /* validate pointer */
9013 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
9014 PTR2UV(sv),SvPVX_const(sv)));
9017 return SvPVX_mutable(sv);
9021 =for apidoc sv_pvbyten_force
9023 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
9029 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
9031 PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
9033 sv_pvn_force(sv,lp);
9034 sv_utf8_downgrade(sv,0);
9040 =for apidoc sv_pvutf8n_force
9042 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
9048 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
9050 PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
9052 sv_pvn_force(sv,lp);
9053 sv_utf8_upgrade(sv);
9059 =for apidoc sv_reftype
9061 Returns a string describing what the SV is a reference to.
9067 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
9069 PERL_ARGS_ASSERT_SV_REFTYPE;
9071 /* The fact that I don't need to downcast to char * everywhere, only in ?:
9072 inside return suggests a const propagation bug in g++. */
9073 if (ob && SvOBJECT(sv)) {
9074 char * const name = HvNAME_get(SvSTASH(sv));
9075 return name ? name : (char *) "__ANON__";
9078 switch (SvTYPE(sv)) {
9093 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
9094 /* tied lvalues should appear to be
9095 * scalars for backwards compatibility */
9096 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
9097 ? "SCALAR" : "LVALUE");
9098 case SVt_PVAV: return "ARRAY";
9099 case SVt_PVHV: return "HASH";
9100 case SVt_PVCV: return "CODE";
9101 case SVt_PVGV: return (char *) (isGV_with_GP(sv)
9102 ? "GLOB" : "SCALAR");
9103 case SVt_PVFM: return "FORMAT";
9104 case SVt_PVIO: return "IO";
9105 case SVt_BIND: return "BIND";
9106 case SVt_REGEXP: return "REGEXP";
9107 default: return "UNKNOWN";
9113 =for apidoc sv_isobject
9115 Returns a boolean indicating whether the SV is an RV pointing to a blessed
9116 object. If the SV is not an RV, or if the object is not blessed, then this
9123 Perl_sv_isobject(pTHX_ SV *sv)
9139 Returns a boolean indicating whether the SV is blessed into the specified
9140 class. This does not check for subtypes; use C<sv_derived_from> to verify
9141 an inheritance relationship.
9147 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
9151 PERL_ARGS_ASSERT_SV_ISA;
9161 hvname = HvNAME_get(SvSTASH(sv));
9165 return strEQ(hvname, name);
9171 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
9172 it will be upgraded to one. If C<classname> is non-null then the new SV will
9173 be blessed in the specified package. The new SV is returned and its
9174 reference count is 1.
9180 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
9185 PERL_ARGS_ASSERT_NEWSVRV;
9189 SV_CHECK_THINKFIRST_COW_DROP(rv);
9190 (void)SvAMAGIC_off(rv);
9192 if (SvTYPE(rv) >= SVt_PVMG) {
9193 const U32 refcnt = SvREFCNT(rv);
9197 SvREFCNT(rv) = refcnt;
9199 sv_upgrade(rv, SVt_IV);
9200 } else if (SvROK(rv)) {
9201 SvREFCNT_dec(SvRV(rv));
9203 prepare_SV_for_RV(rv);
9211 HV* const stash = gv_stashpv(classname, GV_ADD);
9212 (void)sv_bless(rv, stash);
9218 =for apidoc sv_setref_pv
9220 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
9221 argument will be upgraded to an RV. That RV will be modified to point to
9222 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
9223 into the SV. The C<classname> argument indicates the package for the
9224 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9225 will have a reference count of 1, and the RV will be returned.
9227 Do not use with other Perl types such as HV, AV, SV, CV, because those
9228 objects will become corrupted by the pointer copy process.
9230 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
9236 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
9240 PERL_ARGS_ASSERT_SV_SETREF_PV;
9243 sv_setsv(rv, &PL_sv_undef);
9247 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
9252 =for apidoc sv_setref_iv
9254 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
9255 argument will be upgraded to an RV. That RV will be modified to point to
9256 the new SV. The C<classname> argument indicates the package for the
9257 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9258 will have a reference count of 1, and the RV will be returned.
9264 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
9266 PERL_ARGS_ASSERT_SV_SETREF_IV;
9268 sv_setiv(newSVrv(rv,classname), iv);
9273 =for apidoc sv_setref_uv
9275 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
9276 argument will be upgraded to an RV. That RV will be modified to point to
9277 the new SV. The C<classname> argument indicates the package for the
9278 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9279 will have a reference count of 1, and the RV will be returned.
9285 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
9287 PERL_ARGS_ASSERT_SV_SETREF_UV;
9289 sv_setuv(newSVrv(rv,classname), uv);
9294 =for apidoc sv_setref_nv
9296 Copies a double into a new SV, optionally blessing the SV. The C<rv>
9297 argument will be upgraded to an RV. That RV will be modified to point to
9298 the new SV. The C<classname> argument indicates the package for the
9299 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
9300 will have a reference count of 1, and the RV will be returned.
9306 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
9308 PERL_ARGS_ASSERT_SV_SETREF_NV;
9310 sv_setnv(newSVrv(rv,classname), nv);
9315 =for apidoc sv_setref_pvn
9317 Copies a string into a new SV, optionally blessing the SV. The length of the
9318 string must be specified with C<n>. The C<rv> argument will be upgraded to
9319 an RV. That RV will be modified to point to the new SV. The C<classname>
9320 argument indicates the package for the blessing. Set C<classname> to
9321 C<NULL> to avoid the blessing. The new SV will have a reference count
9322 of 1, and the RV will be returned.
9324 Note that C<sv_setref_pv> copies the pointer while this copies the string.
9330 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
9331 const char *const pv, const STRLEN n)
9333 PERL_ARGS_ASSERT_SV_SETREF_PVN;
9335 sv_setpvn(newSVrv(rv,classname), pv, n);
9340 =for apidoc sv_bless
9342 Blesses an SV into a specified package. The SV must be an RV. The package
9343 must be designated by its stash (see C<gv_stashpv()>). The reference count
9344 of the SV is unaffected.
9350 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
9355 PERL_ARGS_ASSERT_SV_BLESS;
9358 Perl_croak(aTHX_ "Can't bless non-reference value");
9360 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
9361 if (SvIsCOW(tmpRef))
9362 sv_force_normal_flags(tmpRef, 0);
9363 if (SvREADONLY(tmpRef))
9364 Perl_croak_no_modify(aTHX);
9365 if (SvOBJECT(tmpRef)) {
9366 if (SvTYPE(tmpRef) != SVt_PVIO)
9368 SvREFCNT_dec(SvSTASH(tmpRef));
9371 SvOBJECT_on(tmpRef);
9372 if (SvTYPE(tmpRef) != SVt_PVIO)
9374 SvUPGRADE(tmpRef, SVt_PVMG);
9375 SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
9380 (void)SvAMAGIC_off(sv);
9382 if(SvSMAGICAL(tmpRef))
9383 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
9391 /* Downgrades a PVGV to a PVMG. If it’s actually a PVLV, we leave the type
9392 * as it is after unglobbing it.
9396 S_sv_unglob(pTHX_ SV *const sv)
9401 SV * const temp = sv_newmortal();
9403 PERL_ARGS_ASSERT_SV_UNGLOB;
9405 assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
9407 gv_efullname3(temp, MUTABLE_GV(sv), "*");
9410 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
9411 && HvNAME_get(stash))
9412 mro_method_changed_in(stash);
9413 gp_free(MUTABLE_GV(sv));
9416 sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv);
9420 if (GvNAME_HEK(sv)) {
9421 unshare_hek(GvNAME_HEK(sv));
9423 isGV_with_GP_off(sv);
9425 if(SvTYPE(sv) == SVt_PVGV) {
9426 /* need to keep SvANY(sv) in the right arena */
9427 xpvmg = new_XPVMG();
9428 StructCopy(SvANY(sv), xpvmg, XPVMG);
9429 del_XPVGV(SvANY(sv));
9432 SvFLAGS(sv) &= ~SVTYPEMASK;
9433 SvFLAGS(sv) |= SVt_PVMG;
9436 /* Intentionally not calling any local SET magic, as this isn't so much a
9437 set operation as merely an internal storage change. */
9438 sv_setsv_flags(sv, temp, 0);
9442 =for apidoc sv_unref_flags
9444 Unsets the RV status of the SV, and decrements the reference count of
9445 whatever was being referenced by the RV. This can almost be thought of
9446 as a reversal of C<newSVrv>. The C<cflags> argument can contain
9447 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
9448 (otherwise the decrementing is conditional on the reference count being
9449 different from one or the reference being a readonly SV).
9456 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
9458 SV* const target = SvRV(ref);
9460 PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
9462 if (SvWEAKREF(ref)) {
9463 sv_del_backref(target, ref);
9465 SvRV_set(ref, NULL);
9468 SvRV_set(ref, NULL);
9470 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
9471 assigned to as BEGIN {$a = \"Foo"} will fail. */
9472 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
9473 SvREFCNT_dec(target);
9474 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
9475 sv_2mortal(target); /* Schedule for freeing later */
9479 =for apidoc sv_untaint
9481 Untaint an SV. Use C<SvTAINTED_off> instead.
9486 Perl_sv_untaint(pTHX_ SV *const sv)
9488 PERL_ARGS_ASSERT_SV_UNTAINT;
9490 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9491 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9498 =for apidoc sv_tainted
9500 Test an SV for taintedness. Use C<SvTAINTED> instead.
9505 Perl_sv_tainted(pTHX_ SV *const sv)
9507 PERL_ARGS_ASSERT_SV_TAINTED;
9509 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
9510 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
9511 if (mg && (mg->mg_len & 1) )
9518 =for apidoc sv_setpviv
9520 Copies an integer into the given SV, also updating its string value.
9521 Does not handle 'set' magic. See C<sv_setpviv_mg>.
9527 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
9529 char buf[TYPE_CHARS(UV)];
9531 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
9533 PERL_ARGS_ASSERT_SV_SETPVIV;
9535 sv_setpvn(sv, ptr, ebuf - ptr);
9539 =for apidoc sv_setpviv_mg
9541 Like C<sv_setpviv>, but also handles 'set' magic.
9547 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
9549 PERL_ARGS_ASSERT_SV_SETPVIV_MG;
9555 #if defined(PERL_IMPLICIT_CONTEXT)
9557 /* pTHX_ magic can't cope with varargs, so this is a no-context
9558 * version of the main function, (which may itself be aliased to us).
9559 * Don't access this version directly.
9563 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
9568 PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
9570 va_start(args, pat);
9571 sv_vsetpvf(sv, pat, &args);
9575 /* pTHX_ magic can't cope with varargs, so this is a no-context
9576 * version of the main function, (which may itself be aliased to us).
9577 * Don't access this version directly.
9581 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9586 PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
9588 va_start(args, pat);
9589 sv_vsetpvf_mg(sv, pat, &args);
9595 =for apidoc sv_setpvf
9597 Works like C<sv_catpvf> but copies the text into the SV instead of
9598 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
9604 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
9608 PERL_ARGS_ASSERT_SV_SETPVF;
9610 va_start(args, pat);
9611 sv_vsetpvf(sv, pat, &args);
9616 =for apidoc sv_vsetpvf
9618 Works like C<sv_vcatpvf> but copies the text into the SV instead of
9619 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
9621 Usually used via its frontend C<sv_setpvf>.
9627 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9629 PERL_ARGS_ASSERT_SV_VSETPVF;
9631 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9635 =for apidoc sv_setpvf_mg
9637 Like C<sv_setpvf>, but also handles 'set' magic.
9643 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9647 PERL_ARGS_ASSERT_SV_SETPVF_MG;
9649 va_start(args, pat);
9650 sv_vsetpvf_mg(sv, pat, &args);
9655 =for apidoc sv_vsetpvf_mg
9657 Like C<sv_vsetpvf>, but also handles 'set' magic.
9659 Usually used via its frontend C<sv_setpvf_mg>.
9665 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9667 PERL_ARGS_ASSERT_SV_VSETPVF_MG;
9669 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9673 #if defined(PERL_IMPLICIT_CONTEXT)
9675 /* pTHX_ magic can't cope with varargs, so this is a no-context
9676 * version of the main function, (which may itself be aliased to us).
9677 * Don't access this version directly.
9681 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
9686 PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
9688 va_start(args, pat);
9689 sv_vcatpvf(sv, pat, &args);
9693 /* pTHX_ magic can't cope with varargs, so this is a no-context
9694 * version of the main function, (which may itself be aliased to us).
9695 * Don't access this version directly.
9699 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
9704 PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
9706 va_start(args, pat);
9707 sv_vcatpvf_mg(sv, pat, &args);
9713 =for apidoc sv_catpvf
9715 Processes its arguments like C<sprintf> and appends the formatted
9716 output to an SV. If the appended data contains "wide" characters
9717 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9718 and characters >255 formatted with %c), the original SV might get
9719 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
9720 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9721 valid UTF-8; if the original SV was bytes, the pattern should be too.
9726 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
9730 PERL_ARGS_ASSERT_SV_CATPVF;
9732 va_start(args, pat);
9733 sv_vcatpvf(sv, pat, &args);
9738 =for apidoc sv_vcatpvf
9740 Processes its arguments like C<vsprintf> and appends the formatted output
9741 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
9743 Usually used via its frontend C<sv_catpvf>.
9749 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9751 PERL_ARGS_ASSERT_SV_VCATPVF;
9753 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9757 =for apidoc sv_catpvf_mg
9759 Like C<sv_catpvf>, but also handles 'set' magic.
9765 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
9769 PERL_ARGS_ASSERT_SV_CATPVF_MG;
9771 va_start(args, pat);
9772 sv_vcatpvf_mg(sv, pat, &args);
9777 =for apidoc sv_vcatpvf_mg
9779 Like C<sv_vcatpvf>, but also handles 'set' magic.
9781 Usually used via its frontend C<sv_catpvf_mg>.
9787 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
9789 PERL_ARGS_ASSERT_SV_VCATPVF_MG;
9791 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
9796 =for apidoc sv_vsetpvfn
9798 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9801 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9807 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9808 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9810 PERL_ARGS_ASSERT_SV_VSETPVFN;
9813 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9818 * Warn of missing argument to sprintf, and then return a defined value
9819 * to avoid inappropriate "use of uninit" warnings [perl #71000].
9821 #define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
9823 S_vcatpvfn_missing_argument(pTHX) {
9824 if (ckWARN(WARN_MISSING)) {
9825 Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s",
9826 PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
9833 S_expect_number(pTHX_ char **const pattern)
9838 PERL_ARGS_ASSERT_EXPECT_NUMBER;
9840 switch (**pattern) {
9841 case '1': case '2': case '3':
9842 case '4': case '5': case '6':
9843 case '7': case '8': case '9':
9844 var = *(*pattern)++ - '0';
9845 while (isDIGIT(**pattern)) {
9846 const I32 tmp = var * 10 + (*(*pattern)++ - '0');
9848 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn"));
9856 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
9858 const int neg = nv < 0;
9861 PERL_ARGS_ASSERT_F0CONVERT;
9869 if (uv & 1 && uv == nv)
9870 uv--; /* Round to even */
9872 const unsigned dig = uv % 10;
9885 =for apidoc sv_vcatpvfn
9887 Processes its arguments like C<vsprintf> and appends the formatted output
9888 to an SV. Uses an array of SVs if the C style variable argument list is
9889 missing (NULL). When running with taint checks enabled, indicates via
9890 C<maybe_tainted> if results are untrustworthy (often due to the use of
9893 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9899 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
9900 vecstr = (U8*)SvPV_const(vecsv,veclen);\
9901 vec_utf8 = DO_UTF8(vecsv);
9903 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9906 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
9907 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
9915 static const char nullstr[] = "(null)";
9917 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
9918 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
9920 /* Times 4: a decimal digit takes more than 3 binary digits.
9921 * NV_DIG: mantissa takes than many decimal digits.
9922 * Plus 32: Playing safe. */
9923 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9924 /* large enough for "%#.#f" --chip */
9925 /* what about long double NVs? --jhi */
9927 PERL_ARGS_ASSERT_SV_VCATPVFN;
9928 PERL_UNUSED_ARG(maybe_tainted);
9930 /* no matter what, this is a string now */
9931 (void)SvPV_force(sv, origlen);
9933 /* special-case "", "%s", and "%-p" (SVf - see below) */
9936 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9938 const char * const s = va_arg(*args, char*);
9939 sv_catpv(sv, s ? s : nullstr);
9941 else if (svix < svmax) {
9942 sv_catsv(sv, *svargs);
9945 S_vcatpvfn_missing_argument(aTHX);
9948 if (args && patlen == 3 && pat[0] == '%' &&
9949 pat[1] == '-' && pat[2] == 'p') {
9950 argsv = MUTABLE_SV(va_arg(*args, void*));
9951 sv_catsv(sv, argsv);
9955 #ifndef USE_LONG_DOUBLE
9956 /* special-case "%.<number>[gf]" */
9957 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9958 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9959 unsigned digits = 0;
9963 while (*pp >= '0' && *pp <= '9')
9964 digits = 10 * digits + (*pp++ - '0');
9965 if (pp - pat == (int)patlen - 1 && svix < svmax) {
9966 const NV nv = SvNV(*svargs);
9968 /* Add check for digits != 0 because it seems that some
9969 gconverts are buggy in this case, and we don't yet have
9970 a Configure test for this. */
9971 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9972 /* 0, point, slack */
9973 Gconvert(nv, (int)digits, 0, ebuf);
9975 if (*ebuf) /* May return an empty string for digits==0 */
9978 } else if (!digits) {
9981 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9982 sv_catpvn(sv, p, l);
9988 #endif /* !USE_LONG_DOUBLE */
9990 if (!args && svix < svmax && DO_UTF8(*svargs))
9993 patend = (char*)pat + patlen;
9994 for (p = (char*)pat; p < patend; p = q) {
9997 bool vectorize = FALSE;
9998 bool vectorarg = FALSE;
9999 bool vec_utf8 = FALSE;
10005 bool has_precis = FALSE;
10007 const I32 osvix = svix;
10008 bool is_utf8 = FALSE; /* is this item utf8? */
10009 #ifdef HAS_LDBL_SPRINTF_BUG
10010 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10011 with sfio - Allen <allens@cpan.org> */
10012 bool fix_ldbl_sprintf_bug = FALSE;
10016 U8 utf8buf[UTF8_MAXBYTES+1];
10017 STRLEN esignlen = 0;
10019 const char *eptr = NULL;
10020 const char *fmtstart;
10023 const U8 *vecstr = NULL;
10030 /* we need a long double target in case HAS_LONG_DOUBLE but
10031 not USE_LONG_DOUBLE
10033 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
10041 const char *dotstr = ".";
10042 STRLEN dotstrlen = 1;
10043 I32 efix = 0; /* explicit format parameter index */
10044 I32 ewix = 0; /* explicit width index */
10045 I32 epix = 0; /* explicit precision index */
10046 I32 evix = 0; /* explicit vector index */
10047 bool asterisk = FALSE;
10049 /* echo everything up to the next format specification */
10050 for (q = p; q < patend && *q != '%'; ++q) ;
10052 if (has_utf8 && !pat_utf8)
10053 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
10055 sv_catpvn(sv, p, q - p);
10064 We allow format specification elements in this order:
10065 \d+\$ explicit format parameter index
10067 v|\*(\d+\$)?v vector with optional (optionally specified) arg
10068 0 flag (as above): repeated to allow "v02"
10069 \d+|\*(\d+\$)? width using optional (optionally specified) arg
10070 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
10072 [%bcdefginopsuxDFOUX] format (mandatory)
10077 As of perl5.9.3, printf format checking is on by default.
10078 Internally, perl uses %p formats to provide an escape to
10079 some extended formatting. This block deals with those
10080 extensions: if it does not match, (char*)q is reset and
10081 the normal format processing code is used.
10083 Currently defined extensions are:
10084 %p include pointer address (standard)
10085 %-p (SVf) include an SV (previously %_)
10086 %-<num>p include an SV with precision <num>
10087 %<num>p reserved for future extensions
10089 Robin Barker 2005-07-14
10091 %1p (VDf) removed. RMB 2007-10-19
10098 n = expect_number(&q);
10100 if (sv) { /* SVf */
10105 argsv = MUTABLE_SV(va_arg(*args, void*));
10106 eptr = SvPV_const(argsv, elen);
10107 if (DO_UTF8(argsv))
10112 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
10113 "internal %%<num>p might conflict with future printf extensions");
10119 if ( (width = expect_number(&q)) ) {
10134 if (plus == '+' && *q == ' ') /* '+' over ' ' */
10163 if ( (ewix = expect_number(&q)) )
10172 if ((vectorarg = asterisk)) {
10185 width = expect_number(&q);
10188 if (vectorize && vectorarg) {
10189 /* vectorizing, but not with the default "." */
10191 vecsv = va_arg(*args, SV*);
10193 vecsv = (evix > 0 && evix <= svmax)
10194 ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX);
10196 vecsv = svix < svmax
10197 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10199 dotstr = SvPV_const(vecsv, dotstrlen);
10200 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
10201 bad with tied or overloaded values that return UTF8. */
10202 if (DO_UTF8(vecsv))
10204 else if (has_utf8) {
10205 vecsv = sv_mortalcopy(vecsv);
10206 sv_utf8_upgrade(vecsv);
10207 dotstr = SvPV_const(vecsv, dotstrlen);
10214 i = va_arg(*args, int);
10216 i = (ewix ? ewix <= svmax : svix < svmax) ?
10217 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10219 width = (i < 0) ? -i : i;
10229 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
10231 /* XXX: todo, support specified precision parameter */
10235 i = va_arg(*args, int);
10237 i = (ewix ? ewix <= svmax : svix < svmax)
10238 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
10240 has_precis = !(i < 0);
10244 while (isDIGIT(*q))
10245 precis = precis * 10 + (*q++ - '0');
10254 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
10255 vecsv = svargs[efix ? efix-1 : svix++];
10256 vecstr = (U8*)SvPV_const(vecsv,veclen);
10257 vec_utf8 = DO_UTF8(vecsv);
10259 /* if this is a version object, we need to convert
10260 * back into v-string notation and then let the
10261 * vectorize happen normally
10263 if (sv_derived_from(vecsv, "version")) {
10264 char *version = savesvpv(vecsv);
10265 if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
10266 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
10267 "vector argument not supported with alpha versions");
10270 vecsv = sv_newmortal();
10271 scan_vstring(version, version + veclen, vecsv);
10272 vecstr = (U8*)SvPV_const(vecsv, veclen);
10273 vec_utf8 = DO_UTF8(vecsv);
10287 case 'I': /* Ix, I32x, and I64x */
10289 if (q[1] == '6' && q[2] == '4') {
10295 if (q[1] == '3' && q[2] == '2') {
10305 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10316 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
10317 if (*++q == 'l') { /* lld, llf */
10326 if (*++q == 'h') { /* hhd, hhu */
10355 if (!vectorize && !args) {
10357 const I32 i = efix-1;
10358 argsv = (i >= 0 && i < svmax)
10359 ? svargs[i] : S_vcatpvfn_missing_argument(aTHX);
10361 argsv = (svix >= 0 && svix < svmax)
10362 ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX);
10366 switch (c = *q++) {
10373 uv = (args) ? va_arg(*args, int) : SvIV(argsv);
10375 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
10377 eptr = (char*)utf8buf;
10378 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
10392 eptr = va_arg(*args, char*);
10394 elen = strlen(eptr);
10396 eptr = (char *)nullstr;
10397 elen = sizeof nullstr - 1;
10401 eptr = SvPV_const(argsv, elen);
10402 if (DO_UTF8(argsv)) {
10403 STRLEN old_precis = precis;
10404 if (has_precis && precis < elen) {
10405 STRLEN ulen = sv_len_utf8(argsv);
10406 I32 p = precis > ulen ? ulen : precis;
10407 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
10410 if (width) { /* fudge width (can't fudge elen) */
10411 if (has_precis && precis < elen)
10412 width += precis - old_precis;
10414 width += elen - sv_len_utf8(argsv);
10421 if (has_precis && precis < elen)
10428 if (alt || vectorize)
10430 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
10451 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10460 esignbuf[esignlen++] = plus;
10464 case 'c': iv = (char)va_arg(*args, int); break;
10465 case 'h': iv = (short)va_arg(*args, int); break;
10466 case 'l': iv = va_arg(*args, long); break;
10467 case 'V': iv = va_arg(*args, IV); break;
10468 case 'z': iv = va_arg(*args, SSize_t); break;
10469 case 't': iv = va_arg(*args, ptrdiff_t); break;
10470 default: iv = va_arg(*args, int); break;
10472 case 'j': iv = va_arg(*args, intmax_t); break;
10476 iv = va_arg(*args, Quad_t); break;
10483 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
10485 case 'c': iv = (char)tiv; break;
10486 case 'h': iv = (short)tiv; break;
10487 case 'l': iv = (long)tiv; break;
10489 default: iv = tiv; break;
10492 iv = (Quad_t)tiv; break;
10498 if ( !vectorize ) /* we already set uv above */
10503 esignbuf[esignlen++] = plus;
10507 esignbuf[esignlen++] = '-';
10551 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
10562 case 'c': uv = (unsigned char)va_arg(*args, unsigned); break;
10563 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
10564 case 'l': uv = va_arg(*args, unsigned long); break;
10565 case 'V': uv = va_arg(*args, UV); break;
10566 case 'z': uv = va_arg(*args, Size_t); break;
10567 case 't': uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */
10569 case 'j': uv = va_arg(*args, uintmax_t); break;
10571 default: uv = va_arg(*args, unsigned); break;
10574 uv = va_arg(*args, Uquad_t); break;
10581 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
10583 case 'c': uv = (unsigned char)tuv; break;
10584 case 'h': uv = (unsigned short)tuv; break;
10585 case 'l': uv = (unsigned long)tuv; break;
10587 default: uv = tuv; break;
10590 uv = (Uquad_t)tuv; break;
10599 char *ptr = ebuf + sizeof ebuf;
10600 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
10606 p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
10610 } while (uv >>= 4);
10612 esignbuf[esignlen++] = '0';
10613 esignbuf[esignlen++] = c; /* 'x' or 'X' */
10619 *--ptr = '0' + dig;
10620 } while (uv >>= 3);
10621 if (alt && *ptr != '0')
10627 *--ptr = '0' + dig;
10628 } while (uv >>= 1);
10630 esignbuf[esignlen++] = '0';
10631 esignbuf[esignlen++] = c;
10634 default: /* it had better be ten or less */
10637 *--ptr = '0' + dig;
10638 } while (uv /= base);
10641 elen = (ebuf + sizeof ebuf) - ptr;
10645 zeros = precis - elen;
10646 else if (precis == 0 && elen == 1 && *eptr == '0'
10647 && !(base == 8 && alt)) /* "%#.0o" prints "0" */
10650 /* a precision nullifies the 0 flag. */
10657 /* FLOATING POINT */
10660 c = 'f'; /* maybe %F isn't supported here */
10662 case 'e': case 'E':
10664 case 'g': case 'G':
10668 /* This is evil, but floating point is even more evil */
10670 /* for SV-style calling, we can only get NV
10671 for C-style calling, we assume %f is double;
10672 for simplicity we allow any of %Lf, %llf, %qf for long double
10676 #if defined(USE_LONG_DOUBLE)
10680 /* [perl #20339] - we should accept and ignore %lf rather than die */
10684 #if defined(USE_LONG_DOUBLE)
10685 intsize = args ? 0 : 'q';
10689 #if defined(HAS_LONG_DOUBLE)
10702 /* now we need (long double) if intsize == 'q', else (double) */
10704 #if LONG_DOUBLESIZE > DOUBLESIZE
10706 va_arg(*args, long double) :
10707 va_arg(*args, double)
10709 va_arg(*args, double)
10714 /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
10715 else. frexp() has some unspecified behaviour for those three */
10716 if (c != 'e' && c != 'E' && (nv * 0) == 0) {
10718 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
10719 will cast our (long double) to (double) */
10720 (void)Perl_frexp(nv, &i);
10721 if (i == PERL_INT_MIN)
10722 Perl_die(aTHX_ "panic: frexp");
10724 need = BIT_DIGITS(i);
10726 need += has_precis ? precis : 6; /* known default */
10731 #ifdef HAS_LDBL_SPRINTF_BUG
10732 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
10733 with sfio - Allen <allens@cpan.org> */
10736 # define MY_DBL_MAX DBL_MAX
10737 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
10738 # if DOUBLESIZE >= 8
10739 # define MY_DBL_MAX 1.7976931348623157E+308L
10741 # define MY_DBL_MAX 3.40282347E+38L
10745 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
10746 # define MY_DBL_MAX_BUG 1L
10748 # define MY_DBL_MAX_BUG MY_DBL_MAX
10752 # define MY_DBL_MIN DBL_MIN
10753 # else /* XXX guessing! -Allen */
10754 # if DOUBLESIZE >= 8
10755 # define MY_DBL_MIN 2.2250738585072014E-308L
10757 # define MY_DBL_MIN 1.17549435E-38L
10761 if ((intsize == 'q') && (c == 'f') &&
10762 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
10763 (need < DBL_DIG)) {
10764 /* it's going to be short enough that
10765 * long double precision is not needed */
10767 if ((nv <= 0L) && (nv >= -0L))
10768 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
10770 /* would use Perl_fp_class as a double-check but not
10771 * functional on IRIX - see perl.h comments */
10773 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
10774 /* It's within the range that a double can represent */
10775 #if defined(DBL_MAX) && !defined(DBL_MIN)
10776 if ((nv >= ((long double)1/DBL_MAX)) ||
10777 (nv <= (-(long double)1/DBL_MAX)))
10779 fix_ldbl_sprintf_bug = TRUE;
10782 if (fix_ldbl_sprintf_bug == TRUE) {
10792 # undef MY_DBL_MAX_BUG
10795 #endif /* HAS_LDBL_SPRINTF_BUG */
10797 need += 20; /* fudge factor */
10798 if (PL_efloatsize < need) {
10799 Safefree(PL_efloatbuf);
10800 PL_efloatsize = need + 20; /* more fudge */
10801 Newx(PL_efloatbuf, PL_efloatsize, char);
10802 PL_efloatbuf[0] = '\0';
10805 if ( !(width || left || plus || alt) && fill != '0'
10806 && has_precis && intsize != 'q' ) { /* Shortcuts */
10807 /* See earlier comment about buggy Gconvert when digits,
10809 if ( c == 'g' && precis) {
10810 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
10811 /* May return an empty string for digits==0 */
10812 if (*PL_efloatbuf) {
10813 elen = strlen(PL_efloatbuf);
10814 goto float_converted;
10816 } else if ( c == 'f' && !precis) {
10817 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10822 char *ptr = ebuf + sizeof ebuf;
10825 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10826 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10827 if (intsize == 'q') {
10828 /* Copy the one or more characters in a long double
10829 * format before the 'base' ([efgEFG]) character to
10830 * the format string. */
10831 static char const prifldbl[] = PERL_PRIfldbl;
10832 char const *p = prifldbl + sizeof(prifldbl) - 3;
10833 while (p >= prifldbl) { *--ptr = *p--; }
10838 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10843 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10855 /* No taint. Otherwise we are in the strange situation
10856 * where printf() taints but print($float) doesn't.
10858 #if defined(HAS_LONG_DOUBLE)
10859 elen = ((intsize == 'q')
10860 ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
10861 : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
10863 elen = my_sprintf(PL_efloatbuf, ptr, nv);
10867 eptr = PL_efloatbuf;
10875 i = SvCUR(sv) - origlen;
10878 case 'c': *(va_arg(*args, char*)) = i; break;
10879 case 'h': *(va_arg(*args, short*)) = i; break;
10880 default: *(va_arg(*args, int*)) = i; break;
10881 case 'l': *(va_arg(*args, long*)) = i; break;
10882 case 'V': *(va_arg(*args, IV*)) = i; break;
10883 case 'z': *(va_arg(*args, SSize_t*)) = i; break;
10884 case 't': *(va_arg(*args, ptrdiff_t*)) = i; break;
10886 case 'j': *(va_arg(*args, intmax_t*)) = i; break;
10890 *(va_arg(*args, Quad_t*)) = i; break;
10897 sv_setuv_mg(argsv, (UV)i);
10898 continue; /* not "break" */
10905 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
10906 && ckWARN(WARN_PRINTF))
10908 SV * const msg = sv_newmortal();
10909 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10910 (PL_op->op_type == OP_PRTF) ? "" : "s");
10911 if (fmtstart < patend) {
10912 const char * const fmtend = q < patend ? q : patend;
10914 sv_catpvs(msg, "\"%");
10915 for (f = fmtstart; f < fmtend; f++) {
10917 sv_catpvn(msg, f, 1);
10919 Perl_sv_catpvf(aTHX_ msg,
10920 "\\%03"UVof, (UV)*f & 0xFF);
10923 sv_catpvs(msg, "\"");
10925 sv_catpvs(msg, "end of string");
10927 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
10930 /* output mangled stuff ... */
10936 /* ... right here, because formatting flags should not apply */
10937 SvGROW(sv, SvCUR(sv) + elen + 1);
10939 Copy(eptr, p, elen, char);
10942 SvCUR_set(sv, p - SvPVX_const(sv));
10944 continue; /* not "break" */
10947 if (is_utf8 != has_utf8) {
10950 sv_utf8_upgrade(sv);
10953 const STRLEN old_elen = elen;
10954 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
10955 sv_utf8_upgrade(nsv);
10956 eptr = SvPVX_const(nsv);
10959 if (width) { /* fudge width (can't fudge elen) */
10960 width += elen - old_elen;
10966 have = esignlen + zeros + elen;
10968 Perl_croak_nocontext("%s", PL_memory_wrap);
10970 need = (have > width ? have : width);
10973 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
10974 Perl_croak_nocontext("%s", PL_memory_wrap);
10975 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10977 if (esignlen && fill == '0') {
10979 for (i = 0; i < (int)esignlen; i++)
10980 *p++ = esignbuf[i];
10982 if (gap && !left) {
10983 memset(p, fill, gap);
10986 if (esignlen && fill != '0') {
10988 for (i = 0; i < (int)esignlen; i++)
10989 *p++ = esignbuf[i];
10993 for (i = zeros; i; i--)
10997 Copy(eptr, p, elen, char);
11001 memset(p, ' ', gap);
11006 Copy(dotstr, p, dotstrlen, char);
11010 vectorize = FALSE; /* done iterating over vecstr */
11017 SvCUR_set(sv, p - SvPVX_const(sv));
11026 /* =========================================================================
11028 =head1 Cloning an interpreter
11030 All the macros and functions in this section are for the private use of
11031 the main function, perl_clone().
11033 The foo_dup() functions make an exact copy of an existing foo thingy.
11034 During the course of a cloning, a hash table is used to map old addresses
11035 to new addresses. The table is created and manipulated with the
11036 ptr_table_* functions.
11040 * =========================================================================*/
11043 #if defined(USE_ITHREADS)
11045 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
11046 #ifndef GpREFCNT_inc
11047 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
11051 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
11052 that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
11053 If this changes, please unmerge ss_dup.
11054 Likewise, sv_dup_inc_multiple() relies on this fact. */
11055 #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup_inc(s,t))
11056 #define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t))
11057 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
11058 #define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t))
11059 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
11060 #define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t))
11061 #define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t))
11062 #define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t))
11063 #define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t))
11064 #define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t))
11065 #define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t))
11066 #define SAVEPV(p) ((p) ? savepv(p) : NULL)
11067 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
11069 /* clone a parser */
11072 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
11076 PERL_ARGS_ASSERT_PARSER_DUP;
11081 /* look for it in the table first */
11082 parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
11086 /* create anew and remember what it is */
11087 Newxz(parser, 1, yy_parser);
11088 ptr_table_store(PL_ptr_table, proto, parser);
11090 /* XXX these not yet duped */
11091 parser->old_parser = NULL;
11092 parser->stack = NULL;
11094 parser->stack_size = 0;
11095 /* XXX parser->stack->state = 0; */
11097 /* XXX eventually, just Copy() most of the parser struct ? */
11099 parser->lex_brackets = proto->lex_brackets;
11100 parser->lex_casemods = proto->lex_casemods;
11101 parser->lex_brackstack = savepvn(proto->lex_brackstack,
11102 (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
11103 parser->lex_casestack = savepvn(proto->lex_casestack,
11104 (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
11105 parser->lex_defer = proto->lex_defer;
11106 parser->lex_dojoin = proto->lex_dojoin;
11107 parser->lex_expect = proto->lex_expect;
11108 parser->lex_formbrack = proto->lex_formbrack;
11109 parser->lex_inpat = proto->lex_inpat;
11110 parser->lex_inwhat = proto->lex_inwhat;
11111 parser->lex_op = proto->lex_op;
11112 parser->lex_repl = sv_dup_inc(proto->lex_repl, param);
11113 parser->lex_starts = proto->lex_starts;
11114 parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param);
11115 parser->multi_close = proto->multi_close;
11116 parser->multi_open = proto->multi_open;
11117 parser->multi_start = proto->multi_start;
11118 parser->multi_end = proto->multi_end;
11119 parser->pending_ident = proto->pending_ident;
11120 parser->preambled = proto->preambled;
11121 parser->sublex_info = proto->sublex_info; /* XXX not quite right */
11122 parser->linestr = sv_dup_inc(proto->linestr, param);
11123 parser->expect = proto->expect;
11124 parser->copline = proto->copline;
11125 parser->last_lop_op = proto->last_lop_op;
11126 parser->lex_state = proto->lex_state;
11127 parser->rsfp = fp_dup(proto->rsfp, '<', param);
11128 /* rsfp_filters entries have fake IoDIRP() */
11129 parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
11130 parser->in_my = proto->in_my;
11131 parser->in_my_stash = hv_dup(proto->in_my_stash, param);
11132 parser->error_count = proto->error_count;
11135 parser->linestr = sv_dup_inc(proto->linestr, param);
11138 char * const ols = SvPVX(proto->linestr);
11139 char * const ls = SvPVX(parser->linestr);
11141 parser->bufptr = ls + (proto->bufptr >= ols ?
11142 proto->bufptr - ols : 0);
11143 parser->oldbufptr = ls + (proto->oldbufptr >= ols ?
11144 proto->oldbufptr - ols : 0);
11145 parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
11146 proto->oldoldbufptr - ols : 0);
11147 parser->linestart = ls + (proto->linestart >= ols ?
11148 proto->linestart - ols : 0);
11149 parser->last_uni = ls + (proto->last_uni >= ols ?
11150 proto->last_uni - ols : 0);
11151 parser->last_lop = ls + (proto->last_lop >= ols ?
11152 proto->last_lop - ols : 0);
11154 parser->bufend = ls + SvCUR(parser->linestr);
11157 Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
11161 parser->endwhite = proto->endwhite;
11162 parser->faketokens = proto->faketokens;
11163 parser->lasttoke = proto->lasttoke;
11164 parser->nextwhite = proto->nextwhite;
11165 parser->realtokenstart = proto->realtokenstart;
11166 parser->skipwhite = proto->skipwhite;
11167 parser->thisclose = proto->thisclose;
11168 parser->thismad = proto->thismad;
11169 parser->thisopen = proto->thisopen;
11170 parser->thisstuff = proto->thisstuff;
11171 parser->thistoken = proto->thistoken;
11172 parser->thiswhite = proto->thiswhite;
11174 Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
11175 parser->curforce = proto->curforce;
11177 Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
11178 Copy(proto->nexttype, parser->nexttype, 5, I32);
11179 parser->nexttoke = proto->nexttoke;
11182 /* XXX should clone saved_curcop here, but we aren't passed
11183 * proto_perl; so do it in perl_clone_using instead */
11189 /* duplicate a file handle */
11192 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
11196 PERL_ARGS_ASSERT_FP_DUP;
11197 PERL_UNUSED_ARG(type);
11200 return (PerlIO*)NULL;
11202 /* look for it in the table first */
11203 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
11207 /* create anew and remember what it is */
11208 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
11209 ptr_table_store(PL_ptr_table, fp, ret);
11213 /* duplicate a directory handle */
11216 Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
11222 register const Direntry_t *dirent;
11223 char smallbuf[256];
11229 PERL_UNUSED_CONTEXT;
11230 PERL_ARGS_ASSERT_DIRP_DUP;
11235 /* look for it in the table first */
11236 ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp);
11242 PERL_UNUSED_ARG(param);
11246 /* open the current directory (so we can switch back) */
11247 if (!(pwd = PerlDir_open("."))) return (DIR *)NULL;
11249 /* chdir to our dir handle and open the present working directory */
11250 if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) {
11251 PerlDir_close(pwd);
11252 return (DIR *)NULL;
11254 /* Now we should have two dir handles pointing to the same dir. */
11256 /* Be nice to the calling code and chdir back to where we were. */
11257 fchdir(my_dirfd(pwd)); /* If this fails, then what? */
11259 /* We have no need of the pwd handle any more. */
11260 PerlDir_close(pwd);
11263 # define d_namlen(d) (d)->d_namlen
11265 # define d_namlen(d) strlen((d)->d_name)
11267 /* Iterate once through dp, to get the file name at the current posi-
11268 tion. Then step back. */
11269 pos = PerlDir_tell(dp);
11270 if ((dirent = PerlDir_read(dp))) {
11271 len = d_namlen(dirent);
11272 if (len <= sizeof smallbuf) name = smallbuf;
11273 else Newx(name, len, char);
11274 Move(dirent->d_name, name, len, char);
11276 PerlDir_seek(dp, pos);
11278 /* Iterate through the new dir handle, till we find a file with the
11280 if (!dirent) /* just before the end */
11282 pos = PerlDir_tell(ret);
11283 if (PerlDir_read(ret)) continue; /* not there yet */
11284 PerlDir_seek(ret, pos); /* step back */
11288 const long pos0 = PerlDir_tell(ret);
11290 pos = PerlDir_tell(ret);
11291 if ((dirent = PerlDir_read(ret))) {
11292 if (len == d_namlen(dirent)
11293 && memEQ(name, dirent->d_name, len)) {
11295 PerlDir_seek(ret, pos); /* step back */
11298 /* else we are not there yet; keep iterating */
11300 else { /* This is not meant to happen. The best we can do is
11301 reset the iterator to the beginning. */
11302 PerlDir_seek(ret, pos0);
11309 if (name && name != smallbuf)
11314 ret = win32_dirp_dup(dp, param);
11317 /* pop it in the pointer table */
11319 ptr_table_store(PL_ptr_table, dp, ret);
11324 /* duplicate a typeglob */
11327 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
11331 PERL_ARGS_ASSERT_GP_DUP;
11335 /* look for it in the table first */
11336 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
11340 /* create anew and remember what it is */
11342 ptr_table_store(PL_ptr_table, gp, ret);
11345 /* ret->gp_refcnt must be 0 before any other dups are called. We're relying
11346 on Newxz() to do this for us. */
11347 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
11348 ret->gp_io = io_dup_inc(gp->gp_io, param);
11349 ret->gp_form = cv_dup_inc(gp->gp_form, param);
11350 ret->gp_av = av_dup_inc(gp->gp_av, param);
11351 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
11352 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
11353 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
11354 ret->gp_cvgen = gp->gp_cvgen;
11355 ret->gp_line = gp->gp_line;
11356 ret->gp_file_hek = hek_dup(gp->gp_file_hek, param);
11360 /* duplicate a chain of magic */
11363 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
11365 MAGIC *mgret = NULL;
11366 MAGIC **mgprev_p = &mgret;
11368 PERL_ARGS_ASSERT_MG_DUP;
11370 for (; mg; mg = mg->mg_moremagic) {
11373 if ((param->flags & CLONEf_JOIN_IN)
11374 && mg->mg_type == PERL_MAGIC_backref)
11375 /* when joining, we let the individual SVs add themselves to
11376 * backref as needed. */
11379 Newx(nmg, 1, MAGIC);
11381 mgprev_p = &(nmg->mg_moremagic);
11383 /* There was a comment "XXX copy dynamic vtable?" but as we don't have
11384 dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates
11385 from the original commit adding Perl_mg_dup() - revision 4538.
11386 Similarly there is the annotation "XXX random ptr?" next to the
11387 assignment to nmg->mg_ptr. */
11390 /* FIXME for plugins
11391 if (nmg->mg_type == PERL_MAGIC_qr) {
11392 nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param));
11396 nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED)
11397 ? nmg->mg_type == PERL_MAGIC_backref
11398 /* The backref AV has its reference
11399 * count deliberately bumped by 1 */
11400 ? SvREFCNT_inc(av_dup_inc((const AV *)
11401 nmg->mg_obj, param))
11402 : sv_dup_inc(nmg->mg_obj, param)
11403 : sv_dup(nmg->mg_obj, param);
11405 if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
11406 if (nmg->mg_len > 0) {
11407 nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len);
11408 if (nmg->mg_type == PERL_MAGIC_overload_table &&
11409 AMT_AMAGIC((AMT*)nmg->mg_ptr))
11411 AMT * const namtp = (AMT*)nmg->mg_ptr;
11412 sv_dup_inc_multiple((SV**)(namtp->table),
11413 (SV**)(namtp->table), NofAMmeth, param);
11416 else if (nmg->mg_len == HEf_SVKEY)
11417 nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param);
11419 if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) {
11420 nmg->mg_virtual->svt_dup(aTHX_ nmg, param);
11426 #endif /* USE_ITHREADS */
11428 struct ptr_tbl_arena {
11429 struct ptr_tbl_arena *next;
11430 struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers. */
11433 /* create a new pointer-mapping table */
11436 Perl_ptr_table_new(pTHX)
11439 PERL_UNUSED_CONTEXT;
11441 Newx(tbl, 1, PTR_TBL_t);
11442 tbl->tbl_max = 511;
11443 tbl->tbl_items = 0;
11444 tbl->tbl_arena = NULL;
11445 tbl->tbl_arena_next = NULL;
11446 tbl->tbl_arena_end = NULL;
11447 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
11451 #define PTR_TABLE_HASH(ptr) \
11452 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
11454 /* map an existing pointer using a table */
11456 STATIC PTR_TBL_ENT_t *
11457 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
11459 PTR_TBL_ENT_t *tblent;
11460 const UV hash = PTR_TABLE_HASH(sv);
11462 PERL_ARGS_ASSERT_PTR_TABLE_FIND;
11464 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
11465 for (; tblent; tblent = tblent->next) {
11466 if (tblent->oldval == sv)
11473 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
11475 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
11477 PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
11478 PERL_UNUSED_CONTEXT;
11480 return tblent ? tblent->newval : NULL;
11483 /* add a new entry to a pointer-mapping table */
11486 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
11488 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
11490 PERL_ARGS_ASSERT_PTR_TABLE_STORE;
11491 PERL_UNUSED_CONTEXT;
11494 tblent->newval = newsv;
11496 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
11498 if (tbl->tbl_arena_next == tbl->tbl_arena_end) {
11499 struct ptr_tbl_arena *new_arena;
11501 Newx(new_arena, 1, struct ptr_tbl_arena);
11502 new_arena->next = tbl->tbl_arena;
11503 tbl->tbl_arena = new_arena;
11504 tbl->tbl_arena_next = new_arena->array;
11505 tbl->tbl_arena_end = new_arena->array
11506 + sizeof(new_arena->array) / sizeof(new_arena->array[0]);
11509 tblent = tbl->tbl_arena_next++;
11511 tblent->oldval = oldsv;
11512 tblent->newval = newsv;
11513 tblent->next = tbl->tbl_ary[entry];
11514 tbl->tbl_ary[entry] = tblent;
11516 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
11517 ptr_table_split(tbl);
11521 /* double the hash bucket size of an existing ptr table */
11524 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
11526 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
11527 const UV oldsize = tbl->tbl_max + 1;
11528 UV newsize = oldsize * 2;
11531 PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
11532 PERL_UNUSED_CONTEXT;
11534 Renew(ary, newsize, PTR_TBL_ENT_t*);
11535 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
11536 tbl->tbl_max = --newsize;
11537 tbl->tbl_ary = ary;
11538 for (i=0; i < oldsize; i++, ary++) {
11539 PTR_TBL_ENT_t **entp = ary;
11540 PTR_TBL_ENT_t *ent = *ary;
11541 PTR_TBL_ENT_t **curentp;
11544 curentp = ary + oldsize;
11546 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
11548 ent->next = *curentp;
11558 /* remove all the entries from a ptr table */
11559 /* Deprecated - will be removed post 5.14 */
11562 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
11564 if (tbl && tbl->tbl_items) {
11565 struct ptr_tbl_arena *arena = tbl->tbl_arena;
11567 Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **);
11570 struct ptr_tbl_arena *next = arena->next;
11576 tbl->tbl_items = 0;
11577 tbl->tbl_arena = NULL;
11578 tbl->tbl_arena_next = NULL;
11579 tbl->tbl_arena_end = NULL;
11583 /* clear and free a ptr table */
11586 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
11588 struct ptr_tbl_arena *arena;
11594 arena = tbl->tbl_arena;
11597 struct ptr_tbl_arena *next = arena->next;
11603 Safefree(tbl->tbl_ary);
11607 #if defined(USE_ITHREADS)
11610 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
11612 PERL_ARGS_ASSERT_RVPV_DUP;
11615 if (SvWEAKREF(sstr)) {
11616 SvRV_set(dstr, sv_dup(SvRV_const(sstr), param));
11617 if (param->flags & CLONEf_JOIN_IN) {
11618 /* if joining, we add any back references individually rather
11619 * than copying the whole backref array */
11620 Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr);
11624 SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param));
11626 else if (SvPVX_const(sstr)) {
11627 /* Has something there */
11629 /* Normal PV - clone whole allocated space */
11630 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
11631 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
11632 /* Not that normal - actually sstr is copy on write.
11633 But we are a true, independent SV, so: */
11634 SvREADONLY_off(dstr);
11639 /* Special case - not normally malloced for some reason */
11640 if (isGV_with_GP(sstr)) {
11641 /* Don't need to do anything here. */
11643 else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
11644 /* A "shared" PV - clone it as "shared" PV */
11646 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
11650 /* Some other special case - random pointer */
11651 SvPV_set(dstr, (char *) SvPVX_const(sstr));
11656 /* Copy the NULL */
11657 SvPV_set(dstr, NULL);
11661 /* duplicate a list of SVs. source and dest may point to the same memory. */
11663 S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest,
11664 SSize_t items, CLONE_PARAMS *const param)
11666 PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE;
11668 while (items-- > 0) {
11669 *dest++ = sv_dup_inc(*source++, param);
11675 /* duplicate an SV of any type (including AV, HV etc) */
11678 S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
11683 PERL_ARGS_ASSERT_SV_DUP_COMMON;
11685 if (SvTYPE(sstr) == SVTYPEMASK) {
11686 #ifdef DEBUG_LEAKING_SCALARS_ABORT
11691 /* look for it in the table first */
11692 dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr));
11696 if(param->flags & CLONEf_JOIN_IN) {
11697 /** We are joining here so we don't want do clone
11698 something that is bad **/
11699 if (SvTYPE(sstr) == SVt_PVHV) {
11700 const HEK * const hvname = HvNAME_HEK(sstr);
11702 /** don't clone stashes if they already exist **/
11703 dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0));
11704 ptr_table_store(PL_ptr_table, sstr, dstr);
11710 /* create anew and remember what it is */
11713 #ifdef DEBUG_LEAKING_SCALARS
11714 dstr->sv_debug_optype = sstr->sv_debug_optype;
11715 dstr->sv_debug_line = sstr->sv_debug_line;
11716 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
11717 dstr->sv_debug_parent = (SV*)sstr;
11718 FREE_SV_DEBUG_FILE(dstr);
11719 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
11722 ptr_table_store(PL_ptr_table, sstr, dstr);
11725 SvFLAGS(dstr) = SvFLAGS(sstr);
11726 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
11727 SvREFCNT(dstr) = 0; /* must be before any other dups! */
11730 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
11731 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
11732 (void*)PL_watch_pvx, SvPVX_const(sstr));
11735 /* don't clone objects whose class has asked us not to */
11736 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
11741 switch (SvTYPE(sstr)) {
11743 SvANY(dstr) = NULL;
11746 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
11748 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11750 SvIV_set(dstr, SvIVX(sstr));
11754 SvANY(dstr) = new_XNV();
11755 SvNV_set(dstr, SvNVX(sstr));
11757 /* case SVt_BIND: */
11760 /* These are all the types that need complex bodies allocating. */
11762 const svtype sv_type = SvTYPE(sstr);
11763 const struct body_details *const sv_type_details
11764 = bodies_by_type + sv_type;
11768 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11783 assert(sv_type_details->body_size);
11784 if (sv_type_details->arena) {
11785 new_body_inline(new_body, sv_type);
11787 = (void*)((char*)new_body - sv_type_details->offset);
11789 new_body = new_NOARENA(sv_type_details);
11793 SvANY(dstr) = new_body;
11796 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
11797 ((char*)SvANY(dstr)) + sv_type_details->offset,
11798 sv_type_details->copy, char);
11800 Copy(((char*)SvANY(sstr)),
11801 ((char*)SvANY(dstr)),
11802 sv_type_details->body_size + sv_type_details->offset, char);
11805 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
11806 && !isGV_with_GP(dstr)
11807 && !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP)))
11808 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11810 /* The Copy above means that all the source (unduplicated) pointers
11811 are now in the destination. We can check the flags and the
11812 pointers in either, but it's possible that there's less cache
11813 missing by always going for the destination.
11814 FIXME - instrument and check that assumption */
11815 if (sv_type >= SVt_PVMG) {
11816 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
11817 SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
11818 } else if (SvMAGIC(dstr))
11819 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
11821 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
11824 /* The cast silences a GCC warning about unhandled types. */
11825 switch ((int)sv_type) {
11835 /* FIXME for plugins */
11836 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
11839 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
11840 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
11841 LvTARG(dstr) = dstr;
11842 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
11843 LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param));
11845 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
11847 /* non-GP case already handled above */
11848 if(isGV_with_GP(sstr)) {
11849 GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
11850 /* Don't call sv_add_backref here as it's going to be
11851 created as part of the magic cloning of the symbol
11852 table--unless this is during a join and the stash
11853 is not actually being cloned. */
11854 /* Danger Will Robinson - GvGP(dstr) isn't initialised
11855 at the point of this comment. */
11856 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
11857 if (param->flags & CLONEf_JOIN_IN)
11858 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
11859 GvGP_set(dstr, gp_dup(GvGP(sstr), param));
11860 (void)GpREFCNT_inc(GvGP(dstr));
11864 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
11865 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
11866 /* I have no idea why fake dirp (rsfps)
11867 should be treated differently but otherwise
11868 we end up with leaks -- sky*/
11869 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
11870 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
11871 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
11873 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
11874 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
11875 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
11876 if (IoDIRP(dstr)) {
11877 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr), param);
11880 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
11882 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(dstr), param);
11884 if (IoOFP(dstr) == IoIFP(sstr))
11885 IoOFP(dstr) = IoIFP(dstr);
11887 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
11888 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
11889 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
11890 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
11893 /* avoid cloning an empty array */
11894 if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) {
11895 SV **dst_ary, **src_ary;
11896 SSize_t items = AvFILLp((const AV *)sstr) + 1;
11898 src_ary = AvARRAY((const AV *)sstr);
11899 Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
11900 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
11901 AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
11902 AvALLOC((const AV *)dstr) = dst_ary;
11903 if (AvREAL((const AV *)sstr)) {
11904 dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items,
11908 while (items-- > 0)
11909 *dst_ary++ = sv_dup(*src_ary++, param);
11911 items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
11912 while (items-- > 0) {
11913 *dst_ary++ = &PL_sv_undef;
11917 AvARRAY(MUTABLE_AV(dstr)) = NULL;
11918 AvALLOC((const AV *)dstr) = (SV**)NULL;
11919 AvMAX( (const AV *)dstr) = -1;
11920 AvFILLp((const AV *)dstr) = -1;
11924 if (HvARRAY((const HV *)sstr)) {
11926 const bool sharekeys = !!HvSHAREKEYS(sstr);
11927 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
11928 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
11930 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
11931 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
11933 HvARRAY(dstr) = (HE**)darray;
11934 while (i <= sxhv->xhv_max) {
11935 const HE * const source = HvARRAY(sstr)[i];
11936 HvARRAY(dstr)[i] = source
11937 ? he_dup(source, sharekeys, param) : 0;
11941 const struct xpvhv_aux * const saux = HvAUX(sstr);
11942 struct xpvhv_aux * const daux = HvAUX(dstr);
11943 /* This flag isn't copied. */
11944 /* SvOOK_on(hv) attacks the IV flags. */
11945 SvFLAGS(dstr) |= SVf_OOK;
11947 if (saux->xhv_name_count) {
11948 HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
11950 = saux->xhv_name_count < 0
11951 ? -saux->xhv_name_count
11952 : saux->xhv_name_count;
11953 HEK **shekp = sname + count;
11955 Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *);
11956 dhekp = daux->xhv_name_u.xhvnameu_names + count;
11957 while (shekp-- > sname) {
11959 *dhekp = hek_dup(*shekp, param);
11963 daux->xhv_name_u.xhvnameu_name
11964 = hek_dup(saux->xhv_name_u.xhvnameu_name,
11967 daux->xhv_name_count = saux->xhv_name_count;
11969 daux->xhv_riter = saux->xhv_riter;
11970 daux->xhv_eiter = saux->xhv_eiter
11971 ? he_dup(saux->xhv_eiter,
11972 cBOOL(HvSHAREKEYS(sstr)), param) : 0;
11973 /* backref array needs refcnt=2; see sv_add_backref */
11974 daux->xhv_backreferences =
11975 (param->flags & CLONEf_JOIN_IN)
11976 /* when joining, we let the individual GVs and
11977 * CVs add themselves to backref as
11978 * needed. This avoids pulling in stuff
11979 * that isn't required, and simplifies the
11980 * case where stashes aren't cloned back
11981 * if they already exist in the parent
11984 : saux->xhv_backreferences
11985 ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV)
11986 ? MUTABLE_AV(SvREFCNT_inc(
11987 sv_dup_inc((const SV *)
11988 saux->xhv_backreferences, param)))
11989 : MUTABLE_AV(sv_dup((const SV *)
11990 saux->xhv_backreferences, param))
11993 daux->xhv_mro_meta = saux->xhv_mro_meta
11994 ? mro_meta_dup(saux->xhv_mro_meta, param)
11997 /* Record stashes for possible cloning in Perl_clone(). */
11999 av_push(param->stashes, dstr);
12003 HvARRAY(MUTABLE_HV(dstr)) = NULL;
12006 if (!(param->flags & CLONEf_COPY_STACKS)) {
12011 /* NOTE: not refcounted */
12012 SvANY(MUTABLE_CV(dstr))->xcv_stash =
12013 hv_dup(CvSTASH(dstr), param);
12014 if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
12015 Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
12016 if (!CvISXSUB(dstr)) {
12018 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
12020 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
12021 } else if (CvCONST(dstr)) {
12022 CvXSUBANY(dstr).any_ptr =
12023 sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
12025 /* don't dup if copying back - CvGV isn't refcounted, so the
12026 * duped GV may never be freed. A bit of a hack! DAPM */
12027 SvANY(MUTABLE_CV(dstr))->xcv_gv =
12029 ? gv_dup_inc(CvGV(sstr), param)
12030 : (param->flags & CLONEf_JOIN_IN)
12032 : gv_dup(CvGV(sstr), param);
12034 CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param);
12036 CvWEAKOUTSIDE(sstr)
12037 ? cv_dup( CvOUTSIDE(dstr), param)
12038 : cv_dup_inc(CvOUTSIDE(dstr), param);
12044 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
12051 Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12053 PERL_ARGS_ASSERT_SV_DUP_INC;
12054 return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL;
12058 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
12060 SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL;
12061 PERL_ARGS_ASSERT_SV_DUP;
12063 /* Track every SV that (at least initially) had a reference count of 0.
12064 We need to do this by holding an actual reference to it in this array.
12065 If we attempt to cheat, turn AvREAL_off(), and store only pointers
12066 (akin to the stashes hash, and the perl stack), we come unstuck if
12067 a weak reference (or other SV legitimately SvREFCNT() == 0 for this
12068 thread) is manipulated in a CLONE method, because CLONE runs before the
12069 unreferenced array is walked to find SVs still with SvREFCNT() == 0
12070 (and fix things up by giving each a reference via the temps stack).
12071 Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and
12072 then SvREFCNT_dec(), it will be cleaned up (and added to the free list)
12073 before the walk of unreferenced happens and a reference to that is SV
12074 added to the temps stack. At which point we have the same SV considered
12075 to be in use, and free to be re-used. Not good.
12077 if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) {
12078 assert(param->unreferenced);
12079 av_push(param->unreferenced, SvREFCNT_inc(dstr));
12085 /* duplicate a context */
12088 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
12090 PERL_CONTEXT *ncxs;
12092 PERL_ARGS_ASSERT_CX_DUP;
12095 return (PERL_CONTEXT*)NULL;
12097 /* look for it in the table first */
12098 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
12102 /* create anew and remember what it is */
12103 Newx(ncxs, max + 1, PERL_CONTEXT);
12104 ptr_table_store(PL_ptr_table, cxs, ncxs);
12105 Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
12108 PERL_CONTEXT * const ncx = &ncxs[ix];
12109 if (CxTYPE(ncx) == CXt_SUBST) {
12110 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
12113 switch (CxTYPE(ncx)) {
12115 ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
12116 ? cv_dup_inc(ncx->blk_sub.cv, param)
12117 : cv_dup(ncx->blk_sub.cv,param));
12118 ncx->blk_sub.argarray = (CxHASARGS(ncx)
12119 ? av_dup_inc(ncx->blk_sub.argarray,
12122 ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,
12124 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
12125 ncx->blk_sub.oldcomppad);
12128 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
12130 ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
12132 case CXt_LOOP_LAZYSV:
12133 ncx->blk_loop.state_u.lazysv.end
12134 = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
12135 /* We are taking advantage of av_dup_inc and sv_dup_inc
12136 actually being the same function, and order equivalence of
12138 We can assert the later [but only at run time :-(] */
12139 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
12140 (void *) &ncx->blk_loop.state_u.lazysv.cur);
12142 ncx->blk_loop.state_u.ary.ary
12143 = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
12144 case CXt_LOOP_LAZYIV:
12145 case CXt_LOOP_PLAIN:
12146 if (CxPADLOOP(ncx)) {
12147 ncx->blk_loop.itervar_u.oldcomppad
12148 = (PAD*)ptr_table_fetch(PL_ptr_table,
12149 ncx->blk_loop.itervar_u.oldcomppad);
12151 ncx->blk_loop.itervar_u.gv
12152 = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
12157 ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param);
12158 ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param);
12159 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
12172 /* duplicate a stack info structure */
12175 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
12179 PERL_ARGS_ASSERT_SI_DUP;
12182 return (PERL_SI*)NULL;
12184 /* look for it in the table first */
12185 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
12189 /* create anew and remember what it is */
12190 Newxz(nsi, 1, PERL_SI);
12191 ptr_table_store(PL_ptr_table, si, nsi);
12193 nsi->si_stack = av_dup_inc(si->si_stack, param);
12194 nsi->si_cxix = si->si_cxix;
12195 nsi->si_cxmax = si->si_cxmax;
12196 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
12197 nsi->si_type = si->si_type;
12198 nsi->si_prev = si_dup(si->si_prev, param);
12199 nsi->si_next = si_dup(si->si_next, param);
12200 nsi->si_markoff = si->si_markoff;
12205 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
12206 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
12207 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
12208 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
12209 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
12210 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
12211 #define POPUV(ss,ix) ((ss)[--(ix)].any_uv)
12212 #define TOPUV(ss,ix) ((ss)[ix].any_uv)
12213 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
12214 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
12215 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
12216 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
12217 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
12218 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
12219 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
12220 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
12223 #define pv_dup_inc(p) SAVEPV(p)
12224 #define pv_dup(p) SAVEPV(p)
12225 #define svp_dup_inc(p,pp) any_dup(p,pp)
12227 /* map any object to the new equivent - either something in the
12228 * ptr table, or something in the interpreter structure
12232 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
12236 PERL_ARGS_ASSERT_ANY_DUP;
12239 return (void*)NULL;
12241 /* look for it in the table first */
12242 ret = ptr_table_fetch(PL_ptr_table, v);
12246 /* see if it is part of the interpreter structure */
12247 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
12248 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
12256 /* duplicate the save stack */
12259 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
12262 ANY * const ss = proto_perl->Isavestack;
12263 const I32 max = proto_perl->Isavestack_max;
12264 I32 ix = proto_perl->Isavestack_ix;
12277 void (*dptr) (void*);
12278 void (*dxptr) (pTHX_ void*);
12280 PERL_ARGS_ASSERT_SS_DUP;
12282 Newxz(nss, max, ANY);
12285 const UV uv = POPUV(ss,ix);
12286 const U8 type = (U8)uv & SAVE_MASK;
12288 TOPUV(nss,ix) = uv;
12290 case SAVEt_CLEARSV:
12292 case SAVEt_HELEM: /* hash element */
12293 sv = (const SV *)POPPTR(ss,ix);
12294 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12296 case SAVEt_ITEM: /* normal string */
12297 case SAVEt_GVSV: /* scalar slot in GV */
12298 case SAVEt_SV: /* scalar reference */
12299 sv = (const SV *)POPPTR(ss,ix);
12300 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12303 case SAVEt_MORTALIZESV:
12304 sv = (const SV *)POPPTR(ss,ix);
12305 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12307 case SAVEt_SHARED_PVREF: /* char* in shared space */
12308 c = (char*)POPPTR(ss,ix);
12309 TOPPTR(nss,ix) = savesharedpv(c);
12310 ptr = POPPTR(ss,ix);
12311 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12313 case SAVEt_GENERIC_SVREF: /* generic sv */
12314 case SAVEt_SVREF: /* scalar reference */
12315 sv = (const SV *)POPPTR(ss,ix);
12316 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12317 ptr = POPPTR(ss,ix);
12318 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
12320 case SAVEt_HV: /* hash reference */
12321 case SAVEt_AV: /* array reference */
12322 sv = (const SV *) POPPTR(ss,ix);
12323 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12325 case SAVEt_COMPPAD:
12327 sv = (const SV *) POPPTR(ss,ix);
12328 TOPPTR(nss,ix) = sv_dup(sv, param);
12330 case SAVEt_INT: /* int reference */
12331 ptr = POPPTR(ss,ix);
12332 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12333 intval = (int)POPINT(ss,ix);
12334 TOPINT(nss,ix) = intval;
12336 case SAVEt_LONG: /* long reference */
12337 ptr = POPPTR(ss,ix);
12338 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12339 longval = (long)POPLONG(ss,ix);
12340 TOPLONG(nss,ix) = longval;
12342 case SAVEt_I32: /* I32 reference */
12343 case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
12344 ptr = POPPTR(ss,ix);
12345 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12347 TOPINT(nss,ix) = i;
12349 case SAVEt_IV: /* IV reference */
12350 ptr = POPPTR(ss,ix);
12351 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12353 TOPIV(nss,ix) = iv;
12355 case SAVEt_HPTR: /* HV* reference */
12356 case SAVEt_APTR: /* AV* reference */
12357 case SAVEt_SPTR: /* SV* reference */
12358 ptr = POPPTR(ss,ix);
12359 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12360 sv = (const SV *)POPPTR(ss,ix);
12361 TOPPTR(nss,ix) = sv_dup(sv, param);
12363 case SAVEt_VPTR: /* random* reference */
12364 ptr = POPPTR(ss,ix);
12365 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12367 case SAVEt_INT_SMALL:
12368 case SAVEt_I32_SMALL:
12369 case SAVEt_I16: /* I16 reference */
12370 case SAVEt_I8: /* I8 reference */
12372 ptr = POPPTR(ss,ix);
12373 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12375 case SAVEt_GENERIC_PVREF: /* generic char* */
12376 case SAVEt_PPTR: /* char* reference */
12377 ptr = POPPTR(ss,ix);
12378 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12379 c = (char*)POPPTR(ss,ix);
12380 TOPPTR(nss,ix) = pv_dup(c);
12382 case SAVEt_GP: /* scalar reference */
12383 gp = (GP*)POPPTR(ss,ix);
12384 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
12385 (void)GpREFCNT_inc(gp);
12386 gv = (const GV *)POPPTR(ss,ix);
12387 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
12390 ptr = POPPTR(ss,ix);
12391 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
12392 /* these are assumed to be refcounted properly */
12394 switch (((OP*)ptr)->op_type) {
12396 case OP_LEAVESUBLV:
12400 case OP_LEAVEWRITE:
12401 TOPPTR(nss,ix) = ptr;
12404 (void) OpREFCNT_inc(o);
12408 TOPPTR(nss,ix) = NULL;
12413 TOPPTR(nss,ix) = NULL;
12415 case SAVEt_FREECOPHH:
12416 ptr = POPPTR(ss,ix);
12417 TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr);
12420 hv = (const HV *)POPPTR(ss,ix);
12421 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
12423 TOPINT(nss,ix) = i;
12426 c = (char*)POPPTR(ss,ix);
12427 TOPPTR(nss,ix) = pv_dup_inc(c);
12429 case SAVEt_STACK_POS: /* Position on Perl stack */
12431 TOPINT(nss,ix) = i;
12433 case SAVEt_DESTRUCTOR:
12434 ptr = POPPTR(ss,ix);
12435 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
12436 dptr = POPDPTR(ss,ix);
12437 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
12438 any_dup(FPTR2DPTR(void *, dptr),
12441 case SAVEt_DESTRUCTOR_X:
12442 ptr = POPPTR(ss,ix);
12443 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
12444 dxptr = POPDXPTR(ss,ix);
12445 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
12446 any_dup(FPTR2DPTR(void *, dxptr),
12449 case SAVEt_REGCONTEXT:
12451 ix -= uv >> SAVE_TIGHT_SHIFT;
12453 case SAVEt_AELEM: /* array element */
12454 sv = (const SV *)POPPTR(ss,ix);
12455 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12457 TOPINT(nss,ix) = i;
12458 av = (const AV *)POPPTR(ss,ix);
12459 TOPPTR(nss,ix) = av_dup_inc(av, param);
12462 ptr = POPPTR(ss,ix);
12463 TOPPTR(nss,ix) = ptr;
12466 ptr = POPPTR(ss,ix);
12467 ptr = cophh_copy((COPHH*)ptr);
12468 TOPPTR(nss,ix) = ptr;
12470 TOPINT(nss,ix) = i;
12471 if (i & HINT_LOCALIZE_HH) {
12472 hv = (const HV *)POPPTR(ss,ix);
12473 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
12476 case SAVEt_PADSV_AND_MORTALIZE:
12477 longval = (long)POPLONG(ss,ix);
12478 TOPLONG(nss,ix) = longval;
12479 ptr = POPPTR(ss,ix);
12480 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
12481 sv = (const SV *)POPPTR(ss,ix);
12482 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
12484 case SAVEt_SET_SVFLAGS:
12486 TOPINT(nss,ix) = i;
12488 TOPINT(nss,ix) = i;
12489 sv = (const SV *)POPPTR(ss,ix);
12490 TOPPTR(nss,ix) = sv_dup(sv, param);
12492 case SAVEt_RE_STATE:
12494 const struct re_save_state *const old_state
12495 = (struct re_save_state *)
12496 (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
12497 struct re_save_state *const new_state
12498 = (struct re_save_state *)
12499 (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
12501 Copy(old_state, new_state, 1, struct re_save_state);
12502 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
12504 new_state->re_state_bostr
12505 = pv_dup(old_state->re_state_bostr);
12506 new_state->re_state_reginput
12507 = pv_dup(old_state->re_state_reginput);
12508 new_state->re_state_regeol
12509 = pv_dup(old_state->re_state_regeol);
12510 new_state->re_state_regoffs
12511 = (regexp_paren_pair*)
12512 any_dup(old_state->re_state_regoffs, proto_perl);
12513 new_state->re_state_reglastparen
12514 = (U32*) any_dup(old_state->re_state_reglastparen,
12516 new_state->re_state_reglastcloseparen
12517 = (U32*)any_dup(old_state->re_state_reglastcloseparen,
12519 /* XXX This just has to be broken. The old save_re_context
12520 code did SAVEGENERICPV(PL_reg_start_tmp);
12521 PL_reg_start_tmp is char **.
12522 Look above to what the dup code does for
12523 SAVEt_GENERIC_PVREF
12524 It can never have worked.
12525 So this is merely a faithful copy of the exiting bug: */
12526 new_state->re_state_reg_start_tmp
12527 = (char **) pv_dup((char *)
12528 old_state->re_state_reg_start_tmp);
12529 /* I assume that it only ever "worked" because no-one called
12530 (pseudo)fork while the regexp engine had re-entered itself.
12532 #ifdef PERL_OLD_COPY_ON_WRITE
12533 new_state->re_state_nrs
12534 = sv_dup(old_state->re_state_nrs, param);
12536 new_state->re_state_reg_magic
12537 = (MAGIC*) any_dup(old_state->re_state_reg_magic,
12539 new_state->re_state_reg_oldcurpm
12540 = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
12542 new_state->re_state_reg_curpm
12543 = (PMOP*) any_dup(old_state->re_state_reg_curpm,
12545 new_state->re_state_reg_oldsaved
12546 = pv_dup(old_state->re_state_reg_oldsaved);
12547 new_state->re_state_reg_poscache
12548 = pv_dup(old_state->re_state_reg_poscache);
12549 new_state->re_state_reg_starttry
12550 = pv_dup(old_state->re_state_reg_starttry);
12553 case SAVEt_COMPILE_WARNINGS:
12554 ptr = POPPTR(ss,ix);
12555 TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
12558 ptr = POPPTR(ss,ix);
12559 TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
12563 "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
12571 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
12572 * flag to the result. This is done for each stash before cloning starts,
12573 * so we know which stashes want their objects cloned */
12576 do_mark_cloneable_stash(pTHX_ SV *const sv)
12578 const HEK * const hvname = HvNAME_HEK((const HV *)sv);
12580 GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0);
12581 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
12582 if (cloner && GvCV(cloner)) {
12589 mXPUSHs(newSVhek(hvname));
12591 call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR);
12598 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
12606 =for apidoc perl_clone
12608 Create and return a new interpreter by cloning the current one.
12610 perl_clone takes these flags as parameters:
12612 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
12613 without it we only clone the data and zero the stacks,
12614 with it we copy the stacks and the new perl interpreter is
12615 ready to run at the exact same point as the previous one.
12616 The pseudo-fork code uses COPY_STACKS while the
12617 threads->create doesn't.
12619 CLONEf_KEEP_PTR_TABLE
12620 perl_clone keeps a ptr_table with the pointer of the old
12621 variable as a key and the new variable as a value,
12622 this allows it to check if something has been cloned and not
12623 clone it again but rather just use the value and increase the
12624 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
12625 the ptr_table using the function
12626 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
12627 reason to keep it around is if you want to dup some of your own
12628 variable who are outside the graph perl scans, example of this
12629 code is in threads.xs create
12632 This is a win32 thing, it is ignored on unix, it tells perls
12633 win32host code (which is c++) to clone itself, this is needed on
12634 win32 if you want to run two threads at the same time,
12635 if you just want to do some stuff in a separate perl interpreter
12636 and then throw it away and return to the original one,
12637 you don't need to do anything.
12642 /* XXX the above needs expanding by someone who actually understands it ! */
12643 EXTERN_C PerlInterpreter *
12644 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
12647 perl_clone(PerlInterpreter *proto_perl, UV flags)
12650 #ifdef PERL_IMPLICIT_SYS
12652 PERL_ARGS_ASSERT_PERL_CLONE;
12654 /* perlhost.h so we need to call into it
12655 to clone the host, CPerlHost should have a c interface, sky */
12657 if (flags & CLONEf_CLONE_HOST) {
12658 return perl_clone_host(proto_perl,flags);
12660 return perl_clone_using(proto_perl, flags,
12662 proto_perl->IMemShared,
12663 proto_perl->IMemParse,
12665 proto_perl->IStdIO,
12669 proto_perl->IProc);
12673 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
12674 struct IPerlMem* ipM, struct IPerlMem* ipMS,
12675 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
12676 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
12677 struct IPerlDir* ipD, struct IPerlSock* ipS,
12678 struct IPerlProc* ipP)
12680 /* XXX many of the string copies here can be optimized if they're
12681 * constants; they need to be allocated as common memory and just
12682 * their pointers copied. */
12685 CLONE_PARAMS clone_params;
12686 CLONE_PARAMS* const param = &clone_params;
12688 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
12690 PERL_ARGS_ASSERT_PERL_CLONE_USING;
12691 #else /* !PERL_IMPLICIT_SYS */
12693 CLONE_PARAMS clone_params;
12694 CLONE_PARAMS* param = &clone_params;
12695 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
12697 PERL_ARGS_ASSERT_PERL_CLONE;
12698 #endif /* PERL_IMPLICIT_SYS */
12700 /* for each stash, determine whether its objects should be cloned */
12701 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
12702 PERL_SET_THX(my_perl);
12705 PoisonNew(my_perl, 1, PerlInterpreter);
12710 PL_scopestack_name = 0;
12712 PL_savestack_ix = 0;
12713 PL_savestack_max = -1;
12714 PL_sig_pending = 0;
12716 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
12717 # ifdef DEBUG_LEAKING_SCALARS
12718 PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
12720 #else /* !DEBUGGING */
12721 Zero(my_perl, 1, PerlInterpreter);
12722 #endif /* DEBUGGING */
12724 #ifdef PERL_IMPLICIT_SYS
12725 /* host pointers */
12727 PL_MemShared = ipMS;
12728 PL_MemParse = ipMP;
12735 #endif /* PERL_IMPLICIT_SYS */
12737 param->flags = flags;
12738 /* Nothing in the core code uses this, but we make it available to
12739 extensions (using mg_dup). */
12740 param->proto_perl = proto_perl;
12741 /* Likely nothing will use this, but it is initialised to be consistent
12742 with Perl_clone_params_new(). */
12743 param->new_perl = my_perl;
12744 param->unreferenced = NULL;
12746 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
12748 PL_body_arenas = NULL;
12749 Zero(&PL_body_roots, 1, PL_body_roots);
12752 PL_sv_objcount = 0;
12754 PL_sv_arenaroot = NULL;
12756 PL_debug = proto_perl->Idebug;
12758 PL_hash_seed = proto_perl->Ihash_seed;
12759 PL_rehash_seed = proto_perl->Irehash_seed;
12761 #ifdef USE_REENTRANT_API
12762 /* XXX: things like -Dm will segfault here in perlio, but doing
12763 * PERL_SET_CONTEXT(proto_perl);
12764 * breaks too many other things
12766 Perl_reentrant_init(aTHX);
12769 /* create SV map for pointer relocation */
12770 PL_ptr_table = ptr_table_new();
12772 /* initialize these special pointers as early as possible */
12773 SvANY(&PL_sv_undef) = NULL;
12774 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
12775 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
12776 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
12778 SvANY(&PL_sv_no) = new_XPVNV();
12779 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
12780 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12781 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12782 SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
12783 SvCUR_set(&PL_sv_no, 0);
12784 SvLEN_set(&PL_sv_no, 1);
12785 SvIV_set(&PL_sv_no, 0);
12786 SvNV_set(&PL_sv_no, 0);
12787 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
12789 SvANY(&PL_sv_yes) = new_XPVNV();
12790 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
12791 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
12792 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
12793 SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
12794 SvCUR_set(&PL_sv_yes, 1);
12795 SvLEN_set(&PL_sv_yes, 2);
12796 SvIV_set(&PL_sv_yes, 1);
12797 SvNV_set(&PL_sv_yes, 1);
12798 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
12800 /* dbargs array probably holds garbage */
12803 /* create (a non-shared!) shared string table */
12804 PL_strtab = newHV();
12805 HvSHAREKEYS_off(PL_strtab);
12806 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
12807 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
12809 PL_compiling = proto_perl->Icompiling;
12811 /* These two PVs will be free'd special way so must set them same way op.c does */
12812 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
12813 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
12815 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
12816 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
12818 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
12819 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
12820 CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling)));
12821 PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
12822 #ifdef PERL_DEBUG_READONLY_OPS
12827 /* pseudo environmental stuff */
12828 PL_origargc = proto_perl->Iorigargc;
12829 PL_origargv = proto_perl->Iorigargv;
12831 param->stashes = newAV(); /* Setup array of objects to call clone on */
12832 /* This makes no difference to the implementation, as it always pushes
12833 and shifts pointers to other SVs without changing their reference
12834 count, with the array becoming empty before it is freed. However, it
12835 makes it conceptually clear what is going on, and will avoid some
12836 work inside av.c, filling slots between AvFILL() and AvMAX() with
12837 &PL_sv_undef, and SvREFCNT_dec()ing those. */
12838 AvREAL_off(param->stashes);
12840 if (!(flags & CLONEf_COPY_STACKS)) {
12841 param->unreferenced = newAV();
12844 /* Set tainting stuff before PerlIO_debug can possibly get called */
12845 PL_tainting = proto_perl->Itainting;
12846 PL_taint_warn = proto_perl->Itaint_warn;
12848 #ifdef PERLIO_LAYERS
12849 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
12850 PerlIO_clone(aTHX_ proto_perl, param);
12853 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
12854 PL_incgv = gv_dup(proto_perl->Iincgv, param);
12855 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
12856 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
12857 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
12858 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
12861 PL_minus_c = proto_perl->Iminus_c;
12862 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
12863 PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param);
12864 PL_localpatches = proto_perl->Ilocalpatches;
12865 PL_splitstr = proto_perl->Isplitstr;
12866 PL_minus_n = proto_perl->Iminus_n;
12867 PL_minus_p = proto_perl->Iminus_p;
12868 PL_minus_l = proto_perl->Iminus_l;
12869 PL_minus_a = proto_perl->Iminus_a;
12870 PL_minus_E = proto_perl->Iminus_E;
12871 PL_minus_F = proto_perl->Iminus_F;
12872 PL_doswitches = proto_perl->Idoswitches;
12873 PL_dowarn = proto_perl->Idowarn;
12874 PL_sawampersand = proto_perl->Isawampersand;
12875 PL_unsafe = proto_perl->Iunsafe;
12876 PL_inplace = SAVEPV(proto_perl->Iinplace);
12877 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
12878 PL_perldb = proto_perl->Iperldb;
12879 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
12880 PL_exit_flags = proto_perl->Iexit_flags;
12882 /* magical thingies */
12883 /* XXX time(&PL_basetime) when asked for? */
12884 PL_basetime = proto_perl->Ibasetime;
12885 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
12887 PL_maxsysfd = proto_perl->Imaxsysfd;
12888 PL_statusvalue = proto_perl->Istatusvalue;
12890 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
12892 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
12894 PL_encoding = sv_dup(proto_perl->Iencoding, param);
12896 sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
12897 sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
12898 sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
12901 /* RE engine related */
12902 Zero(&PL_reg_state, 1, struct re_save_state);
12903 PL_reginterp_cnt = 0;
12904 PL_regmatch_slab = NULL;
12906 /* Clone the regex array */
12907 /* ORANGE FIXME for plugins, probably in the SV dup code.
12908 newSViv(PTR2IV(CALLREGDUPE(
12909 INT2PTR(REGEXP *, SvIVX(regex)), param))))
12911 PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
12912 PL_regex_pad = AvARRAY(PL_regex_padav);
12914 /* shortcuts to various I/O objects */
12915 PL_ofsgv = gv_dup_inc(proto_perl->Iofsgv, param);
12916 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
12917 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
12918 PL_defgv = gv_dup(proto_perl->Idefgv, param);
12919 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
12920 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
12921 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
12923 /* shortcuts to regexp stuff */
12924 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
12926 /* shortcuts to misc objects */
12927 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
12929 /* shortcuts to debugging objects */
12930 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
12931 PL_DBline = gv_dup(proto_perl->IDBline, param);
12932 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
12933 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
12934 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
12935 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
12937 /* symbol tables */
12938 PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
12939 PL_curstash = hv_dup(proto_perl->Icurstash, param);
12940 PL_debstash = hv_dup(proto_perl->Idebstash, param);
12941 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
12942 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
12944 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
12945 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
12946 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
12947 PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
12948 PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
12949 PL_endav = av_dup_inc(proto_perl->Iendav, param);
12950 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
12951 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
12953 PL_sub_generation = proto_perl->Isub_generation;
12954 PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
12956 /* funky return mechanisms */
12957 PL_forkprocess = proto_perl->Iforkprocess;
12959 /* subprocess state */
12960 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
12962 /* internal state */
12963 PL_maxo = proto_perl->Imaxo;
12964 if (proto_perl->Iop_mask)
12965 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
12968 /* PL_asserting = proto_perl->Iasserting; */
12970 /* current interpreter roots */
12971 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
12973 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
12975 PL_main_start = proto_perl->Imain_start;
12976 PL_eval_root = proto_perl->Ieval_root;
12977 PL_eval_start = proto_perl->Ieval_start;
12979 /* runtime control stuff */
12980 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
12982 PL_filemode = proto_perl->Ifilemode;
12983 PL_lastfd = proto_perl->Ilastfd;
12984 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
12987 PL_gensym = proto_perl->Igensym;
12988 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
12989 PL_laststatval = proto_perl->Ilaststatval;
12990 PL_laststype = proto_perl->Ilaststype;
12993 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
12995 /* interpreter atexit processing */
12996 PL_exitlistlen = proto_perl->Iexitlistlen;
12997 if (PL_exitlistlen) {
12998 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12999 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
13002 PL_exitlist = (PerlExitListEntry*)NULL;
13004 PL_my_cxt_size = proto_perl->Imy_cxt_size;
13005 if (PL_my_cxt_size) {
13006 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
13007 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
13008 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
13009 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
13010 Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
13014 PL_my_cxt_list = (void**)NULL;
13015 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
13016 PL_my_cxt_keys = (const char**)NULL;
13019 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
13020 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
13021 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
13022 PL_custom_ops = hv_dup_inc(proto_perl->Icustom_ops, param);
13024 PL_profiledata = NULL;
13026 PL_compcv = cv_dup(proto_perl->Icompcv, param);
13028 PAD_CLONE_VARS(proto_perl, param);
13030 #ifdef HAVE_INTERP_INTERN
13031 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
13034 /* more statics moved here */
13035 PL_generation = proto_perl->Igeneration;
13036 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
13038 PL_in_clean_objs = proto_perl->Iin_clean_objs;
13039 PL_in_clean_all = proto_perl->Iin_clean_all;
13041 PL_uid = proto_perl->Iuid;
13042 PL_euid = proto_perl->Ieuid;
13043 PL_gid = proto_perl->Igid;
13044 PL_egid = proto_perl->Iegid;
13045 PL_nomemok = proto_perl->Inomemok;
13046 PL_an = proto_perl->Ian;
13047 PL_evalseq = proto_perl->Ievalseq;
13048 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
13049 PL_origalen = proto_perl->Iorigalen;
13050 #ifdef PERL_USES_PL_PIDSTATUS
13051 PL_pidstatus = newHV(); /* XXX flag for cloning? */
13053 PL_osname = SAVEPV(proto_perl->Iosname);
13054 PL_sighandlerp = proto_perl->Isighandlerp;
13056 PL_runops = proto_perl->Irunops;
13058 PL_parser = parser_dup(proto_perl->Iparser, param);
13060 /* XXX this only works if the saved cop has already been cloned */
13061 if (proto_perl->Iparser) {
13062 PL_parser->saved_curcop = (COP*)any_dup(
13063 proto_perl->Iparser->saved_curcop,
13067 PL_subline = proto_perl->Isubline;
13068 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
13071 PL_cryptseen = proto_perl->Icryptseen;
13074 PL_hints = proto_perl->Ihints;
13076 PL_amagic_generation = proto_perl->Iamagic_generation;
13078 #ifdef USE_LOCALE_COLLATE
13079 PL_collation_ix = proto_perl->Icollation_ix;
13080 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
13081 PL_collation_standard = proto_perl->Icollation_standard;
13082 PL_collxfrm_base = proto_perl->Icollxfrm_base;
13083 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
13084 #endif /* USE_LOCALE_COLLATE */
13086 #ifdef USE_LOCALE_NUMERIC
13087 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
13088 PL_numeric_standard = proto_perl->Inumeric_standard;
13089 PL_numeric_local = proto_perl->Inumeric_local;
13090 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
13091 #endif /* !USE_LOCALE_NUMERIC */
13093 /* utf8 character classes */
13094 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
13095 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
13096 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
13097 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
13098 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
13099 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
13100 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
13101 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
13102 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
13103 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
13104 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
13105 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
13106 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
13107 PL_utf8_X_begin = sv_dup_inc(proto_perl->Iutf8_X_begin, param);
13108 PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
13109 PL_utf8_X_prepend = sv_dup_inc(proto_perl->Iutf8_X_prepend, param);
13110 PL_utf8_X_non_hangul = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param);
13111 PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param);
13112 PL_utf8_X_LV = sv_dup_inc(proto_perl->Iutf8_X_LV, param);
13113 PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param);
13114 PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param);
13115 PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param);
13116 PL_utf8_X_LV_LVT_V = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, param);
13117 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
13118 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
13119 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
13120 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
13121 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
13122 PL_utf8_xidstart = sv_dup_inc(proto_perl->Iutf8_xidstart, param);
13123 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
13124 PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param);
13125 PL_utf8_foldable = hv_dup_inc(proto_perl->Iutf8_foldable, param);
13127 /* Did the locale setup indicate UTF-8? */
13128 PL_utf8locale = proto_perl->Iutf8locale;
13129 /* Unicode features (see perlrun/-C) */
13130 PL_unicode = proto_perl->Iunicode;
13132 /* Pre-5.8 signals control */
13133 PL_signals = proto_perl->Isignals;
13135 /* times() ticks per second */
13136 PL_clocktick = proto_perl->Iclocktick;
13138 /* Recursion stopper for PerlIO_find_layer */
13139 PL_in_load_module = proto_perl->Iin_load_module;
13141 /* sort() routine */
13142 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
13144 /* Not really needed/useful since the reenrant_retint is "volatile",
13145 * but do it for consistency's sake. */
13146 PL_reentrant_retint = proto_perl->Ireentrant_retint;
13148 /* Hooks to shared SVs and locks. */
13149 PL_sharehook = proto_perl->Isharehook;
13150 PL_lockhook = proto_perl->Ilockhook;
13151 PL_unlockhook = proto_perl->Iunlockhook;
13152 PL_threadhook = proto_perl->Ithreadhook;
13153 PL_destroyhook = proto_perl->Idestroyhook;
13154 PL_signalhook = proto_perl->Isignalhook;
13156 #ifdef THREADS_HAVE_PIDS
13157 PL_ppid = proto_perl->Ippid;
13161 PL_last_swash_hv = NULL; /* reinits on demand */
13162 PL_last_swash_klen = 0;
13163 PL_last_swash_key[0]= '\0';
13164 PL_last_swash_tmps = (U8*)NULL;
13165 PL_last_swash_slen = 0;
13167 PL_glob_index = proto_perl->Iglob_index;
13168 PL_srand_called = proto_perl->Isrand_called;
13170 if (proto_perl->Ipsig_pend) {
13171 Newxz(PL_psig_pend, SIG_SIZE, int);
13174 PL_psig_pend = (int*)NULL;
13177 if (proto_perl->Ipsig_name) {
13178 Newx(PL_psig_name, 2 * SIG_SIZE, SV*);
13179 sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE,
13181 PL_psig_ptr = PL_psig_name + SIG_SIZE;
13184 PL_psig_ptr = (SV**)NULL;
13185 PL_psig_name = (SV**)NULL;
13188 /* intrpvar.h stuff */
13190 if (flags & CLONEf_COPY_STACKS) {
13191 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
13192 PL_tmps_ix = proto_perl->Itmps_ix;
13193 PL_tmps_max = proto_perl->Itmps_max;
13194 PL_tmps_floor = proto_perl->Itmps_floor;
13195 Newx(PL_tmps_stack, PL_tmps_max, SV*);
13196 sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack,
13197 PL_tmps_ix+1, param);
13199 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
13200 i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
13201 Newxz(PL_markstack, i, I32);
13202 PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
13203 - proto_perl->Imarkstack);
13204 PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
13205 - proto_perl->Imarkstack);
13206 Copy(proto_perl->Imarkstack, PL_markstack,
13207 PL_markstack_ptr - PL_markstack + 1, I32);
13209 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
13210 * NOTE: unlike the others! */
13211 PL_scopestack_ix = proto_perl->Iscopestack_ix;
13212 PL_scopestack_max = proto_perl->Iscopestack_max;
13213 Newxz(PL_scopestack, PL_scopestack_max, I32);
13214 Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
13217 Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
13218 Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
13220 /* NOTE: si_dup() looks at PL_markstack */
13221 PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
13223 /* PL_curstack = PL_curstackinfo->si_stack; */
13224 PL_curstack = av_dup(proto_perl->Icurstack, param);
13225 PL_mainstack = av_dup(proto_perl->Imainstack, param);
13227 /* next PUSHs() etc. set *(PL_stack_sp+1) */
13228 PL_stack_base = AvARRAY(PL_curstack);
13229 PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp
13230 - proto_perl->Istack_base);
13231 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
13233 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
13234 * NOTE: unlike the others! */
13235 PL_savestack_ix = proto_perl->Isavestack_ix;
13236 PL_savestack_max = proto_perl->Isavestack_max;
13237 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
13238 PL_savestack = ss_dup(proto_perl, param);
13242 ENTER; /* perl_destruct() wants to LEAVE; */
13245 PL_start_env = proto_perl->Istart_env; /* XXXXXX */
13246 PL_top_env = &PL_start_env;
13248 PL_op = proto_perl->Iop;
13251 PL_Xpv = (XPV*)NULL;
13252 my_perl->Ina = proto_perl->Ina;
13254 PL_statbuf = proto_perl->Istatbuf;
13255 PL_statcache = proto_perl->Istatcache;
13256 PL_statgv = gv_dup(proto_perl->Istatgv, param);
13257 PL_statname = sv_dup_inc(proto_perl->Istatname, param);
13259 PL_timesbuf = proto_perl->Itimesbuf;
13262 PL_tainted = proto_perl->Itainted;
13263 PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
13264 PL_rs = sv_dup_inc(proto_perl->Irs, param);
13265 PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
13266 PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
13267 PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
13268 PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
13269 PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
13270 PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
13272 PL_restartjmpenv = proto_perl->Irestartjmpenv;
13273 PL_restartop = proto_perl->Irestartop;
13274 PL_in_eval = proto_perl->Iin_eval;
13275 PL_delaymagic = proto_perl->Idelaymagic;
13276 PL_phase = proto_perl->Iphase;
13277 PL_localizing = proto_perl->Ilocalizing;
13279 PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
13280 PL_hv_fetch_ent_mh = NULL;
13281 PL_modcount = proto_perl->Imodcount;
13282 PL_lastgotoprobe = NULL;
13283 PL_dumpindent = proto_perl->Idumpindent;
13285 PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
13286 PL_sortstash = hv_dup(proto_perl->Isortstash, param);
13287 PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
13288 PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
13289 PL_efloatbuf = NULL; /* reinits on demand */
13290 PL_efloatsize = 0; /* reinits on demand */
13294 PL_screamfirst = NULL;
13295 PL_screamnext = NULL;
13296 PL_maxscream = -1; /* reinits on demand */
13297 PL_lastscream = NULL;
13300 PL_regdummy = proto_perl->Iregdummy;
13301 PL_colorset = 0; /* reinits PL_colors[] */
13302 /*PL_colors[6] = {0,0,0,0,0,0};*/
13306 /* Pluggable optimizer */
13307 PL_peepp = proto_perl->Ipeepp;
13308 PL_rpeepp = proto_perl->Irpeepp;
13309 /* op_free() hook */
13310 PL_opfreehook = proto_perl->Iopfreehook;
13312 PL_stashcache = newHV();
13314 PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
13315 proto_perl->Iwatchaddr);
13316 PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
13317 if (PL_debug && PL_watchaddr) {
13318 PerlIO_printf(Perl_debug_log,
13319 "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
13320 PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
13321 PTR2UV(PL_watchok));
13324 PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param);
13325 PL_blockhooks = av_dup_inc(proto_perl->Iblockhooks, param);
13326 PL_utf8_foldclosures = hv_dup_inc(proto_perl->Iutf8_foldclosures, param);
13328 /* Call the ->CLONE method, if it exists, for each of the stashes
13329 identified by sv_dup() above.
13331 while(av_len(param->stashes) != -1) {
13332 HV* const stash = MUTABLE_HV(av_shift(param->stashes));
13333 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
13334 if (cloner && GvCV(cloner)) {
13339 mXPUSHs(newSVhek(HvNAME_HEK(stash)));
13341 call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD);
13347 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
13348 ptr_table_free(PL_ptr_table);
13349 PL_ptr_table = NULL;
13352 if (!(flags & CLONEf_COPY_STACKS)) {
13353 unreferenced_to_tmp_stack(param->unreferenced);
13356 SvREFCNT_dec(param->stashes);
13358 /* orphaned? eg threads->new inside BEGIN or use */
13359 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
13360 SvREFCNT_inc_simple_void(PL_compcv);
13361 SAVEFREESV(PL_compcv);
13368 S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced)
13370 PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK;
13372 if (AvFILLp(unreferenced) > -1) {
13373 SV **svp = AvARRAY(unreferenced);
13374 SV **const last = svp + AvFILLp(unreferenced);
13378 if (SvREFCNT(*svp) == 1)
13380 } while (++svp <= last);
13382 EXTEND_MORTAL(count);
13383 svp = AvARRAY(unreferenced);
13386 if (SvREFCNT(*svp) == 1) {
13387 /* Our reference is the only one to this SV. This means that
13388 in this thread, the scalar effectively has a 0 reference.
13389 That doesn't work (cleanup never happens), so donate our
13390 reference to it onto the save stack. */
13391 PL_tmps_stack[++PL_tmps_ix] = *svp;
13393 /* As an optimisation, because we are already walking the
13394 entire array, instead of above doing either
13395 SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead
13396 release our reference to the scalar, so that at the end of
13397 the array owns zero references to the scalars it happens to
13398 point to. We are effectively converting the array from
13399 AvREAL() on to AvREAL() off. This saves the av_clear()
13400 (triggered by the SvREFCNT_dec(unreferenced) below) from
13401 walking the array a second time. */
13402 SvREFCNT_dec(*svp);
13405 } while (++svp <= last);
13406 AvREAL_off(unreferenced);
13408 SvREFCNT_dec(unreferenced);
13412 Perl_clone_params_del(CLONE_PARAMS *param)
13414 /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT
13416 PerlInterpreter *const to = param->new_perl;
13418 PerlInterpreter *const was = PERL_GET_THX;
13420 PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
13426 SvREFCNT_dec(param->stashes);
13427 if (param->unreferenced)
13428 unreferenced_to_tmp_stack(param->unreferenced);
13438 Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
13441 /* Need to play this game, as newAV() can call safesysmalloc(), and that
13442 does a dTHX; to get the context from thread local storage.
13443 FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
13444 a version that passes in my_perl. */
13445 PerlInterpreter *const was = PERL_GET_THX;
13446 CLONE_PARAMS *param;
13448 PERL_ARGS_ASSERT_CLONE_PARAMS_NEW;
13454 /* Given that we've set the context, we can do this unshared. */
13455 Newx(param, 1, CLONE_PARAMS);
13458 param->proto_perl = from;
13459 param->new_perl = to;
13460 param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV);
13461 AvREAL_off(param->stashes);
13462 param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV);
13470 #endif /* USE_ITHREADS */
13473 =head1 Unicode Support
13475 =for apidoc sv_recode_to_utf8
13477 The encoding is assumed to be an Encode object, on entry the PV
13478 of the sv is assumed to be octets in that encoding, and the sv
13479 will be converted into Unicode (and UTF-8).
13481 If the sv already is UTF-8 (or if it is not POK), or if the encoding
13482 is not a reference, nothing is done to the sv. If the encoding is not
13483 an C<Encode::XS> Encoding object, bad things will happen.
13484 (See F<lib/encoding.pm> and L<Encode>).
13486 The PV of the sv is returned.
13491 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
13495 PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
13497 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
13511 Passing sv_yes is wrong - it needs to be or'ed set of constants
13512 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
13513 remove converted chars from source.
13515 Both will default the value - let them.
13517 XPUSHs(&PL_sv_yes);
13520 call_method("decode", G_SCALAR);
13524 s = SvPV_const(uni, len);
13525 if (s != SvPVX_const(sv)) {
13526 SvGROW(sv, len + 1);
13527 Move(s, SvPVX(sv), len + 1, char);
13528 SvCUR_set(sv, len);
13535 return SvPOKp(sv) ? SvPVX(sv) : NULL;
13539 =for apidoc sv_cat_decode
13541 The encoding is assumed to be an Encode object, the PV of the ssv is
13542 assumed to be octets in that encoding and decoding the input starts
13543 from the position which (PV + *offset) pointed to. The dsv will be
13544 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
13545 when the string tstr appears in decoding output or the input ends on
13546 the PV of the ssv. The value which the offset points will be modified
13547 to the last input position on the ssv.
13549 Returns TRUE if the terminator was found, else returns FALSE.
13554 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
13555 SV *ssv, int *offset, char *tstr, int tlen)
13560 PERL_ARGS_ASSERT_SV_CAT_DECODE;
13562 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
13573 offsv = newSViv(*offset);
13575 mXPUSHp(tstr, tlen);
13577 call_method("cat_decode", G_SCALAR);
13579 ret = SvTRUE(TOPs);
13580 *offset = SvIV(offsv);
13586 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
13591 /* ---------------------------------------------------------------------
13593 * support functions for report_uninit()
13596 /* the maxiumum size of array or hash where we will scan looking
13597 * for the undefined element that triggered the warning */
13599 #define FUV_MAX_SEARCH_SIZE 1000
13601 /* Look for an entry in the hash whose value has the same SV as val;
13602 * If so, return a mortal copy of the key. */
13605 S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
13608 register HE **array;
13611 PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
13613 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
13614 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
13617 array = HvARRAY(hv);
13619 for (i=HvMAX(hv); i>0; i--) {
13620 register HE *entry;
13621 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
13622 if (HeVAL(entry) != val)
13624 if ( HeVAL(entry) == &PL_sv_undef ||
13625 HeVAL(entry) == &PL_sv_placeholder)
13629 if (HeKLEN(entry) == HEf_SVKEY)
13630 return sv_mortalcopy(HeKEY_sv(entry));
13631 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
13637 /* Look for an entry in the array whose value has the same SV as val;
13638 * If so, return the index, otherwise return -1. */
13641 S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
13645 PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
13647 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
13648 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
13651 if (val != &PL_sv_undef) {
13652 SV ** const svp = AvARRAY(av);
13655 for (i=AvFILLp(av); i>=0; i--)
13662 /* S_varname(): return the name of a variable, optionally with a subscript.
13663 * If gv is non-zero, use the name of that global, along with gvtype (one
13664 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
13665 * targ. Depending on the value of the subscript_type flag, return:
13668 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
13669 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
13670 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
13671 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
13674 S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
13675 const SV *const keyname, I32 aindex, int subscript_type)
13678 SV * const name = sv_newmortal();
13681 buffer[0] = gvtype;
13684 /* as gv_fullname4(), but add literal '^' for $^FOO names */
13686 gv_fullname4(name, gv, buffer, 0);
13688 if ((unsigned int)SvPVX(name)[1] <= 26) {
13690 buffer[1] = SvPVX(name)[1] + 'A' - 1;
13692 /* Swap the 1 unprintable control character for the 2 byte pretty
13693 version - ie substr($name, 1, 1) = $buffer; */
13694 sv_insert(name, 1, 1, buffer, 2);
13698 CV * const cv = find_runcv(NULL);
13702 if (!cv || !CvPADLIST(cv))
13704 av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
13705 sv = *av_fetch(av, targ, FALSE);
13706 sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
13709 if (subscript_type == FUV_SUBSCRIPT_HASH) {
13710 SV * const sv = newSV(0);
13711 *SvPVX(name) = '$';
13712 Perl_sv_catpvf(aTHX_ name, "{%s}",
13713 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
13716 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
13717 *SvPVX(name) = '$';
13718 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
13720 else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
13721 /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
13722 Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
13730 =for apidoc find_uninit_var
13732 Find the name of the undefined variable (if any) that caused the operator o
13733 to issue a "Use of uninitialized value" warning.
13734 If match is true, only return a name if it's value matches uninit_sv.
13735 So roughly speaking, if a unary operator (such as OP_COS) generates a
13736 warning, then following the direct child of the op may yield an
13737 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
13738 other hand, with OP_ADD there are two branches to follow, so we only print
13739 the variable name if we get an exact match.
13741 The name is returned as a mortal SV.
13743 Assumes that PL_op is the op that originally triggered the error, and that
13744 PL_comppad/PL_curpad points to the currently executing pad.
13750 S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
13756 const OP *o, *o2, *kid;
13758 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
13759 uninit_sv == &PL_sv_placeholder)))
13762 switch (obase->op_type) {
13769 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
13770 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
13773 int subscript_type = FUV_SUBSCRIPT_WITHIN;
13775 if (pad) { /* @lex, %lex */
13776 sv = PAD_SVl(obase->op_targ);
13780 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
13781 /* @global, %global */
13782 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
13785 sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv));
13787 else /* @{expr}, %{expr} */
13788 return find_uninit_var(cUNOPx(obase)->op_first,
13792 /* attempt to find a match within the aggregate */
13794 keysv = find_hash_subscript((const HV*)sv, uninit_sv);
13796 subscript_type = FUV_SUBSCRIPT_HASH;
13799 index = find_array_subscript((const AV *)sv, uninit_sv);
13801 subscript_type = FUV_SUBSCRIPT_ARRAY;
13804 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
13807 return varname(gv, hash ? '%' : '@', obase->op_targ,
13808 keysv, index, subscript_type);
13812 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
13814 return varname(NULL, '$', obase->op_targ,
13815 NULL, 0, FUV_SUBSCRIPT_NONE);
13818 gv = cGVOPx_gv(obase);
13819 if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv))
13821 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
13824 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
13827 AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
13828 if (!av || SvRMAGICAL(av))
13830 svp = av_fetch(av, (I32)obase->op_private, FALSE);
13831 if (!svp || *svp != uninit_sv)
13834 return varname(NULL, '$', obase->op_targ,
13835 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
13838 gv = cGVOPx_gv(obase);
13843 AV *const av = GvAV(gv);
13844 if (!av || SvRMAGICAL(av))
13846 svp = av_fetch(av, (I32)obase->op_private, FALSE);
13847 if (!svp || *svp != uninit_sv)
13850 return varname(gv, '$', 0,
13851 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
13856 o = cUNOPx(obase)->op_first;
13857 if (!o || o->op_type != OP_NULL ||
13858 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
13860 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
13864 if (PL_op == obase)
13865 /* $a[uninit_expr] or $h{uninit_expr} */
13866 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
13869 o = cBINOPx(obase)->op_first;
13870 kid = cBINOPx(obase)->op_last;
13872 /* get the av or hv, and optionally the gv */
13874 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
13875 sv = PAD_SV(o->op_targ);
13877 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
13878 && cUNOPo->op_first->op_type == OP_GV)
13880 gv = cGVOPx_gv(cUNOPo->op_first);
13884 == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv));
13889 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
13890 /* index is constant */
13894 if (obase->op_type == OP_HELEM) {
13895 HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0);
13896 if (!he || HeVAL(he) != uninit_sv)
13900 SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE);
13901 if (!svp || *svp != uninit_sv)
13905 if (obase->op_type == OP_HELEM)
13906 return varname(gv, '%', o->op_targ,
13907 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
13909 return varname(gv, '@', o->op_targ, NULL,
13910 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
13913 /* index is an expression;
13914 * attempt to find a match within the aggregate */
13915 if (obase->op_type == OP_HELEM) {
13916 SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
13918 return varname(gv, '%', o->op_targ,
13919 keysv, 0, FUV_SUBSCRIPT_HASH);
13923 = find_array_subscript((const AV *)sv, uninit_sv);
13925 return varname(gv, '@', o->op_targ,
13926 NULL, index, FUV_SUBSCRIPT_ARRAY);
13931 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
13933 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
13938 /* only examine RHS */
13939 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
13942 o = cUNOPx(obase)->op_first;
13943 if (o->op_type == OP_PUSHMARK)
13946 if (!o->op_sibling) {
13947 /* one-arg version of open is highly magical */
13949 if (o->op_type == OP_GV) { /* open FOO; */
13951 if (match && GvSV(gv) != uninit_sv)
13953 return varname(gv, '$', 0,
13954 NULL, 0, FUV_SUBSCRIPT_NONE);
13956 /* other possibilities not handled are:
13957 * open $x; or open my $x; should return '${*$x}'
13958 * open expr; should return '$'.expr ideally
13964 /* ops where $_ may be an implicit arg */
13968 if ( !(obase->op_flags & OPf_STACKED)) {
13969 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
13970 ? PAD_SVl(obase->op_targ)
13973 sv = sv_newmortal();
13974 sv_setpvs(sv, "$_");
13983 match = 1; /* print etc can return undef on defined args */
13984 /* skip filehandle as it can't produce 'undef' warning */
13985 o = cUNOPx(obase)->op_first;
13986 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
13987 o = o->op_sibling->op_sibling;
13991 case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
13993 case OP_CUSTOM: /* XS or custom code could trigger random warnings */
13995 /* the following ops are capable of returning PL_sv_undef even for
13996 * defined arg(s) */
14015 case OP_GETPEERNAME:
14063 case OP_SMARTMATCH:
14072 /* XXX tmp hack: these two may call an XS sub, and currently
14073 XS subs don't have a SUB entry on the context stack, so CV and
14074 pad determination goes wrong, and BAD things happen. So, just
14075 don't try to determine the value under those circumstances.
14076 Need a better fix at dome point. DAPM 11/2007 */
14082 GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV);
14083 if (gv && GvSV(gv) == uninit_sv)
14084 return newSVpvs_flags("$.", SVs_TEMP);
14089 /* def-ness of rval pos() is independent of the def-ness of its arg */
14090 if ( !(obase->op_flags & OPf_MOD))
14095 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
14096 return newSVpvs_flags("${$/}", SVs_TEMP);
14101 if (!(obase->op_flags & OPf_KIDS))
14103 o = cUNOPx(obase)->op_first;
14109 /* if all except one arg are constant, or have no side-effects,
14110 * or are optimized away, then it's unambiguous */
14112 for (kid=o; kid; kid = kid->op_sibling) {
14114 const OPCODE type = kid->op_type;
14115 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
14116 || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
14117 || (type == OP_PUSHMARK)
14119 /* @$a and %$a, but not @a or %a */
14120 (type == OP_RV2AV || type == OP_RV2HV)
14121 && cUNOPx(kid)->op_first
14122 && cUNOPx(kid)->op_first->op_type != OP_GV
14127 if (o2) { /* more than one found */
14134 return find_uninit_var(o2, uninit_sv, match);
14136 /* scan all args */
14138 sv = find_uninit_var(o, uninit_sv, 1);
14150 =for apidoc report_uninit
14152 Print appropriate "Use of uninitialized variable" warning
14158 Perl_report_uninit(pTHX_ const SV *uninit_sv)
14162 SV* varname = NULL;
14164 varname = find_uninit_var(PL_op, uninit_sv,0);
14166 sv_insert(varname, 0, 0, " ", 1);
14168 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
14169 varname ? SvPV_nolen_const(varname) : "",
14170 " in ", OP_DESC(PL_op));
14173 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
14179 * c-indentation-style: bsd
14180 * c-basic-offset: 4
14181 * indent-tabs-mode: t
14184 * ex: set ts=8 sts=4 sw=4 noet: