3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
9 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
12 * This file contains the code that creates, manipulates and destroys
13 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
14 * structure of an SV, so their creation and destruction is handled
15 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
16 * level functions (eg. substr, split, join) for each of the types are
28 /* Missing proto on LynxOS */
29 char *gconvert(double, int, int, char *);
32 #ifdef PERL_UTF8_CACHE_ASSERT
33 /* The cache element 0 is the Unicode offset;
34 * the cache element 1 is the byte offset of the element 0;
35 * the cache element 2 is the Unicode length of the substring;
36 * the cache element 3 is the byte length of the substring;
37 * The checking of the substring side would be good
38 * but substr() has enough code paths to make my head spin;
39 * if adding more checks watch out for the following tests:
40 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
41 * lib/utf8.t lib/Unicode/Collate/t/index.t
44 #define ASSERT_UTF8_CACHE(cache) \
45 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
47 #define ASSERT_UTF8_CACHE(cache) NOOP
50 #ifdef PERL_OLD_COPY_ON_WRITE
51 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
52 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
53 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
57 /* ============================================================================
59 =head1 Allocation and deallocation of SVs.
61 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
62 sv, av, hv...) contains type and reference count information, and for
63 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
64 contains fields specific to each type. Some types store all they need
65 in the head, so don't have a body.
67 In all but the most memory-paranoid configuations (ex: PURIFY), heads
68 and bodies are allocated out of arenas, which by default are
69 approximately 4K chunks of memory parcelled up into N heads or bodies.
70 Sv-bodies are allocated by their sv-type, guaranteeing size
71 consistency needed to allocate safely from arrays.
73 For SV-heads, the first slot in each arena is reserved, and holds a
74 link to the next arena, some flags, and a note of the number of slots.
75 Snaked through each arena chain is a linked list of free items; when
76 this becomes empty, an extra arena is allocated and divided up into N
77 items which are threaded into the free list.
79 SV-bodies are similar, but they use arena-sets by default, which
80 separate the link and info from the arena itself, and reclaim the 1st
81 slot in the arena. SV-bodies are further described later.
83 The following global variables are associated with arenas:
85 PL_sv_arenaroot pointer to list of SV arenas
86 PL_sv_root pointer to list of free SV structures
88 PL_body_arenas head of linked-list of body arenas
89 PL_body_roots[] array of pointers to list of free bodies of svtype
90 arrays are indexed by the svtype needed
92 A few special SV heads are not allocated from an arena, but are
93 instead directly created in the interpreter structure, eg PL_sv_undef.
94 The size of arenas can be changed from the default by setting
95 PERL_ARENA_SIZE appropriately at compile time.
97 The SV arena serves the secondary purpose of allowing still-live SVs
98 to be located and destroyed during final cleanup.
100 At the lowest level, the macros new_SV() and del_SV() grab and free
101 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
102 to return the SV to the free list with error checking.) new_SV() calls
103 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
104 SVs in the free list have their SvTYPE field set to all ones.
106 At the time of very final cleanup, sv_free_arenas() is called from
107 perl_destruct() to physically free all the arenas allocated since the
108 start of the interpreter.
110 Manipulation of any of the PL_*root pointers is protected by enclosing
111 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
112 if threads are enabled.
114 The function visit() scans the SV arenas list, and calls a specified
115 function for each SV it finds which is still live - ie which has an SvTYPE
116 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
117 following functions (specified as [function that calls visit()] / [function
118 called by visit() for each SV]):
120 sv_report_used() / do_report_used()
121 dump all remaining SVs (debugging aid)
123 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
124 Attempt to free all objects pointed to by RVs,
125 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
126 try to do the same for all objects indirectly
127 referenced by typeglobs too. Called once from
128 perl_destruct(), prior to calling sv_clean_all()
131 sv_clean_all() / do_clean_all()
132 SvREFCNT_dec(sv) each remaining SV, possibly
133 triggering an sv_free(). It also sets the
134 SVf_BREAK flag on the SV to indicate that the
135 refcnt has been artificially lowered, and thus
136 stopping sv_free() from giving spurious warnings
137 about SVs which unexpectedly have a refcnt
138 of zero. called repeatedly from perl_destruct()
139 until there are no SVs left.
141 =head2 Arena allocator API Summary
143 Private API to rest of sv.c
147 new_XIV(), del_XIV(),
148 new_XNV(), del_XNV(),
153 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
157 ============================================================================ */
160 * "A time to plant, and a time to uproot what was planted..."
164 * nice_chunk and nice_chunk size need to be set
165 * and queried under the protection of sv_mutex
168 Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
174 new_chunk = (void *)(chunk);
175 new_chunk_size = (chunk_size);
176 if (new_chunk_size > PL_nice_chunk_size) {
177 Safefree(PL_nice_chunk);
178 PL_nice_chunk = (char *) new_chunk;
179 PL_nice_chunk_size = new_chunk_size;
186 #ifdef DEBUG_LEAKING_SCALARS
187 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
189 # define FREE_SV_DEBUG_FILE(sv)
193 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
194 /* Whilst I'd love to do this, it seems that things like to check on
196 # define POSION_SV_HEAD(sv) Poison(sv, 1, struct STRUCT_SV)
198 # define POSION_SV_HEAD(sv) Poison(&SvANY(sv), 1, void *), \
199 Poison(&SvREFCNT(sv), 1, U32)
201 # define SvARENA_CHAIN(sv) SvANY(sv)
202 # define POSION_SV_HEAD(sv)
205 #define plant_SV(p) \
207 FREE_SV_DEBUG_FILE(p); \
209 SvARENA_CHAIN(p) = (void *)PL_sv_root; \
210 SvFLAGS(p) = SVTYPEMASK; \
215 /* sv_mutex must be held while calling uproot_SV() */
216 #define uproot_SV(p) \
219 PL_sv_root = (SV*)SvARENA_CHAIN(p); \
224 /* make some more SVs by adding another arena */
226 /* sv_mutex must be held while calling more_sv() */
234 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
235 PL_nice_chunk = NULL;
236 PL_nice_chunk_size = 0;
239 char *chunk; /* must use New here to match call to */
240 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
241 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
247 /* new_SV(): return a new, empty SV head */
249 #ifdef DEBUG_LEAKING_SCALARS
250 /* provide a real function for a debugger to play with */
260 sv = S_more_sv(aTHX);
265 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
266 sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
267 (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
268 sv->sv_debug_inpad = 0;
269 sv->sv_debug_cloned = 0;
270 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
274 # define new_SV(p) (p)=S_new_SV(aTHX)
283 (p) = S_more_sv(aTHX); \
292 /* del_SV(): return an empty SV head to the free list */
307 S_del_sv(pTHX_ SV *p)
313 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
314 const SV * const sv = sva + 1;
315 const SV * const svend = &sva[SvREFCNT(sva)];
316 if (p >= sv && p < svend) {
322 if (ckWARN_d(WARN_INTERNAL))
323 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
324 "Attempt to free non-arena SV: 0x%"UVxf
325 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
332 #else /* ! DEBUGGING */
334 #define del_SV(p) plant_SV(p)
336 #endif /* DEBUGGING */
340 =head1 SV Manipulation Functions
342 =for apidoc sv_add_arena
344 Given a chunk of memory, link it to the head of the list of arenas,
345 and split it into a list of free SVs.
351 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
354 SV* const sva = (SV*)ptr;
358 /* The first SV in an arena isn't an SV. */
359 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
360 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
361 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
363 PL_sv_arenaroot = sva;
364 PL_sv_root = sva + 1;
366 svend = &sva[SvREFCNT(sva) - 1];
369 SvARENA_CHAIN(sv) = (void *)(SV*)(sv + 1);
373 /* Must always set typemask because it's awlays checked in on cleanup
374 when the arenas are walked looking for objects. */
375 SvFLAGS(sv) = SVTYPEMASK;
378 SvARENA_CHAIN(sv) = 0;
382 SvFLAGS(sv) = SVTYPEMASK;
385 /* visit(): call the named function for each non-free SV in the arenas
386 * whose flags field matches the flags/mask args. */
389 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
395 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
396 register const SV * const svend = &sva[SvREFCNT(sva)];
398 for (sv = sva + 1; sv < svend; ++sv) {
399 if (SvTYPE(sv) != SVTYPEMASK
400 && (sv->sv_flags & mask) == flags
413 /* called by sv_report_used() for each live SV */
416 do_report_used(pTHX_ SV *sv)
418 if (SvTYPE(sv) != SVTYPEMASK) {
419 PerlIO_printf(Perl_debug_log, "****\n");
426 =for apidoc sv_report_used
428 Dump the contents of all SVs not yet freed. (Debugging aid).
434 Perl_sv_report_used(pTHX)
437 visit(do_report_used, 0, 0);
441 /* called by sv_clean_objs() for each live SV */
444 do_clean_objs(pTHX_ SV *ref)
448 SV * const target = SvRV(ref);
449 if (SvOBJECT(target)) {
450 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
451 if (SvWEAKREF(ref)) {
452 sv_del_backref(target, ref);
458 SvREFCNT_dec(target);
463 /* XXX Might want to check arrays, etc. */
466 /* called by sv_clean_objs() for each live SV */
468 #ifndef DISABLE_DESTRUCTOR_KLUDGE
470 do_clean_named_objs(pTHX_ SV *sv)
473 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
475 #ifdef PERL_DONT_CREATE_GVSV
478 SvOBJECT(GvSV(sv))) ||
479 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
480 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
481 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
482 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
484 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
485 SvFLAGS(sv) |= SVf_BREAK;
493 =for apidoc sv_clean_objs
495 Attempt to destroy all objects not yet freed
501 Perl_sv_clean_objs(pTHX)
504 PL_in_clean_objs = TRUE;
505 visit(do_clean_objs, SVf_ROK, SVf_ROK);
506 #ifndef DISABLE_DESTRUCTOR_KLUDGE
507 /* some barnacles may yet remain, clinging to typeglobs */
508 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
510 PL_in_clean_objs = FALSE;
513 /* called by sv_clean_all() for each live SV */
516 do_clean_all(pTHX_ SV *sv)
519 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
520 SvFLAGS(sv) |= SVf_BREAK;
521 if (PL_comppad == (AV*)sv) {
529 =for apidoc sv_clean_all
531 Decrement the refcnt of each remaining SV, possibly triggering a
532 cleanup. This function may have to be called multiple times to free
533 SVs which are in complex self-referential hierarchies.
539 Perl_sv_clean_all(pTHX)
543 PL_in_clean_all = TRUE;
544 cleaned = visit(do_clean_all, 0,0);
545 PL_in_clean_all = FALSE;
550 ARENASETS: a meta-arena implementation which separates arena-info
551 into struct arena_set, which contains an array of struct
552 arena_descs, each holding info for a single arena. By separating
553 the meta-info from the arena, we recover the 1st slot, formerly
554 borrowed for list management. The arena_set is about the size of an
555 arena, avoiding the needless malloc overhead of a naive linked-list
557 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
558 memory in the last arena-set (1/2 on average). In trade, we get
559 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
560 smaller types). The recovery of the wasted space allows use of
561 small arenas for large, rare body types,
564 char *arena; /* the raw storage, allocated aligned */
565 size_t size; /* its size ~4k typ */
566 int unit_type; /* useful for arena audits */
567 /* info for sv-heads (eventually)
574 /* Get the maximum number of elements in set[] such that struct arena_set
575 will fit within PERL_ARENA_SIZE, which is probabably just under 4K, and
576 therefore likely to be 1 aligned memory page. */
578 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
579 - 2 * sizeof(int)) / sizeof (struct arena_desc))
582 struct arena_set* next;
583 int set_size; /* ie ARENAS_PER_SET */
584 int curr; /* index of next available arena-desc */
585 struct arena_desc set[ARENAS_PER_SET];
591 S_free_arena(pTHX_ void **root) {
593 void ** const next = *(void **)root;
601 =for apidoc sv_free_arenas
603 Deallocate the memory used by all arenas. Note that all the individual SV
604 heads and bodies within the arenas must already have been freed.
609 Perl_sv_free_arenas(pTHX)
616 /* Free arenas here, but be careful about fake ones. (We assume
617 contiguity of the fake ones with the corresponding real ones.) */
619 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
620 svanext = (SV*) SvANY(sva);
621 while (svanext && SvFAKE(svanext))
622 svanext = (SV*) SvANY(svanext);
630 struct arena_set *next, *aroot = (struct arena_set*) PL_body_arenas;
632 for (; aroot; aroot = next) {
633 int max = aroot->curr;
634 for (i=0; i<max; i++) {
635 assert(aroot->set[i].arena);
636 Safefree(aroot->set[i].arena);
643 S_free_arena(aTHX_ (void**) PL_body_arenas);
647 for (i=0; i<PERL_ARENA_ROOTS_SIZE; i++)
648 PL_body_roots[i] = 0;
650 Safefree(PL_nice_chunk);
651 PL_nice_chunk = NULL;
652 PL_nice_chunk_size = 0;
658 Here are mid-level routines that manage the allocation of bodies out
659 of the various arenas. There are 5 kinds of arenas:
661 1. SV-head arenas, which are discussed and handled above
662 2. regular body arenas
663 3. arenas for reduced-size bodies
665 5. pte arenas (thread related)
667 Arena types 2 & 3 are chained by body-type off an array of
668 arena-root pointers, which is indexed by svtype. Some of the
669 larger/less used body types are malloced singly, since a large
670 unused block of them is wasteful. Also, several svtypes dont have
671 bodies; the data fits into the sv-head itself. The arena-root
672 pointer thus has a few unused root-pointers (which may be hijacked
673 later for arena types 4,5)
675 3 differs from 2 as an optimization; some body types have several
676 unused fields in the front of the structure (which are kept in-place
677 for consistency). These bodies can be allocated in smaller chunks,
678 because the leading fields arent accessed. Pointers to such bodies
679 are decremented to point at the unused 'ghost' memory, knowing that
680 the pointers are used with offsets to the real memory.
682 HE, HEK arenas are managed separately, with separate code, but may
683 be merge-able later..
685 PTE arenas are not sv-bodies, but they share these mid-level
686 mechanics, so are considered here. The new mid-level mechanics rely
687 on the sv_type of the body being allocated, so we just reserve one
688 of the unused body-slots for PTEs, then use it in those (2) PTE
689 contexts below (line ~10k)
692 /* get_arena(size): when ARENASETS is enabled, this creates
693 custom-sized arenas, otherwize it uses PERL_ARENA_SIZE, as
695 TBD: export properly for hv.c: S_more_he().
698 Perl_get_arena(pTHX_ int arena_size)
703 /* allocate and attach arena */
704 Newx(arp, arena_size, char);
705 arp->next = PL_body_arenas;
706 PL_body_arenas = arp;
710 struct arena_desc* adesc;
711 struct arena_set *newroot, **aroot = (struct arena_set**) &PL_body_arenas;
714 /* shouldnt need this
715 if (!arena_size) arena_size = PERL_ARENA_SIZE;
718 /* may need new arena-set to hold new arena */
719 if (!*aroot || (*aroot)->curr >= (*aroot)->set_size) {
720 Newxz(newroot, 1, struct arena_set);
721 newroot->set_size = ARENAS_PER_SET;
722 newroot->next = *aroot;
724 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", *aroot));
727 /* ok, now have arena-set with at least 1 empty/available arena-desc */
728 curr = (*aroot)->curr++;
729 adesc = &((*aroot)->set[curr]);
730 assert(!adesc->arena);
732 Newxz(adesc->arena, arena_size, char);
733 adesc->size = arena_size;
734 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %d\n",
735 curr, adesc->arena, arena_size));
742 /* return a thing to the free list */
744 #define del_body(thing, root) \
746 void ** const thing_copy = (void **)thing;\
748 *thing_copy = *root; \
749 *root = (void*)thing_copy; \
755 =head1 SV-Body Allocation
757 Allocation of SV-bodies is similar to SV-heads, differing as follows;
758 the allocation mechanism is used for many body types, so is somewhat
759 more complicated, it uses arena-sets, and has no need for still-live
762 At the outermost level, (new|del)_X*V macros return bodies of the
763 appropriate type. These macros call either (new|del)_body_type or
764 (new|del)_body_allocated macro pairs, depending on specifics of the
765 type. Most body types use the former pair, the latter pair is used to
766 allocate body types with "ghost fields".
768 "ghost fields" are fields that are unused in certain types, and
769 consequently dont need to actually exist. They are declared because
770 they're part of a "base type", which allows use of functions as
771 methods. The simplest examples are AVs and HVs, 2 aggregate types
772 which don't use the fields which support SCALAR semantics.
774 For these types, the arenas are carved up into *_allocated size
775 chunks, we thus avoid wasted memory for those unaccessed members.
776 When bodies are allocated, we adjust the pointer back in memory by the
777 size of the bit not allocated, so it's as if we allocated the full
778 structure. (But things will all go boom if you write to the part that
779 is "not there", because you'll be overwriting the last members of the
780 preceding structure in memory.)
782 We calculate the correction using the STRUCT_OFFSET macro. For
783 example, if xpv_allocated is the same structure as XPV then the two
784 OFFSETs sum to zero, and the pointer is unchanged. If the allocated
785 structure is smaller (no initial NV actually allocated) then the net
786 effect is to subtract the size of the NV from the pointer, to return a
787 new pointer as if an initial NV were actually allocated.
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 S_more_bodies() if
797 necessary to refresh an empty list. Then the lock is released, and
798 the body is returned.
800 S_more_bodies calls get_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.
812 For each sv-type, struct body_details bodies_by_type[] carries
813 parameters which control these aspects of SV handling:
815 Arena_size determines whether arenas are used for this body type, and if
816 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
817 zero, forcing individual mallocs and frees.
819 Body_size determines how big a body is, and therefore how many fit into
820 each arena. Offset carries the body-pointer adjustment needed for
821 *_allocated body types, and is used in *_allocated macros.
823 But its main purpose is to parameterize info needed in
824 Perl_sv_upgrade(). The info here dramatically simplifies the function
825 vs the implementation in 5.8.7, making it table-driven. All fields
826 are used for this, except for arena_size.
828 For the sv-types that have no bodies, arenas are not used, so those
829 PL_body_roots[sv_type] are unused, and can be overloaded. In
830 something of a special case, SVt_NULL is borrowed for HE arenas;
831 PL_body_roots[SVt_NULL] is filled by S_more_he, but the
832 bodies_by_type[SVt_NULL] slot is not used, as the table is not
835 PTEs also use arenas, but are never seen in Perl_sv_upgrade.
836 Nonetheless, they get their own slot in bodies_by_type[SVt_NULL], so
837 they can just use the same allocation semantics. At first, PTEs were
838 also overloaded to a non-body sv-type, but this yielded hard-to-find
839 malloc bugs, so was simplified by claiming a new slot. This choice
840 has no consequence at this time.
844 struct body_details {
845 size_t body_size; /* Size to allocate */
846 size_t copy; /* Size of structure to copy (may be shorter) */
848 bool cant_upgrade; /* Cannot upgrade this type */
849 bool zero_nv; /* zero the NV when upgrading from this */
850 bool arena; /* Allocated from an arena */
851 size_t arena_size; /* Size of arena to allocate */
859 /* With -DPURFIY we allocate everything directly, and don't use arenas.
860 This seems a rather elegant way to simplify some of the code below. */
861 #define HASARENA FALSE
863 #define HASARENA TRUE
865 #define NOARENA FALSE
867 /* Size the arenas to exactly fit a given number of bodies. A count
868 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
869 simplifying the default. If count > 0, the arena is sized to fit
870 only that many bodies, allowing arenas to be used for large, rare
871 bodies (XPVFM, XPVIO) without undue waste. The arena size is
872 limited by PERL_ARENA_SIZE, so we can safely oversize the
875 #define FIT_ARENA(count, body_size) \
876 (!count || count * body_size > PERL_ARENA_SIZE) \
877 ? (int)(PERL_ARENA_SIZE / body_size) * body_size : count * body_size
879 /* A macro to work out the offset needed to subtract from a pointer to (say)
886 to make its members accessible via a pointer to (say)
896 #define relative_STRUCT_OFFSET(longer, shorter, member) \
897 (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member))
899 /* Calculate the length to copy. Specifically work out the length less any
900 final padding the compiler needed to add. See the comment in sv_upgrade
901 for why copying the padding proved to be a bug. */
903 #define copy_length(type, last_member) \
904 STRUCT_OFFSET(type, last_member) \
905 + sizeof (((type*)SvANY((SV*)0))->last_member)
907 static const struct body_details bodies_by_type[] = {
908 { sizeof(HE), 0, 0, FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
910 /* IVs are in the head, so the allocation size is 0.
911 However, the slot is overloaded for PTEs. */
912 { sizeof(struct ptr_tbl_ent), /* This is used for PTEs. */
913 sizeof(IV), /* This is used to copy out the IV body. */
914 STRUCT_OFFSET(XPVIV, xiv_iv), FALSE, NONV,
915 NOARENA /* IVS don't need an arena */,
916 /* But PTEs need to know the size of their arena */
917 FIT_ARENA(0, sizeof(struct ptr_tbl_ent))
920 /* 8 bytes on most ILP32 with IEEE doubles */
921 { sizeof(NV), sizeof(NV), 0, FALSE, HADNV, HASARENA,
922 FIT_ARENA(0, sizeof(NV)) },
924 /* RVs are in the head now. */
925 { 0, 0, 0, FALSE, NONV, NOARENA, 0 },
927 /* 8 bytes on most ILP32 with IEEE doubles */
928 { sizeof(xpv_allocated),
929 copy_length(XPV, xpv_len)
930 - relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
931 + relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
932 FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpv_allocated)) },
935 { sizeof(xpviv_allocated),
936 copy_length(XPVIV, xiv_u)
937 - relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
938 + relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
939 FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpviv_allocated)) },
942 { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, FALSE, HADNV,
943 HASARENA, FIT_ARENA(0, sizeof(XPVNV)) },
946 { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, FALSE, HADNV,
947 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
950 { sizeof(XPVBM), sizeof(XPVBM), 0, TRUE, HADNV,
951 HASARENA, FIT_ARENA(0, sizeof(XPVBM)) },
954 { sizeof(XPVGV), sizeof(XPVGV), 0, TRUE, HADNV,
955 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
958 { sizeof(XPVLV), sizeof(XPVLV), 0, TRUE, HADNV,
959 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
961 { sizeof(xpvav_allocated),
962 copy_length(XPVAV, xmg_stash)
963 - relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
964 + relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
965 TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) },
967 { sizeof(xpvhv_allocated),
968 copy_length(XPVHV, xmg_stash)
969 - relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
970 + relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
971 TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) },
974 { sizeof(xpvcv_allocated), sizeof(xpvcv_allocated),
975 + relative_STRUCT_OFFSET(xpvcv_allocated, XPVCV, xpv_cur),
976 TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvcv_allocated)) },
978 { sizeof(xpvfm_allocated), sizeof(xpvfm_allocated),
979 + relative_STRUCT_OFFSET(xpvfm_allocated, XPVFM, xpv_cur),
980 TRUE, NONV, NOARENA, FIT_ARENA(20, sizeof(xpvfm_allocated)) },
982 /* XPVIO is 84 bytes, fits 48x */
983 { sizeof(XPVIO), sizeof(XPVIO), 0, TRUE, HADNV,
984 HASARENA, FIT_ARENA(24, sizeof(XPVIO)) },
987 #define new_body_type(sv_type) \
988 (void *)((char *)S_new_body(aTHX_ sv_type))
990 #define del_body_type(p, sv_type) \
991 del_body(p, &PL_body_roots[sv_type])
994 #define new_body_allocated(sv_type) \
995 (void *)((char *)S_new_body(aTHX_ sv_type) \
996 - bodies_by_type[sv_type].offset)
998 #define del_body_allocated(p, sv_type) \
999 del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
1002 #define my_safemalloc(s) (void*)safemalloc(s)
1003 #define my_safecalloc(s) (void*)safecalloc(s, 1)
1004 #define my_safefree(p) safefree((char*)p)
1008 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1009 #define del_XNV(p) my_safefree(p)
1011 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1012 #define del_XPVNV(p) my_safefree(p)
1014 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1015 #define del_XPVAV(p) my_safefree(p)
1017 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1018 #define del_XPVHV(p) my_safefree(p)
1020 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1021 #define del_XPVMG(p) my_safefree(p)
1023 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1024 #define del_XPVGV(p) my_safefree(p)
1028 #define new_XNV() new_body_type(SVt_NV)
1029 #define del_XNV(p) del_body_type(p, SVt_NV)
1031 #define new_XPVNV() new_body_type(SVt_PVNV)
1032 #define del_XPVNV(p) del_body_type(p, SVt_PVNV)
1034 #define new_XPVAV() new_body_allocated(SVt_PVAV)
1035 #define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
1037 #define new_XPVHV() new_body_allocated(SVt_PVHV)
1038 #define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
1040 #define new_XPVMG() new_body_type(SVt_PVMG)
1041 #define del_XPVMG(p) del_body_type(p, SVt_PVMG)
1043 #define new_XPVGV() new_body_type(SVt_PVGV)
1044 #define del_XPVGV(p) del_body_type(p, SVt_PVGV)
1048 /* no arena for you! */
1050 #define new_NOARENA(details) \
1051 my_safemalloc((details)->body_size + (details)->offset)
1052 #define new_NOARENAZ(details) \
1053 my_safecalloc((details)->body_size + (details)->offset)
1056 S_more_bodies (pTHX_ svtype sv_type)
1059 void ** const root = &PL_body_roots[sv_type];
1060 const struct body_details *bdp = &bodies_by_type[sv_type];
1061 const size_t body_size = bdp->body_size;
1065 assert(bdp->arena_size);
1066 start = (char*) Perl_get_arena(aTHX_ bdp->arena_size);
1068 end = start + bdp->arena_size - body_size;
1071 /* The initial slot is used to link the arenas together, so it isn't to be
1072 linked into the list of ready-to-use bodies. */
1075 /* computed count doesnt reflect the 1st slot reservation */
1076 DEBUG_m(PerlIO_printf(Perl_debug_log,
1077 "arena %p end %p arena-size %d type %d size %d ct %d\n",
1078 start, end, bdp->arena_size, sv_type, body_size,
1079 bdp->arena_size / body_size));
1082 *root = (void *)start;
1084 while (start < end) {
1085 char * const next = start + body_size;
1086 *(void**) start = (void *)next;
1089 *(void **)start = 0;
1094 /* grab a new thing from the free list, allocating more if necessary.
1095 The inline version is used for speed in hot routines, and the
1096 function using it serves the rest (unless PURIFY).
1098 #define new_body_inline(xpv, sv_type) \
1100 void ** const r3wt = &PL_body_roots[sv_type]; \
1102 xpv = *((void **)(r3wt)) \
1103 ? *((void **)(r3wt)) : S_more_bodies(aTHX_ sv_type); \
1104 *(r3wt) = *(void**)(xpv); \
1111 S_new_body(pTHX_ svtype sv_type)
1115 new_body_inline(xpv, sv_type);
1122 =for apidoc sv_upgrade
1124 Upgrade an SV to a more complex form. Generally adds a new body type to the
1125 SV, then copies across as much information as possible from the old body.
1126 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1132 Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
1137 const U32 old_type = SvTYPE(sv);
1138 const struct body_details *new_type_details;
1139 const struct body_details *const old_type_details
1140 = bodies_by_type + old_type;
1142 if (new_type != SVt_PV && SvIsCOW(sv)) {
1143 sv_force_normal_flags(sv, 0);
1146 if (old_type == new_type)
1149 if (old_type > new_type)
1150 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1151 (int)old_type, (int)new_type);
1154 old_body = SvANY(sv);
1156 /* Copying structures onto other structures that have been neatly zeroed
1157 has a subtle gotcha. Consider XPVMG
1159 +------+------+------+------+------+-------+-------+
1160 | NV | CUR | LEN | IV | MAGIC | STASH |
1161 +------+------+------+------+------+-------+-------+
1162 0 4 8 12 16 20 24 28
1164 where NVs are aligned to 8 bytes, so that sizeof that structure is
1165 actually 32 bytes long, with 4 bytes of padding at the end:
1167 +------+------+------+------+------+-------+-------+------+
1168 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1169 +------+------+------+------+------+-------+-------+------+
1170 0 4 8 12 16 20 24 28 32
1172 so what happens if you allocate memory for this structure:
1174 +------+------+------+------+------+-------+-------+------+------+...
1175 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1176 +------+------+------+------+------+-------+-------+------+------+...
1177 0 4 8 12 16 20 24 28 32 36
1179 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1180 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1181 started out as zero once, but it's quite possible that it isn't. So now,
1182 rather than a nicely zeroed GP, you have it pointing somewhere random.
1185 (In fact, GP ends up pointing at a previous GP structure, because the
1186 principle cause of the padding in XPVMG getting garbage is a copy of
1187 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob)
1189 So we are careful and work out the size of used parts of all the
1196 if (new_type < SVt_PVIV) {
1197 new_type = (new_type == SVt_NV)
1198 ? SVt_PVNV : SVt_PVIV;
1202 if (new_type < SVt_PVNV) {
1203 new_type = SVt_PVNV;
1209 assert(new_type > SVt_PV);
1210 assert(SVt_IV < SVt_PV);
1211 assert(SVt_NV < SVt_PV);
1218 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1219 there's no way that it can be safely upgraded, because perl.c
1220 expects to Safefree(SvANY(PL_mess_sv)) */
1221 assert(sv != PL_mess_sv);
1222 /* This flag bit is used to mean other things in other scalar types.
1223 Given that it only has meaning inside the pad, it shouldn't be set
1224 on anything that can get upgraded. */
1225 assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
1228 if (old_type_details->cant_upgrade)
1229 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1230 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1232 new_type_details = bodies_by_type + new_type;
1234 SvFLAGS(sv) &= ~SVTYPEMASK;
1235 SvFLAGS(sv) |= new_type;
1237 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1238 the return statements above will have triggered. */
1239 assert (new_type != SVt_NULL);
1242 assert(old_type == SVt_NULL);
1243 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1247 assert(old_type == SVt_NULL);
1248 SvANY(sv) = new_XNV();
1252 assert(old_type == SVt_NULL);
1253 SvANY(sv) = &sv->sv_u.svu_rv;
1258 assert(new_type_details->body_size);
1261 assert(new_type_details->arena);
1262 assert(new_type_details->arena_size);
1263 /* This points to the start of the allocated area. */
1264 new_body_inline(new_body, new_type);
1265 Zero(new_body, new_type_details->body_size, char);
1266 new_body = ((char *)new_body) - new_type_details->offset;
1268 /* We always allocated the full length item with PURIFY. To do this
1269 we fake things so that arena is false for all 16 types.. */
1270 new_body = new_NOARENAZ(new_type_details);
1272 SvANY(sv) = new_body;
1273 if (new_type == SVt_PVAV) {
1279 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1280 The target created by newSVrv also is, and it can have magic.
1281 However, it never has SvPVX set.
1283 if (old_type >= SVt_RV) {
1284 assert(SvPVX_const(sv) == 0);
1287 /* Could put this in the else clause below, as PVMG must have SvPVX
1288 0 already (the assertion above) */
1291 if (old_type >= SVt_PVMG) {
1292 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic);
1293 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1299 /* XXX Is this still needed? Was it ever needed? Surely as there is
1300 no route from NV to PVIV, NOK can never be true */
1301 assert(!SvNOKp(sv));
1313 assert(new_type_details->body_size);
1314 /* We always allocated the full length item with PURIFY. To do this
1315 we fake things so that arena is false for all 16 types.. */
1316 if(new_type_details->arena) {
1317 /* This points to the start of the allocated area. */
1318 new_body_inline(new_body, new_type);
1319 Zero(new_body, new_type_details->body_size, char);
1320 new_body = ((char *)new_body) - new_type_details->offset;
1322 new_body = new_NOARENAZ(new_type_details);
1324 SvANY(sv) = new_body;
1326 if (old_type_details->copy) {
1327 Copy((char *)old_body + old_type_details->offset,
1328 (char *)new_body + old_type_details->offset,
1329 old_type_details->copy, char);
1332 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1333 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1334 * correct 0.0 for us. Otherwise, if the old body didn't have an
1335 * NV slot, but the new one does, then we need to initialise the
1336 * freshly created NV slot with whatever the correct bit pattern is
1338 if (old_type_details->zero_nv && !new_type_details->zero_nv)
1342 if (new_type == SVt_PVIO)
1343 IoPAGE_LEN(sv) = 60;
1344 if (old_type < SVt_RV)
1348 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1349 (unsigned long)new_type);
1352 if (old_type_details->arena) {
1353 /* If there was an old body, then we need to free it.
1354 Note that there is an assumption that all bodies of types that
1355 can be upgraded came from arenas. Only the more complex non-
1356 upgradable types are allowed to be directly malloc()ed. */
1358 my_safefree(old_body);
1360 del_body((void*)((char*)old_body + old_type_details->offset),
1361 &PL_body_roots[old_type]);
1367 =for apidoc sv_backoff
1369 Remove any string offset. You should normally use the C<SvOOK_off> macro
1376 Perl_sv_backoff(pTHX_ register SV *sv)
1379 assert(SvTYPE(sv) != SVt_PVHV);
1380 assert(SvTYPE(sv) != SVt_PVAV);
1382 const char * const s = SvPVX_const(sv);
1383 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1384 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1386 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1388 SvFLAGS(sv) &= ~SVf_OOK;
1395 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1396 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1397 Use the C<SvGROW> wrapper instead.
1403 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1407 #ifdef HAS_64K_LIMIT
1408 if (newlen >= 0x10000) {
1409 PerlIO_printf(Perl_debug_log,
1410 "Allocation too large: %"UVxf"\n", (UV)newlen);
1413 #endif /* HAS_64K_LIMIT */
1416 if (SvTYPE(sv) < SVt_PV) {
1417 sv_upgrade(sv, SVt_PV);
1418 s = SvPVX_mutable(sv);
1420 else if (SvOOK(sv)) { /* pv is offset? */
1422 s = SvPVX_mutable(sv);
1423 if (newlen > SvLEN(sv))
1424 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1425 #ifdef HAS_64K_LIMIT
1426 if (newlen >= 0x10000)
1431 s = SvPVX_mutable(sv);
1433 if (newlen > SvLEN(sv)) { /* need more room? */
1434 newlen = PERL_STRLEN_ROUNDUP(newlen);
1435 if (SvLEN(sv) && s) {
1437 const STRLEN l = malloced_size((void*)SvPVX_const(sv));
1443 s = saferealloc(s, newlen);
1446 s = safemalloc(newlen);
1447 if (SvPVX_const(sv) && SvCUR(sv)) {
1448 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1452 SvLEN_set(sv, newlen);
1458 =for apidoc sv_setiv
1460 Copies an integer into the given SV, upgrading first if necessary.
1461 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1467 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1470 SV_CHECK_THINKFIRST_COW_DROP(sv);
1471 switch (SvTYPE(sv)) {
1473 sv_upgrade(sv, SVt_IV);
1476 sv_upgrade(sv, SVt_PVNV);
1480 sv_upgrade(sv, SVt_PVIV);
1489 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1492 (void)SvIOK_only(sv); /* validate number */
1498 =for apidoc sv_setiv_mg
1500 Like C<sv_setiv>, but also handles 'set' magic.
1506 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1513 =for apidoc sv_setuv
1515 Copies an unsigned integer into the given SV, upgrading first if necessary.
1516 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1522 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1524 /* With these two if statements:
1525 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1528 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1530 If you wish to remove them, please benchmark to see what the effect is
1532 if (u <= (UV)IV_MAX) {
1533 sv_setiv(sv, (IV)u);
1542 =for apidoc sv_setuv_mg
1544 Like C<sv_setuv>, but also handles 'set' magic.
1550 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1559 =for apidoc sv_setnv
1561 Copies a double into the given SV, upgrading first if necessary.
1562 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1568 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1571 SV_CHECK_THINKFIRST_COW_DROP(sv);
1572 switch (SvTYPE(sv)) {
1575 sv_upgrade(sv, SVt_NV);
1580 sv_upgrade(sv, SVt_PVNV);
1589 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1593 (void)SvNOK_only(sv); /* validate number */
1598 =for apidoc sv_setnv_mg
1600 Like C<sv_setnv>, but also handles 'set' magic.
1606 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1612 /* Print an "isn't numeric" warning, using a cleaned-up,
1613 * printable version of the offending string
1617 S_not_a_number(pTHX_ SV *sv)
1625 dsv = sv_2mortal(newSVpvs(""));
1626 pv = sv_uni_display(dsv, sv, 10, 0);
1629 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1630 /* each *s can expand to 4 chars + "...\0",
1631 i.e. need room for 8 chars */
1633 const char *s = SvPVX_const(sv);
1634 const char * const end = s + SvCUR(sv);
1635 for ( ; s < end && d < limit; s++ ) {
1637 if (ch & 128 && !isPRINT_LC(ch)) {
1646 else if (ch == '\r') {
1650 else if (ch == '\f') {
1654 else if (ch == '\\') {
1658 else if (ch == '\0') {
1662 else if (isPRINT_LC(ch))
1679 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1680 "Argument \"%s\" isn't numeric in %s", pv,
1683 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1684 "Argument \"%s\" isn't numeric", pv);
1688 =for apidoc looks_like_number
1690 Test if the content of an SV looks like a number (or is a number).
1691 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1692 non-numeric warning), even if your atof() doesn't grok them.
1698 Perl_looks_like_number(pTHX_ SV *sv)
1700 register const char *sbegin;
1704 sbegin = SvPVX_const(sv);
1707 else if (SvPOKp(sv))
1708 sbegin = SvPV_const(sv, len);
1710 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1711 return grok_number(sbegin, len, NULL);
1715 S_glob_2inpuv(pTHX_ GV *gv, STRLEN *len, bool want_number)
1717 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1718 SV *const buffer = sv_newmortal();
1720 /* FAKE globs can get coerced, so need to turn this off temporarily if it
1723 gv_efullname3(buffer, gv, "*");
1724 SvFLAGS(gv) |= wasfake;
1727 /* We know that all GVs stringify to something that is not-a-number,
1728 so no need to test that. */
1729 if (ckWARN(WARN_NUMERIC))
1730 not_a_number(buffer);
1731 /* We just want something true to return, so that S_sv_2iuv_common
1732 can tail call us and return true. */
1735 return SvPV(buffer, *len);
1739 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1740 until proven guilty, assume that things are not that bad... */
1745 As 64 bit platforms often have an NV that doesn't preserve all bits of
1746 an IV (an assumption perl has been based on to date) it becomes necessary
1747 to remove the assumption that the NV always carries enough precision to
1748 recreate the IV whenever needed, and that the NV is the canonical form.
1749 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1750 precision as a side effect of conversion (which would lead to insanity
1751 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1752 1) to distinguish between IV/UV/NV slots that have cached a valid
1753 conversion where precision was lost and IV/UV/NV slots that have a
1754 valid conversion which has lost no precision
1755 2) to ensure that if a numeric conversion to one form is requested that
1756 would lose precision, the precise conversion (or differently
1757 imprecise conversion) is also performed and cached, to prevent
1758 requests for different numeric formats on the same SV causing
1759 lossy conversion chains. (lossless conversion chains are perfectly
1764 SvIOKp is true if the IV slot contains a valid value
1765 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1766 SvNOKp is true if the NV slot contains a valid value
1767 SvNOK is true only if the NV value is accurate
1770 while converting from PV to NV, check to see if converting that NV to an
1771 IV(or UV) would lose accuracy over a direct conversion from PV to
1772 IV(or UV). If it would, cache both conversions, return NV, but mark
1773 SV as IOK NOKp (ie not NOK).
1775 While converting from PV to IV, check to see if converting that IV to an
1776 NV would lose accuracy over a direct conversion from PV to NV. If it
1777 would, cache both conversions, flag similarly.
1779 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1780 correctly because if IV & NV were set NV *always* overruled.
1781 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1782 changes - now IV and NV together means that the two are interchangeable:
1783 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1785 The benefit of this is that operations such as pp_add know that if
1786 SvIOK is true for both left and right operands, then integer addition
1787 can be used instead of floating point (for cases where the result won't
1788 overflow). Before, floating point was always used, which could lead to
1789 loss of precision compared with integer addition.
1791 * making IV and NV equal status should make maths accurate on 64 bit
1793 * may speed up maths somewhat if pp_add and friends start to use
1794 integers when possible instead of fp. (Hopefully the overhead in
1795 looking for SvIOK and checking for overflow will not outweigh the
1796 fp to integer speedup)
1797 * will slow down integer operations (callers of SvIV) on "inaccurate"
1798 values, as the change from SvIOK to SvIOKp will cause a call into
1799 sv_2iv each time rather than a macro access direct to the IV slot
1800 * should speed up number->string conversion on integers as IV is
1801 favoured when IV and NV are equally accurate
1803 ####################################################################
1804 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1805 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1806 On the other hand, SvUOK is true iff UV.
1807 ####################################################################
1809 Your mileage will vary depending your CPU's relative fp to integer
1813 #ifndef NV_PRESERVES_UV
1814 # define IS_NUMBER_UNDERFLOW_IV 1
1815 # define IS_NUMBER_UNDERFLOW_UV 2
1816 # define IS_NUMBER_IV_AND_UV 2
1817 # define IS_NUMBER_OVERFLOW_IV 4
1818 # define IS_NUMBER_OVERFLOW_UV 5
1820 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1822 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1824 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
1827 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));
1828 if (SvNVX(sv) < (NV)IV_MIN) {
1829 (void)SvIOKp_on(sv);
1831 SvIV_set(sv, IV_MIN);
1832 return IS_NUMBER_UNDERFLOW_IV;
1834 if (SvNVX(sv) > (NV)UV_MAX) {
1835 (void)SvIOKp_on(sv);
1838 SvUV_set(sv, UV_MAX);
1839 return IS_NUMBER_OVERFLOW_UV;
1841 (void)SvIOKp_on(sv);
1843 /* Can't use strtol etc to convert this string. (See truth table in
1845 if (SvNVX(sv) <= (UV)IV_MAX) {
1846 SvIV_set(sv, I_V(SvNVX(sv)));
1847 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1848 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1850 /* Integer is imprecise. NOK, IOKp */
1852 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1855 SvUV_set(sv, U_V(SvNVX(sv)));
1856 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1857 if (SvUVX(sv) == UV_MAX) {
1858 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1859 possibly be preserved by NV. Hence, it must be overflow.
1861 return IS_NUMBER_OVERFLOW_UV;
1863 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1865 /* Integer is imprecise. NOK, IOKp */
1867 return IS_NUMBER_OVERFLOW_IV;
1869 #endif /* !NV_PRESERVES_UV*/
1872 S_sv_2iuv_common(pTHX_ SV *sv) {
1875 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1876 * without also getting a cached IV/UV from it at the same time
1877 * (ie PV->NV conversion should detect loss of accuracy and cache
1878 * IV or UV at same time to avoid this. */
1879 /* IV-over-UV optimisation - choose to cache IV if possible */
1881 if (SvTYPE(sv) == SVt_NV)
1882 sv_upgrade(sv, SVt_PVNV);
1884 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1885 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1886 certainly cast into the IV range at IV_MAX, whereas the correct
1887 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1889 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1890 SvIV_set(sv, I_V(SvNVX(sv)));
1891 if (SvNVX(sv) == (NV) SvIVX(sv)
1892 #ifndef NV_PRESERVES_UV
1893 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1894 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1895 /* Don't flag it as "accurately an integer" if the number
1896 came from a (by definition imprecise) NV operation, and
1897 we're outside the range of NV integer precision */
1900 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1901 DEBUG_c(PerlIO_printf(Perl_debug_log,
1902 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
1908 /* IV not precise. No need to convert from PV, as NV
1909 conversion would already have cached IV if it detected
1910 that PV->IV would be better than PV->NV->IV
1911 flags already correct - don't set public IOK. */
1912 DEBUG_c(PerlIO_printf(Perl_debug_log,
1913 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
1918 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1919 but the cast (NV)IV_MIN rounds to a the value less (more
1920 negative) than IV_MIN which happens to be equal to SvNVX ??
1921 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1922 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1923 (NV)UVX == NVX are both true, but the values differ. :-(
1924 Hopefully for 2s complement IV_MIN is something like
1925 0x8000000000000000 which will be exact. NWC */
1928 SvUV_set(sv, U_V(SvNVX(sv)));
1930 (SvNVX(sv) == (NV) SvUVX(sv))
1931 #ifndef NV_PRESERVES_UV
1932 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1933 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1934 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1935 /* Don't flag it as "accurately an integer" if the number
1936 came from a (by definition imprecise) NV operation, and
1937 we're outside the range of NV integer precision */
1942 DEBUG_c(PerlIO_printf(Perl_debug_log,
1943 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1949 else if (SvPOKp(sv) && SvLEN(sv)) {
1951 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
1952 /* We want to avoid a possible problem when we cache an IV/ a UV which
1953 may be later translated to an NV, and the resulting NV is not
1954 the same as the direct translation of the initial string
1955 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
1956 be careful to ensure that the value with the .456 is around if the
1957 NV value is requested in the future).
1959 This means that if we cache such an IV/a UV, we need to cache the
1960 NV as well. Moreover, we trade speed for space, and do not
1961 cache the NV if we are sure it's not needed.
1964 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
1965 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1966 == IS_NUMBER_IN_UV) {
1967 /* It's definitely an integer, only upgrade to PVIV */
1968 if (SvTYPE(sv) < SVt_PVIV)
1969 sv_upgrade(sv, SVt_PVIV);
1971 } else if (SvTYPE(sv) < SVt_PVNV)
1972 sv_upgrade(sv, SVt_PVNV);
1974 /* If NVs preserve UVs then we only use the UV value if we know that
1975 we aren't going to call atof() below. If NVs don't preserve UVs
1976 then the value returned may have more precision than atof() will
1977 return, even though value isn't perfectly accurate. */
1978 if ((numtype & (IS_NUMBER_IN_UV
1979 #ifdef NV_PRESERVES_UV
1982 )) == IS_NUMBER_IN_UV) {
1983 /* This won't turn off the public IOK flag if it was set above */
1984 (void)SvIOKp_on(sv);
1986 if (!(numtype & IS_NUMBER_NEG)) {
1988 if (value <= (UV)IV_MAX) {
1989 SvIV_set(sv, (IV)value);
1991 /* it didn't overflow, and it was positive. */
1992 SvUV_set(sv, value);
1996 /* 2s complement assumption */
1997 if (value <= (UV)IV_MIN) {
1998 SvIV_set(sv, -(IV)value);
2000 /* Too negative for an IV. This is a double upgrade, but
2001 I'm assuming it will be rare. */
2002 if (SvTYPE(sv) < SVt_PVNV)
2003 sv_upgrade(sv, SVt_PVNV);
2007 SvNV_set(sv, -(NV)value);
2008 SvIV_set(sv, IV_MIN);
2012 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2013 will be in the previous block to set the IV slot, and the next
2014 block to set the NV slot. So no else here. */
2016 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2017 != IS_NUMBER_IN_UV) {
2018 /* It wasn't an (integer that doesn't overflow the UV). */
2019 SvNV_set(sv, Atof(SvPVX_const(sv)));
2021 if (! numtype && ckWARN(WARN_NUMERIC))
2024 #if defined(USE_LONG_DOUBLE)
2025 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2026 PTR2UV(sv), SvNVX(sv)));
2028 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2029 PTR2UV(sv), SvNVX(sv)));
2032 #ifdef NV_PRESERVES_UV
2033 (void)SvIOKp_on(sv);
2035 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2036 SvIV_set(sv, I_V(SvNVX(sv)));
2037 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2040 /*EMPTY*/; /* Integer is imprecise. NOK, IOKp */
2042 /* UV will not work better than IV */
2044 if (SvNVX(sv) > (NV)UV_MAX) {
2046 /* Integer is inaccurate. NOK, IOKp, is UV */
2047 SvUV_set(sv, UV_MAX);
2049 SvUV_set(sv, U_V(SvNVX(sv)));
2050 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2051 NV preservse UV so can do correct comparison. */
2052 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2055 /*EMPTY*/; /* Integer is imprecise. NOK, IOKp, is UV */
2060 #else /* NV_PRESERVES_UV */
2061 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2062 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2063 /* The IV/UV slot will have been set from value returned by
2064 grok_number above. The NV slot has just been set using
2067 assert (SvIOKp(sv));
2069 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2070 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2071 /* Small enough to preserve all bits. */
2072 (void)SvIOKp_on(sv);
2074 SvIV_set(sv, I_V(SvNVX(sv)));
2075 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2077 /* Assumption: first non-preserved integer is < IV_MAX,
2078 this NV is in the preserved range, therefore: */
2079 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2081 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);
2085 0 0 already failed to read UV.
2086 0 1 already failed to read UV.
2087 1 0 you won't get here in this case. IV/UV
2088 slot set, public IOK, Atof() unneeded.
2089 1 1 already read UV.
2090 so there's no point in sv_2iuv_non_preserve() attempting
2091 to use atol, strtol, strtoul etc. */
2092 sv_2iuv_non_preserve (sv, numtype);
2095 #endif /* NV_PRESERVES_UV */
2099 if (((SvFLAGS(sv) & (SVp_POK|SVp_SCREAM)) == SVp_SCREAM)
2100 && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV)) {
2101 return PTR2IV(glob_2inpuv((GV *)sv, NULL, TRUE));
2103 if (SvTYPE(sv) == SVt_PVGV)
2106 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2107 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2110 if (SvTYPE(sv) < SVt_IV)
2111 /* Typically the caller expects that sv_any is not NULL now. */
2112 sv_upgrade(sv, SVt_IV);
2113 /* Return 0 from the caller. */
2120 =for apidoc sv_2iv_flags
2122 Return the integer value of an SV, doing any necessary string
2123 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2124 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2130 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2135 if (SvGMAGICAL(sv)) {
2136 if (flags & SV_GMAGIC)
2141 return I_V(SvNVX(sv));
2143 if (SvPOKp(sv) && SvLEN(sv)) {
2146 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2148 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2149 == IS_NUMBER_IN_UV) {
2150 /* It's definitely an integer */
2151 if (numtype & IS_NUMBER_NEG) {
2152 if (value < (UV)IV_MIN)
2155 if (value < (UV)IV_MAX)
2160 if (ckWARN(WARN_NUMERIC))
2163 return I_V(Atof(SvPVX_const(sv)));
2168 assert(SvTYPE(sv) >= SVt_PVMG);
2169 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2170 } else if (SvTHINKFIRST(sv)) {
2174 SV * const tmpstr=AMG_CALLun(sv,numer);
2175 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2176 return SvIV(tmpstr);
2179 return PTR2IV(SvRV(sv));
2182 sv_force_normal_flags(sv, 0);
2184 if (SvREADONLY(sv) && !SvOK(sv)) {
2185 if (ckWARN(WARN_UNINITIALIZED))
2191 if (S_sv_2iuv_common(aTHX_ sv))
2194 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2195 PTR2UV(sv),SvIVX(sv)));
2196 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2200 =for apidoc sv_2uv_flags
2202 Return the unsigned integer value of an SV, doing any necessary string
2203 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2204 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2210 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2215 if (SvGMAGICAL(sv)) {
2216 if (flags & SV_GMAGIC)
2221 return U_V(SvNVX(sv));
2222 if (SvPOKp(sv) && SvLEN(sv)) {
2225 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2227 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2228 == IS_NUMBER_IN_UV) {
2229 /* It's definitely an integer */
2230 if (!(numtype & IS_NUMBER_NEG))
2234 if (ckWARN(WARN_NUMERIC))
2237 return U_V(Atof(SvPVX_const(sv)));
2242 assert(SvTYPE(sv) >= SVt_PVMG);
2243 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2244 } else if (SvTHINKFIRST(sv)) {
2248 SV *const tmpstr = AMG_CALLun(sv,numer);
2249 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2250 return SvUV(tmpstr);
2253 return PTR2UV(SvRV(sv));
2256 sv_force_normal_flags(sv, 0);
2258 if (SvREADONLY(sv) && !SvOK(sv)) {
2259 if (ckWARN(WARN_UNINITIALIZED))
2265 if (S_sv_2iuv_common(aTHX_ sv))
2269 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2270 PTR2UV(sv),SvUVX(sv)));
2271 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2277 Return the num value of an SV, doing any necessary string or integer
2278 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2285 Perl_sv_2nv(pTHX_ register SV *sv)
2290 if (SvGMAGICAL(sv)) {
2294 if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2295 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2296 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2298 return Atof(SvPVX_const(sv));
2302 return (NV)SvUVX(sv);
2304 return (NV)SvIVX(sv);
2309 assert(SvTYPE(sv) >= SVt_PVMG);
2310 /* This falls through to the report_uninit near the end of the
2312 } else if (SvTHINKFIRST(sv)) {
2316 SV *const tmpstr = AMG_CALLun(sv,numer);
2317 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2318 return SvNV(tmpstr);
2321 return PTR2NV(SvRV(sv));
2324 sv_force_normal_flags(sv, 0);
2326 if (SvREADONLY(sv) && !SvOK(sv)) {
2327 if (ckWARN(WARN_UNINITIALIZED))
2332 if (SvTYPE(sv) < SVt_NV) {
2333 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2334 sv_upgrade(sv, SVt_NV);
2335 #ifdef USE_LONG_DOUBLE
2337 STORE_NUMERIC_LOCAL_SET_STANDARD();
2338 PerlIO_printf(Perl_debug_log,
2339 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2340 PTR2UV(sv), SvNVX(sv));
2341 RESTORE_NUMERIC_LOCAL();
2345 STORE_NUMERIC_LOCAL_SET_STANDARD();
2346 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2347 PTR2UV(sv), SvNVX(sv));
2348 RESTORE_NUMERIC_LOCAL();
2352 else if (SvTYPE(sv) < SVt_PVNV)
2353 sv_upgrade(sv, SVt_PVNV);
2358 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2359 #ifdef NV_PRESERVES_UV
2362 /* Only set the public NV OK flag if this NV preserves the IV */
2363 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2364 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2365 : (SvIVX(sv) == I_V(SvNVX(sv))))
2371 else if (SvPOKp(sv) && SvLEN(sv)) {
2373 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2374 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2376 #ifdef NV_PRESERVES_UV
2377 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2378 == IS_NUMBER_IN_UV) {
2379 /* It's definitely an integer */
2380 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2382 SvNV_set(sv, Atof(SvPVX_const(sv)));
2385 SvNV_set(sv, Atof(SvPVX_const(sv)));
2386 /* Only set the public NV OK flag if this NV preserves the value in
2387 the PV at least as well as an IV/UV would.
2388 Not sure how to do this 100% reliably. */
2389 /* if that shift count is out of range then Configure's test is
2390 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2392 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2393 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2394 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2395 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2396 /* Can't use strtol etc to convert this string, so don't try.
2397 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2400 /* value has been set. It may not be precise. */
2401 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2402 /* 2s complement assumption for (UV)IV_MIN */
2403 SvNOK_on(sv); /* Integer is too negative. */
2408 if (numtype & IS_NUMBER_NEG) {
2409 SvIV_set(sv, -(IV)value);
2410 } else if (value <= (UV)IV_MAX) {
2411 SvIV_set(sv, (IV)value);
2413 SvUV_set(sv, value);
2417 if (numtype & IS_NUMBER_NOT_INT) {
2418 /* I believe that even if the original PV had decimals,
2419 they are lost beyond the limit of the FP precision.
2420 However, neither is canonical, so both only get p
2421 flags. NWC, 2000/11/25 */
2422 /* Both already have p flags, so do nothing */
2424 const NV nv = SvNVX(sv);
2425 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2426 if (SvIVX(sv) == I_V(nv)) {
2429 /* It had no "." so it must be integer. */
2433 /* between IV_MAX and NV(UV_MAX).
2434 Could be slightly > UV_MAX */
2436 if (numtype & IS_NUMBER_NOT_INT) {
2437 /* UV and NV both imprecise. */
2439 const UV nv_as_uv = U_V(nv);
2441 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2450 #endif /* NV_PRESERVES_UV */
2453 if (((SvFLAGS(sv) & (SVp_POK|SVp_SCREAM)) == SVp_SCREAM)
2454 && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV)) {
2455 glob_2inpuv((GV *)sv, NULL, TRUE);
2459 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2461 assert (SvTYPE(sv) >= SVt_NV);
2462 /* Typically the caller expects that sv_any is not NULL now. */
2463 /* XXX Ilya implies that this is a bug in callers that assume this
2464 and ideally should be fixed. */
2467 #if defined(USE_LONG_DOUBLE)
2469 STORE_NUMERIC_LOCAL_SET_STANDARD();
2470 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2471 PTR2UV(sv), SvNVX(sv));
2472 RESTORE_NUMERIC_LOCAL();
2476 STORE_NUMERIC_LOCAL_SET_STANDARD();
2477 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2478 PTR2UV(sv), SvNVX(sv));
2479 RESTORE_NUMERIC_LOCAL();
2485 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2486 * UV as a string towards the end of buf, and return pointers to start and
2489 * We assume that buf is at least TYPE_CHARS(UV) long.
2493 S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2495 char *ptr = buf + TYPE_CHARS(UV);
2496 char * const ebuf = ptr;
2509 *--ptr = '0' + (char)(uv % 10);
2517 /* stringify_regexp(): private routine for use by sv_2pv_flags(): converts
2518 * a regexp to its stringified form.
2522 S_stringify_regexp(pTHX_ SV *sv, MAGIC *mg, STRLEN *lp) {
2524 const regexp * const re = (regexp *)mg->mg_obj;
2527 const char *fptr = "msix";
2532 bool need_newline = 0;
2533 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
2535 while((ch = *fptr++)) {
2537 reflags[left++] = ch;
2540 reflags[right--] = ch;
2545 reflags[left] = '-';
2549 mg->mg_len = re->prelen + 4 + left;
2551 * If /x was used, we have to worry about a regex ending with a
2552 * comment later being embedded within another regex. If so, we don't
2553 * want this regex's "commentization" to leak out to the right part of
2554 * the enclosing regex, we must cap it with a newline.
2556 * So, if /x was used, we scan backwards from the end of the regex. If
2557 * we find a '#' before we find a newline, we need to add a newline
2558 * ourself. If we find a '\n' first (or if we don't find '#' or '\n'),
2559 * we don't need to add anything. -jfriedl
2561 if (PMf_EXTENDED & re->reganch) {
2562 const char *endptr = re->precomp + re->prelen;
2563 while (endptr >= re->precomp) {
2564 const char c = *(endptr--);
2566 break; /* don't need another */
2568 /* we end while in a comment, so we need a newline */
2569 mg->mg_len++; /* save space for it */
2570 need_newline = 1; /* note to add it */
2576 Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
2577 mg->mg_ptr[0] = '(';
2578 mg->mg_ptr[1] = '?';
2579 Copy(reflags, mg->mg_ptr+2, left, char);
2580 *(mg->mg_ptr+left+2) = ':';
2581 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2583 mg->mg_ptr[mg->mg_len - 2] = '\n';
2584 mg->mg_ptr[mg->mg_len - 1] = ')';
2585 mg->mg_ptr[mg->mg_len] = 0;
2587 PL_reginterp_cnt += re->program[0].next_off;
2589 if (re->reganch & ROPT_UTF8)
2599 =for apidoc sv_2pv_flags
2601 Returns a pointer to the string value of an SV, and sets *lp to its length.
2602 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2604 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2605 usually end up here too.
2611 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2621 if (SvGMAGICAL(sv)) {
2622 if (flags & SV_GMAGIC)
2627 if (flags & SV_MUTABLE_RETURN)
2628 return SvPVX_mutable(sv);
2629 if (flags & SV_CONST_RETURN)
2630 return (char *)SvPVX_const(sv);
2633 if (SvIOKp(sv) || SvNOKp(sv)) {
2634 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2638 len = SvIsUV(sv) ? my_sprintf(tbuf,"%"UVuf, (UV)SvUVX(sv))
2639 : my_sprintf(tbuf,"%"IVdf, (IV)SvIVX(sv));
2641 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2648 #ifdef FIXNEGATIVEZERO
2649 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2655 SvUPGRADE(sv, SVt_PV);
2658 s = SvGROW_mutable(sv, len + 1);
2661 return memcpy(s, tbuf, len + 1);
2667 assert(SvTYPE(sv) >= SVt_PVMG);
2668 /* This falls through to the report_uninit near the end of the
2670 } else if (SvTHINKFIRST(sv)) {
2674 SV *const tmpstr = AMG_CALLun(sv,string);
2675 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2677 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2681 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2682 if (flags & SV_CONST_RETURN) {
2683 pv = (char *) SvPVX_const(tmpstr);
2685 pv = (flags & SV_MUTABLE_RETURN)
2686 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2689 *lp = SvCUR(tmpstr);
2691 pv = sv_2pv_flags(tmpstr, lp, flags);
2703 const SV *const referent = (SV*)SvRV(sv);
2706 tsv = sv_2mortal(newSVpvs("NULLREF"));
2707 } else if (SvTYPE(referent) == SVt_PVMG
2708 && ((SvFLAGS(referent) &
2709 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2710 == (SVs_OBJECT|SVs_SMG))
2711 && (mg = mg_find(referent, PERL_MAGIC_qr))) {
2712 return stringify_regexp(sv, mg, lp);
2714 const char *const typestr = sv_reftype(referent, 0);
2716 tsv = sv_newmortal();
2717 if (SvOBJECT(referent)) {
2718 const char *const name = HvNAME_get(SvSTASH(referent));
2719 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
2720 name ? name : "__ANON__" , typestr,
2724 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr,
2732 if (SvREADONLY(sv) && !SvOK(sv)) {
2733 if (ckWARN(WARN_UNINITIALIZED))
2740 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2741 /* I'm assuming that if both IV and NV are equally valid then
2742 converting the IV is going to be more efficient */
2743 const U32 isIOK = SvIOK(sv);
2744 const U32 isUIOK = SvIsUV(sv);
2745 char buf[TYPE_CHARS(UV)];
2748 if (SvTYPE(sv) < SVt_PVIV)
2749 sv_upgrade(sv, SVt_PVIV);
2750 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2751 /* inlined from sv_setpvn */
2752 SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
2753 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
2754 SvCUR_set(sv, ebuf - ptr);
2764 else if (SvNOKp(sv)) {
2765 const int olderrno = errno;
2766 if (SvTYPE(sv) < SVt_PVNV)
2767 sv_upgrade(sv, SVt_PVNV);
2768 /* The +20 is pure guesswork. Configure test needed. --jhi */
2769 s = SvGROW_mutable(sv, NV_DIG + 20);
2770 /* some Xenix systems wipe out errno here */
2772 if (SvNVX(sv) == 0.0)
2773 (void)strcpy(s,"0");
2777 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2780 #ifdef FIXNEGATIVEZERO
2781 if (*s == '-' && s[1] == '0' && !s[2])
2791 if (((SvFLAGS(sv) & (SVp_POK|SVp_SCREAM)) == SVp_SCREAM)
2792 && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV)) {
2793 return glob_2inpuv((GV *)sv, lp, FALSE);
2796 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2800 if (SvTYPE(sv) < SVt_PV)
2801 /* Typically the caller expects that sv_any is not NULL now. */
2802 sv_upgrade(sv, SVt_PV);
2806 const STRLEN len = s - SvPVX_const(sv);
2812 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2813 PTR2UV(sv),SvPVX_const(sv)));
2814 if (flags & SV_CONST_RETURN)
2815 return (char *)SvPVX_const(sv);
2816 if (flags & SV_MUTABLE_RETURN)
2817 return SvPVX_mutable(sv);
2822 =for apidoc sv_copypv
2824 Copies a stringified representation of the source SV into the
2825 destination SV. Automatically performs any necessary mg_get and
2826 coercion of numeric values into strings. Guaranteed to preserve
2827 UTF-8 flag even from overloaded objects. Similar in nature to
2828 sv_2pv[_flags] but operates directly on an SV instead of just the
2829 string. Mostly uses sv_2pv_flags to do its work, except when that
2830 would lose the UTF-8'ness of the PV.
2836 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
2839 const char * const s = SvPV_const(ssv,len);
2840 sv_setpvn(dsv,s,len);
2848 =for apidoc sv_2pvbyte
2850 Return a pointer to the byte-encoded representation of the SV, and set *lp
2851 to its length. May cause the SV to be downgraded from UTF-8 as a
2854 Usually accessed via the C<SvPVbyte> macro.
2860 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2862 sv_utf8_downgrade(sv,0);
2863 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
2867 =for apidoc sv_2pvutf8
2869 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
2870 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
2872 Usually accessed via the C<SvPVutf8> macro.
2878 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2880 sv_utf8_upgrade(sv);
2881 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
2886 =for apidoc sv_2bool
2888 This function is only called on magical items, and is only used by
2889 sv_true() or its macro equivalent.
2895 Perl_sv_2bool(pTHX_ register SV *sv)
2904 SV * const tmpsv = AMG_CALLun(sv,bool_);
2905 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2906 return (bool)SvTRUE(tmpsv);
2908 return SvRV(sv) != 0;
2911 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
2913 (*sv->sv_u.svu_pv > '0' ||
2914 Xpvtmp->xpv_cur > 1 ||
2915 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
2922 return SvIVX(sv) != 0;
2925 return SvNVX(sv) != 0.0;
2927 if ((SvFLAGS(sv) & SVp_SCREAM)
2928 && (SvTYPE(sv) == (SVt_PVGV) || SvTYPE(sv) == (SVt_PVLV)))
2938 =for apidoc sv_utf8_upgrade
2940 Converts the PV of an SV to its UTF-8-encoded form.
2941 Forces the SV to string form if it is not already.
2942 Always sets the SvUTF8 flag to avoid future validity checks even
2943 if all the bytes have hibit clear.
2945 This is not as a general purpose byte encoding to Unicode interface:
2946 use the Encode extension for that.
2948 =for apidoc sv_utf8_upgrade_flags
2950 Converts the PV of an SV to its UTF-8-encoded form.
2951 Forces the SV to string form if it is not already.
2952 Always sets the SvUTF8 flag to avoid future validity checks even
2953 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
2954 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
2955 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
2957 This is not as a general purpose byte encoding to Unicode interface:
2958 use the Encode extension for that.
2964 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
2967 if (sv == &PL_sv_undef)
2971 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
2972 (void) sv_2pv_flags(sv,&len, flags);
2976 (void) SvPV_force(sv,len);
2985 sv_force_normal_flags(sv, 0);
2988 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
2989 sv_recode_to_utf8(sv, PL_encoding);
2990 else { /* Assume Latin-1/EBCDIC */
2991 /* This function could be much more efficient if we
2992 * had a FLAG in SVs to signal if there are any hibit
2993 * chars in the PV. Given that there isn't such a flag
2994 * make the loop as fast as possible. */
2995 const U8 * const s = (U8 *) SvPVX_const(sv);
2996 const U8 * const e = (U8 *) SvEND(sv);
3001 /* Check for hi bit */
3002 if (!NATIVE_IS_INVARIANT(ch)) {
3003 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3004 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
3006 SvPV_free(sv); /* No longer using what was there before. */
3007 SvPV_set(sv, (char*)recoded);
3008 SvCUR_set(sv, len - 1);
3009 SvLEN_set(sv, len); /* No longer know the real size. */
3013 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3020 =for apidoc sv_utf8_downgrade
3022 Attempts to convert the PV of an SV from characters to bytes.
3023 If the PV contains a character beyond byte, this conversion will fail;
3024 in this case, either returns false or, if C<fail_ok> is not
3027 This is not as a general purpose Unicode to byte encoding interface:
3028 use the Encode extension for that.
3034 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3037 if (SvPOKp(sv) && SvUTF8(sv)) {
3043 sv_force_normal_flags(sv, 0);
3045 s = (U8 *) SvPV(sv, len);
3046 if (!utf8_to_bytes(s, &len)) {
3051 Perl_croak(aTHX_ "Wide character in %s",
3054 Perl_croak(aTHX_ "Wide character");
3065 =for apidoc sv_utf8_encode
3067 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3068 flag off so that it looks like octets again.
3074 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3076 (void) sv_utf8_upgrade(sv);
3078 sv_force_normal_flags(sv, 0);
3080 if (SvREADONLY(sv)) {
3081 Perl_croak(aTHX_ PL_no_modify);
3087 =for apidoc sv_utf8_decode
3089 If the PV of the SV is an octet sequence in UTF-8
3090 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3091 so that it looks like a character. If the PV contains only single-byte
3092 characters, the C<SvUTF8> flag stays being off.
3093 Scans PV for validity and returns false if the PV is invalid UTF-8.
3099 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3105 /* The octets may have got themselves encoded - get them back as
3108 if (!sv_utf8_downgrade(sv, TRUE))
3111 /* it is actually just a matter of turning the utf8 flag on, but
3112 * we want to make sure everything inside is valid utf8 first.
3114 c = (const U8 *) SvPVX_const(sv);
3115 if (!is_utf8_string(c, SvCUR(sv)+1))
3117 e = (const U8 *) SvEND(sv);
3120 if (!UTF8_IS_INVARIANT(ch)) {
3130 =for apidoc sv_setsv
3132 Copies the contents of the source SV C<ssv> into the destination SV
3133 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3134 function if the source SV needs to be reused. Does not handle 'set' magic.
3135 Loosely speaking, it performs a copy-by-value, obliterating any previous
3136 content of the destination.
3138 You probably want to use one of the assortment of wrappers, such as
3139 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3140 C<SvSetMagicSV_nosteal>.
3142 =for apidoc sv_setsv_flags
3144 Copies the contents of the source SV C<ssv> into the destination SV
3145 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3146 function if the source SV needs to be reused. Does not handle 'set' magic.
3147 Loosely speaking, it performs a copy-by-value, obliterating any previous
3148 content of the destination.
3149 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3150 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3151 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3152 and C<sv_setsv_nomg> are implemented in terms of this function.
3154 You probably want to use one of the assortment of wrappers, such as
3155 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3156 C<SvSetMagicSV_nosteal>.
3158 This is the primary function for copying scalars, and most other
3159 copy-ish functions and macros use this underneath.
3165 S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype)
3167 if (dtype != SVt_PVGV) {
3168 const char * const name = GvNAME(sstr);
3169 const STRLEN len = GvNAMELEN(sstr);
3170 /* don't upgrade SVt_PVLV: it can hold a glob */
3171 if (dtype != SVt_PVLV)
3172 sv_upgrade(dstr, SVt_PVGV);
3173 sv_magic(dstr, dstr, PERL_MAGIC_glob, NULL, 0);
3174 GvSTASH(dstr) = GvSTASH(sstr);
3176 Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3177 GvNAME(dstr) = savepvn(name, len);
3178 GvNAMELEN(dstr) = len;
3179 SvFAKE_on(dstr); /* can coerce to non-glob */
3182 #ifdef GV_UNIQUE_CHECK
3183 if (GvUNIQUE((GV*)dstr)) {
3184 Perl_croak(aTHX_ PL_no_modify);
3188 (void)SvOK_off(dstr);
3190 GvINTRO_off(dstr); /* one-shot flag */
3192 GvGP(dstr) = gp_ref(GvGP(sstr));
3193 if (SvTAINTED(sstr))
3195 if (GvIMPORTED(dstr) != GVf_IMPORTED
3196 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3198 GvIMPORTED_on(dstr);
3205 S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) {
3206 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3208 const int intro = GvINTRO(dstr);
3211 const U32 stype = SvTYPE(sref);
3214 #ifdef GV_UNIQUE_CHECK
3215 if (GvUNIQUE((GV*)dstr)) {
3216 Perl_croak(aTHX_ PL_no_modify);
3221 GvINTRO_off(dstr); /* one-shot flag */
3222 GvLINE(dstr) = CopLINE(PL_curcop);
3223 GvEGV(dstr) = (GV*)dstr;
3228 location = (SV **) &GvCV(dstr);
3229 import_flag = GVf_IMPORTED_CV;
3232 location = (SV **) &GvHV(dstr);
3233 import_flag = GVf_IMPORTED_HV;
3236 location = (SV **) &GvAV(dstr);
3237 import_flag = GVf_IMPORTED_AV;
3240 location = (SV **) &GvIOp(dstr);
3243 location = (SV **) &GvFORM(dstr);
3245 location = &GvSV(dstr);
3246 import_flag = GVf_IMPORTED_SV;
3249 if (stype == SVt_PVCV) {
3250 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3251 SvREFCNT_dec(GvCV(dstr));
3253 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3254 PL_sub_generation++;
3257 SAVEGENERICSV(*location);
3261 if (stype == SVt_PVCV && *location != sref) {
3262 CV* const cv = (CV*)*location;
3264 if (!GvCVGEN((GV*)dstr) &&
3265 (CvROOT(cv) || CvXSUB(cv)))
3267 /* Redefining a sub - warning is mandatory if
3268 it was a const and its value changed. */
3269 if (CvCONST(cv) && CvCONST((CV*)sref)
3270 && cv_const_sv(cv) == cv_const_sv((CV*)sref)) {
3272 /* They are 2 constant subroutines generated from
3273 the same constant. This probably means that
3274 they are really the "same" proxy subroutine
3275 instantiated in 2 places. Most likely this is
3276 when a constant is exported twice. Don't warn.
3279 else if (ckWARN(WARN_REDEFINE)
3281 && (!CvCONST((CV*)sref)
3282 || sv_cmp(cv_const_sv(cv),
3283 cv_const_sv((CV*)sref))))) {
3284 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3286 ? "Constant subroutine %s::%s redefined"
3287 : "Subroutine %s::%s redefined",
3288 HvNAME_get(GvSTASH((GV*)dstr)),
3289 GvENAME((GV*)dstr));
3293 cv_ckproto(cv, (GV*)dstr,
3294 SvPOK(sref) ? SvPVX_const(sref) : NULL);
3296 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3297 GvASSUMECV_on(dstr);
3298 PL_sub_generation++;
3301 if (import_flag && !(GvFLAGS(dstr) & import_flag)
3302 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3303 GvFLAGS(dstr) |= import_flag;
3309 if (SvTAINTED(sstr))
3315 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3318 register U32 sflags;
3324 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3326 sstr = &PL_sv_undef;
3327 stype = SvTYPE(sstr);
3328 dtype = SvTYPE(dstr);
3333 /* need to nuke the magic */
3335 SvRMAGICAL_off(dstr);
3338 /* There's a lot of redundancy below but we're going for speed here */
3343 if (dtype != SVt_PVGV) {
3344 (void)SvOK_off(dstr);
3352 sv_upgrade(dstr, SVt_IV);
3355 sv_upgrade(dstr, SVt_PVNV);
3359 sv_upgrade(dstr, SVt_PVIV);
3362 (void)SvIOK_only(dstr);
3363 SvIV_set(dstr, SvIVX(sstr));
3366 /* SvTAINTED can only be true if the SV has taint magic, which in
3367 turn means that the SV type is PVMG (or greater). This is the
3368 case statement for SVt_IV, so this cannot be true (whatever gcov
3370 assert(!SvTAINTED(sstr));
3380 sv_upgrade(dstr, SVt_NV);
3385 sv_upgrade(dstr, SVt_PVNV);
3388 SvNV_set(dstr, SvNVX(sstr));
3389 (void)SvNOK_only(dstr);
3390 /* SvTAINTED can only be true if the SV has taint magic, which in
3391 turn means that the SV type is PVMG (or greater). This is the
3392 case statement for SVt_NV, so this cannot be true (whatever gcov
3394 assert(!SvTAINTED(sstr));
3401 sv_upgrade(dstr, SVt_RV);
3404 #ifdef PERL_OLD_COPY_ON_WRITE
3405 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3406 if (dtype < SVt_PVIV)
3407 sv_upgrade(dstr, SVt_PVIV);
3414 sv_upgrade(dstr, SVt_PV);
3417 if (dtype < SVt_PVIV)
3418 sv_upgrade(dstr, SVt_PVIV);
3421 if (dtype < SVt_PVNV)
3422 sv_upgrade(dstr, SVt_PVNV);
3429 const char * const type = sv_reftype(sstr,0);
3431 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3433 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3438 if (dtype <= SVt_PVGV) {
3439 S_glob_assign_glob(aTHX_ dstr, sstr, dtype);
3445 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3447 if ((int)SvTYPE(sstr) != stype) {
3448 stype = SvTYPE(sstr);
3449 if (stype == SVt_PVGV && dtype <= SVt_PVGV) {
3450 S_glob_assign_glob(aTHX_ dstr, sstr, dtype);
3455 if (stype == SVt_PVLV)
3456 SvUPGRADE(dstr, SVt_PVNV);
3458 SvUPGRADE(dstr, (U32)stype);
3461 sflags = SvFLAGS(sstr);
3463 if (sflags & SVf_ROK) {
3464 if (dtype == SVt_PVGV &&
3465 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3468 if (GvIMPORTED(dstr) != GVf_IMPORTED
3469 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3471 GvIMPORTED_on(dstr);
3476 S_glob_assign_glob(aTHX_ dstr, sstr, dtype);
3480 if (dtype >= SVt_PV) {
3481 if (dtype == SVt_PVGV) {
3482 S_glob_assign_ref(aTHX_ dstr, sstr);
3485 if (SvPVX_const(dstr)) {
3491 (void)SvOK_off(dstr);
3492 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3493 SvFLAGS(dstr) |= sflags & (SVf_ROK|SVf_AMAGIC);
3494 assert(!(sflags & SVp_NOK));
3495 assert(!(sflags & SVp_IOK));
3496 assert(!(sflags & SVf_NOK));
3497 assert(!(sflags & SVf_IOK));
3499 else if (sflags & SVp_POK) {
3503 * Check to see if we can just swipe the string. If so, it's a
3504 * possible small lose on short strings, but a big win on long ones.
3505 * It might even be a win on short strings if SvPVX_const(dstr)
3506 * has to be allocated and SvPVX_const(sstr) has to be freed.
3509 /* Whichever path we take through the next code, we want this true,
3510 and doing it now facilitates the COW check. */
3511 (void)SvPOK_only(dstr);
3514 /* We're not already COW */
3515 ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
3516 #ifndef PERL_OLD_COPY_ON_WRITE
3517 /* or we are, but dstr isn't a suitable target. */
3518 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
3523 (sflags & SVs_TEMP) && /* slated for free anyway? */
3524 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3525 (!(flags & SV_NOSTEAL)) &&
3526 /* and we're allowed to steal temps */
3527 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3528 SvLEN(sstr) && /* and really is a string */
3529 /* and won't be needed again, potentially */
3530 !(PL_op && PL_op->op_type == OP_AASSIGN))
3531 #ifdef PERL_OLD_COPY_ON_WRITE
3532 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
3533 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
3534 && SvTYPE(sstr) >= SVt_PVIV)
3537 /* Failed the swipe test, and it's not a shared hash key either.
3538 Have to copy the string. */
3539 STRLEN len = SvCUR(sstr);
3540 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3541 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
3542 SvCUR_set(dstr, len);
3543 *SvEND(dstr) = '\0';
3545 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
3547 /* Either it's a shared hash key, or it's suitable for
3548 copy-on-write or we can swipe the string. */
3550 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
3554 #ifdef PERL_OLD_COPY_ON_WRITE
3556 /* I believe I should acquire a global SV mutex if
3557 it's a COW sv (not a shared hash key) to stop
3558 it going un copy-on-write.
3559 If the source SV has gone un copy on write between up there
3560 and down here, then (assert() that) it is of the correct
3561 form to make it copy on write again */
3562 if ((sflags & (SVf_FAKE | SVf_READONLY))
3563 != (SVf_FAKE | SVf_READONLY)) {
3564 SvREADONLY_on(sstr);
3566 /* Make the source SV into a loop of 1.
3567 (about to become 2) */
3568 SV_COW_NEXT_SV_SET(sstr, sstr);
3572 /* Initial code is common. */
3573 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
3578 /* making another shared SV. */
3579 STRLEN cur = SvCUR(sstr);
3580 STRLEN len = SvLEN(sstr);
3581 #ifdef PERL_OLD_COPY_ON_WRITE
3583 assert (SvTYPE(dstr) >= SVt_PVIV);
3584 /* SvIsCOW_normal */
3585 /* splice us in between source and next-after-source. */
3586 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3587 SV_COW_NEXT_SV_SET(sstr, dstr);
3588 SvPV_set(dstr, SvPVX_mutable(sstr));
3592 /* SvIsCOW_shared_hash */
3593 DEBUG_C(PerlIO_printf(Perl_debug_log,
3594 "Copy on write: Sharing hash\n"));
3596 assert (SvTYPE(dstr) >= SVt_PV);
3598 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
3600 SvLEN_set(dstr, len);
3601 SvCUR_set(dstr, cur);
3602 SvREADONLY_on(dstr);
3604 /* Relesase a global SV mutex. */
3607 { /* Passes the swipe test. */
3608 SvPV_set(dstr, SvPVX_mutable(sstr));
3609 SvLEN_set(dstr, SvLEN(sstr));
3610 SvCUR_set(dstr, SvCUR(sstr));
3613 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3614 SvPV_set(sstr, NULL);
3620 if (sflags & SVp_NOK) {
3621 SvNV_set(dstr, SvNVX(sstr));
3623 if (sflags & SVp_IOK) {
3624 SvRELEASE_IVX(dstr);
3625 SvIV_set(dstr, SvIVX(sstr));
3626 /* Must do this otherwise some other overloaded use of 0x80000000
3627 gets confused. I guess SVpbm_VALID */
3628 if (sflags & SVf_IVisUV)
3631 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
3633 const MAGIC * const smg = SvVOK(sstr);
3635 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
3636 smg->mg_ptr, smg->mg_len);
3637 SvRMAGICAL_on(dstr);
3641 else if (sflags & (SVp_IOK|SVp_NOK)) {
3642 (void)SvOK_off(dstr);
3643 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
3644 if (sflags & SVp_IOK) {
3645 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3646 SvIV_set(dstr, SvIVX(sstr));
3648 if (sflags & SVp_NOK) {
3649 SvNV_set(dstr, SvNVX(sstr));
3653 if (dtype == SVt_PVGV) {
3654 if (ckWARN(WARN_MISC))
3655 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
3657 else if ((stype == SVt_PVGV || stype == SVt_PVLV)
3658 && (sflags & SVp_SCREAM)) {
3659 /* This stringification rule for globs is spread in 3 places.
3660 This feels bad. FIXME. */
3661 const U32 wasfake = sflags & SVf_FAKE;
3663 /* FAKE globs can get coerced, so need to turn this off
3664 temporarily if it is on. */
3666 gv_efullname3(dstr, (GV *)sstr, "*");
3667 SvFLAGS(sstr) |= wasfake;
3670 (void)SvOK_off(dstr);
3672 if (SvTAINTED(sstr))
3677 =for apidoc sv_setsv_mg
3679 Like C<sv_setsv>, but also handles 'set' magic.
3685 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3687 sv_setsv(dstr,sstr);
3691 #ifdef PERL_OLD_COPY_ON_WRITE
3693 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
3695 STRLEN cur = SvCUR(sstr);
3696 STRLEN len = SvLEN(sstr);
3697 register char *new_pv;
3700 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
3708 if (SvTHINKFIRST(dstr))
3709 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
3710 else if (SvPVX_const(dstr))
3711 Safefree(SvPVX_const(dstr));
3715 SvUPGRADE(dstr, SVt_PVIV);
3717 assert (SvPOK(sstr));
3718 assert (SvPOKp(sstr));
3719 assert (!SvIOK(sstr));
3720 assert (!SvIOKp(sstr));
3721 assert (!SvNOK(sstr));
3722 assert (!SvNOKp(sstr));
3724 if (SvIsCOW(sstr)) {
3726 if (SvLEN(sstr) == 0) {
3727 /* source is a COW shared hash key. */
3728 DEBUG_C(PerlIO_printf(Perl_debug_log,
3729 "Fast copy on write: Sharing hash\n"));
3730 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
3733 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3735 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
3736 SvUPGRADE(sstr, SVt_PVIV);
3737 SvREADONLY_on(sstr);
3739 DEBUG_C(PerlIO_printf(Perl_debug_log,
3740 "Fast copy on write: Converting sstr to COW\n"));
3741 SV_COW_NEXT_SV_SET(dstr, sstr);
3743 SV_COW_NEXT_SV_SET(sstr, dstr);
3744 new_pv = SvPVX_mutable(sstr);
3747 SvPV_set(dstr, new_pv);
3748 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
3751 SvLEN_set(dstr, len);
3752 SvCUR_set(dstr, cur);
3761 =for apidoc sv_setpvn
3763 Copies a string into an SV. The C<len> parameter indicates the number of
3764 bytes to be copied. If the C<ptr> argument is NULL the SV will become
3765 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3771 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3774 register char *dptr;
3776 SV_CHECK_THINKFIRST_COW_DROP(sv);
3782 /* len is STRLEN which is unsigned, need to copy to signed */
3785 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3787 SvUPGRADE(sv, SVt_PV);
3789 dptr = SvGROW(sv, len + 1);
3790 Move(ptr,dptr,len,char);
3793 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3798 =for apidoc sv_setpvn_mg
3800 Like C<sv_setpvn>, but also handles 'set' magic.
3806 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3808 sv_setpvn(sv,ptr,len);
3813 =for apidoc sv_setpv
3815 Copies a string into an SV. The string must be null-terminated. Does not
3816 handle 'set' magic. See C<sv_setpv_mg>.
3822 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3825 register STRLEN len;
3827 SV_CHECK_THINKFIRST_COW_DROP(sv);
3833 SvUPGRADE(sv, SVt_PV);
3835 SvGROW(sv, len + 1);
3836 Move(ptr,SvPVX(sv),len+1,char);
3838 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3843 =for apidoc sv_setpv_mg
3845 Like C<sv_setpv>, but also handles 'set' magic.
3851 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3858 =for apidoc sv_usepvn
3860 Tells an SV to use C<ptr> to find its string value. Normally the string is
3861 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3862 The C<ptr> should point to memory that was allocated by C<malloc>. The
3863 string length, C<len>, must be supplied. This function will realloc the
3864 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3865 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3866 See C<sv_usepvn_mg>.
3872 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3876 SV_CHECK_THINKFIRST_COW_DROP(sv);
3877 SvUPGRADE(sv, SVt_PV);
3882 if (SvPVX_const(sv))
3885 allocate = PERL_STRLEN_ROUNDUP(len + 1);
3886 ptr = saferealloc (ptr, allocate);
3889 SvLEN_set(sv, allocate);
3891 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3896 =for apidoc sv_usepvn_mg
3898 Like C<sv_usepvn>, but also handles 'set' magic.
3904 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3906 sv_usepvn(sv,ptr,len);
3910 #ifdef PERL_OLD_COPY_ON_WRITE
3911 /* Need to do this *after* making the SV normal, as we need the buffer
3912 pointer to remain valid until after we've copied it. If we let go too early,
3913 another thread could invalidate it by unsharing last of the same hash key
3914 (which it can do by means other than releasing copy-on-write Svs)
3915 or by changing the other copy-on-write SVs in the loop. */
3917 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
3919 if (len) { /* this SV was SvIsCOW_normal(sv) */
3920 /* we need to find the SV pointing to us. */
3921 SV *current = SV_COW_NEXT_SV(after);
3923 if (current == sv) {
3924 /* The SV we point to points back to us (there were only two of us
3926 Hence other SV is no longer copy on write either. */
3928 SvREADONLY_off(after);
3930 /* We need to follow the pointers around the loop. */
3932 while ((next = SV_COW_NEXT_SV(current)) != sv) {
3935 /* don't loop forever if the structure is bust, and we have
3936 a pointer into a closed loop. */
3937 assert (current != after);
3938 assert (SvPVX_const(current) == pvx);
3940 /* Make the SV before us point to the SV after us. */
3941 SV_COW_NEXT_SV_SET(current, after);
3944 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
3949 Perl_sv_release_IVX(pTHX_ register SV *sv)
3952 sv_force_normal_flags(sv, 0);
3958 =for apidoc sv_force_normal_flags
3960 Undo various types of fakery on an SV: if the PV is a shared string, make
3961 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
3962 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
3963 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
3964 then a copy-on-write scalar drops its PV buffer (if any) and becomes
3965 SvPOK_off rather than making a copy. (Used where this scalar is about to be
3966 set to some other value.) In addition, the C<flags> parameter gets passed to
3967 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
3968 with flags set to 0.
3974 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3977 #ifdef PERL_OLD_COPY_ON_WRITE
3978 if (SvREADONLY(sv)) {
3979 /* At this point I believe I should acquire a global SV mutex. */
3981 const char * const pvx = SvPVX_const(sv);
3982 const STRLEN len = SvLEN(sv);
3983 const STRLEN cur = SvCUR(sv);
3984 SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
3986 PerlIO_printf(Perl_debug_log,
3987 "Copy on write: Force normal %ld\n",
3993 /* This SV doesn't own the buffer, so need to Newx() a new one: */
3996 if (flags & SV_COW_DROP_PV) {
3997 /* OK, so we don't need to copy our buffer. */
4000 SvGROW(sv, cur + 1);
4001 Move(pvx,SvPVX(sv),cur,char);
4005 sv_release_COW(sv, pvx, len, next);
4010 else if (IN_PERL_RUNTIME)
4011 Perl_croak(aTHX_ PL_no_modify);
4012 /* At this point I believe that I can drop the global SV mutex. */
4015 if (SvREADONLY(sv)) {
4017 const char * const pvx = SvPVX_const(sv);
4018 const STRLEN len = SvCUR(sv);
4023 SvGROW(sv, len + 1);
4024 Move(pvx,SvPVX(sv),len,char);
4026 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4028 else if (IN_PERL_RUNTIME)
4029 Perl_croak(aTHX_ PL_no_modify);
4033 sv_unref_flags(sv, flags);
4034 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4041 Efficient removal of characters from the beginning of the string buffer.
4042 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4043 the string buffer. The C<ptr> becomes the first character of the adjusted
4044 string. Uses the "OOK hack".
4045 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4046 refer to the same chunk of data.
4052 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
4054 register STRLEN delta;
4055 if (!ptr || !SvPOKp(sv))
4057 delta = ptr - SvPVX_const(sv);
4058 SV_CHECK_THINKFIRST(sv);
4059 if (SvTYPE(sv) < SVt_PVIV)
4060 sv_upgrade(sv,SVt_PVIV);
4063 if (!SvLEN(sv)) { /* make copy of shared string */
4064 const char *pvx = SvPVX_const(sv);
4065 const STRLEN len = SvCUR(sv);
4066 SvGROW(sv, len + 1);
4067 Move(pvx,SvPVX(sv),len,char);
4071 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
4072 and we do that anyway inside the SvNIOK_off
4074 SvFLAGS(sv) |= SVf_OOK;
4077 SvLEN_set(sv, SvLEN(sv) - delta);
4078 SvCUR_set(sv, SvCUR(sv) - delta);
4079 SvPV_set(sv, SvPVX(sv) + delta);
4080 SvIV_set(sv, SvIVX(sv) + delta);
4084 =for apidoc sv_catpvn
4086 Concatenates the string onto the end of the string which is in the SV. The
4087 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4088 status set, then the bytes appended should be valid UTF-8.
4089 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4091 =for apidoc sv_catpvn_flags
4093 Concatenates the string onto the end of the string which is in the SV. The
4094 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4095 status set, then the bytes appended should be valid UTF-8.
4096 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4097 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4098 in terms of this function.
4104 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4108 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4110 SvGROW(dsv, dlen + slen + 1);
4112 sstr = SvPVX_const(dsv);
4113 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4114 SvCUR_set(dsv, SvCUR(dsv) + slen);
4116 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4118 if (flags & SV_SMAGIC)
4123 =for apidoc sv_catsv
4125 Concatenates the string from SV C<ssv> onto the end of the string in
4126 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4127 not 'set' magic. See C<sv_catsv_mg>.
4129 =for apidoc sv_catsv_flags
4131 Concatenates the string from SV C<ssv> onto the end of the string in
4132 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4133 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4134 and C<sv_catsv_nomg> are implemented in terms of this function.
4139 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4144 const char *spv = SvPV_const(ssv, slen);
4146 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4147 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4148 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4149 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4150 dsv->sv_flags doesn't have that bit set.
4151 Andy Dougherty 12 Oct 2001
4153 const I32 sutf8 = DO_UTF8(ssv);
4156 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4158 dutf8 = DO_UTF8(dsv);
4160 if (dutf8 != sutf8) {
4162 /* Not modifying source SV, so taking a temporary copy. */
4163 SV* const csv = sv_2mortal(newSVpvn(spv, slen));
4165 sv_utf8_upgrade(csv);
4166 spv = SvPV_const(csv, slen);
4169 sv_utf8_upgrade_nomg(dsv);
4171 sv_catpvn_nomg(dsv, spv, slen);
4174 if (flags & SV_SMAGIC)
4179 =for apidoc sv_catpv
4181 Concatenates the string onto the end of the string which is in the SV.
4182 If the SV has the UTF-8 status set, then the bytes appended should be
4183 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4188 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4191 register STRLEN len;
4197 junk = SvPV_force(sv, tlen);
4199 SvGROW(sv, tlen + len + 1);
4201 ptr = SvPVX_const(sv);
4202 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4203 SvCUR_set(sv, SvCUR(sv) + len);
4204 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4209 =for apidoc sv_catpv_mg
4211 Like C<sv_catpv>, but also handles 'set' magic.
4217 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4226 Creates a new SV. A non-zero C<len> parameter indicates the number of
4227 bytes of preallocated string space the SV should have. An extra byte for a
4228 trailing NUL is also reserved. (SvPOK is not set for the SV even if string
4229 space is allocated.) The reference count for the new SV is set to 1.
4231 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
4232 parameter, I<x>, a debug aid which allowed callers to identify themselves.
4233 This aid has been superseded by a new build option, PERL_MEM_LOG (see
4234 L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
4235 modules supporting older perls.
4241 Perl_newSV(pTHX_ STRLEN len)
4248 sv_upgrade(sv, SVt_PV);
4249 SvGROW(sv, len + 1);
4254 =for apidoc sv_magicext
4256 Adds magic to an SV, upgrading it if necessary. Applies the
4257 supplied vtable and returns a pointer to the magic added.
4259 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4260 In particular, you can add magic to SvREADONLY SVs, and add more than
4261 one instance of the same 'how'.
4263 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4264 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4265 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4266 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4268 (This is now used as a subroutine by C<sv_magic>.)
4273 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
4274 const char* name, I32 namlen)
4279 if (SvTYPE(sv) < SVt_PVMG) {
4280 SvUPGRADE(sv, SVt_PVMG);
4282 Newxz(mg, 1, MAGIC);
4283 mg->mg_moremagic = SvMAGIC(sv);
4284 SvMAGIC_set(sv, mg);
4286 /* Sometimes a magic contains a reference loop, where the sv and
4287 object refer to each other. To prevent a reference loop that
4288 would prevent such objects being freed, we look for such loops
4289 and if we find one we avoid incrementing the object refcount.
4291 Note we cannot do this to avoid self-tie loops as intervening RV must
4292 have its REFCNT incremented to keep it in existence.
4295 if (!obj || obj == sv ||
4296 how == PERL_MAGIC_arylen ||
4297 how == PERL_MAGIC_qr ||
4298 how == PERL_MAGIC_symtab ||
4299 (SvTYPE(obj) == SVt_PVGV &&
4300 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4301 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4302 GvFORM(obj) == (CV*)sv)))
4307 mg->mg_obj = SvREFCNT_inc(obj);
4308 mg->mg_flags |= MGf_REFCOUNTED;
4311 /* Normal self-ties simply pass a null object, and instead of
4312 using mg_obj directly, use the SvTIED_obj macro to produce a
4313 new RV as needed. For glob "self-ties", we are tieing the PVIO
4314 with an RV obj pointing to the glob containing the PVIO. In
4315 this case, to avoid a reference loop, we need to weaken the
4319 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4320 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4326 mg->mg_len = namlen;
4329 mg->mg_ptr = savepvn(name, namlen);
4330 else if (namlen == HEf_SVKEY)
4331 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4333 mg->mg_ptr = (char *) name;
4335 mg->mg_virtual = vtable;
4339 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4344 =for apidoc sv_magic
4346 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4347 then adds a new magic item of type C<how> to the head of the magic list.
4349 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4350 handling of the C<name> and C<namlen> arguments.
4352 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4353 to add more than one instance of the same 'how'.
4359 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4365 #ifdef PERL_OLD_COPY_ON_WRITE
4367 sv_force_normal_flags(sv, 0);
4369 if (SvREADONLY(sv)) {
4371 /* its okay to attach magic to shared strings; the subsequent
4372 * upgrade to PVMG will unshare the string */
4373 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4376 && how != PERL_MAGIC_regex_global
4377 && how != PERL_MAGIC_bm
4378 && how != PERL_MAGIC_fm
4379 && how != PERL_MAGIC_sv
4380 && how != PERL_MAGIC_backref
4383 Perl_croak(aTHX_ PL_no_modify);
4386 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4387 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4388 /* sv_magic() refuses to add a magic of the same 'how' as an
4391 if (how == PERL_MAGIC_taint) {
4393 /* Any scalar which already had taint magic on which someone
4394 (erroneously?) did SvIOK_on() or similar will now be
4395 incorrectly sporting public "OK" flags. */
4396 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4404 vtable = &PL_vtbl_sv;
4406 case PERL_MAGIC_overload:
4407 vtable = &PL_vtbl_amagic;
4409 case PERL_MAGIC_overload_elem:
4410 vtable = &PL_vtbl_amagicelem;
4412 case PERL_MAGIC_overload_table:
4413 vtable = &PL_vtbl_ovrld;
4416 vtable = &PL_vtbl_bm;
4418 case PERL_MAGIC_regdata:
4419 vtable = &PL_vtbl_regdata;
4421 case PERL_MAGIC_regdatum:
4422 vtable = &PL_vtbl_regdatum;
4424 case PERL_MAGIC_env:
4425 vtable = &PL_vtbl_env;
4428 vtable = &PL_vtbl_fm;
4430 case PERL_MAGIC_envelem:
4431 vtable = &PL_vtbl_envelem;
4433 case PERL_MAGIC_regex_global:
4434 vtable = &PL_vtbl_mglob;
4436 case PERL_MAGIC_isa:
4437 vtable = &PL_vtbl_isa;
4439 case PERL_MAGIC_isaelem:
4440 vtable = &PL_vtbl_isaelem;
4442 case PERL_MAGIC_nkeys:
4443 vtable = &PL_vtbl_nkeys;
4445 case PERL_MAGIC_dbfile:
4448 case PERL_MAGIC_dbline:
4449 vtable = &PL_vtbl_dbline;
4451 #ifdef USE_LOCALE_COLLATE
4452 case PERL_MAGIC_collxfrm:
4453 vtable = &PL_vtbl_collxfrm;
4455 #endif /* USE_LOCALE_COLLATE */
4456 case PERL_MAGIC_tied:
4457 vtable = &PL_vtbl_pack;
4459 case PERL_MAGIC_tiedelem:
4460 case PERL_MAGIC_tiedscalar:
4461 vtable = &PL_vtbl_packelem;
4464 vtable = &PL_vtbl_regexp;
4466 case PERL_MAGIC_sig:
4467 vtable = &PL_vtbl_sig;
4469 case PERL_MAGIC_sigelem:
4470 vtable = &PL_vtbl_sigelem;
4472 case PERL_MAGIC_taint:
4473 vtable = &PL_vtbl_taint;
4475 case PERL_MAGIC_uvar:
4476 vtable = &PL_vtbl_uvar;
4478 case PERL_MAGIC_vec:
4479 vtable = &PL_vtbl_vec;
4481 case PERL_MAGIC_arylen_p:
4482 case PERL_MAGIC_rhash:
4483 case PERL_MAGIC_symtab:
4484 case PERL_MAGIC_vstring:
4487 case PERL_MAGIC_utf8:
4488 vtable = &PL_vtbl_utf8;
4490 case PERL_MAGIC_substr:
4491 vtable = &PL_vtbl_substr;
4493 case PERL_MAGIC_defelem:
4494 vtable = &PL_vtbl_defelem;
4496 case PERL_MAGIC_glob:
4497 vtable = &PL_vtbl_glob;
4499 case PERL_MAGIC_arylen:
4500 vtable = &PL_vtbl_arylen;
4502 case PERL_MAGIC_pos:
4503 vtable = &PL_vtbl_pos;
4505 case PERL_MAGIC_backref:
4506 vtable = &PL_vtbl_backref;
4508 case PERL_MAGIC_ext:
4509 /* Reserved for use by extensions not perl internals. */
4510 /* Useful for attaching extension internal data to perl vars. */
4511 /* Note that multiple extensions may clash if magical scalars */
4512 /* etc holding private data from one are passed to another. */
4516 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4519 /* Rest of work is done else where */
4520 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4523 case PERL_MAGIC_taint:
4526 case PERL_MAGIC_ext:
4527 case PERL_MAGIC_dbfile:
4534 =for apidoc sv_unmagic
4536 Removes all magic of type C<type> from an SV.
4542 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4546 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4549 for (mg = *mgp; mg; mg = *mgp) {
4550 if (mg->mg_type == type) {
4551 const MGVTBL* const vtbl = mg->mg_virtual;
4552 *mgp = mg->mg_moremagic;
4553 if (vtbl && vtbl->svt_free)
4554 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4555 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4557 Safefree(mg->mg_ptr);
4558 else if (mg->mg_len == HEf_SVKEY)
4559 SvREFCNT_dec((SV*)mg->mg_ptr);
4560 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
4561 Safefree(mg->mg_ptr);
4563 if (mg->mg_flags & MGf_REFCOUNTED)
4564 SvREFCNT_dec(mg->mg_obj);
4568 mgp = &mg->mg_moremagic;
4572 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4573 SvMAGIC_set(sv, NULL);
4580 =for apidoc sv_rvweaken
4582 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4583 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4584 push a back-reference to this RV onto the array of backreferences
4585 associated with that magic.
4591 Perl_sv_rvweaken(pTHX_ SV *sv)
4594 if (!SvOK(sv)) /* let undefs pass */
4597 Perl_croak(aTHX_ "Can't weaken a nonreference");
4598 else if (SvWEAKREF(sv)) {
4599 if (ckWARN(WARN_MISC))
4600 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
4604 Perl_sv_add_backref(aTHX_ tsv, sv);
4610 /* Give tsv backref magic if it hasn't already got it, then push a
4611 * back-reference to sv onto the array associated with the backref magic.
4615 Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4620 if (SvTYPE(tsv) == SVt_PVHV) {
4621 AV **const avp = Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
4625 /* There is no AV in the offical place - try a fixup. */
4626 MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
4629 /* Aha. They've got it stowed in magic. Bring it back. */
4630 av = (AV*)mg->mg_obj;
4631 /* Stop mg_free decreasing the refernce count. */
4633 /* Stop mg_free even calling the destructor, given that
4634 there's no AV to free up. */
4636 sv_unmagic(tsv, PERL_MAGIC_backref);
4645 const MAGIC *const mg
4646 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
4648 av = (AV*)mg->mg_obj;
4652 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4653 /* av now has a refcnt of 2, which avoids it getting freed
4654 * before us during global cleanup. The extra ref is removed
4655 * by magic_killbackrefs() when tsv is being freed */
4658 if (AvFILLp(av) >= AvMAX(av)) {
4659 av_extend(av, AvFILLp(av)+1);
4661 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
4664 /* delete a back-reference to ourselves from the backref magic associated
4665 * with the SV we point to.
4669 S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
4676 if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
4677 av = *Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
4678 /* We mustn't attempt to "fix up" the hash here by moving the
4679 backreference array back to the hv_aux structure, as that is stored
4680 in the main HvARRAY(), and hfreentries assumes that no-one
4681 reallocates HvARRAY() while it is running. */
4684 const MAGIC *const mg
4685 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
4687 av = (AV *)mg->mg_obj;
4690 if (PL_in_clean_all)
4692 Perl_croak(aTHX_ "panic: del_backref");
4699 /* We shouldn't be in here more than once, but for paranoia reasons lets
4701 for (i = AvFILLp(av); i >= 0; i--) {
4703 const SSize_t fill = AvFILLp(av);
4705 /* We weren't the last entry.
4706 An unordered list has this property that you can take the
4707 last element off the end to fill the hole, and it's still
4708 an unordered list :-)
4713 AvFILLp(av) = fill - 1;
4719 Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *av)
4721 SV **svp = AvARRAY(av);
4723 PERL_UNUSED_ARG(sv);
4725 /* Not sure why the av can get freed ahead of its sv, but somehow it does
4726 in ext/B/t/bytecode.t test 15 (involving print <DATA>) */
4727 if (svp && !SvIS_FREED(av)) {
4728 SV *const *const last = svp + AvFILLp(av);
4730 while (svp <= last) {
4732 SV *const referrer = *svp;
4733 if (SvWEAKREF(referrer)) {
4734 /* XXX Should we check that it hasn't changed? */
4735 SvRV_set(referrer, 0);
4737 SvWEAKREF_off(referrer);
4738 } else if (SvTYPE(referrer) == SVt_PVGV ||
4739 SvTYPE(referrer) == SVt_PVLV) {
4740 /* You lookin' at me? */
4741 assert(GvSTASH(referrer));
4742 assert(GvSTASH(referrer) == (HV*)sv);
4743 GvSTASH(referrer) = 0;
4746 "panic: magic_killbackrefs (flags=%"UVxf")",
4747 (UV)SvFLAGS(referrer));
4755 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
4760 =for apidoc sv_insert
4762 Inserts a string at the specified offset/length within the SV. Similar to
4763 the Perl substr() function.
4769 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
4774 register char *midend;
4775 register char *bigend;
4781 Perl_croak(aTHX_ "Can't modify non-existent substring");
4782 SvPV_force(bigstr, curlen);
4783 (void)SvPOK_only_UTF8(bigstr);
4784 if (offset + len > curlen) {
4785 SvGROW(bigstr, offset+len+1);
4786 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4787 SvCUR_set(bigstr, offset+len);
4791 i = littlelen - len;
4792 if (i > 0) { /* string might grow */
4793 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4794 mid = big + offset + len;
4795 midend = bigend = big + SvCUR(bigstr);
4798 while (midend > mid) /* shove everything down */
4799 *--bigend = *--midend;
4800 Move(little,big+offset,littlelen,char);
4801 SvCUR_set(bigstr, SvCUR(bigstr) + i);
4806 Move(little,SvPVX(bigstr)+offset,len,char);
4811 big = SvPVX(bigstr);
4814 bigend = big + SvCUR(bigstr);
4816 if (midend > bigend)
4817 Perl_croak(aTHX_ "panic: sv_insert");
4819 if (mid - big > bigend - midend) { /* faster to shorten from end */
4821 Move(little, mid, littlelen,char);
4824 i = bigend - midend;
4826 Move(midend, mid, i,char);
4830 SvCUR_set(bigstr, mid - big);
4832 else if ((i = mid - big)) { /* faster from front */
4833 midend -= littlelen;
4835 sv_chop(bigstr,midend-i);
4840 Move(little, mid, littlelen,char);
4842 else if (littlelen) {
4843 midend -= littlelen;
4844 sv_chop(bigstr,midend);
4845 Move(little,midend,littlelen,char);
4848 sv_chop(bigstr,midend);
4854 =for apidoc sv_replace
4856 Make the first argument a copy of the second, then delete the original.
4857 The target SV physically takes over ownership of the body of the source SV
4858 and inherits its flags; however, the target keeps any magic it owns,
4859 and any magic in the source is discarded.
4860 Note that this is a rather specialist SV copying operation; most of the
4861 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
4867 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4870 const U32 refcnt = SvREFCNT(sv);
4871 SV_CHECK_THINKFIRST_COW_DROP(sv);
4872 if (SvREFCNT(nsv) != 1) {
4873 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
4874 UVuf " != 1)", (UV) SvREFCNT(nsv));
4876 if (SvMAGICAL(sv)) {
4880 sv_upgrade(nsv, SVt_PVMG);
4881 SvMAGIC_set(nsv, SvMAGIC(sv));
4882 SvFLAGS(nsv) |= SvMAGICAL(sv);
4884 SvMAGIC_set(sv, NULL);
4888 assert(!SvREFCNT(sv));
4889 #ifdef DEBUG_LEAKING_SCALARS
4890 sv->sv_flags = nsv->sv_flags;
4891 sv->sv_any = nsv->sv_any;
4892 sv->sv_refcnt = nsv->sv_refcnt;
4893 sv->sv_u = nsv->sv_u;
4895 StructCopy(nsv,sv,SV);
4897 /* Currently could join these into one piece of pointer arithmetic, but
4898 it would be unclear. */
4899 if(SvTYPE(sv) == SVt_IV)
4901 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
4902 else if (SvTYPE(sv) == SVt_RV) {
4903 SvANY(sv) = &sv->sv_u.svu_rv;
4907 #ifdef PERL_OLD_COPY_ON_WRITE
4908 if (SvIsCOW_normal(nsv)) {
4909 /* We need to follow the pointers around the loop to make the
4910 previous SV point to sv, rather than nsv. */
4913 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
4916 assert(SvPVX_const(current) == SvPVX_const(nsv));
4918 /* Make the SV before us point to the SV after us. */
4920 PerlIO_printf(Perl_debug_log, "previous is\n");
4922 PerlIO_printf(Perl_debug_log,
4923 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
4924 (UV) SV_COW_NEXT_SV(current), (UV) sv);
4926 SV_COW_NEXT_SV_SET(current, sv);
4929 SvREFCNT(sv) = refcnt;
4930 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4936 =for apidoc sv_clear
4938 Clear an SV: call any destructors, free up any memory used by the body,
4939 and free the body itself. The SV's head is I<not> freed, although
4940 its type is set to all 1's so that it won't inadvertently be assumed
4941 to be live during global destruction etc.
4942 This function should only be called when REFCNT is zero. Most of the time
4943 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
4950 Perl_sv_clear(pTHX_ register SV *sv)
4953 const U32 type = SvTYPE(sv);
4954 const struct body_details *const sv_type_details
4955 = bodies_by_type + type;
4958 assert(SvREFCNT(sv) == 0);
4960 if (type <= SVt_IV) {
4961 /* See the comment in sv.h about the collusion between this early
4962 return and the overloading of the NULL and IV slots in the size
4968 if (PL_defstash) { /* Still have a symbol table? */
4973 stash = SvSTASH(sv);
4974 destructor = StashHANDLER(stash,DESTROY);
4976 SV* const tmpref = newRV(sv);
4977 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
4979 PUSHSTACKi(PERLSI_DESTROY);
4984 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
4990 if(SvREFCNT(tmpref) < 2) {
4991 /* tmpref is not kept alive! */
4993 SvRV_set(tmpref, NULL);
4996 SvREFCNT_dec(tmpref);
4998 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5002 if (PL_in_clean_objs)
5003 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5005 /* DESTROY gave object new lease on life */
5011 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5012 SvOBJECT_off(sv); /* Curse the object. */
5013 if (type != SVt_PVIO)
5014 --PL_sv_objcount; /* XXX Might want something more general */
5017 if (type >= SVt_PVMG) {
5020 if (type == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
5021 SvREFCNT_dec(SvSTASH(sv));
5026 IoIFP(sv) != PerlIO_stdin() &&
5027 IoIFP(sv) != PerlIO_stdout() &&
5028 IoIFP(sv) != PerlIO_stderr())
5030 io_close((IO*)sv, FALSE);
5032 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5033 PerlDir_close(IoDIRP(sv));
5034 IoDIRP(sv) = (DIR*)NULL;
5035 Safefree(IoTOP_NAME(sv));
5036 Safefree(IoFMT_NAME(sv));
5037 Safefree(IoBOTTOM_NAME(sv));
5046 Perl_hv_kill_backrefs(aTHX_ (HV*)sv);
5053 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5054 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5055 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5056 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5058 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5059 SvREFCNT_dec(LvTARG(sv));
5063 Safefree(GvNAME(sv));
5064 /* If we're in a stash, we don't own a reference to it. However it does
5065 have a back reference to us, which needs to be cleared. */
5067 sv_del_backref((SV*)GvSTASH(sv), sv);
5072 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5074 SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
5075 /* Don't even bother with turning off the OOK flag. */
5080 SV *target = SvRV(sv);
5082 sv_del_backref(target, sv);
5084 SvREFCNT_dec(target);
5086 #ifdef PERL_OLD_COPY_ON_WRITE
5087 else if (SvPVX_const(sv)) {
5089 /* I believe I need to grab the global SV mutex here and
5090 then recheck the COW status. */
5092 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5095 sv_release_COW(sv, SvPVX_const(sv), SvLEN(sv),
5096 SV_COW_NEXT_SV(sv));
5097 /* And drop it here. */
5099 } else if (SvLEN(sv)) {
5100 Safefree(SvPVX_const(sv));
5104 else if (SvPVX_const(sv) && SvLEN(sv))
5105 Safefree(SvPVX_mutable(sv));
5106 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5107 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5116 SvFLAGS(sv) &= SVf_BREAK;
5117 SvFLAGS(sv) |= SVTYPEMASK;
5119 if (sv_type_details->arena) {
5120 del_body(((char *)SvANY(sv) + sv_type_details->offset),
5121 &PL_body_roots[type]);
5123 else if (sv_type_details->body_size) {
5124 my_safefree(SvANY(sv));
5129 =for apidoc sv_newref
5131 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5138 Perl_sv_newref(pTHX_ SV *sv)
5148 Decrement an SV's reference count, and if it drops to zero, call
5149 C<sv_clear> to invoke destructors and free up any memory used by
5150 the body; finally, deallocate the SV's head itself.
5151 Normally called via a wrapper macro C<SvREFCNT_dec>.
5157 Perl_sv_free(pTHX_ SV *sv)
5162 if (SvREFCNT(sv) == 0) {
5163 if (SvFLAGS(sv) & SVf_BREAK)
5164 /* this SV's refcnt has been artificially decremented to
5165 * trigger cleanup */
5167 if (PL_in_clean_all) /* All is fair */
5169 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5170 /* make sure SvREFCNT(sv)==0 happens very seldom */
5171 SvREFCNT(sv) = (~(U32)0)/2;
5174 if (ckWARN_d(WARN_INTERNAL)) {
5175 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5176 "Attempt to free unreferenced scalar: SV 0x%"UVxf
5177 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5178 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5179 Perl_dump_sv_child(aTHX_ sv);
5184 if (--(SvREFCNT(sv)) > 0)
5186 Perl_sv_free2(aTHX_ sv);
5190 Perl_sv_free2(pTHX_ SV *sv)
5195 if (ckWARN_d(WARN_DEBUGGING))
5196 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5197 "Attempt to free temp prematurely: SV 0x%"UVxf
5198 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5202 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5203 /* make sure SvREFCNT(sv)==0 happens very seldom */
5204 SvREFCNT(sv) = (~(U32)0)/2;
5215 Returns the length of the string in the SV. Handles magic and type
5216 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5222 Perl_sv_len(pTHX_ register SV *sv)
5230 len = mg_length(sv);
5232 (void)SvPV_const(sv, len);
5237 =for apidoc sv_len_utf8
5239 Returns the number of characters in the string in an SV, counting wide
5240 UTF-8 bytes as a single character. Handles magic and type coercion.
5246 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
5247 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
5248 * (Note that the mg_len is not the length of the mg_ptr field.)
5253 Perl_sv_len_utf8(pTHX_ register SV *sv)
5259 return mg_length(sv);
5263 const U8 *s = (U8*)SvPV_const(sv, len);
5264 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
5266 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
5268 #ifdef PERL_UTF8_CACHE_ASSERT
5269 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
5273 ulen = Perl_utf8_length(aTHX_ s, s + len);
5274 if (!mg && !SvREADONLY(sv)) {
5275 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5276 mg = mg_find(sv, PERL_MAGIC_utf8);
5286 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
5287 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5288 * between UTF-8 and byte offsets. There are two (substr offset and substr
5289 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
5290 * and byte offset) cache positions.
5292 * The mg_len field is used by sv_len_utf8(), see its comments.
5293 * Note that the mg_len is not the length of the mg_ptr field.
5297 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i,
5298 I32 offsetp, const U8 *s, const U8 *start)
5302 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5304 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
5308 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5310 Newxz(*cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5311 (*mgp)->mg_ptr = (char *) *cachep;
5315 (*cachep)[i] = offsetp;
5316 (*cachep)[i+1] = s - start;
5324 * S_utf8_mg_pos() is used to query and update mg_ptr field of
5325 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5326 * between UTF-8 and byte offsets. See also the comments of
5327 * S_utf8_mg_pos_init().
5331 S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, const U8 **sp, const U8 *start, const U8 *send)
5335 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5337 *mgp = mg_find(sv, PERL_MAGIC_utf8);
5338 if (*mgp && (*mgp)->mg_ptr) {
5339 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5340 ASSERT_UTF8_CACHE(*cachep);
5341 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
5343 else { /* We will skip to the right spot. */
5348 /* The assumption is that going backward is half
5349 * the speed of going forward (that's where the
5350 * 2 * backw in the below comes from). (The real
5351 * figure of course depends on the UTF-8 data.) */
5353 if ((*cachep)[i] > (STRLEN)uoff) {
5355 backw = (*cachep)[i] - (STRLEN)uoff;
5357 if (forw < 2 * backw)
5360 p = start + (*cachep)[i+1];
5362 /* Try this only for the substr offset (i == 0),
5363 * not for the substr length (i == 2). */
5364 else if (i == 0) { /* (*cachep)[i] < uoff */
5365 const STRLEN ulen = sv_len_utf8(sv);
5367 if ((STRLEN)uoff < ulen) {
5368 forw = (STRLEN)uoff - (*cachep)[i];
5369 backw = ulen - (STRLEN)uoff;
5371 if (forw < 2 * backw)
5372 p = start + (*cachep)[i+1];
5377 /* If the string is not long enough for uoff,
5378 * we could extend it, but not at this low a level. */
5382 if (forw < 2 * backw) {
5389 while (UTF8_IS_CONTINUATION(*p))
5394 /* Update the cache. */
5395 (*cachep)[i] = (STRLEN)uoff;
5396 (*cachep)[i+1] = p - start;
5398 /* Drop the stale "length" cache */
5407 if (found) { /* Setup the return values. */
5408 *offsetp = (*cachep)[i+1];
5409 *sp = start + *offsetp;
5412 *offsetp = send - start;
5414 else if (*sp < start) {
5420 #ifdef PERL_UTF8_CACHE_ASSERT
5425 while (n-- && s < send)
5429 assert(*offsetp == s - start);
5430 assert((*cachep)[0] == (STRLEN)uoff);
5431 assert((*cachep)[1] == *offsetp);
5433 ASSERT_UTF8_CACHE(*cachep);
5442 =for apidoc sv_pos_u2b
5444 Converts the value pointed to by offsetp from a count of UTF-8 chars from
5445 the start of the string, to a count of the equivalent number of bytes; if
5446 lenp is non-zero, it does the same to lenp, but this time starting from
5447 the offset, rather than from the start of the string. Handles magic and
5454 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
5455 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5456 * byte offsets. See also the comments of S_utf8_mg_pos().
5461 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5469 start = (U8*)SvPV_const(sv, len);
5472 STRLEN *cache = NULL;
5473 const U8 *s = start;
5474 I32 uoffset = *offsetp;
5475 const U8 * const send = s + len;
5477 bool found = utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send);
5479 if (!found && uoffset > 0) {
5480 while (s < send && uoffset--)
5484 if (utf8_mg_pos_init(sv, &mg, &cache, 0, *offsetp, s, start))
5486 *offsetp = s - start;
5491 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) {
5495 if (!found && *lenp > 0) {
5498 while (s < send && ulen--)
5502 utf8_mg_pos_init(sv, &mg, &cache, 2, *lenp, s, start);
5506 ASSERT_UTF8_CACHE(cache);
5518 =for apidoc sv_pos_b2u
5520 Converts the value pointed to by offsetp from a count of bytes from the
5521 start of the string, to a count of the equivalent number of UTF-8 chars.
5522 Handles magic and type coercion.
5528 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
5529 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5530 * byte offsets. See also the comments of S_utf8_mg_pos().
5535 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
5543 s = (const U8*)SvPV_const(sv, len);
5544 if ((I32)len < *offsetp)
5545 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5547 const U8* send = s + *offsetp;
5549 STRLEN *cache = NULL;
5553 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5554 mg = mg_find(sv, PERL_MAGIC_utf8);
5555 if (mg && mg->mg_ptr) {
5556 cache = (STRLEN *) mg->mg_ptr;
5557 if (cache[1] == (STRLEN)*offsetp) {
5558 /* An exact match. */
5559 *offsetp = cache[0];
5563 else if (cache[1] < (STRLEN)*offsetp) {
5564 /* We already know part of the way. */
5567 /* Let the below loop do the rest. */
5569 else { /* cache[1] > *offsetp */
5570 /* We already know all of the way, now we may
5571 * be able to walk back. The same assumption
5572 * is made as in S_utf8_mg_pos(), namely that
5573 * walking backward is twice slower than
5574 * walking forward. */
5575 const STRLEN forw = *offsetp;
5576 STRLEN backw = cache[1] - *offsetp;
5578 if (!(forw < 2 * backw)) {
5579 const U8 *p = s + cache[1];
5586 while (UTF8_IS_CONTINUATION(*p)) {
5594 *offsetp = cache[0];
5596 /* Drop the stale "length" cache */
5604 ASSERT_UTF8_CACHE(cache);
5610 /* Call utf8n_to_uvchr() to validate the sequence
5611 * (unless a simple non-UTF character) */
5612 if (!UTF8_IS_INVARIANT(*s))
5613 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
5622 if (!SvREADONLY(sv)) {
5624 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5625 mg = mg_find(sv, PERL_MAGIC_utf8);
5630 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5631 mg->mg_ptr = (char *) cache;
5636 cache[1] = *offsetp;
5637 /* Drop the stale "length" cache */
5650 Returns a boolean indicating whether the strings in the two SVs are
5651 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5652 coerce its args to strings if necessary.
5658 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5667 SV* svrecode = NULL;
5674 pv1 = SvPV_const(sv1, cur1);
5681 pv2 = SvPV_const(sv2, cur2);
5683 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5684 /* Differing utf8ness.
5685 * Do not UTF8size the comparands as a side-effect. */
5688 svrecode = newSVpvn(pv2, cur2);
5689 sv_recode_to_utf8(svrecode, PL_encoding);
5690 pv2 = SvPV_const(svrecode, cur2);
5693 svrecode = newSVpvn(pv1, cur1);
5694 sv_recode_to_utf8(svrecode, PL_encoding);
5695 pv1 = SvPV_const(svrecode, cur1);
5697 /* Now both are in UTF-8. */
5699 SvREFCNT_dec(svrecode);
5704 bool is_utf8 = TRUE;
5707 /* sv1 is the UTF-8 one,
5708 * if is equal it must be downgrade-able */
5709 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
5715 /* sv2 is the UTF-8 one,
5716 * if is equal it must be downgrade-able */
5717 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
5723 /* Downgrade not possible - cannot be eq */
5731 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
5734 SvREFCNT_dec(svrecode);
5745 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
5746 string in C<sv1> is less than, equal to, or greater than the string in
5747 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5748 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
5754 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
5758 const char *pv1, *pv2;
5761 SV *svrecode = NULL;
5768 pv1 = SvPV_const(sv1, cur1);
5775 pv2 = SvPV_const(sv2, cur2);
5777 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5778 /* Differing utf8ness.
5779 * Do not UTF8size the comparands as a side-effect. */
5782 svrecode = newSVpvn(pv2, cur2);
5783 sv_recode_to_utf8(svrecode, PL_encoding);
5784 pv2 = SvPV_const(svrecode, cur2);
5787 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
5792 svrecode = newSVpvn(pv1, cur1);
5793 sv_recode_to_utf8(svrecode, PL_encoding);
5794 pv1 = SvPV_const(svrecode, cur1);
5797 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
5803 cmp = cur2 ? -1 : 0;
5807 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
5810 cmp = retval < 0 ? -1 : 1;
5811 } else if (cur1 == cur2) {
5814 cmp = cur1 < cur2 ? -1 : 1;
5819 SvREFCNT_dec(svrecode);
5828 =for apidoc sv_cmp_locale
5830 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
5831 'use bytes' aware, handles get magic, and will coerce its args to strings
5832 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
5838 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5841 #ifdef USE_LOCALE_COLLATE
5847 if (PL_collation_standard)
5851 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5853 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5855 if (!pv1 || !len1) {
5866 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5869 return retval < 0 ? -1 : 1;
5872 * When the result of collation is equality, that doesn't mean
5873 * that there are no differences -- some locales exclude some
5874 * characters from consideration. So to avoid false equalities,
5875 * we use the raw string as a tiebreaker.
5881 #endif /* USE_LOCALE_COLLATE */
5883 return sv_cmp(sv1, sv2);
5887 #ifdef USE_LOCALE_COLLATE
5890 =for apidoc sv_collxfrm
5892 Add Collate Transform magic to an SV if it doesn't already have it.
5894 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5895 scalar data of the variable, but transformed to such a format that a normal
5896 memory comparison can be used to compare the data according to the locale
5903 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5908 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5909 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5915 Safefree(mg->mg_ptr);
5916 s = SvPV_const(sv, len);
5917 if ((xf = mem_collxfrm(s, len, &xlen))) {
5918 if (SvREADONLY(sv)) {
5921 return xf + sizeof(PL_collation_ix);
5924 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5925 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5938 if (mg && mg->mg_ptr) {
5940 return mg->mg_ptr + sizeof(PL_collation_ix);
5948 #endif /* USE_LOCALE_COLLATE */
5953 Get a line from the filehandle and store it into the SV, optionally
5954 appending to the currently-stored string.
5960 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5965 register STDCHAR rslast;
5966 register STDCHAR *bp;
5972 if (SvTHINKFIRST(sv))
5973 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
5974 /* XXX. If you make this PVIV, then copy on write can copy scalars read
5976 However, perlbench says it's slower, because the existing swipe code
5977 is faster than copy on write.
5978 Swings and roundabouts. */
5979 SvUPGRADE(sv, SVt_PV);
5984 if (PerlIO_isutf8(fp)) {
5986 sv_utf8_upgrade_nomg(sv);
5987 sv_pos_u2b(sv,&append,0);
5989 } else if (SvUTF8(sv)) {
5990 SV * const tsv = newSV(0);
5991 sv_gets(tsv, fp, 0);
5992 sv_utf8_upgrade_nomg(tsv);
5993 SvCUR_set(sv,append);
5996 goto return_string_or_null;
6001 if (PerlIO_isutf8(fp))
6004 if (IN_PERL_COMPILETIME) {
6005 /* we always read code in line mode */
6009 else if (RsSNARF(PL_rs)) {
6010 /* If it is a regular disk file use size from stat() as estimate
6011 of amount we are going to read - may result in malloc-ing
6012 more memory than we realy need if layers bellow reduce
6013 size we read (e.g. CRLF or a gzip layer)
6016 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6017 const Off_t offset = PerlIO_tell(fp);
6018 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6019 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6025 else if (RsRECORD(PL_rs)) {
6029 /* Grab the size of the record we're getting */
6030 recsize = SvIV(SvRV(PL_rs));
6031 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6034 /* VMS wants read instead of fread, because fread doesn't respect */
6035 /* RMS record boundaries. This is not necessarily a good thing to be */
6036 /* doing, but we've got no other real choice - except avoid stdio
6037 as implementation - perhaps write a :vms layer ?
6039 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6041 bytesread = PerlIO_read(fp, buffer, recsize);
6045 SvCUR_set(sv, bytesread += append);
6046 buffer[bytesread] = '\0';
6047 goto return_string_or_null;
6049 else if (RsPARA(PL_rs)) {
6055 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6056 if (PerlIO_isutf8(fp)) {
6057 rsptr = SvPVutf8(PL_rs, rslen);
6060 if (SvUTF8(PL_rs)) {
6061 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6062 Perl_croak(aTHX_ "Wide character in $/");
6065 rsptr = SvPV_const(PL_rs, rslen);
6069 rslast = rslen ? rsptr[rslen - 1] : '\0';
6071 if (rspara) { /* have to do this both before and after */
6072 do { /* to make sure file boundaries work right */
6075 i = PerlIO_getc(fp);
6079 PerlIO_ungetc(fp,i);
6085 /* See if we know enough about I/O mechanism to cheat it ! */
6087 /* This used to be #ifdef test - it is made run-time test for ease
6088 of abstracting out stdio interface. One call should be cheap
6089 enough here - and may even be a macro allowing compile
6093 if (PerlIO_fast_gets(fp)) {
6096 * We're going to steal some values from the stdio struct
6097 * and put EVERYTHING in the innermost loop into registers.
6099 register STDCHAR *ptr;
6103 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6104 /* An ungetc()d char is handled separately from the regular
6105 * buffer, so we getc() it back out and stuff it in the buffer.
6107 i = PerlIO_getc(fp);
6108 if (i == EOF) return 0;
6109 *(--((*fp)->_ptr)) = (unsigned char) i;
6113 /* Here is some breathtakingly efficient cheating */
6115 cnt = PerlIO_get_cnt(fp); /* get count into register */
6116 /* make sure we have the room */
6117 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
6118 /* Not room for all of it
6119 if we are looking for a separator and room for some
6121 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
6122 /* just process what we have room for */
6123 shortbuffered = cnt - SvLEN(sv) + append + 1;
6124 cnt -= shortbuffered;
6128 /* remember that cnt can be negative */
6129 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
6134 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
6135 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
6136 DEBUG_P(PerlIO_printf(Perl_debug_log,
6137 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6138 DEBUG_P(PerlIO_printf(Perl_debug_log,
6139 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6140 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6141 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6146 while (cnt > 0) { /* this | eat */
6148 if ((*bp++ = *ptr++) == rslast) /* really | dust */
6149 goto thats_all_folks; /* screams | sed :-) */
6153 Copy(ptr, bp, cnt, char); /* this | eat */
6154 bp += cnt; /* screams | dust */
6155 ptr += cnt; /* louder | sed :-) */
6160 if (shortbuffered) { /* oh well, must extend */
6161 cnt = shortbuffered;
6163 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6165 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6166 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6170 DEBUG_P(PerlIO_printf(Perl_debug_log,
6171 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6172 PTR2UV(ptr),(long)cnt));
6173 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6175 DEBUG_P(PerlIO_printf(Perl_debug_log,
6176 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6177 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6178 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6180 /* This used to call 'filbuf' in stdio form, but as that behaves like
6181 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6182 another abstraction. */
6183 i = PerlIO_getc(fp); /* get more characters */
6185 DEBUG_P(PerlIO_printf(Perl_debug_log,
6186 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6187 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6188 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6190 cnt = PerlIO_get_cnt(fp);
6191 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
6192 DEBUG_P(PerlIO_printf(Perl_debug_log,
6193 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6195 if (i == EOF) /* all done for ever? */
6196 goto thats_really_all_folks;
6198 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6200 SvGROW(sv, bpx + cnt + 2);
6201 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6203 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
6205 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
6206 goto thats_all_folks;
6210 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
6211 memNE((char*)bp - rslen, rsptr, rslen))
6212 goto screamer; /* go back to the fray */
6213 thats_really_all_folks:
6215 cnt += shortbuffered;
6216 DEBUG_P(PerlIO_printf(Perl_debug_log,
6217 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6218 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
6219 DEBUG_P(PerlIO_printf(Perl_debug_log,
6220 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6221 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6222 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6224 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
6225 DEBUG_P(PerlIO_printf(Perl_debug_log,
6226 "Screamer: done, len=%ld, string=|%.*s|\n",
6227 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
6231 /*The big, slow, and stupid way. */
6232 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
6233 STDCHAR *buf = NULL;
6234 Newx(buf, 8192, STDCHAR);
6242 register const STDCHAR * const bpe = buf + sizeof(buf);
6244 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6245 ; /* keep reading */
6249 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6250 /* Accomodate broken VAXC compiler, which applies U8 cast to
6251 * both args of ?: operator, causing EOF to change into 255
6254 i = (U8)buf[cnt - 1];
6260 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
6262 sv_catpvn(sv, (char *) buf, cnt);
6264 sv_setpvn(sv, (char *) buf, cnt);
6266 if (i != EOF && /* joy */
6268 SvCUR(sv) < rslen ||
6269 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6273 * If we're reading from a TTY and we get a short read,
6274 * indicating that the user hit his EOF character, we need
6275 * to notice it now, because if we try to read from the TTY
6276 * again, the EOF condition will disappear.
6278 * The comparison of cnt to sizeof(buf) is an optimization
6279 * that prevents unnecessary calls to feof().
6283 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
6287 #ifdef USE_HEAP_INSTEAD_OF_STACK
6292 if (rspara) { /* have to do this both before and after */
6293 while (i != EOF) { /* to make sure file boundaries work right */
6294 i = PerlIO_getc(fp);
6296 PerlIO_ungetc(fp,i);
6302 return_string_or_null:
6303 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
6309 Auto-increment of the value in the SV, doing string to numeric conversion
6310 if necessary. Handles 'get' magic.
6316 Perl_sv_inc(pTHX_ register SV *sv)
6325 if (SvTHINKFIRST(sv)) {
6327 sv_force_normal_flags(sv, 0);
6328 if (SvREADONLY(sv)) {
6329 if (IN_PERL_RUNTIME)
6330 Perl_croak(aTHX_ PL_no_modify);
6334 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6336 i = PTR2IV(SvRV(sv));
6341 flags = SvFLAGS(sv);
6342 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6343 /* It's (privately or publicly) a float, but not tested as an
6344 integer, so test it to see. */
6346 flags = SvFLAGS(sv);
6348 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6349 /* It's publicly an integer, or privately an integer-not-float */
6350 #ifdef PERL_PRESERVE_IVUV
6354 if (SvUVX(sv) == UV_MAX)
6355 sv_setnv(sv, UV_MAX_P1);
6357 (void)SvIOK_only_UV(sv);
6358 SvUV_set(sv, SvUVX(sv) + 1);
6360 if (SvIVX(sv) == IV_MAX)
6361 sv_setuv(sv, (UV)IV_MAX + 1);
6363 (void)SvIOK_only(sv);
6364 SvIV_set(sv, SvIVX(sv) + 1);
6369 if (flags & SVp_NOK) {
6370 (void)SvNOK_only(sv);
6371 SvNV_set(sv, SvNVX(sv) + 1.0);
6375 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
6376 if ((flags & SVTYPEMASK) < SVt_PVIV)
6377 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
6378 (void)SvIOK_only(sv);
6383 while (isALPHA(*d)) d++;
6384 while (isDIGIT(*d)) d++;
6386 #ifdef PERL_PRESERVE_IVUV
6387 /* Got to punt this as an integer if needs be, but we don't issue
6388 warnings. Probably ought to make the sv_iv_please() that does
6389 the conversion if possible, and silently. */
6390 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6391 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6392 /* Need to try really hard to see if it's an integer.
6393 9.22337203685478e+18 is an integer.
6394 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6395 so $a="9.22337203685478e+18"; $a+0; $a++
6396 needs to be the same as $a="9.22337203685478e+18"; $a++
6403 /* sv_2iv *should* have made this an NV */
6404 if (flags & SVp_NOK) {
6405 (void)SvNOK_only(sv);
6406 SvNV_set(sv, SvNVX(sv) + 1.0);
6409 /* I don't think we can get here. Maybe I should assert this
6410 And if we do get here I suspect that sv_setnv will croak. NWC
6412 #if defined(USE_LONG_DOUBLE)
6413 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",
6414 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6416 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6417 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6420 #endif /* PERL_PRESERVE_IVUV */
6421 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
6425 while (d >= SvPVX_const(sv)) {
6433 /* MKS: The original code here died if letters weren't consecutive.
6434 * at least it didn't have to worry about non-C locales. The
6435 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6436 * arranged in order (although not consecutively) and that only
6437 * [A-Za-z] are accepted by isALPHA in the C locale.
6439 if (*d != 'z' && *d != 'Z') {
6440 do { ++*d; } while (!isALPHA(*d));
6443 *(d--) -= 'z' - 'a';
6448 *(d--) -= 'z' - 'a' + 1;
6452 /* oh,oh, the number grew */
6453 SvGROW(sv, SvCUR(sv) + 2);
6454 SvCUR_set(sv, SvCUR(sv) + 1);
6455 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
6466 Auto-decrement of the value in the SV, doing string to numeric conversion
6467 if necessary. Handles 'get' magic.
6473 Perl_sv_dec(pTHX_ register SV *sv)
6481 if (SvTHINKFIRST(sv)) {
6483 sv_force_normal_flags(sv, 0);
6484 if (SvREADONLY(sv)) {
6485 if (IN_PERL_RUNTIME)
6486 Perl_croak(aTHX_ PL_no_modify);
6490 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6492 i = PTR2IV(SvRV(sv));
6497 /* Unlike sv_inc we don't have to worry about string-never-numbers
6498 and keeping them magic. But we mustn't warn on punting */
6499 flags = SvFLAGS(sv);
6500 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6501 /* It's publicly an integer, or privately an integer-not-float */
6502 #ifdef PERL_PRESERVE_IVUV
6506 if (SvUVX(sv) == 0) {
6507 (void)SvIOK_only(sv);
6511 (void)SvIOK_only_UV(sv);
6512 SvUV_set(sv, SvUVX(sv) - 1);
6515 if (SvIVX(sv) == IV_MIN)
6516 sv_setnv(sv, (NV)IV_MIN - 1.0);
6518 (void)SvIOK_only(sv);
6519 SvIV_set(sv, SvIVX(sv) - 1);
6524 if (flags & SVp_NOK) {
6525 SvNV_set(sv, SvNVX(sv) - 1.0);
6526 (void)SvNOK_only(sv);
6529 if (!(flags & SVp_POK)) {
6530 if ((flags & SVTYPEMASK) < SVt_PVIV)
6531 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
6533 (void)SvIOK_only(sv);
6536 #ifdef PERL_PRESERVE_IVUV
6538 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6539 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6540 /* Need to try really hard to see if it's an integer.
6541 9.22337203685478e+18 is an integer.
6542 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6543 so $a="9.22337203685478e+18"; $a+0; $a--
6544 needs to be the same as $a="9.22337203685478e+18"; $a--
6551 /* sv_2iv *should* have made this an NV */
6552 if (flags & SVp_NOK) {
6553 (void)SvNOK_only(sv);
6554 SvNV_set(sv, SvNVX(sv) - 1.0);
6557 /* I don't think we can get here. Maybe I should assert this
6558 And if we do get here I suspect that sv_setnv will croak. NWC
6560 #if defined(USE_LONG_DOUBLE)
6561 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",
6562 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6564 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6565 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6569 #endif /* PERL_PRESERVE_IVUV */
6570 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
6574 =for apidoc sv_mortalcopy
6576 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6577 The new SV is marked as mortal. It will be destroyed "soon", either by an
6578 explicit call to FREETMPS, or by an implicit call at places such as
6579 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
6584 /* Make a string that will exist for the duration of the expression
6585 * evaluation. Actually, it may have to last longer than that, but
6586 * hopefully we won't free it until it has been assigned to a
6587 * permanent location. */
6590 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6596 sv_setsv(sv,oldstr);
6598 PL_tmps_stack[++PL_tmps_ix] = sv;
6604 =for apidoc sv_newmortal
6606 Creates a new null SV which is mortal. The reference count of the SV is
6607 set to 1. It will be destroyed "soon", either by an explicit call to
6608 FREETMPS, or by an implicit call at places such as statement boundaries.
6609 See also C<sv_mortalcopy> and C<sv_2mortal>.
6615 Perl_sv_newmortal(pTHX)
6621 SvFLAGS(sv) = SVs_TEMP;
6623 PL_tmps_stack[++PL_tmps_ix] = sv;
6628 =for apidoc sv_2mortal
6630 Marks an existing SV as mortal. The SV will be destroyed "soon", either
6631 by an explicit call to FREETMPS, or by an implicit call at places such as
6632 statement boundaries. SvTEMP() is turned on which means that the SV's
6633 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
6634 and C<sv_mortalcopy>.
6640 Perl_sv_2mortal(pTHX_ register SV *sv)
6645 if (SvREADONLY(sv) && SvIMMORTAL(sv))
6648 PL_tmps_stack[++PL_tmps_ix] = sv;
6656 Creates a new SV and copies a string into it. The reference count for the
6657 SV is set to 1. If C<len> is zero, Perl will compute the length using
6658 strlen(). For efficiency, consider using C<newSVpvn> instead.
6664 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6670 sv_setpvn(sv,s,len ? len : strlen(s));
6675 =for apidoc newSVpvn
6677 Creates a new SV and copies a string into it. The reference count for the
6678 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
6679 string. You are responsible for ensuring that the source string is at least
6680 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
6686 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
6692 sv_setpvn(sv,s,len);
6698 =for apidoc newSVhek
6700 Creates a new SV from the hash key structure. It will generate scalars that
6701 point to the shared string table where possible. Returns a new (undefined)
6702 SV if the hek is NULL.
6708 Perl_newSVhek(pTHX_ const HEK *hek)
6718 if (HEK_LEN(hek) == HEf_SVKEY) {
6719 return newSVsv(*(SV**)HEK_KEY(hek));
6721 const int flags = HEK_FLAGS(hek);
6722 if (flags & HVhek_WASUTF8) {
6724 Andreas would like keys he put in as utf8 to come back as utf8
6726 STRLEN utf8_len = HEK_LEN(hek);
6727 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
6728 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
6731 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
6733 } else if (flags & HVhek_REHASH) {
6734 /* We don't have a pointer to the hv, so we have to replicate the
6735 flag into every HEK. This hv is using custom a hasing
6736 algorithm. Hence we can't return a shared string scalar, as
6737 that would contain the (wrong) hash value, and might get passed
6738 into an hv routine with a regular hash */
6740 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
6745 /* This will be overwhelminly the most common case. */
6746 return newSVpvn_share(HEK_KEY(hek),
6747 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
6753 =for apidoc newSVpvn_share
6755 Creates a new SV with its SvPVX_const pointing to a shared string in the string
6756 table. If the string does not already exist in the table, it is created
6757 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
6758 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
6759 otherwise the hash is computed. The idea here is that as the string table
6760 is used for shared hash keys these strings will have SvPVX_const == HeKEY and
6761 hash lookup will avoid string compare.
6767 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
6771 bool is_utf8 = FALSE;
6773 STRLEN tmplen = -len;
6775 /* See the note in hv.c:hv_fetch() --jhi */
6776 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
6780 PERL_HASH(hash, src, len);
6782 sv_upgrade(sv, SVt_PV);
6783 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
6795 #if defined(PERL_IMPLICIT_CONTEXT)
6797 /* pTHX_ magic can't cope with varargs, so this is a no-context
6798 * version of the main function, (which may itself be aliased to us).
6799 * Don't access this version directly.
6803 Perl_newSVpvf_nocontext(const char* pat, ...)
6808 va_start(args, pat);
6809 sv = vnewSVpvf(pat, &args);
6816 =for apidoc newSVpvf
6818 Creates a new SV and initializes it with the string formatted like
6825 Perl_newSVpvf(pTHX_ const char* pat, ...)
6829 va_start(args, pat);
6830 sv = vnewSVpvf(pat, &args);
6835 /* backend for newSVpvf() and newSVpvf_nocontext() */
6838 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
6843 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
6850 Creates a new SV and copies a floating point value into it.
6851 The reference count for the SV is set to 1.
6857 Perl_newSVnv(pTHX_ NV n)
6870 Creates a new SV and copies an integer into it. The reference count for the
6877 Perl_newSViv(pTHX_ IV i)
6890 Creates a new SV and copies an unsigned integer into it.
6891 The reference count for the SV is set to 1.
6897 Perl_newSVuv(pTHX_ UV u)
6908 =for apidoc newRV_noinc
6910 Creates an RV wrapper for an SV. The reference count for the original
6911 SV is B<not> incremented.
6917 Perl_newRV_noinc(pTHX_ SV *tmpRef)
6923 sv_upgrade(sv, SVt_RV);
6925 SvRV_set(sv, tmpRef);
6930 /* newRV_inc is the official function name to use now.
6931 * newRV_inc is in fact #defined to newRV in sv.h
6935 Perl_newRV(pTHX_ SV *tmpRef)
6938 return newRV_noinc(SvREFCNT_inc(tmpRef));
6944 Creates a new SV which is an exact duplicate of the original SV.
6951 Perl_newSVsv(pTHX_ register SV *old)
6958 if (SvTYPE(old) == SVTYPEMASK) {
6959 if (ckWARN_d(WARN_INTERNAL))
6960 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
6964 /* SV_GMAGIC is the default for sv_setv()
6965 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
6966 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
6967 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
6972 =for apidoc sv_reset
6974 Underlying implementation for the C<reset> Perl function.
6975 Note that the perl-level function is vaguely deprecated.
6981 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
6984 char todo[PERL_UCHAR_MAX+1];
6989 if (!*s) { /* reset ?? searches */
6990 MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
6992 PMOP *pm = (PMOP *) mg->mg_obj;
6994 pm->op_pmdynflags &= ~PMdf_USED;
7001 /* reset variables */
7003 if (!HvARRAY(stash))
7006 Zero(todo, 256, char);
7009 I32 i = (unsigned char)*s;
7013 max = (unsigned char)*s++;
7014 for ( ; i <= max; i++) {
7017 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7019 for (entry = HvARRAY(stash)[i];
7021 entry = HeNEXT(entry))
7026 if (!todo[(U8)*HeKEY(entry)])
7028 gv = (GV*)HeVAL(entry);
7031 if (SvTHINKFIRST(sv)) {
7032 if (!SvREADONLY(sv) && SvROK(sv))
7034 /* XXX Is this continue a bug? Why should THINKFIRST
7035 exempt us from resetting arrays and hashes? */
7039 if (SvTYPE(sv) >= SVt_PV) {
7041 if (SvPVX_const(sv) != NULL)
7049 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
7051 Perl_die(aTHX_ "Can't reset %%ENV on this system");
7054 # if defined(USE_ENVIRON_ARRAY)
7057 # endif /* USE_ENVIRON_ARRAY */
7068 Using various gambits, try to get an IO from an SV: the IO slot if its a
7069 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7070 named after the PV if we're a string.
7076 Perl_sv_2io(pTHX_ SV *sv)
7081 switch (SvTYPE(sv)) {
7089 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7093 Perl_croak(aTHX_ PL_no_usym, "filehandle");
7095 return sv_2io(SvRV(sv));
7096 gv = gv_fetchsv(sv, 0, SVt_PVIO);
7102 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
7111 Using various gambits, try to get a CV from an SV; in addition, try if
7112 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7113 The flags in C<lref> are passed to sv_fetchsv.
7119 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7130 switch (SvTYPE(sv)) {
7149 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
7150 tryAMAGICunDEREF(to_cv);
7153 if (SvTYPE(sv) == SVt_PVCV) {
7162 Perl_croak(aTHX_ "Not a subroutine reference");
7167 gv = gv_fetchsv(sv, lref, SVt_PVCV);
7173 /* Some flags to gv_fetchsv mean don't really create the GV */
7174 if (SvTYPE(gv) != SVt_PVGV) {
7180 if (lref && !GvCVu(gv)) {
7184 gv_efullname3(tmpsv, gv, NULL);
7185 /* XXX this is probably not what they think they're getting.
7186 * It has the same effect as "sub name;", i.e. just a forward
7188 newSUB(start_subparse(FALSE, 0),
7189 newSVOP(OP_CONST, 0, tmpsv),
7193 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
7203 Returns true if the SV has a true value by Perl's rules.
7204 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
7205 instead use an in-line version.
7211 Perl_sv_true(pTHX_ register SV *sv)
7216 register const XPV* const tXpv = (XPV*)SvANY(sv);
7218 (tXpv->xpv_cur > 1 ||
7219 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
7226 return SvIVX(sv) != 0;
7229 return SvNVX(sv) != 0.0;
7231 return sv_2bool(sv);
7237 =for apidoc sv_pvn_force
7239 Get a sensible string out of the SV somehow.
7240 A private implementation of the C<SvPV_force> macro for compilers which
7241 can't cope with complex macro expressions. Always use the macro instead.
7243 =for apidoc sv_pvn_force_flags
7245 Get a sensible string out of the SV somehow.
7246 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
7247 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
7248 implemented in terms of this function.
7249 You normally want to use the various wrapper macros instead: see
7250 C<SvPV_force> and C<SvPV_force_nomg>
7256 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
7259 if (SvTHINKFIRST(sv) && !SvROK(sv))
7260 sv_force_normal_flags(sv, 0);
7270 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
7271 const char * const ref = sv_reftype(sv,0);
7273 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
7274 ref, OP_NAME(PL_op));
7276 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
7278 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
7279 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
7281 s = sv_2pv_flags(sv, &len, flags);
7285 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
7288 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
7289 SvGROW(sv, len + 1);
7290 Move(s,SvPVX(sv),len,char);
7295 SvPOK_on(sv); /* validate pointer */
7297 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
7298 PTR2UV(sv),SvPVX_const(sv)));
7301 return SvPVX_mutable(sv);
7305 =for apidoc sv_pvbyten_force
7307 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
7313 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
7315 sv_pvn_force(sv,lp);
7316 sv_utf8_downgrade(sv,0);
7322 =for apidoc sv_pvutf8n_force
7324 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
7330 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
7332 sv_pvn_force(sv,lp);
7333 sv_utf8_upgrade(sv);
7339 =for apidoc sv_reftype
7341 Returns a string describing what the SV is a reference to.
7347 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
7349 /* The fact that I don't need to downcast to char * everywhere, only in ?:
7350 inside return suggests a const propagation bug in g++. */
7351 if (ob && SvOBJECT(sv)) {
7352 char * const name = HvNAME_get(SvSTASH(sv));
7353 return name ? name : (char *) "__ANON__";
7356 switch (SvTYPE(sv)) {
7373 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
7374 /* tied lvalues should appear to be
7375 * scalars for backwards compatitbility */
7376 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
7377 ? "SCALAR" : "LVALUE");
7378 case SVt_PVAV: return "ARRAY";
7379 case SVt_PVHV: return "HASH";
7380 case SVt_PVCV: return "CODE";
7381 case SVt_PVGV: return "GLOB";
7382 case SVt_PVFM: return "FORMAT";
7383 case SVt_PVIO: return "IO";
7384 default: return "UNKNOWN";
7390 =for apidoc sv_isobject
7392 Returns a boolean indicating whether the SV is an RV pointing to a blessed
7393 object. If the SV is not an RV, or if the object is not blessed, then this
7400 Perl_sv_isobject(pTHX_ SV *sv)
7416 Returns a boolean indicating whether the SV is blessed into the specified
7417 class. This does not check for subtypes; use C<sv_derived_from> to verify
7418 an inheritance relationship.
7424 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7435 hvname = HvNAME_get(SvSTASH(sv));
7439 return strEQ(hvname, name);
7445 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
7446 it will be upgraded to one. If C<classname> is non-null then the new SV will
7447 be blessed in the specified package. The new SV is returned and its
7448 reference count is 1.
7454 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7461 SV_CHECK_THINKFIRST_COW_DROP(rv);
7464 if (SvTYPE(rv) >= SVt_PVMG) {
7465 const U32 refcnt = SvREFCNT(rv);
7469 SvREFCNT(rv) = refcnt;
7472 if (SvTYPE(rv) < SVt_RV)
7473 sv_upgrade(rv, SVt_RV);
7474 else if (SvTYPE(rv) > SVt_RV) {
7485 HV* const stash = gv_stashpv(classname, TRUE);
7486 (void)sv_bless(rv, stash);
7492 =for apidoc sv_setref_pv
7494 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7495 argument will be upgraded to an RV. That RV will be modified to point to
7496 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7497 into the SV. The C<classname> argument indicates the package for the
7498 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
7499 will have a reference count of 1, and the RV will be returned.
7501 Do not use with other Perl types such as HV, AV, SV, CV, because those
7502 objects will become corrupted by the pointer copy process.
7504 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7510 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7514 sv_setsv(rv, &PL_sv_undef);
7518 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7523 =for apidoc sv_setref_iv
7525 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7526 argument will be upgraded to an RV. That RV will be modified to point to
7527 the new SV. The C<classname> argument indicates the package for the
7528 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
7529 will have a reference count of 1, and the RV will be returned.
7535 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7537 sv_setiv(newSVrv(rv,classname), iv);
7542 =for apidoc sv_setref_uv
7544 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7545 argument will be upgraded to an RV. That RV will be modified to point to
7546 the new SV. The C<classname> argument indicates the package for the
7547 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
7548 will have a reference count of 1, and the RV will be returned.
7554 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7556 sv_setuv(newSVrv(rv,classname), uv);
7561 =for apidoc sv_setref_nv
7563 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7564 argument will be upgraded to an RV. That RV will be modified to point to
7565 the new SV. The C<classname> argument indicates the package for the
7566 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
7567 will have a reference count of 1, and the RV will be returned.
7573 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7575 sv_setnv(newSVrv(rv,classname), nv);
7580 =for apidoc sv_setref_pvn
7582 Copies a string into a new SV, optionally blessing the SV. The length of the
7583 string must be specified with C<n>. The C<rv> argument will be upgraded to
7584 an RV. That RV will be modified to point to the new SV. The C<classname>
7585 argument indicates the package for the blessing. Set C<classname> to
7586 C<NULL> to avoid the blessing. The new SV will have a reference count
7587 of 1, and the RV will be returned.
7589 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7595 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n)
7597 sv_setpvn(newSVrv(rv,classname), pv, n);
7602 =for apidoc sv_bless
7604 Blesses an SV into a specified package. The SV must be an RV. The package
7605 must be designated by its stash (see C<gv_stashpv()>). The reference count
7606 of the SV is unaffected.
7612 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7617 Perl_croak(aTHX_ "Can't bless non-reference value");
7619 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7620 if (SvREADONLY(tmpRef))
7621 Perl_croak(aTHX_ PL_no_modify);
7622 if (SvOBJECT(tmpRef)) {
7623 if (SvTYPE(tmpRef) != SVt_PVIO)
7625 SvREFCNT_dec(SvSTASH(tmpRef));
7628 SvOBJECT_on(tmpRef);
7629 if (SvTYPE(tmpRef) != SVt_PVIO)
7631 SvUPGRADE(tmpRef, SVt_PVMG);
7632 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
7639 if(SvSMAGICAL(tmpRef))
7640 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
7648 /* Downgrades a PVGV to a PVMG.
7652 S_sv_unglob(pTHX_ SV *sv)
7656 SV *temp = sv_newmortal();
7658 assert(SvTYPE(sv) == SVt_PVGV);
7660 gv_efullname3(temp, (GV *) sv, "*");
7665 sv_del_backref((SV*)GvSTASH(sv), sv);
7668 sv_unmagic(sv, PERL_MAGIC_glob);
7670 Safefree(GvNAME(sv));
7673 /* need to keep SvANY(sv) in the right arena */
7674 xpvmg = new_XPVMG();
7675 StructCopy(SvANY(sv), xpvmg, XPVMG);
7676 del_XPVGV(SvANY(sv));
7679 SvFLAGS(sv) &= ~SVTYPEMASK;
7680 SvFLAGS(sv) |= SVt_PVMG;
7682 /* Intentionally not calling any local SET magic, as this isn't so much a
7683 set operation as merely an internal storage change. */
7684 sv_setsv_flags(sv, temp, 0);
7688 =for apidoc sv_unref_flags
7690 Unsets the RV status of the SV, and decrements the reference count of
7691 whatever was being referenced by the RV. This can almost be thought of
7692 as a reversal of C<newSVrv>. The C<cflags> argument can contain
7693 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
7694 (otherwise the decrementing is conditional on the reference count being
7695 different from one or the reference being a readonly SV).
7702 Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags)
7704 SV* const target = SvRV(ref);
7706 if (SvWEAKREF(ref)) {
7707 sv_del_backref(target, ref);
7709 SvRV_set(ref, NULL);
7712 SvRV_set(ref, NULL);
7714 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
7715 assigned to as BEGIN {$a = \"Foo"} will fail. */
7716 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
7717 SvREFCNT_dec(target);
7718 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
7719 sv_2mortal(target); /* Schedule for freeing later */
7723 =for apidoc sv_untaint
7725 Untaint an SV. Use C<SvTAINTED_off> instead.
7730 Perl_sv_untaint(pTHX_ SV *sv)
7732 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7733 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
7740 =for apidoc sv_tainted
7742 Test an SV for taintedness. Use C<SvTAINTED> instead.
7747 Perl_sv_tainted(pTHX_ SV *sv)
7749 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7750 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
7751 if (mg && (mg->mg_len & 1) )
7758 =for apidoc sv_setpviv
7760 Copies an integer into the given SV, also updating its string value.
7761 Does not handle 'set' magic. See C<sv_setpviv_mg>.
7767 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
7769 char buf[TYPE_CHARS(UV)];
7771 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7773 sv_setpvn(sv, ptr, ebuf - ptr);
7777 =for apidoc sv_setpviv_mg
7779 Like C<sv_setpviv>, but also handles 'set' magic.
7785 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
7791 #if defined(PERL_IMPLICIT_CONTEXT)
7793 /* pTHX_ magic can't cope with varargs, so this is a no-context
7794 * version of the main function, (which may itself be aliased to us).
7795 * Don't access this version directly.
7799 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
7803 va_start(args, pat);
7804 sv_vsetpvf(sv, pat, &args);
7808 /* pTHX_ magic can't cope with varargs, so this is a no-context
7809 * version of the main function, (which may itself be aliased to us).
7810 * Don't access this version directly.
7814 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
7818 va_start(args, pat);
7819 sv_vsetpvf_mg(sv, pat, &args);
7825 =for apidoc sv_setpvf
7827 Works like C<sv_catpvf> but copies the text into the SV instead of
7828 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
7834 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
7837 va_start(args, pat);
7838 sv_vsetpvf(sv, pat, &args);
7843 =for apidoc sv_vsetpvf
7845 Works like C<sv_vcatpvf> but copies the text into the SV instead of
7846 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
7848 Usually used via its frontend C<sv_setpvf>.
7854 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7856 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7860 =for apidoc sv_setpvf_mg
7862 Like C<sv_setpvf>, but also handles 'set' magic.
7868 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7871 va_start(args, pat);
7872 sv_vsetpvf_mg(sv, pat, &args);
7877 =for apidoc sv_vsetpvf_mg
7879 Like C<sv_vsetpvf>, but also handles 'set' magic.
7881 Usually used via its frontend C<sv_setpvf_mg>.
7887 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7889 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7893 #if defined(PERL_IMPLICIT_CONTEXT)
7895 /* pTHX_ magic can't cope with varargs, so this is a no-context
7896 * version of the main function, (which may itself be aliased to us).
7897 * Don't access this version directly.
7901 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
7905 va_start(args, pat);
7906 sv_vcatpvf(sv, pat, &args);
7910 /* pTHX_ magic can't cope with varargs, so this is a no-context
7911 * version of the main function, (which may itself be aliased to us).
7912 * Don't access this version directly.
7916 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
7920 va_start(args, pat);
7921 sv_vcatpvf_mg(sv, pat, &args);
7927 =for apidoc sv_catpvf
7929 Processes its arguments like C<sprintf> and appends the formatted
7930 output to an SV. If the appended data contains "wide" characters
7931 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
7932 and characters >255 formatted with %c), the original SV might get
7933 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
7934 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
7935 valid UTF-8; if the original SV was bytes, the pattern should be too.
7940 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
7943 va_start(args, pat);
7944 sv_vcatpvf(sv, pat, &args);
7949 =for apidoc sv_vcatpvf
7951 Processes its arguments like C<vsprintf> and appends the formatted output
7952 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
7954 Usually used via its frontend C<sv_catpvf>.
7960 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7962 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7966 =for apidoc sv_catpvf_mg
7968 Like C<sv_catpvf>, but also handles 'set' magic.
7974 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7977 va_start(args, pat);
7978 sv_vcatpvf_mg(sv, pat, &args);
7983 =for apidoc sv_vcatpvf_mg
7985 Like C<sv_vcatpvf>, but also handles 'set' magic.
7987 Usually used via its frontend C<sv_catpvf_mg>.
7993 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7995 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8000 =for apidoc sv_vsetpvfn
8002 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
8005 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
8011 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8013 sv_setpvn(sv, "", 0);
8014 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8018 S_expect_number(pTHX_ char** pattern)
8022 switch (**pattern) {
8023 case '1': case '2': case '3':
8024 case '4': case '5': case '6':
8025 case '7': case '8': case '9':
8026 var = *(*pattern)++ - '0';
8027 while (isDIGIT(**pattern)) {
8028 const I32 tmp = var * 10 + (*(*pattern)++ - '0');
8030 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn"));
8038 S_F0convert(NV nv, char *endbuf, STRLEN *len)
8040 const int neg = nv < 0;
8049 if (uv & 1 && uv == nv)
8050 uv--; /* Round to even */
8052 const unsigned dig = uv % 10;
8065 =for apidoc sv_vcatpvfn
8067 Processes its arguments like C<vsprintf> and appends the formatted output
8068 to an SV. Uses an array of SVs if the C style variable argument list is
8069 missing (NULL). When running with taint checks enabled, indicates via
8070 C<maybe_tainted> if results are untrustworthy (often due to the use of
8073 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
8079 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
8080 vecstr = (U8*)SvPV_const(vecsv,veclen);\
8081 vec_utf8 = DO_UTF8(vecsv);
8083 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
8086 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8094 static const char nullstr[] = "(null)";
8096 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
8097 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
8099 /* Times 4: a decimal digit takes more than 3 binary digits.
8100 * NV_DIG: mantissa takes than many decimal digits.
8101 * Plus 32: Playing safe. */
8102 char ebuf[IV_DIG * 4 + NV_DIG + 32];
8103 /* large enough for "%#.#f" --chip */
8104 /* what about long double NVs? --jhi */
8106 PERL_UNUSED_ARG(maybe_tainted);
8108 /* no matter what, this is a string now */
8109 (void)SvPV_force(sv, origlen);
8111 /* special-case "", "%s", and "%-p" (SVf - see below) */
8114 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
8116 const char * const s = va_arg(*args, char*);
8117 sv_catpv(sv, s ? s : nullstr);
8119 else if (svix < svmax) {
8120 sv_catsv(sv, *svargs);
8124 if (args && patlen == 3 && pat[0] == '%' &&
8125 pat[1] == '-' && pat[2] == 'p') {
8126 argsv = va_arg(*args, SV*);
8127 sv_catsv(sv, argsv);
8131 #ifndef USE_LONG_DOUBLE
8132 /* special-case "%.<number>[gf]" */
8133 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
8134 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
8135 unsigned digits = 0;
8139 while (*pp >= '0' && *pp <= '9')
8140 digits = 10 * digits + (*pp++ - '0');
8141 if (pp - pat == (int)patlen - 1) {
8149 /* Add check for digits != 0 because it seems that some
8150 gconverts are buggy in this case, and we don't yet have
8151 a Configure test for this. */
8152 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
8153 /* 0, point, slack */
8154 Gconvert(nv, (int)digits, 0, ebuf);
8156 if (*ebuf) /* May return an empty string for digits==0 */
8159 } else if (!digits) {
8162 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
8163 sv_catpvn(sv, p, l);
8169 #endif /* !USE_LONG_DOUBLE */
8171 if (!args && svix < svmax && DO_UTF8(*svargs))
8174 patend = (char*)pat + patlen;
8175 for (p = (char*)pat; p < patend; p = q) {
8178 bool vectorize = FALSE;
8179 bool vectorarg = FALSE;
8180 bool vec_utf8 = FALSE;
8186 bool has_precis = FALSE;
8188 const I32 osvix = svix;
8189 bool is_utf8 = FALSE; /* is this item utf8? */
8190 #ifdef HAS_LDBL_SPRINTF_BUG
8191 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8192 with sfio - Allen <allens@cpan.org> */
8193 bool fix_ldbl_sprintf_bug = FALSE;
8197 U8 utf8buf[UTF8_MAXBYTES+1];
8198 STRLEN esignlen = 0;
8200 const char *eptr = NULL;
8203 const U8 *vecstr = NULL;
8210 /* we need a long double target in case HAS_LONG_DOUBLE but
8213 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
8221 const char *dotstr = ".";
8222 STRLEN dotstrlen = 1;
8223 I32 efix = 0; /* explicit format parameter index */
8224 I32 ewix = 0; /* explicit width index */
8225 I32 epix = 0; /* explicit precision index */
8226 I32 evix = 0; /* explicit vector index */
8227 bool asterisk = FALSE;
8229 /* echo everything up to the next format specification */
8230 for (q = p; q < patend && *q != '%'; ++q) ;
8232 if (has_utf8 && !pat_utf8)
8233 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
8235 sv_catpvn(sv, p, q - p);
8242 We allow format specification elements in this order:
8243 \d+\$ explicit format parameter index
8245 v|\*(\d+\$)?v vector with optional (optionally specified) arg
8246 0 flag (as above): repeated to allow "v02"
8247 \d+|\*(\d+\$)? width using optional (optionally specified) arg
8248 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8250 [%bcdefginopsuxDFOUX] format (mandatory)
8255 As of perl5.9.3, printf format checking is on by default.
8256 Internally, perl uses %p formats to provide an escape to
8257 some extended formatting. This block deals with those
8258 extensions: if it does not match, (char*)q is reset and
8259 the normal format processing code is used.
8261 Currently defined extensions are:
8262 %p include pointer address (standard)
8263 %-p (SVf) include an SV (previously %_)
8264 %-<num>p include an SV with precision <num>
8265 %1p (VDf) include a v-string (as %vd)
8266 %<num>p reserved for future extensions
8268 Robin Barker 2005-07-14
8275 n = expect_number(&q);
8282 argsv = va_arg(*args, SV*);
8283 eptr = SvPVx_const(argsv, elen);
8289 else if (n == vdNUMBER) { /* VDf */
8296 if (ckWARN_d(WARN_INTERNAL))
8297 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
8298 "internal %%<num>p might conflict with future printf extensions");
8304 if ( (width = expect_number(&q)) ) {
8345 if ( (ewix = expect_number(&q)) )
8354 if ((vectorarg = asterisk)) {
8367 width = expect_number(&q);
8373 vecsv = va_arg(*args, SV*);
8375 vecsv = (evix > 0 && evix <= svmax)
8376 ? svargs[evix-1] : &PL_sv_undef;
8378 vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef;
8380 dotstr = SvPV_const(vecsv, dotstrlen);
8381 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
8382 bad with tied or overloaded values that return UTF8. */
8385 else if (has_utf8) {
8386 vecsv = sv_mortalcopy(vecsv);
8387 sv_utf8_upgrade(vecsv);
8388 dotstr = SvPV_const(vecsv, dotstrlen);
8395 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
8396 vecsv = svargs[efix ? efix-1 : svix++];
8397 vecstr = (U8*)SvPV_const(vecsv,veclen);
8398 vec_utf8 = DO_UTF8(vecsv);
8400 /* if this is a version object, we need to convert
8401 * back into v-string notation and then let the
8402 * vectorize happen normally
8404 if (sv_derived_from(vecsv, "version")) {
8405 char *version = savesvpv(vecsv);
8406 if ( hv_exists((HV*)SvRV(vecsv), "alpha", 5 ) ) {
8407 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
8408 "vector argument not supported with alpha versions");
8411 vecsv = sv_newmortal();
8412 /* scan_vstring is expected to be called during
8413 * tokenization, so we need to fake up the end
8414 * of the buffer for it
8416 PL_bufend = version + veclen;
8417 scan_vstring(version, vecsv);
8418 vecstr = (U8*)SvPV_const(vecsv, veclen);
8419 vec_utf8 = DO_UTF8(vecsv);
8431 i = va_arg(*args, int);
8433 i = (ewix ? ewix <= svmax : svix < svmax) ?
8434 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8436 width = (i < 0) ? -i : i;
8446 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
8448 /* XXX: todo, support specified precision parameter */
8452 i = va_arg(*args, int);
8454 i = (ewix ? ewix <= svmax : svix < svmax)
8455 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8456 precis = (i < 0) ? 0 : i;
8461 precis = precis * 10 + (*q++ - '0');
8470 case 'I': /* Ix, I32x, and I64x */
8472 if (q[1] == '6' && q[2] == '4') {
8478 if (q[1] == '3' && q[2] == '2') {
8488 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8499 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8500 if (*(q + 1) == 'l') { /* lld, llf */
8526 if (!vectorize && !args) {
8528 const I32 i = efix-1;
8529 argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef;
8531 argsv = (svix >= 0 && svix < svmax)
8532 ? svargs[svix++] : &PL_sv_undef;
8543 uv = (args) ? va_arg(*args, int) : SvIVx(argsv);
8545 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
8547 eptr = (char*)utf8buf;
8548 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
8562 eptr = va_arg(*args, char*);
8564 #ifdef MACOS_TRADITIONAL
8565 /* On MacOS, %#s format is used for Pascal strings */
8570 elen = strlen(eptr);
8572 eptr = (char *)nullstr;
8573 elen = sizeof nullstr - 1;
8577 eptr = SvPVx_const(argsv, elen);
8578 if (DO_UTF8(argsv)) {
8579 if (has_precis && precis < elen) {
8581 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
8584 if (width) { /* fudge width (can't fudge elen) */
8585 width += elen - sv_len_utf8(argsv);
8592 if (has_precis && elen > precis)
8599 if (alt || vectorize)
8601 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
8622 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8631 esignbuf[esignlen++] = plus;
8635 case 'h': iv = (short)va_arg(*args, int); break;
8636 case 'l': iv = va_arg(*args, long); break;
8637 case 'V': iv = va_arg(*args, IV); break;
8638 default: iv = va_arg(*args, int); break;
8640 case 'q': iv = va_arg(*args, Quad_t); break;
8645 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
8647 case 'h': iv = (short)tiv; break;
8648 case 'l': iv = (long)tiv; break;
8650 default: iv = tiv; break;
8652 case 'q': iv = (Quad_t)tiv; break;
8656 if ( !vectorize ) /* we already set uv above */
8661 esignbuf[esignlen++] = plus;
8665 esignbuf[esignlen++] = '-';
8708 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8719 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
8720 case 'l': uv = va_arg(*args, unsigned long); break;
8721 case 'V': uv = va_arg(*args, UV); break;
8722 default: uv = va_arg(*args, unsigned); break;
8724 case 'q': uv = va_arg(*args, Uquad_t); break;
8729 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
8731 case 'h': uv = (unsigned short)tuv; break;
8732 case 'l': uv = (unsigned long)tuv; break;
8734 default: uv = tuv; break;
8736 case 'q': uv = (Uquad_t)tuv; break;
8743 char *ptr = ebuf + sizeof ebuf;
8749 p = (char*)((c == 'X')
8750 ? "0123456789ABCDEF" : "0123456789abcdef");
8756 esignbuf[esignlen++] = '0';
8757 esignbuf[esignlen++] = c; /* 'x' or 'X' */
8765 if (alt && *ptr != '0')
8776 esignbuf[esignlen++] = '0';
8777 esignbuf[esignlen++] = 'b';
8780 default: /* it had better be ten or less */
8784 } while (uv /= base);
8787 elen = (ebuf + sizeof ebuf) - ptr;
8791 zeros = precis - elen;
8792 else if (precis == 0 && elen == 1 && *eptr == '0')
8798 /* FLOATING POINT */
8801 c = 'f'; /* maybe %F isn't supported here */
8809 /* This is evil, but floating point is even more evil */
8811 /* for SV-style calling, we can only get NV
8812 for C-style calling, we assume %f is double;
8813 for simplicity we allow any of %Lf, %llf, %qf for long double
8817 #if defined(USE_LONG_DOUBLE)
8821 /* [perl #20339] - we should accept and ignore %lf rather than die */
8825 #if defined(USE_LONG_DOUBLE)
8826 intsize = args ? 0 : 'q';
8830 #if defined(HAS_LONG_DOUBLE)
8839 /* now we need (long double) if intsize == 'q', else (double) */
8841 #if LONG_DOUBLESIZE > DOUBLESIZE
8843 va_arg(*args, long double) :
8844 va_arg(*args, double)
8846 va_arg(*args, double)
8851 if (c != 'e' && c != 'E') {
8853 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
8854 will cast our (long double) to (double) */
8855 (void)Perl_frexp(nv, &i);
8856 if (i == PERL_INT_MIN)
8857 Perl_die(aTHX_ "panic: frexp");
8859 need = BIT_DIGITS(i);
8861 need += has_precis ? precis : 6; /* known default */
8866 #ifdef HAS_LDBL_SPRINTF_BUG
8867 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8868 with sfio - Allen <allens@cpan.org> */
8871 # define MY_DBL_MAX DBL_MAX
8872 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
8873 # if DOUBLESIZE >= 8
8874 # define MY_DBL_MAX 1.7976931348623157E+308L
8876 # define MY_DBL_MAX 3.40282347E+38L
8880 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
8881 # define MY_DBL_MAX_BUG 1L
8883 # define MY_DBL_MAX_BUG MY_DBL_MAX
8887 # define MY_DBL_MIN DBL_MIN
8888 # else /* XXX guessing! -Allen */
8889 # if DOUBLESIZE >= 8
8890 # define MY_DBL_MIN 2.2250738585072014E-308L
8892 # define MY_DBL_MIN 1.17549435E-38L
8896 if ((intsize == 'q') && (c == 'f') &&
8897 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
8899 /* it's going to be short enough that
8900 * long double precision is not needed */
8902 if ((nv <= 0L) && (nv >= -0L))
8903 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
8905 /* would use Perl_fp_class as a double-check but not
8906 * functional on IRIX - see perl.h comments */
8908 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
8909 /* It's within the range that a double can represent */
8910 #if defined(DBL_MAX) && !defined(DBL_MIN)
8911 if ((nv >= ((long double)1/DBL_MAX)) ||
8912 (nv <= (-(long double)1/DBL_MAX)))
8914 fix_ldbl_sprintf_bug = TRUE;
8917 if (fix_ldbl_sprintf_bug == TRUE) {
8927 # undef MY_DBL_MAX_BUG
8930 #endif /* HAS_LDBL_SPRINTF_BUG */
8932 need += 20; /* fudge factor */
8933 if (PL_efloatsize < need) {
8934 Safefree(PL_efloatbuf);
8935 PL_efloatsize = need + 20; /* more fudge */
8936 Newx(PL_efloatbuf, PL_efloatsize, char);
8937 PL_efloatbuf[0] = '\0';
8940 if ( !(width || left || plus || alt) && fill != '0'
8941 && has_precis && intsize != 'q' ) { /* Shortcuts */
8942 /* See earlier comment about buggy Gconvert when digits,
8944 if ( c == 'g' && precis) {
8945 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
8946 /* May return an empty string for digits==0 */
8947 if (*PL_efloatbuf) {
8948 elen = strlen(PL_efloatbuf);
8949 goto float_converted;
8951 } else if ( c == 'f' && !precis) {
8952 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
8957 char *ptr = ebuf + sizeof ebuf;
8960 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
8961 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
8962 if (intsize == 'q') {
8963 /* Copy the one or more characters in a long double
8964 * format before the 'base' ([efgEFG]) character to
8965 * the format string. */
8966 static char const prifldbl[] = PERL_PRIfldbl;
8967 char const *p = prifldbl + sizeof(prifldbl) - 3;
8968 while (p >= prifldbl) { *--ptr = *p--; }
8973 do { *--ptr = '0' + (base % 10); } while (base /= 10);
8978 do { *--ptr = '0' + (base % 10); } while (base /= 10);
8990 /* No taint. Otherwise we are in the strange situation
8991 * where printf() taints but print($float) doesn't.
8993 #if defined(HAS_LONG_DOUBLE)
8994 elen = ((intsize == 'q')
8995 ? my_sprintf(PL_efloatbuf, ptr, nv)
8996 : my_sprintf(PL_efloatbuf, ptr, (double)nv));
8998 elen = my_sprintf(PL_efloatbuf, ptr, nv);
9002 eptr = PL_efloatbuf;
9010 i = SvCUR(sv) - origlen;
9013 case 'h': *(va_arg(*args, short*)) = i; break;
9014 default: *(va_arg(*args, int*)) = i; break;
9015 case 'l': *(va_arg(*args, long*)) = i; break;
9016 case 'V': *(va_arg(*args, IV*)) = i; break;
9018 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
9023 sv_setuv_mg(argsv, (UV)i);
9024 continue; /* not "break" */
9031 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
9032 && ckWARN(WARN_PRINTF))
9034 SV * const msg = sv_newmortal();
9035 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9036 (PL_op->op_type == OP_PRTF) ? "" : "s");
9039 Perl_sv_catpvf(aTHX_ msg,
9040 "\"%%%c\"", c & 0xFF);
9042 Perl_sv_catpvf(aTHX_ msg,
9043 "\"%%\\%03"UVof"\"",
9046 sv_catpvs(msg, "end of string");
9047 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
9050 /* output mangled stuff ... */
9056 /* ... right here, because formatting flags should not apply */
9057 SvGROW(sv, SvCUR(sv) + elen + 1);
9059 Copy(eptr, p, elen, char);
9062 SvCUR_set(sv, p - SvPVX_const(sv));
9064 continue; /* not "break" */
9067 /* calculate width before utf8_upgrade changes it */
9068 have = esignlen + zeros + elen;
9070 Perl_croak_nocontext(PL_memory_wrap);
9072 if (is_utf8 != has_utf8) {
9075 sv_utf8_upgrade(sv);
9078 SV * const nsv = sv_2mortal(newSVpvn(eptr, elen));
9079 sv_utf8_upgrade(nsv);
9080 eptr = SvPVX_const(nsv);
9083 SvGROW(sv, SvCUR(sv) + elen + 1);
9088 need = (have > width ? have : width);
9091 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
9092 Perl_croak_nocontext(PL_memory_wrap);
9093 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
9095 if (esignlen && fill == '0') {
9097 for (i = 0; i < (int)esignlen; i++)
9101 memset(p, fill, gap);
9104 if (esignlen && fill != '0') {
9106 for (i = 0; i < (int)esignlen; i++)
9111 for (i = zeros; i; i--)
9115 Copy(eptr, p, elen, char);
9119 memset(p, ' ', gap);
9124 Copy(dotstr, p, dotstrlen, char);
9128 vectorize = FALSE; /* done iterating over vecstr */
9135 SvCUR_set(sv, p - SvPVX_const(sv));
9143 /* =========================================================================
9145 =head1 Cloning an interpreter
9147 All the macros and functions in this section are for the private use of
9148 the main function, perl_clone().
9150 The foo_dup() functions make an exact copy of an existing foo thinngy.
9151 During the course of a cloning, a hash table is used to map old addresses
9152 to new addresses. The table is created and manipulated with the
9153 ptr_table_* functions.
9157 ============================================================================*/
9160 #if defined(USE_ITHREADS)
9162 #ifndef GpREFCNT_inc
9163 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
9167 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
9168 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
9169 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9170 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
9171 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9172 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
9173 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9174 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
9175 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
9176 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
9177 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9178 #define SAVEPV(p) ((p) ? savepv(p) : NULL)
9179 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
9182 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
9183 regcomp.c. AMS 20010712 */
9186 Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
9191 struct reg_substr_datum *s;
9194 return (REGEXP *)NULL;
9196 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
9199 len = r->offsets[0];
9200 npar = r->nparens+1;
9202 Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
9203 Copy(r->program, ret->program, len+1, regnode);
9205 Newx(ret->startp, npar, I32);
9206 Copy(r->startp, ret->startp, npar, I32);
9207 Newx(ret->endp, npar, I32);
9208 Copy(r->startp, ret->startp, npar, I32);
9210 Newx(ret->substrs, 1, struct reg_substr_data);
9211 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
9212 s->min_offset = r->substrs->data[i].min_offset;
9213 s->max_offset = r->substrs->data[i].max_offset;
9214 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
9215 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
9218 ret->regstclass = NULL;
9221 const int count = r->data->count;
9224 Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
9225 char, struct reg_data);
9226 Newx(d->what, count, U8);
9229 for (i = 0; i < count; i++) {
9230 d->what[i] = r->data->what[i];
9231 switch (d->what[i]) {
9232 /* legal options are one of: sfpont
9233 see also regcomp.h and pregfree() */
9235 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
9238 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
9241 /* This is cheating. */
9242 Newx(d->data[i], 1, struct regnode_charclass_class);
9243 StructCopy(r->data->data[i], d->data[i],
9244 struct regnode_charclass_class);
9245 ret->regstclass = (regnode*)d->data[i];
9248 /* Compiled op trees are readonly, and can thus be
9249 shared without duplication. */
9251 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
9255 d->data[i] = r->data->data[i];
9258 d->data[i] = r->data->data[i];
9260 ((reg_trie_data*)d->data[i])->refcount++;
9264 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
9273 Newx(ret->offsets, 2*len+1, U32);
9274 Copy(r->offsets, ret->offsets, 2*len+1, U32);
9276 ret->precomp = SAVEPVN(r->precomp, r->prelen);
9277 ret->refcnt = r->refcnt;
9278 ret->minlen = r->minlen;
9279 ret->prelen = r->prelen;
9280 ret->nparens = r->nparens;
9281 ret->lastparen = r->lastparen;
9282 ret->lastcloseparen = r->lastcloseparen;
9283 ret->reganch = r->reganch;
9285 ret->sublen = r->sublen;
9287 if (RX_MATCH_COPIED(ret))
9288 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
9291 #ifdef PERL_OLD_COPY_ON_WRITE
9292 ret->saved_copy = NULL;
9295 ptr_table_store(PL_ptr_table, r, ret);
9299 /* duplicate a file handle */
9302 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
9306 PERL_UNUSED_ARG(type);
9309 return (PerlIO*)NULL;
9311 /* look for it in the table first */
9312 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
9316 /* create anew and remember what it is */
9317 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
9318 ptr_table_store(PL_ptr_table, fp, ret);
9322 /* duplicate a directory handle */
9325 Perl_dirp_dup(pTHX_ DIR *dp)
9333 /* duplicate a typeglob */
9336 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
9341 /* look for it in the table first */
9342 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
9346 /* create anew and remember what it is */
9348 ptr_table_store(PL_ptr_table, gp, ret);
9351 ret->gp_refcnt = 0; /* must be before any other dups! */
9352 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
9353 ret->gp_io = io_dup_inc(gp->gp_io, param);
9354 ret->gp_form = cv_dup_inc(gp->gp_form, param);
9355 ret->gp_av = av_dup_inc(gp->gp_av, param);
9356 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
9357 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
9358 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
9359 ret->gp_cvgen = gp->gp_cvgen;
9360 ret->gp_line = gp->gp_line;
9361 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
9365 /* duplicate a chain of magic */
9368 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
9370 MAGIC *mgprev = (MAGIC*)NULL;
9373 return (MAGIC*)NULL;
9374 /* look for it in the table first */
9375 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
9379 for (; mg; mg = mg->mg_moremagic) {
9381 Newxz(nmg, 1, MAGIC);
9383 mgprev->mg_moremagic = nmg;
9386 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
9387 nmg->mg_private = mg->mg_private;
9388 nmg->mg_type = mg->mg_type;
9389 nmg->mg_flags = mg->mg_flags;
9390 if (mg->mg_type == PERL_MAGIC_qr) {
9391 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
9393 else if(mg->mg_type == PERL_MAGIC_backref) {
9394 /* The backref AV has its reference count deliberately bumped by
9396 nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param));
9398 else if (mg->mg_type == PERL_MAGIC_symtab) {
9399 nmg->mg_obj = mg->mg_obj;
9402 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
9403 ? sv_dup_inc(mg->mg_obj, param)
9404 : sv_dup(mg->mg_obj, param);
9406 nmg->mg_len = mg->mg_len;
9407 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
9408 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
9409 if (mg->mg_len > 0) {
9410 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
9411 if (mg->mg_type == PERL_MAGIC_overload_table &&
9412 AMT_AMAGIC((AMT*)mg->mg_ptr))
9414 const AMT * const amtp = (AMT*)mg->mg_ptr;
9415 AMT * const namtp = (AMT*)nmg->mg_ptr;
9417 for (i = 1; i < NofAMmeth; i++) {
9418 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
9422 else if (mg->mg_len == HEf_SVKEY)
9423 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
9425 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
9426 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
9433 /* create a new pointer-mapping table */
9436 Perl_ptr_table_new(pTHX)
9439 Newxz(tbl, 1, PTR_TBL_t);
9442 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
9446 #define PTR_TABLE_HASH(ptr) \
9447 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
9450 we use the PTE_SVSLOT 'reservation' made above, both here (in the
9451 following define) and at call to new_body_inline made below in
9452 Perl_ptr_table_store()
9455 #define del_pte(p) del_body_type(p, PTE_SVSLOT)
9457 /* map an existing pointer using a table */
9459 STATIC PTR_TBL_ENT_t *
9460 S_ptr_table_find(PTR_TBL_t *tbl, const void *sv) {
9461 PTR_TBL_ENT_t *tblent;
9462 const UV hash = PTR_TABLE_HASH(sv);
9464 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
9465 for (; tblent; tblent = tblent->next) {
9466 if (tblent->oldval == sv)
9473 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
9475 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
9476 return tblent ? tblent->newval : (void *) 0;
9479 /* add a new entry to a pointer-mapping table */
9482 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
9484 PTR_TBL_ENT_t *tblent = S_ptr_table_find(tbl, oldsv);
9487 tblent->newval = newsv;
9489 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
9491 new_body_inline(tblent, PTE_SVSLOT);
9493 tblent->oldval = oldsv;
9494 tblent->newval = newsv;
9495 tblent->next = tbl->tbl_ary[entry];
9496 tbl->tbl_ary[entry] = tblent;
9498 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
9499 ptr_table_split(tbl);
9503 /* double the hash bucket size of an existing ptr table */
9506 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
9508 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
9509 const UV oldsize = tbl->tbl_max + 1;
9510 UV newsize = oldsize * 2;
9513 Renew(ary, newsize, PTR_TBL_ENT_t*);
9514 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
9515 tbl->tbl_max = --newsize;
9517 for (i=0; i < oldsize; i++, ary++) {
9518 PTR_TBL_ENT_t **curentp, **entp, *ent;
9521 curentp = ary + oldsize;
9522 for (entp = ary, ent = *ary; ent; ent = *entp) {
9523 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
9525 ent->next = *curentp;
9535 /* remove all the entries from a ptr table */
9538 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
9540 if (tbl && tbl->tbl_items) {
9541 register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary;
9542 UV riter = tbl->tbl_max;
9545 PTR_TBL_ENT_t *entry = array[riter];
9548 PTR_TBL_ENT_t * const oentry = entry;
9549 entry = entry->next;
9558 /* clear and free a ptr table */
9561 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
9566 ptr_table_clear(tbl);
9567 Safefree(tbl->tbl_ary);
9573 Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param)
9576 SvRV_set(dstr, SvWEAKREF(sstr)
9577 ? sv_dup(SvRV(sstr), param)
9578 : sv_dup_inc(SvRV(sstr), param));
9581 else if (SvPVX_const(sstr)) {
9582 /* Has something there */
9584 /* Normal PV - clone whole allocated space */
9585 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
9586 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9587 /* Not that normal - actually sstr is copy on write.
9588 But we are a true, independant SV, so: */
9589 SvREADONLY_off(dstr);
9594 /* Special case - not normally malloced for some reason */
9595 if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
9596 /* A "shared" PV - clone it as "shared" PV */
9598 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
9602 /* Some other special case - random pointer */
9603 SvPV_set(dstr, SvPVX(sstr));
9609 if (SvTYPE(dstr) == SVt_RV)
9610 SvRV_set(dstr, NULL);
9612 SvPV_set(dstr, NULL);
9616 /* duplicate an SV of any type (including AV, HV etc) */
9619 Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
9624 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
9626 /* look for it in the table first */
9627 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
9631 if(param->flags & CLONEf_JOIN_IN) {
9632 /** We are joining here so we don't want do clone
9633 something that is bad **/
9634 if (SvTYPE(sstr) == SVt_PVHV) {
9635 const char * const hvname = HvNAME_get(sstr);
9637 /** don't clone stashes if they already exist **/
9638 return (SV*)gv_stashpv(hvname,0);
9642 /* create anew and remember what it is */
9645 #ifdef DEBUG_LEAKING_SCALARS
9646 dstr->sv_debug_optype = sstr->sv_debug_optype;
9647 dstr->sv_debug_line = sstr->sv_debug_line;
9648 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
9649 dstr->sv_debug_cloned = 1;
9650 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
9653 ptr_table_store(PL_ptr_table, sstr, dstr);
9656 SvFLAGS(dstr) = SvFLAGS(sstr);
9657 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
9658 SvREFCNT(dstr) = 0; /* must be before any other dups! */
9661 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
9662 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
9663 PL_watch_pvx, SvPVX_const(sstr));
9666 /* don't clone objects whose class has asked us not to */
9667 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
9668 SvFLAGS(dstr) &= ~SVTYPEMASK;
9673 switch (SvTYPE(sstr)) {
9678 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
9679 SvIV_set(dstr, SvIVX(sstr));
9682 SvANY(dstr) = new_XNV();
9683 SvNV_set(dstr, SvNVX(sstr));
9686 SvANY(dstr) = &(dstr->sv_u.svu_rv);
9687 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9691 /* These are all the types that need complex bodies allocating. */
9693 const svtype sv_type = SvTYPE(sstr);
9694 const struct body_details *const sv_type_details
9695 = bodies_by_type + sv_type;
9699 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
9703 if (GvUNIQUE((GV*)sstr)) {
9704 /*EMPTY*/; /* Do sharing here, and fall through */
9717 assert(sv_type_details->body_size);
9718 if (sv_type_details->arena) {
9719 new_body_inline(new_body, sv_type);
9721 = (void*)((char*)new_body - sv_type_details->offset);
9723 new_body = new_NOARENA(sv_type_details);
9727 SvANY(dstr) = new_body;
9730 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
9731 ((char*)SvANY(dstr)) + sv_type_details->offset,
9732 sv_type_details->copy, char);
9734 Copy(((char*)SvANY(sstr)),
9735 ((char*)SvANY(dstr)),
9736 sv_type_details->body_size + sv_type_details->offset, char);
9739 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV)
9740 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9742 /* The Copy above means that all the source (unduplicated) pointers
9743 are now in the destination. We can check the flags and the
9744 pointers in either, but it's possible that there's less cache
9745 missing by always going for the destination.
9746 FIXME - instrument and check that assumption */
9747 if (sv_type >= SVt_PVMG) {
9749 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
9751 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
9754 /* The cast silences a GCC warning about unhandled types. */
9755 switch ((int)sv_type) {
9767 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
9768 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
9769 LvTARG(dstr) = dstr;
9770 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
9771 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
9773 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
9776 GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr));
9777 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
9778 /* Don't call sv_add_backref here as it's going to be created
9779 as part of the magic cloning of the symbol table. */
9780 GvGP(dstr) = gp_dup(GvGP(dstr), param);
9781 (void)GpREFCNT_inc(GvGP(dstr));
9784 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
9785 if (IoOFP(dstr) == IoIFP(sstr))
9786 IoOFP(dstr) = IoIFP(dstr);
9788 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
9789 /* PL_rsfp_filters entries have fake IoDIRP() */
9790 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
9791 /* I have no idea why fake dirp (rsfps)
9792 should be treated differently but otherwise
9793 we end up with leaks -- sky*/
9794 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
9795 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
9796 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
9798 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
9799 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
9800 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
9802 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
9805 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
9808 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
9809 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
9810 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
9813 if (AvARRAY((AV*)sstr)) {
9814 SV **dst_ary, **src_ary;
9815 SSize_t items = AvFILLp((AV*)sstr) + 1;
9817 src_ary = AvARRAY((AV*)sstr);
9818 Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*);
9819 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
9820 SvPV_set(dstr, (char*)dst_ary);
9821 AvALLOC((AV*)dstr) = dst_ary;
9822 if (AvREAL((AV*)sstr)) {
9824 *dst_ary++ = sv_dup_inc(*src_ary++, param);
9828 *dst_ary++ = sv_dup(*src_ary++, param);
9830 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
9831 while (items-- > 0) {
9832 *dst_ary++ = &PL_sv_undef;
9836 SvPV_set(dstr, NULL);
9837 AvALLOC((AV*)dstr) = (SV**)NULL;
9844 if (HvARRAY((HV*)sstr)) {
9846 const bool sharekeys = !!HvSHAREKEYS(sstr);
9847 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
9848 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
9850 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
9851 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
9853 HvARRAY(dstr) = (HE**)darray;
9854 while (i <= sxhv->xhv_max) {
9855 const HE *source = HvARRAY(sstr)[i];
9856 HvARRAY(dstr)[i] = source
9857 ? he_dup(source, sharekeys, param) : 0;
9861 struct xpvhv_aux * const saux = HvAUX(sstr);
9862 struct xpvhv_aux * const daux = HvAUX(dstr);
9863 /* This flag isn't copied. */
9864 /* SvOOK_on(hv) attacks the IV flags. */
9865 SvFLAGS(dstr) |= SVf_OOK;
9867 hvname = saux->xhv_name;
9869 = hvname ? hek_dup(hvname, param) : hvname;
9871 daux->xhv_riter = saux->xhv_riter;
9872 daux->xhv_eiter = saux->xhv_eiter
9873 ? he_dup(saux->xhv_eiter,
9874 (bool)!!HvSHAREKEYS(sstr), param) : 0;
9875 daux->xhv_backreferences = saux->xhv_backreferences
9876 ? (AV*) SvREFCNT_inc(
9884 SvPV_set(dstr, NULL);
9886 /* Record stashes for possible cloning in Perl_clone(). */
9888 av_push(param->stashes, dstr);
9892 if (!(param->flags & CLONEf_COPY_STACKS)) {
9896 /* NOTE: not refcounted */
9897 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
9899 if (!CvISXSUB(dstr))
9900 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
9902 if (CvCONST(dstr) && CvISXSUB(dstr)) {
9903 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
9904 SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
9905 sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
9907 /* don't dup if copying back - CvGV isn't refcounted, so the
9908 * duped GV may never be freed. A bit of a hack! DAPM */
9909 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
9910 NULL : gv_dup(CvGV(dstr), param) ;
9911 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
9914 ? cv_dup( CvOUTSIDE(dstr), param)
9915 : cv_dup_inc(CvOUTSIDE(dstr), param);
9916 if (!CvISXSUB(dstr))
9917 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
9923 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
9929 /* duplicate a context */
9932 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
9937 return (PERL_CONTEXT*)NULL;
9939 /* look for it in the table first */
9940 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
9944 /* create anew and remember what it is */
9945 Newxz(ncxs, max + 1, PERL_CONTEXT);
9946 ptr_table_store(PL_ptr_table, cxs, ncxs);
9949 PERL_CONTEXT * const cx = &cxs[ix];
9950 PERL_CONTEXT * const ncx = &ncxs[ix];
9951 ncx->cx_type = cx->cx_type;
9952 if (CxTYPE(cx) == CXt_SUBST) {
9953 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
9956 ncx->blk_oldsp = cx->blk_oldsp;
9957 ncx->blk_oldcop = cx->blk_oldcop;
9958 ncx->blk_oldmarksp = cx->blk_oldmarksp;
9959 ncx->blk_oldscopesp = cx->blk_oldscopesp;
9960 ncx->blk_oldpm = cx->blk_oldpm;
9961 ncx->blk_gimme = cx->blk_gimme;
9962 switch (CxTYPE(cx)) {
9964 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
9965 ? cv_dup_inc(cx->blk_sub.cv, param)
9966 : cv_dup(cx->blk_sub.cv,param));
9967 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
9968 ? av_dup_inc(cx->blk_sub.argarray, param)
9970 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
9971 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
9972 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9973 ncx->blk_sub.lval = cx->blk_sub.lval;
9974 ncx->blk_sub.retop = cx->blk_sub.retop;
9977 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
9978 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
9979 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
9980 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
9981 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
9982 ncx->blk_eval.retop = cx->blk_eval.retop;
9985 ncx->blk_loop.label = cx->blk_loop.label;
9986 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
9987 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
9988 ncx->blk_loop.next_op = cx->blk_loop.next_op;
9989 ncx->blk_loop.last_op = cx->blk_loop.last_op;
9990 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
9991 ? cx->blk_loop.iterdata
9992 : gv_dup((GV*)cx->blk_loop.iterdata, param));
9993 ncx->blk_loop.oldcomppad
9994 = (PAD*)ptr_table_fetch(PL_ptr_table,
9995 cx->blk_loop.oldcomppad);
9996 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
9997 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
9998 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
9999 ncx->blk_loop.iterix = cx->blk_loop.iterix;
10000 ncx->blk_loop.itermax = cx->blk_loop.itermax;
10003 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
10004 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
10005 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
10006 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10007 ncx->blk_sub.retop = cx->blk_sub.retop;
10019 /* duplicate a stack info structure */
10022 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10027 return (PERL_SI*)NULL;
10029 /* look for it in the table first */
10030 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10034 /* create anew and remember what it is */
10035 Newxz(nsi, 1, PERL_SI);
10036 ptr_table_store(PL_ptr_table, si, nsi);
10038 nsi->si_stack = av_dup_inc(si->si_stack, param);
10039 nsi->si_cxix = si->si_cxix;
10040 nsi->si_cxmax = si->si_cxmax;
10041 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
10042 nsi->si_type = si->si_type;
10043 nsi->si_prev = si_dup(si->si_prev, param);
10044 nsi->si_next = si_dup(si->si_next, param);
10045 nsi->si_markoff = si->si_markoff;
10050 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
10051 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
10052 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
10053 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
10054 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
10055 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
10056 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
10057 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
10058 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
10059 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
10060 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
10061 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
10062 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
10063 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
10066 #define pv_dup_inc(p) SAVEPV(p)
10067 #define pv_dup(p) SAVEPV(p)
10068 #define svp_dup_inc(p,pp) any_dup(p,pp)
10070 /* map any object to the new equivent - either something in the
10071 * ptr table, or something in the interpreter structure
10075 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
10080 return (void*)NULL;
10082 /* look for it in the table first */
10083 ret = ptr_table_fetch(PL_ptr_table, v);
10087 /* see if it is part of the interpreter structure */
10088 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
10089 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
10097 /* duplicate the save stack */
10100 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
10102 ANY * const ss = proto_perl->Tsavestack;
10103 const I32 max = proto_perl->Tsavestack_max;
10104 I32 ix = proto_perl->Tsavestack_ix;
10116 void (*dptr) (void*);
10117 void (*dxptr) (pTHX_ void*);
10119 Newxz(nss, max, ANY);
10122 I32 i = POPINT(ss,ix);
10123 TOPINT(nss,ix) = i;
10125 case SAVEt_ITEM: /* normal string */
10126 sv = (SV*)POPPTR(ss,ix);
10127 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10128 sv = (SV*)POPPTR(ss,ix);
10129 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10131 case SAVEt_SV: /* scalar reference */
10132 sv = (SV*)POPPTR(ss,ix);
10133 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10134 gv = (GV*)POPPTR(ss,ix);
10135 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10137 case SAVEt_GENERIC_PVREF: /* generic char* */
10138 c = (char*)POPPTR(ss,ix);
10139 TOPPTR(nss,ix) = pv_dup(c);
10140 ptr = POPPTR(ss,ix);
10141 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10143 case SAVEt_SHARED_PVREF: /* char* in shared space */
10144 c = (char*)POPPTR(ss,ix);
10145 TOPPTR(nss,ix) = savesharedpv(c);
10146 ptr = POPPTR(ss,ix);
10147 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10149 case SAVEt_GENERIC_SVREF: /* generic sv */
10150 case SAVEt_SVREF: /* scalar reference */
10151 sv = (SV*)POPPTR(ss,ix);
10152 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10153 ptr = POPPTR(ss,ix);
10154 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
10156 case SAVEt_AV: /* array reference */
10157 av = (AV*)POPPTR(ss,ix);
10158 TOPPTR(nss,ix) = av_dup_inc(av, param);
10159 gv = (GV*)POPPTR(ss,ix);
10160 TOPPTR(nss,ix) = gv_dup(gv, param);
10162 case SAVEt_HV: /* hash reference */
10163 hv = (HV*)POPPTR(ss,ix);
10164 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10165 gv = (GV*)POPPTR(ss,ix);
10166 TOPPTR(nss,ix) = gv_dup(gv, param);
10168 case SAVEt_INT: /* int reference */
10169 ptr = POPPTR(ss,ix);
10170 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10171 intval = (int)POPINT(ss,ix);
10172 TOPINT(nss,ix) = intval;
10174 case SAVEt_LONG: /* long reference */
10175 ptr = POPPTR(ss,ix);
10176 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10177 longval = (long)POPLONG(ss,ix);
10178 TOPLONG(nss,ix) = longval;
10180 case SAVEt_I32: /* I32 reference */
10181 case SAVEt_I16: /* I16 reference */
10182 case SAVEt_I8: /* I8 reference */
10183 ptr = POPPTR(ss,ix);
10184 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10186 TOPINT(nss,ix) = i;
10188 case SAVEt_IV: /* IV reference */
10189 ptr = POPPTR(ss,ix);
10190 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10192 TOPIV(nss,ix) = iv;
10194 case SAVEt_SPTR: /* SV* reference */
10195 ptr = POPPTR(ss,ix);
10196 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10197 sv = (SV*)POPPTR(ss,ix);
10198 TOPPTR(nss,ix) = sv_dup(sv, param);
10200 case SAVEt_VPTR: /* random* reference */
10201 ptr = POPPTR(ss,ix);
10202 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10203 ptr = POPPTR(ss,ix);
10204 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10206 case SAVEt_PPTR: /* char* reference */
10207 ptr = POPPTR(ss,ix);
10208 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10209 c = (char*)POPPTR(ss,ix);
10210 TOPPTR(nss,ix) = pv_dup(c);
10212 case SAVEt_HPTR: /* HV* reference */
10213 ptr = POPPTR(ss,ix);
10214 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10215 hv = (HV*)POPPTR(ss,ix);
10216 TOPPTR(nss,ix) = hv_dup(hv, param);
10218 case SAVEt_APTR: /* AV* reference */
10219 ptr = POPPTR(ss,ix);
10220 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10221 av = (AV*)POPPTR(ss,ix);
10222 TOPPTR(nss,ix) = av_dup(av, param);
10225 gv = (GV*)POPPTR(ss,ix);
10226 TOPPTR(nss,ix) = gv_dup(gv, param);
10228 case SAVEt_GP: /* scalar reference */
10229 gp = (GP*)POPPTR(ss,ix);
10230 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
10231 (void)GpREFCNT_inc(gp);
10232 gv = (GV*)POPPTR(ss,ix);
10233 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10234 c = (char*)POPPTR(ss,ix);
10235 TOPPTR(nss,ix) = pv_dup(c);
10237 TOPIV(nss,ix) = iv;
10239 TOPIV(nss,ix) = iv;
10242 case SAVEt_MORTALIZESV:
10243 sv = (SV*)POPPTR(ss,ix);
10244 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10247 ptr = POPPTR(ss,ix);
10248 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
10249 /* these are assumed to be refcounted properly */
10251 switch (((OP*)ptr)->op_type) {
10253 case OP_LEAVESUBLV:
10257 case OP_LEAVEWRITE:
10258 TOPPTR(nss,ix) = ptr;
10263 TOPPTR(nss,ix) = NULL;
10268 TOPPTR(nss,ix) = NULL;
10271 c = (char*)POPPTR(ss,ix);
10272 TOPPTR(nss,ix) = pv_dup_inc(c);
10274 case SAVEt_CLEARSV:
10275 longval = POPLONG(ss,ix);
10276 TOPLONG(nss,ix) = longval;
10279 hv = (HV*)POPPTR(ss,ix);
10280 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10281 c = (char*)POPPTR(ss,ix);
10282 TOPPTR(nss,ix) = pv_dup_inc(c);
10284 TOPINT(nss,ix) = i;
10286 case SAVEt_DESTRUCTOR:
10287 ptr = POPPTR(ss,ix);
10288 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10289 dptr = POPDPTR(ss,ix);
10290 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
10291 any_dup(FPTR2DPTR(void *, dptr),
10294 case SAVEt_DESTRUCTOR_X:
10295 ptr = POPPTR(ss,ix);
10296 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10297 dxptr = POPDXPTR(ss,ix);
10298 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
10299 any_dup(FPTR2DPTR(void *, dxptr),
10302 case SAVEt_REGCONTEXT:
10305 TOPINT(nss,ix) = i;
10308 case SAVEt_STACK_POS: /* Position on Perl stack */
10310 TOPINT(nss,ix) = i;
10312 case SAVEt_AELEM: /* array element */
10313 sv = (SV*)POPPTR(ss,ix);
10314 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10316 TOPINT(nss,ix) = i;
10317 av = (AV*)POPPTR(ss,ix);
10318 TOPPTR(nss,ix) = av_dup_inc(av, param);
10320 case SAVEt_HELEM: /* hash element */
10321 sv = (SV*)POPPTR(ss,ix);
10322 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10323 sv = (SV*)POPPTR(ss,ix);
10324 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10325 hv = (HV*)POPPTR(ss,ix);
10326 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10329 ptr = POPPTR(ss,ix);
10330 TOPPTR(nss,ix) = ptr;
10334 TOPINT(nss,ix) = i;
10336 case SAVEt_COMPPAD:
10337 av = (AV*)POPPTR(ss,ix);
10338 TOPPTR(nss,ix) = av_dup(av, param);
10341 longval = (long)POPLONG(ss,ix);
10342 TOPLONG(nss,ix) = longval;
10343 ptr = POPPTR(ss,ix);
10344 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10345 sv = (SV*)POPPTR(ss,ix);
10346 TOPPTR(nss,ix) = sv_dup(sv, param);
10349 ptr = POPPTR(ss,ix);
10350 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10351 longval = (long)POPBOOL(ss,ix);
10352 TOPBOOL(nss,ix) = (bool)longval;
10354 case SAVEt_SET_SVFLAGS:
10356 TOPINT(nss,ix) = i;
10358 TOPINT(nss,ix) = i;
10359 sv = (SV*)POPPTR(ss,ix);
10360 TOPPTR(nss,ix) = sv_dup(sv, param);
10363 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
10371 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
10372 * flag to the result. This is done for each stash before cloning starts,
10373 * so we know which stashes want their objects cloned */
10376 do_mark_cloneable_stash(pTHX_ SV *sv)
10378 const HEK * const hvname = HvNAME_HEK((HV*)sv);
10380 GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
10381 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
10382 if (cloner && GvCV(cloner)) {
10389 XPUSHs(sv_2mortal(newSVhek(hvname)));
10391 call_sv((SV*)GvCV(cloner), G_SCALAR);
10398 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
10406 =for apidoc perl_clone
10408 Create and return a new interpreter by cloning the current one.
10410 perl_clone takes these flags as parameters:
10412 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
10413 without it we only clone the data and zero the stacks,
10414 with it we copy the stacks and the new perl interpreter is
10415 ready to run at the exact same point as the previous one.
10416 The pseudo-fork code uses COPY_STACKS while the
10417 threads->new doesn't.
10419 CLONEf_KEEP_PTR_TABLE
10420 perl_clone keeps a ptr_table with the pointer of the old
10421 variable as a key and the new variable as a value,
10422 this allows it to check if something has been cloned and not
10423 clone it again but rather just use the value and increase the
10424 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
10425 the ptr_table using the function
10426 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
10427 reason to keep it around is if you want to dup some of your own
10428 variable who are outside the graph perl scans, example of this
10429 code is in threads.xs create
10432 This is a win32 thing, it is ignored on unix, it tells perls
10433 win32host code (which is c++) to clone itself, this is needed on
10434 win32 if you want to run two threads at the same time,
10435 if you just want to do some stuff in a separate perl interpreter
10436 and then throw it away and return to the original one,
10437 you don't need to do anything.
10442 /* XXX the above needs expanding by someone who actually understands it ! */
10443 EXTERN_C PerlInterpreter *
10444 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
10447 perl_clone(PerlInterpreter *proto_perl, UV flags)
10450 #ifdef PERL_IMPLICIT_SYS
10452 /* perlhost.h so we need to call into it
10453 to clone the host, CPerlHost should have a c interface, sky */
10455 if (flags & CLONEf_CLONE_HOST) {
10456 return perl_clone_host(proto_perl,flags);
10458 return perl_clone_using(proto_perl, flags,
10460 proto_perl->IMemShared,
10461 proto_perl->IMemParse,
10463 proto_perl->IStdIO,
10467 proto_perl->IProc);
10471 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
10472 struct IPerlMem* ipM, struct IPerlMem* ipMS,
10473 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
10474 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
10475 struct IPerlDir* ipD, struct IPerlSock* ipS,
10476 struct IPerlProc* ipP)
10478 /* XXX many of the string copies here can be optimized if they're
10479 * constants; they need to be allocated as common memory and just
10480 * their pointers copied. */
10483 CLONE_PARAMS clone_params;
10484 CLONE_PARAMS* const param = &clone_params;
10486 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
10487 /* for each stash, determine whether its objects should be cloned */
10488 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10489 PERL_SET_THX(my_perl);
10492 Poison(my_perl, 1, PerlInterpreter);
10498 PL_savestack_ix = 0;
10499 PL_savestack_max = -1;
10500 PL_sig_pending = 0;
10501 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10502 # else /* !DEBUGGING */
10503 Zero(my_perl, 1, PerlInterpreter);
10504 # endif /* DEBUGGING */
10506 /* host pointers */
10508 PL_MemShared = ipMS;
10509 PL_MemParse = ipMP;
10516 #else /* !PERL_IMPLICIT_SYS */
10518 CLONE_PARAMS clone_params;
10519 CLONE_PARAMS* param = &clone_params;
10520 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
10521 /* for each stash, determine whether its objects should be cloned */
10522 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10523 PERL_SET_THX(my_perl);
10526 Poison(my_perl, 1, PerlInterpreter);
10532 PL_savestack_ix = 0;
10533 PL_savestack_max = -1;
10534 PL_sig_pending = 0;
10535 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10536 # else /* !DEBUGGING */
10537 Zero(my_perl, 1, PerlInterpreter);
10538 # endif /* DEBUGGING */
10539 #endif /* PERL_IMPLICIT_SYS */
10540 param->flags = flags;
10541 param->proto_perl = proto_perl;
10543 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
10545 PL_body_arenas = NULL;
10546 Zero(&PL_body_roots, 1, PL_body_roots);
10548 PL_nice_chunk = NULL;
10549 PL_nice_chunk_size = 0;
10551 PL_sv_objcount = 0;
10553 PL_sv_arenaroot = NULL;
10555 PL_debug = proto_perl->Idebug;
10557 PL_hash_seed = proto_perl->Ihash_seed;
10558 PL_rehash_seed = proto_perl->Irehash_seed;
10560 #ifdef USE_REENTRANT_API
10561 /* XXX: things like -Dm will segfault here in perlio, but doing
10562 * PERL_SET_CONTEXT(proto_perl);
10563 * breaks too many other things
10565 Perl_reentrant_init(aTHX);
10568 /* create SV map for pointer relocation */
10569 PL_ptr_table = ptr_table_new();
10571 /* initialize these special pointers as early as possible */
10572 SvANY(&PL_sv_undef) = NULL;
10573 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
10574 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
10575 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
10577 SvANY(&PL_sv_no) = new_XPVNV();
10578 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
10579 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
10580 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10581 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
10582 SvCUR_set(&PL_sv_no, 0);
10583 SvLEN_set(&PL_sv_no, 1);
10584 SvIV_set(&PL_sv_no, 0);
10585 SvNV_set(&PL_sv_no, 0);
10586 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
10588 SvANY(&PL_sv_yes) = new_XPVNV();
10589 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
10590 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
10591 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10592 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
10593 SvCUR_set(&PL_sv_yes, 1);
10594 SvLEN_set(&PL_sv_yes, 2);
10595 SvIV_set(&PL_sv_yes, 1);
10596 SvNV_set(&PL_sv_yes, 1);
10597 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
10599 /* create (a non-shared!) shared string table */
10600 PL_strtab = newHV();
10601 HvSHAREKEYS_off(PL_strtab);
10602 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
10603 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
10605 PL_compiling = proto_perl->Icompiling;
10607 /* These two PVs will be free'd special way so must set them same way op.c does */
10608 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
10609 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
10611 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
10612 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
10614 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
10615 if (!specialWARN(PL_compiling.cop_warnings))
10616 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
10617 if (!specialCopIO(PL_compiling.cop_io))
10618 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
10619 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
10621 /* pseudo environmental stuff */
10622 PL_origargc = proto_perl->Iorigargc;
10623 PL_origargv = proto_perl->Iorigargv;
10625 param->stashes = newAV(); /* Setup array of objects to call clone on */
10627 /* Set tainting stuff before PerlIO_debug can possibly get called */
10628 PL_tainting = proto_perl->Itainting;
10629 PL_taint_warn = proto_perl->Itaint_warn;
10631 #ifdef PERLIO_LAYERS
10632 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
10633 PerlIO_clone(aTHX_ proto_perl, param);
10636 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
10637 PL_incgv = gv_dup(proto_perl->Iincgv, param);
10638 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
10639 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
10640 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
10641 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
10644 PL_minus_c = proto_perl->Iminus_c;
10645 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
10646 PL_localpatches = proto_perl->Ilocalpatches;
10647 PL_splitstr = proto_perl->Isplitstr;
10648 PL_preprocess = proto_perl->Ipreprocess;
10649 PL_minus_n = proto_perl->Iminus_n;
10650 PL_minus_p = proto_perl->Iminus_p;
10651 PL_minus_l = proto_perl->Iminus_l;
10652 PL_minus_a = proto_perl->Iminus_a;
10653 PL_minus_E = proto_perl->Iminus_E;
10654 PL_minus_F = proto_perl->Iminus_F;
10655 PL_doswitches = proto_perl->Idoswitches;
10656 PL_dowarn = proto_perl->Idowarn;
10657 PL_doextract = proto_perl->Idoextract;
10658 PL_sawampersand = proto_perl->Isawampersand;
10659 PL_unsafe = proto_perl->Iunsafe;
10660 PL_inplace = SAVEPV(proto_perl->Iinplace);
10661 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
10662 PL_perldb = proto_perl->Iperldb;
10663 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
10664 PL_exit_flags = proto_perl->Iexit_flags;
10666 /* magical thingies */
10667 /* XXX time(&PL_basetime) when asked for? */
10668 PL_basetime = proto_perl->Ibasetime;
10669 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
10671 PL_maxsysfd = proto_perl->Imaxsysfd;
10672 PL_multiline = proto_perl->Imultiline;
10673 PL_statusvalue = proto_perl->Istatusvalue;
10675 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
10677 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
10679 PL_encoding = sv_dup(proto_perl->Iencoding, param);
10681 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
10682 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
10683 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
10685 /* Clone the regex array */
10686 PL_regex_padav = newAV();
10688 const I32 len = av_len((AV*)proto_perl->Iregex_padav);
10689 SV* const * const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
10691 av_push(PL_regex_padav,
10692 sv_dup_inc(regexen[0],param));
10693 for(i = 1; i <= len; i++) {
10694 const SV * const regex = regexen[i];
10697 ? sv_dup_inc(regex, param)
10699 newSViv(PTR2IV(re_dup(
10700 INT2PTR(REGEXP *, SvIVX(regex)), param))))
10702 av_push(PL_regex_padav, sv);
10705 PL_regex_pad = AvARRAY(PL_regex_padav);
10707 /* shortcuts to various I/O objects */
10708 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
10709 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
10710 PL_defgv = gv_dup(proto_perl->Idefgv, param);
10711 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
10712 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
10713 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
10715 /* shortcuts to regexp stuff */
10716 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
10718 /* shortcuts to misc objects */
10719 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
10721 /* shortcuts to debugging objects */
10722 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
10723 PL_DBline = gv_dup(proto_perl->IDBline, param);
10724 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
10725 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
10726 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
10727 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
10728 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
10729 PL_lineary = av_dup(proto_perl->Ilineary, param);
10730 PL_dbargs = av_dup(proto_perl->Idbargs, param);
10732 /* symbol tables */
10733 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
10734 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
10735 PL_debstash = hv_dup(proto_perl->Idebstash, param);
10736 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
10737 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
10739 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
10740 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
10741 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
10742 PL_endav = av_dup_inc(proto_perl->Iendav, param);
10743 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
10744 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
10746 PL_sub_generation = proto_perl->Isub_generation;
10748 /* funky return mechanisms */
10749 PL_forkprocess = proto_perl->Iforkprocess;
10751 /* subprocess state */
10752 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
10754 /* internal state */
10755 PL_maxo = proto_perl->Imaxo;
10756 if (proto_perl->Iop_mask)
10757 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
10760 /* PL_asserting = proto_perl->Iasserting; */
10762 /* current interpreter roots */
10763 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
10764 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
10765 PL_main_start = proto_perl->Imain_start;
10766 PL_eval_root = proto_perl->Ieval_root;
10767 PL_eval_start = proto_perl->Ieval_start;
10769 /* runtime control stuff */
10770 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
10771 PL_copline = proto_perl->Icopline;
10773 PL_filemode = proto_perl->Ifilemode;
10774 PL_lastfd = proto_perl->Ilastfd;
10775 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
10778 PL_gensym = proto_perl->Igensym;
10779 PL_preambled = proto_perl->Ipreambled;
10780 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
10781 PL_laststatval = proto_perl->Ilaststatval;
10782 PL_laststype = proto_perl->Ilaststype;
10785 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
10787 /* interpreter atexit processing */
10788 PL_exitlistlen = proto_perl->Iexitlistlen;
10789 if (PL_exitlistlen) {
10790 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10791 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10794 PL_exitlist = (PerlExitListEntry*)NULL;
10796 PL_my_cxt_size = proto_perl->Imy_cxt_size;
10797 if (PL_my_cxt_size) {
10798 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
10799 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
10802 PL_my_cxt_list = (void**)NULL;
10803 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
10804 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
10805 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
10807 PL_profiledata = NULL;
10808 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
10809 /* PL_rsfp_filters entries have fake IoDIRP() */
10810 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
10812 PL_compcv = cv_dup(proto_perl->Icompcv, param);
10814 PAD_CLONE_VARS(proto_perl, param);
10816 #ifdef HAVE_INTERP_INTERN
10817 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
10820 /* more statics moved here */
10821 PL_generation = proto_perl->Igeneration;
10822 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
10824 PL_in_clean_objs = proto_perl->Iin_clean_objs;
10825 PL_in_clean_all = proto_perl->Iin_clean_all;
10827 PL_uid = proto_perl->Iuid;
10828 PL_euid = proto_perl->Ieuid;
10829 PL_gid = proto_perl->Igid;
10830 PL_egid = proto_perl->Iegid;
10831 PL_nomemok = proto_perl->Inomemok;
10832 PL_an = proto_perl->Ian;
10833 PL_evalseq = proto_perl->Ievalseq;
10834 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
10835 PL_origalen = proto_perl->Iorigalen;
10836 #ifdef PERL_USES_PL_PIDSTATUS
10837 PL_pidstatus = newHV(); /* XXX flag for cloning? */
10839 PL_osname = SAVEPV(proto_perl->Iosname);
10840 PL_sighandlerp = proto_perl->Isighandlerp;
10842 PL_runops = proto_perl->Irunops;
10844 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
10847 PL_cshlen = proto_perl->Icshlen;
10848 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
10851 PL_lex_state = proto_perl->Ilex_state;
10852 PL_lex_defer = proto_perl->Ilex_defer;
10853 PL_lex_expect = proto_perl->Ilex_expect;
10854 PL_lex_formbrack = proto_perl->Ilex_formbrack;
10855 PL_lex_dojoin = proto_perl->Ilex_dojoin;
10856 PL_lex_starts = proto_perl->Ilex_starts;
10857 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
10858 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
10859 PL_lex_op = proto_perl->Ilex_op;
10860 PL_lex_inpat = proto_perl->Ilex_inpat;
10861 PL_lex_inwhat = proto_perl->Ilex_inwhat;
10862 PL_lex_brackets = proto_perl->Ilex_brackets;
10863 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
10864 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
10865 PL_lex_casemods = proto_perl->Ilex_casemods;
10866 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
10867 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
10869 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
10870 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
10871 PL_nexttoke = proto_perl->Inexttoke;
10873 /* XXX This is probably masking the deeper issue of why
10874 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
10875 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
10876 * (A little debugging with a watchpoint on it may help.)
10878 if (SvANY(proto_perl->Ilinestr)) {
10879 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
10880 i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
10881 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10882 i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
10883 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10884 i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
10885 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10886 i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
10887 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10890 PL_linestr = newSV(79);
10891 sv_upgrade(PL_linestr,SVt_PVIV);
10892 sv_setpvn(PL_linestr,"",0);
10893 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
10895 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10896 PL_pending_ident = proto_perl->Ipending_ident;
10897 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
10899 PL_expect = proto_perl->Iexpect;
10901 PL_multi_start = proto_perl->Imulti_start;
10902 PL_multi_end = proto_perl->Imulti_end;
10903 PL_multi_open = proto_perl->Imulti_open;
10904 PL_multi_close = proto_perl->Imulti_close;
10906 PL_error_count = proto_perl->Ierror_count;
10907 PL_subline = proto_perl->Isubline;
10908 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
10910 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
10911 if (SvANY(proto_perl->Ilinestr)) {
10912 i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
10913 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10914 i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
10915 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10916 PL_last_lop_op = proto_perl->Ilast_lop_op;
10919 PL_last_uni = SvPVX(PL_linestr);
10920 PL_last_lop = SvPVX(PL_linestr);
10921 PL_last_lop_op = 0;
10923 PL_in_my = proto_perl->Iin_my;
10924 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
10926 PL_cryptseen = proto_perl->Icryptseen;
10929 PL_hints = proto_perl->Ihints;
10931 PL_amagic_generation = proto_perl->Iamagic_generation;
10933 #ifdef USE_LOCALE_COLLATE
10934 PL_collation_ix = proto_perl->Icollation_ix;
10935 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
10936 PL_collation_standard = proto_perl->Icollation_standard;
10937 PL_collxfrm_base = proto_perl->Icollxfrm_base;
10938 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
10939 #endif /* USE_LOCALE_COLLATE */
10941 #ifdef USE_LOCALE_NUMERIC
10942 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
10943 PL_numeric_standard = proto_perl->Inumeric_standard;
10944 PL_numeric_local = proto_perl->Inumeric_local;
10945 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
10946 #endif /* !USE_LOCALE_NUMERIC */
10948 /* utf8 character classes */
10949 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
10950 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
10951 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
10952 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
10953 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
10954 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
10955 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
10956 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
10957 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
10958 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
10959 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
10960 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
10961 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
10962 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
10963 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
10964 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
10965 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
10966 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
10967 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
10968 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
10970 /* Did the locale setup indicate UTF-8? */
10971 PL_utf8locale = proto_perl->Iutf8locale;
10972 /* Unicode features (see perlrun/-C) */
10973 PL_unicode = proto_perl->Iunicode;
10975 /* Pre-5.8 signals control */
10976 PL_signals = proto_perl->Isignals;
10978 /* times() ticks per second */
10979 PL_clocktick = proto_perl->Iclocktick;
10981 /* Recursion stopper for PerlIO_find_layer */
10982 PL_in_load_module = proto_perl->Iin_load_module;
10984 /* sort() routine */
10985 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
10987 /* Not really needed/useful since the reenrant_retint is "volatile",
10988 * but do it for consistency's sake. */
10989 PL_reentrant_retint = proto_perl->Ireentrant_retint;
10991 /* Hooks to shared SVs and locks. */
10992 PL_sharehook = proto_perl->Isharehook;
10993 PL_lockhook = proto_perl->Ilockhook;
10994 PL_unlockhook = proto_perl->Iunlockhook;
10995 PL_threadhook = proto_perl->Ithreadhook;
10997 PL_runops_std = proto_perl->Irunops_std;
10998 PL_runops_dbg = proto_perl->Irunops_dbg;
11000 #ifdef THREADS_HAVE_PIDS
11001 PL_ppid = proto_perl->Ippid;
11005 PL_last_swash_hv = NULL; /* reinits on demand */
11006 PL_last_swash_klen = 0;
11007 PL_last_swash_key[0]= '\0';
11008 PL_last_swash_tmps = (U8*)NULL;
11009 PL_last_swash_slen = 0;
11011 PL_glob_index = proto_perl->Iglob_index;
11012 PL_srand_called = proto_perl->Isrand_called;
11013 PL_uudmap['M'] = 0; /* reinits on demand */
11014 PL_bitcount = NULL; /* reinits on demand */
11016 if (proto_perl->Ipsig_pend) {
11017 Newxz(PL_psig_pend, SIG_SIZE, int);
11020 PL_psig_pend = (int*)NULL;
11023 if (proto_perl->Ipsig_ptr) {
11024 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
11025 Newxz(PL_psig_name, SIG_SIZE, SV*);
11026 for (i = 1; i < SIG_SIZE; i++) {
11027 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11028 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11032 PL_psig_ptr = (SV**)NULL;
11033 PL_psig_name = (SV**)NULL;
11036 /* thrdvar.h stuff */
11038 if (flags & CLONEf_COPY_STACKS) {
11039 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11040 PL_tmps_ix = proto_perl->Ttmps_ix;
11041 PL_tmps_max = proto_perl->Ttmps_max;
11042 PL_tmps_floor = proto_perl->Ttmps_floor;
11043 Newxz(PL_tmps_stack, PL_tmps_max, SV*);
11045 while (i <= PL_tmps_ix) {
11046 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
11050 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11051 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
11052 Newxz(PL_markstack, i, I32);
11053 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
11054 - proto_perl->Tmarkstack);
11055 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
11056 - proto_perl->Tmarkstack);
11057 Copy(proto_perl->Tmarkstack, PL_markstack,
11058 PL_markstack_ptr - PL_markstack + 1, I32);
11060 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
11061 * NOTE: unlike the others! */
11062 PL_scopestack_ix = proto_perl->Tscopestack_ix;
11063 PL_scopestack_max = proto_perl->Tscopestack_max;
11064 Newxz(PL_scopestack, PL_scopestack_max, I32);
11065 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
11067 /* NOTE: si_dup() looks at PL_markstack */
11068 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
11070 /* PL_curstack = PL_curstackinfo->si_stack; */
11071 PL_curstack = av_dup(proto_perl->Tcurstack, param);
11072 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
11074 /* next PUSHs() etc. set *(PL_stack_sp+1) */
11075 PL_stack_base = AvARRAY(PL_curstack);
11076 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
11077 - proto_perl->Tstack_base);
11078 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
11080 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
11081 * NOTE: unlike the others! */
11082 PL_savestack_ix = proto_perl->Tsavestack_ix;
11083 PL_savestack_max = proto_perl->Tsavestack_max;
11084 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
11085 PL_savestack = ss_dup(proto_perl, param);
11089 ENTER; /* perl_destruct() wants to LEAVE; */
11091 /* although we're not duplicating the tmps stack, we should still
11092 * add entries for any SVs on the tmps stack that got cloned by a
11093 * non-refcount means (eg a temp in @_); otherwise they will be
11096 for (i = 0; i<= proto_perl->Ttmps_ix; i++) {
11097 SV * const nsv = (SV*)ptr_table_fetch(PL_ptr_table,
11098 proto_perl->Ttmps_stack[i]);
11099 if (nsv && !SvREFCNT(nsv)) {
11101 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc(nsv);
11106 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
11107 PL_top_env = &PL_start_env;
11109 PL_op = proto_perl->Top;
11112 PL_Xpv = (XPV*)NULL;
11113 PL_na = proto_perl->Tna;
11115 PL_statbuf = proto_perl->Tstatbuf;
11116 PL_statcache = proto_perl->Tstatcache;
11117 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
11118 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
11120 PL_timesbuf = proto_perl->Ttimesbuf;
11123 PL_tainted = proto_perl->Ttainted;
11124 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
11125 PL_rs = sv_dup_inc(proto_perl->Trs, param);
11126 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
11127 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
11128 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
11129 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
11130 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
11131 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
11132 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
11134 PL_restartop = proto_perl->Trestartop;
11135 PL_in_eval = proto_perl->Tin_eval;
11136 PL_delaymagic = proto_perl->Tdelaymagic;
11137 PL_dirty = proto_perl->Tdirty;
11138 PL_localizing = proto_perl->Tlocalizing;
11140 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
11141 PL_hv_fetch_ent_mh = NULL;
11142 PL_modcount = proto_perl->Tmodcount;
11143 PL_lastgotoprobe = NULL;
11144 PL_dumpindent = proto_perl->Tdumpindent;
11146 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
11147 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
11148 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
11149 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
11150 PL_efloatbuf = NULL; /* reinits on demand */
11151 PL_efloatsize = 0; /* reinits on demand */
11155 PL_screamfirst = NULL;
11156 PL_screamnext = NULL;
11157 PL_maxscream = -1; /* reinits on demand */
11158 PL_lastscream = NULL;
11160 PL_watchaddr = NULL;
11163 PL_regdummy = proto_perl->Tregdummy;
11164 PL_regprecomp = NULL;
11167 PL_colorset = 0; /* reinits PL_colors[] */
11168 /*PL_colors[6] = {0,0,0,0,0,0};*/
11169 PL_reginput = NULL;
11172 PL_regstartp = (I32*)NULL;
11173 PL_regendp = (I32*)NULL;
11174 PL_reglastparen = (U32*)NULL;
11175 PL_reglastcloseparen = (U32*)NULL;
11177 PL_reg_start_tmp = (char**)NULL;
11178 PL_reg_start_tmpl = 0;
11179 PL_regdata = (struct reg_data*)NULL;
11182 PL_reg_eval_set = 0;
11184 PL_regprogram = (regnode*)NULL;
11186 PL_regcc = (CURCUR*)NULL;
11187 PL_reg_call_cc = (struct re_cc_state*)NULL;
11188 PL_reg_re = (regexp*)NULL;
11189 PL_reg_ganch = NULL;
11191 PL_reg_match_utf8 = FALSE;
11192 PL_reg_magic = (MAGIC*)NULL;
11194 PL_reg_oldcurpm = (PMOP*)NULL;
11195 PL_reg_curpm = (PMOP*)NULL;
11196 PL_reg_oldsaved = NULL;
11197 PL_reg_oldsavedlen = 0;
11198 #ifdef PERL_OLD_COPY_ON_WRITE
11201 PL_reg_maxiter = 0;
11202 PL_reg_leftiter = 0;
11203 PL_reg_poscache = NULL;
11204 PL_reg_poscache_size= 0;
11206 /* RE engine - function pointers */
11207 PL_regcompp = proto_perl->Tregcompp;
11208 PL_regexecp = proto_perl->Tregexecp;
11209 PL_regint_start = proto_perl->Tregint_start;
11210 PL_regint_string = proto_perl->Tregint_string;
11211 PL_regfree = proto_perl->Tregfree;
11213 PL_reginterp_cnt = 0;
11214 PL_reg_starttry = 0;
11216 /* Pluggable optimizer */
11217 PL_peepp = proto_perl->Tpeepp;
11219 PL_stashcache = newHV();
11221 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
11222 ptr_table_free(PL_ptr_table);
11223 PL_ptr_table = NULL;
11226 /* Call the ->CLONE method, if it exists, for each of the stashes
11227 identified by sv_dup() above.
11229 while(av_len(param->stashes) != -1) {
11230 HV* const stash = (HV*) av_shift(param->stashes);
11231 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
11232 if (cloner && GvCV(cloner)) {
11237 XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
11239 call_sv((SV*)GvCV(cloner), G_DISCARD);
11245 SvREFCNT_dec(param->stashes);
11247 /* orphaned? eg threads->new inside BEGIN or use */
11248 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
11249 (void)SvREFCNT_inc(PL_compcv);
11250 SAVEFREESV(PL_compcv);
11256 #endif /* USE_ITHREADS */
11259 =head1 Unicode Support
11261 =for apidoc sv_recode_to_utf8
11263 The encoding is assumed to be an Encode object, on entry the PV
11264 of the sv is assumed to be octets in that encoding, and the sv
11265 will be converted into Unicode (and UTF-8).
11267 If the sv already is UTF-8 (or if it is not POK), or if the encoding
11268 is not a reference, nothing is done to the sv. If the encoding is not
11269 an C<Encode::XS> Encoding object, bad things will happen.
11270 (See F<lib/encoding.pm> and L<Encode>).
11272 The PV of the sv is returned.
11277 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
11280 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
11294 Passing sv_yes is wrong - it needs to be or'ed set of constants
11295 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
11296 remove converted chars from source.
11298 Both will default the value - let them.
11300 XPUSHs(&PL_sv_yes);
11303 call_method("decode", G_SCALAR);
11307 s = SvPV_const(uni, len);
11308 if (s != SvPVX_const(sv)) {
11309 SvGROW(sv, len + 1);
11310 Move(s, SvPVX(sv), len + 1, char);
11311 SvCUR_set(sv, len);
11318 return SvPOKp(sv) ? SvPVX(sv) : NULL;
11322 =for apidoc sv_cat_decode
11324 The encoding is assumed to be an Encode object, the PV of the ssv is
11325 assumed to be octets in that encoding and decoding the input starts
11326 from the position which (PV + *offset) pointed to. The dsv will be
11327 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
11328 when the string tstr appears in decoding output or the input ends on
11329 the PV of the ssv. The value which the offset points will be modified
11330 to the last input position on the ssv.
11332 Returns TRUE if the terminator was found, else returns FALSE.
11337 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
11338 SV *ssv, int *offset, char *tstr, int tlen)
11342 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
11353 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
11354 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
11356 call_method("cat_decode", G_SCALAR);
11358 ret = SvTRUE(TOPs);
11359 *offset = SvIV(offsv);
11365 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
11370 /* ---------------------------------------------------------------------
11372 * support functions for report_uninit()
11375 /* the maxiumum size of array or hash where we will scan looking
11376 * for the undefined element that triggered the warning */
11378 #define FUV_MAX_SEARCH_SIZE 1000
11380 /* Look for an entry in the hash whose value has the same SV as val;
11381 * If so, return a mortal copy of the key. */
11384 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
11387 register HE **array;
11390 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
11391 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
11394 array = HvARRAY(hv);
11396 for (i=HvMAX(hv); i>0; i--) {
11397 register HE *entry;
11398 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
11399 if (HeVAL(entry) != val)
11401 if ( HeVAL(entry) == &PL_sv_undef ||
11402 HeVAL(entry) == &PL_sv_placeholder)
11406 if (HeKLEN(entry) == HEf_SVKEY)
11407 return sv_mortalcopy(HeKEY_sv(entry));
11408 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
11414 /* Look for an entry in the array whose value has the same SV as val;
11415 * If so, return the index, otherwise return -1. */
11418 S_find_array_subscript(pTHX_ AV *av, SV* val)
11423 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
11424 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
11428 for (i=AvFILLp(av); i>=0; i--) {
11429 if (svp[i] == val && svp[i] != &PL_sv_undef)
11435 /* S_varname(): return the name of a variable, optionally with a subscript.
11436 * If gv is non-zero, use the name of that global, along with gvtype (one
11437 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
11438 * targ. Depending on the value of the subscript_type flag, return:
11441 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
11442 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
11443 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
11444 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
11447 S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
11448 SV* keyname, I32 aindex, int subscript_type)
11451 SV * const name = sv_newmortal();
11454 buffer[0] = gvtype;
11457 /* as gv_fullname4(), but add literal '^' for $^FOO names */
11459 gv_fullname4(name, gv, buffer, 0);
11461 if ((unsigned int)SvPVX(name)[1] <= 26) {
11463 buffer[1] = SvPVX(name)[1] + 'A' - 1;
11465 /* Swap the 1 unprintable control character for the 2 byte pretty
11466 version - ie substr($name, 1, 1) = $buffer; */
11467 sv_insert(name, 1, 1, buffer, 2);
11472 CV * const cv = find_runcv(&unused);
11476 if (!cv || !CvPADLIST(cv))
11478 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
11479 sv = *av_fetch(av, targ, FALSE);
11480 /* SvLEN in a pad name is not to be trusted */
11481 sv_setpv(name, SvPV_nolen_const(sv));
11484 if (subscript_type == FUV_SUBSCRIPT_HASH) {
11485 SV * const sv = newSV(0);
11486 *SvPVX(name) = '$';
11487 Perl_sv_catpvf(aTHX_ name, "{%s}",
11488 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
11491 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
11492 *SvPVX(name) = '$';
11493 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
11495 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
11496 Perl_sv_insert(aTHX_ name, 0, 0, STR_WITH_LEN("within "));
11503 =for apidoc find_uninit_var
11505 Find the name of the undefined variable (if any) that caused the operator o
11506 to issue a "Use of uninitialized value" warning.
11507 If match is true, only return a name if it's value matches uninit_sv.
11508 So roughly speaking, if a unary operator (such as OP_COS) generates a
11509 warning, then following the direct child of the op may yield an
11510 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
11511 other hand, with OP_ADD there are two branches to follow, so we only print
11512 the variable name if we get an exact match.
11514 The name is returned as a mortal SV.
11516 Assumes that PL_op is the op that originally triggered the error, and that
11517 PL_comppad/PL_curpad points to the currently executing pad.
11523 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
11531 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
11532 uninit_sv == &PL_sv_placeholder)))
11535 switch (obase->op_type) {
11542 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
11543 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
11546 int subscript_type = FUV_SUBSCRIPT_WITHIN;
11548 if (pad) { /* @lex, %lex */
11549 sv = PAD_SVl(obase->op_targ);
11553 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
11554 /* @global, %global */
11555 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
11558 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
11560 else /* @{expr}, %{expr} */
11561 return find_uninit_var(cUNOPx(obase)->op_first,
11565 /* attempt to find a match within the aggregate */
11567 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
11569 subscript_type = FUV_SUBSCRIPT_HASH;
11572 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
11574 subscript_type = FUV_SUBSCRIPT_ARRAY;
11577 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
11580 return varname(gv, hash ? '%' : '@', obase->op_targ,
11581 keysv, index, subscript_type);
11585 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
11587 return varname(NULL, '$', obase->op_targ,
11588 NULL, 0, FUV_SUBSCRIPT_NONE);
11591 gv = cGVOPx_gv(obase);
11592 if (!gv || (match && GvSV(gv) != uninit_sv))
11594 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
11597 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
11600 av = (AV*)PAD_SV(obase->op_targ);
11601 if (!av || SvRMAGICAL(av))
11603 svp = av_fetch(av, (I32)obase->op_private, FALSE);
11604 if (!svp || *svp != uninit_sv)
11607 return varname(NULL, '$', obase->op_targ,
11608 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
11611 gv = cGVOPx_gv(obase);
11617 if (!av || SvRMAGICAL(av))
11619 svp = av_fetch(av, (I32)obase->op_private, FALSE);
11620 if (!svp || *svp != uninit_sv)
11623 return varname(gv, '$', 0,
11624 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
11629 o = cUNOPx(obase)->op_first;
11630 if (!o || o->op_type != OP_NULL ||
11631 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
11633 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
11637 if (PL_op == obase)
11638 /* $a[uninit_expr] or $h{uninit_expr} */
11639 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
11642 o = cBINOPx(obase)->op_first;
11643 kid = cBINOPx(obase)->op_last;
11645 /* get the av or hv, and optionally the gv */
11647 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
11648 sv = PAD_SV(o->op_targ);
11650 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
11651 && cUNOPo->op_first->op_type == OP_GV)
11653 gv = cGVOPx_gv(cUNOPo->op_first);
11656 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
11661 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
11662 /* index is constant */
11666 if (obase->op_type == OP_HELEM) {
11667 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
11668 if (!he || HeVAL(he) != uninit_sv)
11672 SV * const * const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
11673 if (!svp || *svp != uninit_sv)
11677 if (obase->op_type == OP_HELEM)
11678 return varname(gv, '%', o->op_targ,
11679 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
11681 return varname(gv, '@', o->op_targ, NULL,
11682 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
11685 /* index is an expression;
11686 * attempt to find a match within the aggregate */
11687 if (obase->op_type == OP_HELEM) {
11688 SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
11690 return varname(gv, '%', o->op_targ,
11691 keysv, 0, FUV_SUBSCRIPT_HASH);
11694 const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
11696 return varname(gv, '@', o->op_targ,
11697 NULL, index, FUV_SUBSCRIPT_ARRAY);
11702 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
11704 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
11709 /* only examine RHS */
11710 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
11713 o = cUNOPx(obase)->op_first;
11714 if (o->op_type == OP_PUSHMARK)
11717 if (!o->op_sibling) {
11718 /* one-arg version of open is highly magical */
11720 if (o->op_type == OP_GV) { /* open FOO; */
11722 if (match && GvSV(gv) != uninit_sv)
11724 return varname(gv, '$', 0,
11725 NULL, 0, FUV_SUBSCRIPT_NONE);
11727 /* other possibilities not handled are:
11728 * open $x; or open my $x; should return '${*$x}'
11729 * open expr; should return '$'.expr ideally
11735 /* ops where $_ may be an implicit arg */
11739 if ( !(obase->op_flags & OPf_STACKED)) {
11740 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
11741 ? PAD_SVl(obase->op_targ)
11744 sv = sv_newmortal();
11745 sv_setpvn(sv, "$_", 2);
11753 /* skip filehandle as it can't produce 'undef' warning */
11754 o = cUNOPx(obase)->op_first;
11755 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
11756 o = o->op_sibling->op_sibling;
11763 match = 1; /* XS or custom code could trigger random warnings */
11768 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
11769 return sv_2mortal(newSVpvs("${$/}"));
11774 if (!(obase->op_flags & OPf_KIDS))
11776 o = cUNOPx(obase)->op_first;
11782 /* if all except one arg are constant, or have no side-effects,
11783 * or are optimized away, then it's unambiguous */
11785 for (kid=o; kid; kid = kid->op_sibling) {
11787 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
11788 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
11789 || (kid->op_type == OP_PUSHMARK)
11793 if (o2) { /* more than one found */
11800 return find_uninit_var(o2, uninit_sv, match);
11802 /* scan all args */
11804 sv = find_uninit_var(o, uninit_sv, 1);
11816 =for apidoc report_uninit
11818 Print appropriate "Use of uninitialized variable" warning
11824 Perl_report_uninit(pTHX_ SV* uninit_sv)
11828 SV* varname = NULL;
11830 varname = find_uninit_var(PL_op, uninit_sv,0);
11832 sv_insert(varname, 0, 0, " ", 1);
11834 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
11835 varname ? SvPV_nolen_const(varname) : "",
11836 " in ", OP_DESC(PL_op));
11839 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
11845 * c-indentation-style: bsd
11846 * c-basic-offset: 4
11847 * indent-tabs-mode: t
11850 * ex: set ts=8 sts=4 sw=4 noet: