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);
443 /* called by sv_clean_objs() for each live SV */
446 do_clean_objs(pTHX_ SV *ref)
450 SV * const target = SvRV(ref);
451 if (SvOBJECT(target)) {
452 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
453 if (SvWEAKREF(ref)) {
454 sv_del_backref(target, ref);
460 SvREFCNT_dec(target);
465 /* XXX Might want to check arrays, etc. */
468 /* called by sv_clean_objs() for each live SV */
470 #ifndef DISABLE_DESTRUCTOR_KLUDGE
472 do_clean_named_objs(pTHX_ SV *sv)
475 if (SvTYPE(sv) == SVt_PVGV && isGV_with_GP(sv) && GvGP(sv)) {
477 #ifdef PERL_DONT_CREATE_GVSV
480 SvOBJECT(GvSV(sv))) ||
481 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
482 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
483 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
484 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
486 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
487 SvFLAGS(sv) |= SVf_BREAK;
495 =for apidoc sv_clean_objs
497 Attempt to destroy all objects not yet freed
503 Perl_sv_clean_objs(pTHX)
506 PL_in_clean_objs = TRUE;
507 visit(do_clean_objs, SVf_ROK, SVf_ROK);
508 #ifndef DISABLE_DESTRUCTOR_KLUDGE
509 /* some barnacles may yet remain, clinging to typeglobs */
510 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
512 PL_in_clean_objs = FALSE;
515 /* called by sv_clean_all() for each live SV */
518 do_clean_all(pTHX_ SV *sv)
521 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
522 SvFLAGS(sv) |= SVf_BREAK;
523 if (PL_comppad == (AV*)sv) {
531 =for apidoc sv_clean_all
533 Decrement the refcnt of each remaining SV, possibly triggering a
534 cleanup. This function may have to be called multiple times to free
535 SVs which are in complex self-referential hierarchies.
541 Perl_sv_clean_all(pTHX)
545 PL_in_clean_all = TRUE;
546 cleaned = visit(do_clean_all, 0,0);
547 PL_in_clean_all = FALSE;
552 ARENASETS: a meta-arena implementation which separates arena-info
553 into struct arena_set, which contains an array of struct
554 arena_descs, each holding info for a single arena. By separating
555 the meta-info from the arena, we recover the 1st slot, formerly
556 borrowed for list management. The arena_set is about the size of an
557 arena, avoiding the needless malloc overhead of a naive linked-list
559 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
560 memory in the last arena-set (1/2 on average). In trade, we get
561 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
562 smaller types). The recovery of the wasted space allows use of
563 small arenas for large, rare body types,
566 char *arena; /* the raw storage, allocated aligned */
567 size_t size; /* its size ~4k typ */
568 int unit_type; /* useful for arena audits */
569 /* info for sv-heads (eventually)
576 /* Get the maximum number of elements in set[] such that struct arena_set
577 will fit within PERL_ARENA_SIZE, which is probabably just under 4K, and
578 therefore likely to be 1 aligned memory page. */
580 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
581 - 2 * sizeof(int)) / sizeof (struct arena_desc))
584 struct arena_set* next;
585 int set_size; /* ie ARENAS_PER_SET */
586 int curr; /* index of next available arena-desc */
587 struct arena_desc set[ARENAS_PER_SET];
593 S_free_arena(pTHX_ void **root) {
595 void ** const next = *(void **)root;
603 =for apidoc sv_free_arenas
605 Deallocate the memory used by all arenas. Note that all the individual SV
606 heads and bodies within the arenas must already have been freed.
611 Perl_sv_free_arenas(pTHX)
618 /* Free arenas here, but be careful about fake ones. (We assume
619 contiguity of the fake ones with the corresponding real ones.) */
621 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
622 svanext = (SV*) SvANY(sva);
623 while (svanext && SvFAKE(svanext))
624 svanext = (SV*) SvANY(svanext);
632 struct arena_set *next, *aroot = (struct arena_set*) PL_body_arenas;
634 for (; aroot; aroot = next) {
635 const int max = aroot->curr;
636 for (i=0; i<max; i++) {
637 assert(aroot->set[i].arena);
638 Safefree(aroot->set[i].arena);
645 S_free_arena(aTHX_ (void**) PL_body_arenas);
649 for (i=0; i<PERL_ARENA_ROOTS_SIZE; i++)
650 PL_body_roots[i] = 0;
652 Safefree(PL_nice_chunk);
653 PL_nice_chunk = NULL;
654 PL_nice_chunk_size = 0;
660 Here are mid-level routines that manage the allocation of bodies out
661 of the various arenas. There are 5 kinds of arenas:
663 1. SV-head arenas, which are discussed and handled above
664 2. regular body arenas
665 3. arenas for reduced-size bodies
667 5. pte arenas (thread related)
669 Arena types 2 & 3 are chained by body-type off an array of
670 arena-root pointers, which is indexed by svtype. Some of the
671 larger/less used body types are malloced singly, since a large
672 unused block of them is wasteful. Also, several svtypes dont have
673 bodies; the data fits into the sv-head itself. The arena-root
674 pointer thus has a few unused root-pointers (which may be hijacked
675 later for arena types 4,5)
677 3 differs from 2 as an optimization; some body types have several
678 unused fields in the front of the structure (which are kept in-place
679 for consistency). These bodies can be allocated in smaller chunks,
680 because the leading fields arent accessed. Pointers to such bodies
681 are decremented to point at the unused 'ghost' memory, knowing that
682 the pointers are used with offsets to the real memory.
684 HE, HEK arenas are managed separately, with separate code, but may
685 be merge-able later..
687 PTE arenas are not sv-bodies, but they share these mid-level
688 mechanics, so are considered here. The new mid-level mechanics rely
689 on the sv_type of the body being allocated, so we just reserve one
690 of the unused body-slots for PTEs, then use it in those (2) PTE
691 contexts below (line ~10k)
694 /* get_arena(size): when ARENASETS is enabled, this creates
695 custom-sized arenas, otherwize it uses PERL_ARENA_SIZE, as
697 TBD: export properly for hv.c: S_more_he().
700 Perl_get_arena(pTHX_ int arena_size)
705 /* allocate and attach arena */
706 Newx(arp, arena_size, char);
707 arp->next = PL_body_arenas;
708 PL_body_arenas = arp;
712 struct arena_desc* adesc;
713 struct arena_set *newroot, **aroot = (struct arena_set**) &PL_body_arenas;
716 /* shouldnt need this
717 if (!arena_size) arena_size = PERL_ARENA_SIZE;
720 /* may need new arena-set to hold new arena */
721 if (!*aroot || (*aroot)->curr >= (*aroot)->set_size) {
722 Newxz(newroot, 1, struct arena_set);
723 newroot->set_size = ARENAS_PER_SET;
724 newroot->next = *aroot;
726 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", *aroot));
729 /* ok, now have arena-set with at least 1 empty/available arena-desc */
730 curr = (*aroot)->curr++;
731 adesc = &((*aroot)->set[curr]);
732 assert(!adesc->arena);
734 Newxz(adesc->arena, arena_size, char);
735 adesc->size = arena_size;
736 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %d\n",
737 curr, adesc->arena, arena_size));
744 /* return a thing to the free list */
746 #define del_body(thing, root) \
748 void ** const thing_copy = (void **)thing;\
750 *thing_copy = *root; \
751 *root = (void*)thing_copy; \
757 =head1 SV-Body Allocation
759 Allocation of SV-bodies is similar to SV-heads, differing as follows;
760 the allocation mechanism is used for many body types, so is somewhat
761 more complicated, it uses arena-sets, and has no need for still-live
764 At the outermost level, (new|del)_X*V macros return bodies of the
765 appropriate type. These macros call either (new|del)_body_type or
766 (new|del)_body_allocated macro pairs, depending on specifics of the
767 type. Most body types use the former pair, the latter pair is used to
768 allocate body types with "ghost fields".
770 "ghost fields" are fields that are unused in certain types, and
771 consequently dont need to actually exist. They are declared because
772 they're part of a "base type", which allows use of functions as
773 methods. The simplest examples are AVs and HVs, 2 aggregate types
774 which don't use the fields which support SCALAR semantics.
776 For these types, the arenas are carved up into *_allocated size
777 chunks, we thus avoid wasted memory for those unaccessed members.
778 When bodies are allocated, we adjust the pointer back in memory by the
779 size of the bit not allocated, so it's as if we allocated the full
780 structure. (But things will all go boom if you write to the part that
781 is "not there", because you'll be overwriting the last members of the
782 preceding structure in memory.)
784 We calculate the correction using the STRUCT_OFFSET macro. For
785 example, if xpv_allocated is the same structure as XPV then the two
786 OFFSETs sum to zero, and the pointer is unchanged. If the allocated
787 structure is smaller (no initial NV actually allocated) then the net
788 effect is to subtract the size of the NV from the pointer, to return a
789 new pointer as if an initial NV were actually allocated.
791 This is the same trick as was used for NV and IV bodies. Ironically it
792 doesn't need to be used for NV bodies any more, because NV is now at
793 the start of the structure. IV bodies don't need it either, because
794 they are no longer allocated.
796 In turn, the new_body_* allocators call S_new_body(), which invokes
797 new_body_inline macro, which takes a lock, and takes a body off the
798 linked list at PL_body_roots[sv_type], calling S_more_bodies() if
799 necessary to refresh an empty list. Then the lock is released, and
800 the body is returned.
802 S_more_bodies calls get_arena(), and carves it up into an array of N
803 bodies, which it strings into a linked list. It looks up arena-size
804 and body-size from the body_details table described below, thus
805 supporting the multiple body-types.
807 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
808 the (new|del)_X*V macros are mapped directly to malloc/free.
814 For each sv-type, struct body_details bodies_by_type[] carries
815 parameters which control these aspects of SV handling:
817 Arena_size determines whether arenas are used for this body type, and if
818 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
819 zero, forcing individual mallocs and frees.
821 Body_size determines how big a body is, and therefore how many fit into
822 each arena. Offset carries the body-pointer adjustment needed for
823 *_allocated body types, and is used in *_allocated macros.
825 But its main purpose is to parameterize info needed in
826 Perl_sv_upgrade(). The info here dramatically simplifies the function
827 vs the implementation in 5.8.7, making it table-driven. All fields
828 are used for this, except for arena_size.
830 For the sv-types that have no bodies, arenas are not used, so those
831 PL_body_roots[sv_type] are unused, and can be overloaded. In
832 something of a special case, SVt_NULL is borrowed for HE arenas;
833 PL_body_roots[SVt_NULL] is filled by S_more_he, but the
834 bodies_by_type[SVt_NULL] slot is not used, as the table is not
837 PTEs also use arenas, but are never seen in Perl_sv_upgrade.
838 Nonetheless, they get their own slot in bodies_by_type[SVt_NULL], so
839 they can just use the same allocation semantics. At first, PTEs were
840 also overloaded to a non-body sv-type, but this yielded hard-to-find
841 malloc bugs, so was simplified by claiming a new slot. This choice
842 has no consequence at this time.
846 struct body_details {
847 U8 body_size; /* Size to allocate */
848 U8 copy; /* Size of structure to copy (may be shorter) */
850 unsigned int type : 4; /* We have space for a sanity check. */
851 unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
852 unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
853 unsigned int arena : 1; /* Allocated from an arena */
854 size_t arena_size; /* Size of arena to allocate */
862 /* With -DPURFIY we allocate everything directly, and don't use arenas.
863 This seems a rather elegant way to simplify some of the code below. */
864 #define HASARENA FALSE
866 #define HASARENA TRUE
868 #define NOARENA FALSE
870 /* Size the arenas to exactly fit a given number of bodies. A count
871 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
872 simplifying the default. If count > 0, the arena is sized to fit
873 only that many bodies, allowing arenas to be used for large, rare
874 bodies (XPVFM, XPVIO) without undue waste. The arena size is
875 limited by PERL_ARENA_SIZE, so we can safely oversize the
878 #define FIT_ARENA0(body_size) \
879 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
880 #define FIT_ARENAn(count,body_size) \
881 ( count * body_size <= PERL_ARENA_SIZE) \
882 ? count * body_size \
883 : FIT_ARENA0 (body_size)
884 #define FIT_ARENA(count,body_size) \
886 ? FIT_ARENAn (count, body_size) \
887 : FIT_ARENA0 (body_size)
889 /* A macro to work out the offset needed to subtract from a pointer to (say)
896 to make its members accessible via a pointer to (say)
906 #define relative_STRUCT_OFFSET(longer, shorter, member) \
907 (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member))
909 /* Calculate the length to copy. Specifically work out the length less any
910 final padding the compiler needed to add. See the comment in sv_upgrade
911 for why copying the padding proved to be a bug. */
913 #define copy_length(type, last_member) \
914 STRUCT_OFFSET(type, last_member) \
915 + sizeof (((type*)SvANY((SV*)0))->last_member)
917 static const struct body_details bodies_by_type[] = {
918 { sizeof(HE), 0, 0, SVt_NULL,
919 FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
921 /* IVs are in the head, so the allocation size is 0.
922 However, the slot is overloaded for PTEs. */
923 { sizeof(struct ptr_tbl_ent), /* This is used for PTEs. */
924 sizeof(IV), /* This is used to copy out the IV body. */
925 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
926 NOARENA /* IVS don't need an arena */,
927 /* But PTEs need to know the size of their arena */
928 FIT_ARENA(0, sizeof(struct ptr_tbl_ent))
931 /* 8 bytes on most ILP32 with IEEE doubles */
932 { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA,
933 FIT_ARENA(0, sizeof(NV)) },
935 /* RVs are in the head now. */
936 { 0, 0, 0, SVt_RV, FALSE, NONV, NOARENA, 0 },
938 /* 8 bytes on most ILP32 with IEEE doubles */
939 { sizeof(xpv_allocated),
940 copy_length(XPV, xpv_len)
941 - relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
942 + relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
943 SVt_PV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpv_allocated)) },
946 { sizeof(xpviv_allocated),
947 copy_length(XPVIV, xiv_u)
948 - relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
949 + relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
950 SVt_PVIV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpviv_allocated)) },
953 { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, SVt_PVNV, FALSE, HADNV,
954 HASARENA, FIT_ARENA(0, sizeof(XPVNV)) },
957 { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
958 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
961 { sizeof(XPVBM), sizeof(XPVBM), 0, SVt_PVBM, TRUE, HADNV,
962 HASARENA, FIT_ARENA(0, sizeof(XPVBM)) },
965 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
966 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
969 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
970 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
972 { sizeof(xpvav_allocated),
973 copy_length(XPVAV, xmg_stash)
974 - relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
975 + relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
976 SVt_PVAV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) },
978 { sizeof(xpvhv_allocated),
979 copy_length(XPVHV, xmg_stash)
980 - relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
981 + relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
982 SVt_PVHV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) },
985 { sizeof(xpvcv_allocated), sizeof(xpvcv_allocated),
986 + relative_STRUCT_OFFSET(xpvcv_allocated, XPVCV, xpv_cur),
987 SVt_PVCV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvcv_allocated)) },
989 { sizeof(xpvfm_allocated), sizeof(xpvfm_allocated),
990 + relative_STRUCT_OFFSET(xpvfm_allocated, XPVFM, xpv_cur),
991 SVt_PVFM, TRUE, NONV, NOARENA, FIT_ARENA(20, sizeof(xpvfm_allocated)) },
993 /* XPVIO is 84 bytes, fits 48x */
994 { sizeof(XPVIO), sizeof(XPVIO), 0, SVt_PVIO, TRUE, HADNV,
995 HASARENA, FIT_ARENA(24, sizeof(XPVIO)) },
998 #define new_body_type(sv_type) \
999 (void *)((char *)S_new_body(aTHX_ sv_type))
1001 #define del_body_type(p, sv_type) \
1002 del_body(p, &PL_body_roots[sv_type])
1005 #define new_body_allocated(sv_type) \
1006 (void *)((char *)S_new_body(aTHX_ sv_type) \
1007 - bodies_by_type[sv_type].offset)
1009 #define del_body_allocated(p, sv_type) \
1010 del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
1013 #define my_safemalloc(s) (void*)safemalloc(s)
1014 #define my_safecalloc(s) (void*)safecalloc(s, 1)
1015 #define my_safefree(p) safefree((char*)p)
1019 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1020 #define del_XNV(p) my_safefree(p)
1022 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1023 #define del_XPVNV(p) my_safefree(p)
1025 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1026 #define del_XPVAV(p) my_safefree(p)
1028 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1029 #define del_XPVHV(p) my_safefree(p)
1031 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1032 #define del_XPVMG(p) my_safefree(p)
1034 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1035 #define del_XPVGV(p) my_safefree(p)
1039 #define new_XNV() new_body_type(SVt_NV)
1040 #define del_XNV(p) del_body_type(p, SVt_NV)
1042 #define new_XPVNV() new_body_type(SVt_PVNV)
1043 #define del_XPVNV(p) del_body_type(p, SVt_PVNV)
1045 #define new_XPVAV() new_body_allocated(SVt_PVAV)
1046 #define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
1048 #define new_XPVHV() new_body_allocated(SVt_PVHV)
1049 #define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
1051 #define new_XPVMG() new_body_type(SVt_PVMG)
1052 #define del_XPVMG(p) del_body_type(p, SVt_PVMG)
1054 #define new_XPVGV() new_body_type(SVt_PVGV)
1055 #define del_XPVGV(p) del_body_type(p, SVt_PVGV)
1059 /* no arena for you! */
1061 #define new_NOARENA(details) \
1062 my_safemalloc((details)->body_size + (details)->offset)
1063 #define new_NOARENAZ(details) \
1064 my_safecalloc((details)->body_size + (details)->offset)
1067 static bool done_sanity_check;
1071 S_more_bodies (pTHX_ svtype sv_type)
1074 void ** const root = &PL_body_roots[sv_type];
1075 const struct body_details * const bdp = &bodies_by_type[sv_type];
1076 const size_t body_size = bdp->body_size;
1080 assert(bdp->arena_size);
1083 if (!done_sanity_check) {
1086 done_sanity_check = TRUE;
1089 assert (bodies_by_type[i].type == i);
1093 start = (char*) Perl_get_arena(aTHX_ bdp->arena_size);
1095 end = start + bdp->arena_size - body_size;
1098 /* The initial slot is used to link the arenas together, so it isn't to be
1099 linked into the list of ready-to-use bodies. */
1102 /* computed count doesnt reflect the 1st slot reservation */
1103 DEBUG_m(PerlIO_printf(Perl_debug_log,
1104 "arena %p end %p arena-size %d type %d size %d ct %d\n",
1105 start, end, bdp->arena_size, sv_type, body_size,
1106 bdp->arena_size / body_size));
1109 *root = (void *)start;
1111 while (start < end) {
1112 char * const next = start + body_size;
1113 *(void**) start = (void *)next;
1116 *(void **)start = 0;
1121 /* grab a new thing from the free list, allocating more if necessary.
1122 The inline version is used for speed in hot routines, and the
1123 function using it serves the rest (unless PURIFY).
1125 #define new_body_inline(xpv, sv_type) \
1127 void ** const r3wt = &PL_body_roots[sv_type]; \
1129 xpv = *((void **)(r3wt)) \
1130 ? *((void **)(r3wt)) : S_more_bodies(aTHX_ sv_type); \
1131 *(r3wt) = *(void**)(xpv); \
1138 S_new_body(pTHX_ svtype sv_type)
1142 new_body_inline(xpv, sv_type);
1149 =for apidoc sv_upgrade
1151 Upgrade an SV to a more complex form. Generally adds a new body type to the
1152 SV, then copies across as much information as possible from the old body.
1153 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1159 Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
1164 const U32 old_type = SvTYPE(sv);
1165 const struct body_details *new_type_details;
1166 const struct body_details *const old_type_details
1167 = bodies_by_type + old_type;
1169 if (new_type != SVt_PV && SvIsCOW(sv)) {
1170 sv_force_normal_flags(sv, 0);
1173 if (old_type == new_type)
1176 if (old_type > new_type)
1177 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1178 (int)old_type, (int)new_type);
1181 old_body = SvANY(sv);
1183 /* Copying structures onto other structures that have been neatly zeroed
1184 has a subtle gotcha. Consider XPVMG
1186 +------+------+------+------+------+-------+-------+
1187 | NV | CUR | LEN | IV | MAGIC | STASH |
1188 +------+------+------+------+------+-------+-------+
1189 0 4 8 12 16 20 24 28
1191 where NVs are aligned to 8 bytes, so that sizeof that structure is
1192 actually 32 bytes long, with 4 bytes of padding at the end:
1194 +------+------+------+------+------+-------+-------+------+
1195 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1196 +------+------+------+------+------+-------+-------+------+
1197 0 4 8 12 16 20 24 28 32
1199 so what happens if you allocate memory for this structure:
1201 +------+------+------+------+------+-------+-------+------+------+...
1202 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1203 +------+------+------+------+------+-------+-------+------+------+...
1204 0 4 8 12 16 20 24 28 32 36
1206 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1207 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1208 started out as zero once, but it's quite possible that it isn't. So now,
1209 rather than a nicely zeroed GP, you have it pointing somewhere random.
1212 (In fact, GP ends up pointing at a previous GP structure, because the
1213 principle cause of the padding in XPVMG getting garbage is a copy of
1214 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob)
1216 So we are careful and work out the size of used parts of all the
1223 if (new_type < SVt_PVIV) {
1224 new_type = (new_type == SVt_NV)
1225 ? SVt_PVNV : SVt_PVIV;
1229 if (new_type < SVt_PVNV) {
1230 new_type = SVt_PVNV;
1236 assert(new_type > SVt_PV);
1237 assert(SVt_IV < SVt_PV);
1238 assert(SVt_NV < SVt_PV);
1245 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1246 there's no way that it can be safely upgraded, because perl.c
1247 expects to Safefree(SvANY(PL_mess_sv)) */
1248 assert(sv != PL_mess_sv);
1249 /* This flag bit is used to mean other things in other scalar types.
1250 Given that it only has meaning inside the pad, it shouldn't be set
1251 on anything that can get upgraded. */
1252 assert(!SvPAD_TYPED(sv));
1255 if (old_type_details->cant_upgrade)
1256 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1257 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1259 new_type_details = bodies_by_type + new_type;
1261 SvFLAGS(sv) &= ~SVTYPEMASK;
1262 SvFLAGS(sv) |= new_type;
1264 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1265 the return statements above will have triggered. */
1266 assert (new_type != SVt_NULL);
1269 assert(old_type == SVt_NULL);
1270 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1274 assert(old_type == SVt_NULL);
1275 SvANY(sv) = new_XNV();
1279 assert(old_type == SVt_NULL);
1280 SvANY(sv) = &sv->sv_u.svu_rv;
1285 assert(new_type_details->body_size);
1288 assert(new_type_details->arena);
1289 assert(new_type_details->arena_size);
1290 /* This points to the start of the allocated area. */
1291 new_body_inline(new_body, new_type);
1292 Zero(new_body, new_type_details->body_size, char);
1293 new_body = ((char *)new_body) - new_type_details->offset;
1295 /* We always allocated the full length item with PURIFY. To do this
1296 we fake things so that arena is false for all 16 types.. */
1297 new_body = new_NOARENAZ(new_type_details);
1299 SvANY(sv) = new_body;
1300 if (new_type == SVt_PVAV) {
1306 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1307 The target created by newSVrv also is, and it can have magic.
1308 However, it never has SvPVX set.
1310 if (old_type >= SVt_RV) {
1311 assert(SvPVX_const(sv) == 0);
1314 /* Could put this in the else clause below, as PVMG must have SvPVX
1315 0 already (the assertion above) */
1318 if (old_type >= SVt_PVMG) {
1319 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1320 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1326 /* XXX Is this still needed? Was it ever needed? Surely as there is
1327 no route from NV to PVIV, NOK can never be true */
1328 assert(!SvNOKp(sv));
1340 assert(new_type_details->body_size);
1341 /* We always allocated the full length item with PURIFY. To do this
1342 we fake things so that arena is false for all 16 types.. */
1343 if(new_type_details->arena) {
1344 /* This points to the start of the allocated area. */
1345 new_body_inline(new_body, new_type);
1346 Zero(new_body, new_type_details->body_size, char);
1347 new_body = ((char *)new_body) - new_type_details->offset;
1349 new_body = new_NOARENAZ(new_type_details);
1351 SvANY(sv) = new_body;
1353 if (old_type_details->copy) {
1354 Copy((char *)old_body + old_type_details->offset,
1355 (char *)new_body + old_type_details->offset,
1356 old_type_details->copy, char);
1359 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1360 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1361 * correct 0.0 for us. Otherwise, if the old body didn't have an
1362 * NV slot, but the new one does, then we need to initialise the
1363 * freshly created NV slot with whatever the correct bit pattern is
1365 if (old_type_details->zero_nv && !new_type_details->zero_nv)
1369 if (new_type == SVt_PVIO)
1370 IoPAGE_LEN(sv) = 60;
1371 if (old_type < SVt_RV)
1375 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1376 (unsigned long)new_type);
1379 if (old_type_details->arena) {
1380 /* If there was an old body, then we need to free it.
1381 Note that there is an assumption that all bodies of types that
1382 can be upgraded came from arenas. Only the more complex non-
1383 upgradable types are allowed to be directly malloc()ed. */
1385 my_safefree(old_body);
1387 del_body((void*)((char*)old_body + old_type_details->offset),
1388 &PL_body_roots[old_type]);
1394 =for apidoc sv_backoff
1396 Remove any string offset. You should normally use the C<SvOOK_off> macro
1403 Perl_sv_backoff(pTHX_ register SV *sv)
1405 PERL_UNUSED_CONTEXT;
1407 assert(SvTYPE(sv) != SVt_PVHV);
1408 assert(SvTYPE(sv) != SVt_PVAV);
1410 const char * const s = SvPVX_const(sv);
1411 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1412 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1414 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1416 SvFLAGS(sv) &= ~SVf_OOK;
1423 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1424 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1425 Use the C<SvGROW> wrapper instead.
1431 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1435 #ifdef HAS_64K_LIMIT
1436 if (newlen >= 0x10000) {
1437 PerlIO_printf(Perl_debug_log,
1438 "Allocation too large: %"UVxf"\n", (UV)newlen);
1441 #endif /* HAS_64K_LIMIT */
1444 if (SvTYPE(sv) < SVt_PV) {
1445 sv_upgrade(sv, SVt_PV);
1446 s = SvPVX_mutable(sv);
1448 else if (SvOOK(sv)) { /* pv is offset? */
1450 s = SvPVX_mutable(sv);
1451 if (newlen > SvLEN(sv))
1452 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1453 #ifdef HAS_64K_LIMIT
1454 if (newlen >= 0x10000)
1459 s = SvPVX_mutable(sv);
1461 if (newlen > SvLEN(sv)) { /* need more room? */
1462 newlen = PERL_STRLEN_ROUNDUP(newlen);
1463 if (SvLEN(sv) && s) {
1465 const STRLEN l = malloced_size((void*)SvPVX_const(sv));
1471 s = saferealloc(s, newlen);
1474 s = safemalloc(newlen);
1475 if (SvPVX_const(sv) && SvCUR(sv)) {
1476 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1480 SvLEN_set(sv, newlen);
1486 =for apidoc sv_setiv
1488 Copies an integer into the given SV, upgrading first if necessary.
1489 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1495 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1498 SV_CHECK_THINKFIRST_COW_DROP(sv);
1499 switch (SvTYPE(sv)) {
1501 sv_upgrade(sv, SVt_IV);
1504 sv_upgrade(sv, SVt_PVNV);
1508 sv_upgrade(sv, SVt_PVIV);
1517 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1520 (void)SvIOK_only(sv); /* validate number */
1526 =for apidoc sv_setiv_mg
1528 Like C<sv_setiv>, but also handles 'set' magic.
1534 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1541 =for apidoc sv_setuv
1543 Copies an unsigned integer into the given SV, upgrading first if necessary.
1544 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1550 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1552 /* With these two if statements:
1553 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1556 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1558 If you wish to remove them, please benchmark to see what the effect is
1560 if (u <= (UV)IV_MAX) {
1561 sv_setiv(sv, (IV)u);
1570 =for apidoc sv_setuv_mg
1572 Like C<sv_setuv>, but also handles 'set' magic.
1578 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1587 =for apidoc sv_setnv
1589 Copies a double into the given SV, upgrading first if necessary.
1590 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1596 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1599 SV_CHECK_THINKFIRST_COW_DROP(sv);
1600 switch (SvTYPE(sv)) {
1603 sv_upgrade(sv, SVt_NV);
1608 sv_upgrade(sv, SVt_PVNV);
1617 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1621 (void)SvNOK_only(sv); /* validate number */
1626 =for apidoc sv_setnv_mg
1628 Like C<sv_setnv>, but also handles 'set' magic.
1634 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1640 /* Print an "isn't numeric" warning, using a cleaned-up,
1641 * printable version of the offending string
1645 S_not_a_number(pTHX_ SV *sv)
1653 dsv = sv_2mortal(newSVpvs(""));
1654 pv = sv_uni_display(dsv, sv, 10, 0);
1657 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1658 /* each *s can expand to 4 chars + "...\0",
1659 i.e. need room for 8 chars */
1661 const char *s = SvPVX_const(sv);
1662 const char * const end = s + SvCUR(sv);
1663 for ( ; s < end && d < limit; s++ ) {
1665 if (ch & 128 && !isPRINT_LC(ch)) {
1674 else if (ch == '\r') {
1678 else if (ch == '\f') {
1682 else if (ch == '\\') {
1686 else if (ch == '\0') {
1690 else if (isPRINT_LC(ch))
1707 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1708 "Argument \"%s\" isn't numeric in %s", pv,
1711 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1712 "Argument \"%s\" isn't numeric", pv);
1716 =for apidoc looks_like_number
1718 Test if the content of an SV looks like a number (or is a number).
1719 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1720 non-numeric warning), even if your atof() doesn't grok them.
1726 Perl_looks_like_number(pTHX_ SV *sv)
1728 register const char *sbegin;
1732 sbegin = SvPVX_const(sv);
1735 else if (SvPOKp(sv))
1736 sbegin = SvPV_const(sv, len);
1738 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1739 return grok_number(sbegin, len, NULL);
1743 S_glob_2inpuv(pTHX_ GV *gv, STRLEN *len, bool want_number)
1745 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1746 SV *const buffer = sv_newmortal();
1748 /* FAKE globs can get coerced, so need to turn this off temporarily if it
1751 gv_efullname3(buffer, gv, "*");
1752 SvFLAGS(gv) |= wasfake;
1755 /* We know that all GVs stringify to something that is not-a-number,
1756 so no need to test that. */
1757 if (ckWARN(WARN_NUMERIC))
1758 not_a_number(buffer);
1759 /* We just want something true to return, so that S_sv_2iuv_common
1760 can tail call us and return true. */
1763 return SvPV(buffer, *len);
1767 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1768 until proven guilty, assume that things are not that bad... */
1773 As 64 bit platforms often have an NV that doesn't preserve all bits of
1774 an IV (an assumption perl has been based on to date) it becomes necessary
1775 to remove the assumption that the NV always carries enough precision to
1776 recreate the IV whenever needed, and that the NV is the canonical form.
1777 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1778 precision as a side effect of conversion (which would lead to insanity
1779 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1780 1) to distinguish between IV/UV/NV slots that have cached a valid
1781 conversion where precision was lost and IV/UV/NV slots that have a
1782 valid conversion which has lost no precision
1783 2) to ensure that if a numeric conversion to one form is requested that
1784 would lose precision, the precise conversion (or differently
1785 imprecise conversion) is also performed and cached, to prevent
1786 requests for different numeric formats on the same SV causing
1787 lossy conversion chains. (lossless conversion chains are perfectly
1792 SvIOKp is true if the IV slot contains a valid value
1793 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1794 SvNOKp is true if the NV slot contains a valid value
1795 SvNOK is true only if the NV value is accurate
1798 while converting from PV to NV, check to see if converting that NV to an
1799 IV(or UV) would lose accuracy over a direct conversion from PV to
1800 IV(or UV). If it would, cache both conversions, return NV, but mark
1801 SV as IOK NOKp (ie not NOK).
1803 While converting from PV to IV, check to see if converting that IV to an
1804 NV would lose accuracy over a direct conversion from PV to NV. If it
1805 would, cache both conversions, flag similarly.
1807 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1808 correctly because if IV & NV were set NV *always* overruled.
1809 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1810 changes - now IV and NV together means that the two are interchangeable:
1811 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1813 The benefit of this is that operations such as pp_add know that if
1814 SvIOK is true for both left and right operands, then integer addition
1815 can be used instead of floating point (for cases where the result won't
1816 overflow). Before, floating point was always used, which could lead to
1817 loss of precision compared with integer addition.
1819 * making IV and NV equal status should make maths accurate on 64 bit
1821 * may speed up maths somewhat if pp_add and friends start to use
1822 integers when possible instead of fp. (Hopefully the overhead in
1823 looking for SvIOK and checking for overflow will not outweigh the
1824 fp to integer speedup)
1825 * will slow down integer operations (callers of SvIV) on "inaccurate"
1826 values, as the change from SvIOK to SvIOKp will cause a call into
1827 sv_2iv each time rather than a macro access direct to the IV slot
1828 * should speed up number->string conversion on integers as IV is
1829 favoured when IV and NV are equally accurate
1831 ####################################################################
1832 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1833 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1834 On the other hand, SvUOK is true iff UV.
1835 ####################################################################
1837 Your mileage will vary depending your CPU's relative fp to integer
1841 #ifndef NV_PRESERVES_UV
1842 # define IS_NUMBER_UNDERFLOW_IV 1
1843 # define IS_NUMBER_UNDERFLOW_UV 2
1844 # define IS_NUMBER_IV_AND_UV 2
1845 # define IS_NUMBER_OVERFLOW_IV 4
1846 # define IS_NUMBER_OVERFLOW_UV 5
1848 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1850 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1852 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
1855 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));
1856 if (SvNVX(sv) < (NV)IV_MIN) {
1857 (void)SvIOKp_on(sv);
1859 SvIV_set(sv, IV_MIN);
1860 return IS_NUMBER_UNDERFLOW_IV;
1862 if (SvNVX(sv) > (NV)UV_MAX) {
1863 (void)SvIOKp_on(sv);
1866 SvUV_set(sv, UV_MAX);
1867 return IS_NUMBER_OVERFLOW_UV;
1869 (void)SvIOKp_on(sv);
1871 /* Can't use strtol etc to convert this string. (See truth table in
1873 if (SvNVX(sv) <= (UV)IV_MAX) {
1874 SvIV_set(sv, I_V(SvNVX(sv)));
1875 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1876 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1878 /* Integer is imprecise. NOK, IOKp */
1880 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1883 SvUV_set(sv, U_V(SvNVX(sv)));
1884 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1885 if (SvUVX(sv) == UV_MAX) {
1886 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1887 possibly be preserved by NV. Hence, it must be overflow.
1889 return IS_NUMBER_OVERFLOW_UV;
1891 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1893 /* Integer is imprecise. NOK, IOKp */
1895 return IS_NUMBER_OVERFLOW_IV;
1897 #endif /* !NV_PRESERVES_UV*/
1900 S_sv_2iuv_common(pTHX_ SV *sv) {
1903 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1904 * without also getting a cached IV/UV from it at the same time
1905 * (ie PV->NV conversion should detect loss of accuracy and cache
1906 * IV or UV at same time to avoid this. */
1907 /* IV-over-UV optimisation - choose to cache IV if possible */
1909 if (SvTYPE(sv) == SVt_NV)
1910 sv_upgrade(sv, SVt_PVNV);
1912 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1913 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1914 certainly cast into the IV range at IV_MAX, whereas the correct
1915 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1917 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1918 SvIV_set(sv, I_V(SvNVX(sv)));
1919 if (SvNVX(sv) == (NV) SvIVX(sv)
1920 #ifndef NV_PRESERVES_UV
1921 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1922 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1923 /* Don't flag it as "accurately an integer" if the number
1924 came from a (by definition imprecise) NV operation, and
1925 we're outside the range of NV integer precision */
1928 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1929 DEBUG_c(PerlIO_printf(Perl_debug_log,
1930 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
1936 /* IV not precise. No need to convert from PV, as NV
1937 conversion would already have cached IV if it detected
1938 that PV->IV would be better than PV->NV->IV
1939 flags already correct - don't set public IOK. */
1940 DEBUG_c(PerlIO_printf(Perl_debug_log,
1941 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
1946 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1947 but the cast (NV)IV_MIN rounds to a the value less (more
1948 negative) than IV_MIN which happens to be equal to SvNVX ??
1949 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1950 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1951 (NV)UVX == NVX are both true, but the values differ. :-(
1952 Hopefully for 2s complement IV_MIN is something like
1953 0x8000000000000000 which will be exact. NWC */
1956 SvUV_set(sv, U_V(SvNVX(sv)));
1958 (SvNVX(sv) == (NV) SvUVX(sv))
1959 #ifndef NV_PRESERVES_UV
1960 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1961 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1962 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1963 /* Don't flag it as "accurately an integer" if the number
1964 came from a (by definition imprecise) NV operation, and
1965 we're outside the range of NV integer precision */
1970 DEBUG_c(PerlIO_printf(Perl_debug_log,
1971 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1977 else if (SvPOKp(sv) && SvLEN(sv)) {
1979 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
1980 /* We want to avoid a possible problem when we cache an IV/ a UV which
1981 may be later translated to an NV, and the resulting NV is not
1982 the same as the direct translation of the initial string
1983 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
1984 be careful to ensure that the value with the .456 is around if the
1985 NV value is requested in the future).
1987 This means that if we cache such an IV/a UV, we need to cache the
1988 NV as well. Moreover, we trade speed for space, and do not
1989 cache the NV if we are sure it's not needed.
1992 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
1993 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1994 == IS_NUMBER_IN_UV) {
1995 /* It's definitely an integer, only upgrade to PVIV */
1996 if (SvTYPE(sv) < SVt_PVIV)
1997 sv_upgrade(sv, SVt_PVIV);
1999 } else if (SvTYPE(sv) < SVt_PVNV)
2000 sv_upgrade(sv, SVt_PVNV);
2002 /* If NVs preserve UVs then we only use the UV value if we know that
2003 we aren't going to call atof() below. If NVs don't preserve UVs
2004 then the value returned may have more precision than atof() will
2005 return, even though value isn't perfectly accurate. */
2006 if ((numtype & (IS_NUMBER_IN_UV
2007 #ifdef NV_PRESERVES_UV
2010 )) == IS_NUMBER_IN_UV) {
2011 /* This won't turn off the public IOK flag if it was set above */
2012 (void)SvIOKp_on(sv);
2014 if (!(numtype & IS_NUMBER_NEG)) {
2016 if (value <= (UV)IV_MAX) {
2017 SvIV_set(sv, (IV)value);
2019 /* it didn't overflow, and it was positive. */
2020 SvUV_set(sv, value);
2024 /* 2s complement assumption */
2025 if (value <= (UV)IV_MIN) {
2026 SvIV_set(sv, -(IV)value);
2028 /* Too negative for an IV. This is a double upgrade, but
2029 I'm assuming it will be rare. */
2030 if (SvTYPE(sv) < SVt_PVNV)
2031 sv_upgrade(sv, SVt_PVNV);
2035 SvNV_set(sv, -(NV)value);
2036 SvIV_set(sv, IV_MIN);
2040 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2041 will be in the previous block to set the IV slot, and the next
2042 block to set the NV slot. So no else here. */
2044 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2045 != IS_NUMBER_IN_UV) {
2046 /* It wasn't an (integer that doesn't overflow the UV). */
2047 SvNV_set(sv, Atof(SvPVX_const(sv)));
2049 if (! numtype && ckWARN(WARN_NUMERIC))
2052 #if defined(USE_LONG_DOUBLE)
2053 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2054 PTR2UV(sv), SvNVX(sv)));
2056 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2057 PTR2UV(sv), SvNVX(sv)));
2060 #ifdef NV_PRESERVES_UV
2061 (void)SvIOKp_on(sv);
2063 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2064 SvIV_set(sv, I_V(SvNVX(sv)));
2065 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2068 /*EMPTY*/; /* Integer is imprecise. NOK, IOKp */
2070 /* UV will not work better than IV */
2072 if (SvNVX(sv) > (NV)UV_MAX) {
2074 /* Integer is inaccurate. NOK, IOKp, is UV */
2075 SvUV_set(sv, UV_MAX);
2077 SvUV_set(sv, U_V(SvNVX(sv)));
2078 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2079 NV preservse UV so can do correct comparison. */
2080 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2083 /*EMPTY*/; /* Integer is imprecise. NOK, IOKp, is UV */
2088 #else /* NV_PRESERVES_UV */
2089 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2090 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2091 /* The IV/UV slot will have been set from value returned by
2092 grok_number above. The NV slot has just been set using
2095 assert (SvIOKp(sv));
2097 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2098 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2099 /* Small enough to preserve all bits. */
2100 (void)SvIOKp_on(sv);
2102 SvIV_set(sv, I_V(SvNVX(sv)));
2103 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2105 /* Assumption: first non-preserved integer is < IV_MAX,
2106 this NV is in the preserved range, therefore: */
2107 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2109 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);
2113 0 0 already failed to read UV.
2114 0 1 already failed to read UV.
2115 1 0 you won't get here in this case. IV/UV
2116 slot set, public IOK, Atof() unneeded.
2117 1 1 already read UV.
2118 so there's no point in sv_2iuv_non_preserve() attempting
2119 to use atol, strtol, strtoul etc. */
2120 sv_2iuv_non_preserve (sv, numtype);
2123 #endif /* NV_PRESERVES_UV */
2127 if (isGV_with_GP(sv)) {
2128 return PTR2IV(glob_2inpuv((GV *)sv, NULL, TRUE));
2131 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2132 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2135 if (SvTYPE(sv) < SVt_IV)
2136 /* Typically the caller expects that sv_any is not NULL now. */
2137 sv_upgrade(sv, SVt_IV);
2138 /* Return 0 from the caller. */
2145 =for apidoc sv_2iv_flags
2147 Return the integer value of an SV, doing any necessary string
2148 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2149 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2155 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2160 if (SvGMAGICAL(sv)) {
2161 if (flags & SV_GMAGIC)
2166 return I_V(SvNVX(sv));
2168 if (SvPOKp(sv) && SvLEN(sv)) {
2171 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2173 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2174 == IS_NUMBER_IN_UV) {
2175 /* It's definitely an integer */
2176 if (numtype & IS_NUMBER_NEG) {
2177 if (value < (UV)IV_MIN)
2180 if (value < (UV)IV_MAX)
2185 if (ckWARN(WARN_NUMERIC))
2188 return I_V(Atof(SvPVX_const(sv)));
2193 assert(SvTYPE(sv) >= SVt_PVMG);
2194 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2195 } else if (SvTHINKFIRST(sv)) {
2199 SV * const tmpstr=AMG_CALLun(sv,numer);
2200 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2201 return SvIV(tmpstr);
2204 return PTR2IV(SvRV(sv));
2207 sv_force_normal_flags(sv, 0);
2209 if (SvREADONLY(sv) && !SvOK(sv)) {
2210 if (ckWARN(WARN_UNINITIALIZED))
2216 if (S_sv_2iuv_common(aTHX_ sv))
2219 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2220 PTR2UV(sv),SvIVX(sv)));
2221 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2225 =for apidoc sv_2uv_flags
2227 Return the unsigned integer value of an SV, doing any necessary string
2228 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2229 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2235 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2240 if (SvGMAGICAL(sv)) {
2241 if (flags & SV_GMAGIC)
2246 return U_V(SvNVX(sv));
2247 if (SvPOKp(sv) && SvLEN(sv)) {
2250 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2252 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2253 == IS_NUMBER_IN_UV) {
2254 /* It's definitely an integer */
2255 if (!(numtype & IS_NUMBER_NEG))
2259 if (ckWARN(WARN_NUMERIC))
2262 return U_V(Atof(SvPVX_const(sv)));
2267 assert(SvTYPE(sv) >= SVt_PVMG);
2268 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2269 } else if (SvTHINKFIRST(sv)) {
2273 SV *const tmpstr = AMG_CALLun(sv,numer);
2274 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2275 return SvUV(tmpstr);
2278 return PTR2UV(SvRV(sv));
2281 sv_force_normal_flags(sv, 0);
2283 if (SvREADONLY(sv) && !SvOK(sv)) {
2284 if (ckWARN(WARN_UNINITIALIZED))
2290 if (S_sv_2iuv_common(aTHX_ sv))
2294 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2295 PTR2UV(sv),SvUVX(sv)));
2296 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2302 Return the num value of an SV, doing any necessary string or integer
2303 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2310 Perl_sv_2nv(pTHX_ register SV *sv)
2315 if (SvGMAGICAL(sv)) {
2319 if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2320 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2321 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2323 return Atof(SvPVX_const(sv));
2327 return (NV)SvUVX(sv);
2329 return (NV)SvIVX(sv);
2334 assert(SvTYPE(sv) >= SVt_PVMG);
2335 /* This falls through to the report_uninit near the end of the
2337 } else if (SvTHINKFIRST(sv)) {
2341 SV *const tmpstr = AMG_CALLun(sv,numer);
2342 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2343 return SvNV(tmpstr);
2346 return PTR2NV(SvRV(sv));
2349 sv_force_normal_flags(sv, 0);
2351 if (SvREADONLY(sv) && !SvOK(sv)) {
2352 if (ckWARN(WARN_UNINITIALIZED))
2357 if (SvTYPE(sv) < SVt_NV) {
2358 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2359 sv_upgrade(sv, SVt_NV);
2360 #ifdef USE_LONG_DOUBLE
2362 STORE_NUMERIC_LOCAL_SET_STANDARD();
2363 PerlIO_printf(Perl_debug_log,
2364 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2365 PTR2UV(sv), SvNVX(sv));
2366 RESTORE_NUMERIC_LOCAL();
2370 STORE_NUMERIC_LOCAL_SET_STANDARD();
2371 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2372 PTR2UV(sv), SvNVX(sv));
2373 RESTORE_NUMERIC_LOCAL();
2377 else if (SvTYPE(sv) < SVt_PVNV)
2378 sv_upgrade(sv, SVt_PVNV);
2383 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2384 #ifdef NV_PRESERVES_UV
2387 /* Only set the public NV OK flag if this NV preserves the IV */
2388 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2389 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2390 : (SvIVX(sv) == I_V(SvNVX(sv))))
2396 else if (SvPOKp(sv) && SvLEN(sv)) {
2398 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2399 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2401 #ifdef NV_PRESERVES_UV
2402 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2403 == IS_NUMBER_IN_UV) {
2404 /* It's definitely an integer */
2405 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2407 SvNV_set(sv, Atof(SvPVX_const(sv)));
2410 SvNV_set(sv, Atof(SvPVX_const(sv)));
2411 /* Only set the public NV OK flag if this NV preserves the value in
2412 the PV at least as well as an IV/UV would.
2413 Not sure how to do this 100% reliably. */
2414 /* if that shift count is out of range then Configure's test is
2415 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2417 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2418 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2419 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2420 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2421 /* Can't use strtol etc to convert this string, so don't try.
2422 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2425 /* value has been set. It may not be precise. */
2426 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2427 /* 2s complement assumption for (UV)IV_MIN */
2428 SvNOK_on(sv); /* Integer is too negative. */
2433 if (numtype & IS_NUMBER_NEG) {
2434 SvIV_set(sv, -(IV)value);
2435 } else if (value <= (UV)IV_MAX) {
2436 SvIV_set(sv, (IV)value);
2438 SvUV_set(sv, value);
2442 if (numtype & IS_NUMBER_NOT_INT) {
2443 /* I believe that even if the original PV had decimals,
2444 they are lost beyond the limit of the FP precision.
2445 However, neither is canonical, so both only get p
2446 flags. NWC, 2000/11/25 */
2447 /* Both already have p flags, so do nothing */
2449 const NV nv = SvNVX(sv);
2450 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2451 if (SvIVX(sv) == I_V(nv)) {
2454 /* It had no "." so it must be integer. */
2458 /* between IV_MAX and NV(UV_MAX).
2459 Could be slightly > UV_MAX */
2461 if (numtype & IS_NUMBER_NOT_INT) {
2462 /* UV and NV both imprecise. */
2464 const UV nv_as_uv = U_V(nv);
2466 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2475 #endif /* NV_PRESERVES_UV */
2478 if (isGV_with_GP(sv)) {
2479 glob_2inpuv((GV *)sv, NULL, TRUE);
2483 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2485 assert (SvTYPE(sv) >= SVt_NV);
2486 /* Typically the caller expects that sv_any is not NULL now. */
2487 /* XXX Ilya implies that this is a bug in callers that assume this
2488 and ideally should be fixed. */
2491 #if defined(USE_LONG_DOUBLE)
2493 STORE_NUMERIC_LOCAL_SET_STANDARD();
2494 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2495 PTR2UV(sv), SvNVX(sv));
2496 RESTORE_NUMERIC_LOCAL();
2500 STORE_NUMERIC_LOCAL_SET_STANDARD();
2501 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2502 PTR2UV(sv), SvNVX(sv));
2503 RESTORE_NUMERIC_LOCAL();
2509 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2510 * UV as a string towards the end of buf, and return pointers to start and
2513 * We assume that buf is at least TYPE_CHARS(UV) long.
2517 S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2519 char *ptr = buf + TYPE_CHARS(UV);
2520 char * const ebuf = ptr;
2533 *--ptr = '0' + (char)(uv % 10);
2541 /* stringify_regexp(): private routine for use by sv_2pv_flags(): converts
2542 * a regexp to its stringified form.
2546 S_stringify_regexp(pTHX_ SV *sv, MAGIC *mg, STRLEN *lp) {
2548 const regexp * const re = (regexp *)mg->mg_obj;
2551 const char *fptr = "msix";
2556 bool need_newline = 0;
2557 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
2559 while((ch = *fptr++)) {
2561 reflags[left++] = ch;
2564 reflags[right--] = ch;
2569 reflags[left] = '-';
2573 mg->mg_len = re->prelen + 4 + left;
2575 * If /x was used, we have to worry about a regex ending with a
2576 * comment later being embedded within another regex. If so, we don't
2577 * want this regex's "commentization" to leak out to the right part of
2578 * the enclosing regex, we must cap it with a newline.
2580 * So, if /x was used, we scan backwards from the end of the regex. If
2581 * we find a '#' before we find a newline, we need to add a newline
2582 * ourself. If we find a '\n' first (or if we don't find '#' or '\n'),
2583 * we don't need to add anything. -jfriedl
2585 if (PMf_EXTENDED & re->reganch) {
2586 const char *endptr = re->precomp + re->prelen;
2587 while (endptr >= re->precomp) {
2588 const char c = *(endptr--);
2590 break; /* don't need another */
2592 /* we end while in a comment, so we need a newline */
2593 mg->mg_len++; /* save space for it */
2594 need_newline = 1; /* note to add it */
2600 Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
2601 mg->mg_ptr[0] = '(';
2602 mg->mg_ptr[1] = '?';
2603 Copy(reflags, mg->mg_ptr+2, left, char);
2604 *(mg->mg_ptr+left+2) = ':';
2605 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2607 mg->mg_ptr[mg->mg_len - 2] = '\n';
2608 mg->mg_ptr[mg->mg_len - 1] = ')';
2609 mg->mg_ptr[mg->mg_len] = 0;
2611 PL_reginterp_cnt += re->program[0].next_off;
2613 if (re->reganch & ROPT_UTF8)
2623 =for apidoc sv_2pv_flags
2625 Returns a pointer to the string value of an SV, and sets *lp to its length.
2626 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2628 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2629 usually end up here too.
2635 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2645 if (SvGMAGICAL(sv)) {
2646 if (flags & SV_GMAGIC)
2651 if (flags & SV_MUTABLE_RETURN)
2652 return SvPVX_mutable(sv);
2653 if (flags & SV_CONST_RETURN)
2654 return (char *)SvPVX_const(sv);
2657 if (SvIOKp(sv) || SvNOKp(sv)) {
2658 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2662 len = SvIsUV(sv) ? my_sprintf(tbuf,"%"UVuf, (UV)SvUVX(sv))
2663 : my_sprintf(tbuf,"%"IVdf, (IV)SvIVX(sv));
2665 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2672 #ifdef FIXNEGATIVEZERO
2673 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2679 SvUPGRADE(sv, SVt_PV);
2682 s = SvGROW_mutable(sv, len + 1);
2685 return memcpy(s, tbuf, len + 1);
2691 assert(SvTYPE(sv) >= SVt_PVMG);
2692 /* This falls through to the report_uninit near the end of the
2694 } else if (SvTHINKFIRST(sv)) {
2698 SV *const tmpstr = AMG_CALLun(sv,string);
2699 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2701 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2705 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2706 if (flags & SV_CONST_RETURN) {
2707 pv = (char *) SvPVX_const(tmpstr);
2709 pv = (flags & SV_MUTABLE_RETURN)
2710 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2713 *lp = SvCUR(tmpstr);
2715 pv = sv_2pv_flags(tmpstr, lp, flags);
2727 const SV *const referent = (SV*)SvRV(sv);
2730 tsv = sv_2mortal(newSVpvs("NULLREF"));
2731 } else if (SvTYPE(referent) == SVt_PVMG
2732 && ((SvFLAGS(referent) &
2733 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2734 == (SVs_OBJECT|SVs_SMG))
2735 && (mg = mg_find(referent, PERL_MAGIC_qr))) {
2736 return stringify_regexp(sv, mg, lp);
2738 const char *const typestr = sv_reftype(referent, 0);
2740 tsv = sv_newmortal();
2741 if (SvOBJECT(referent)) {
2742 const char *const name = HvNAME_get(SvSTASH(referent));
2743 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
2744 name ? name : "__ANON__" , typestr,
2748 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr,
2756 if (SvREADONLY(sv) && !SvOK(sv)) {
2757 if (ckWARN(WARN_UNINITIALIZED))
2764 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2765 /* I'm assuming that if both IV and NV are equally valid then
2766 converting the IV is going to be more efficient */
2767 const U32 isIOK = SvIOK(sv);
2768 const U32 isUIOK = SvIsUV(sv);
2769 char buf[TYPE_CHARS(UV)];
2772 if (SvTYPE(sv) < SVt_PVIV)
2773 sv_upgrade(sv, SVt_PVIV);
2774 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2775 /* inlined from sv_setpvn */
2776 SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
2777 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
2778 SvCUR_set(sv, ebuf - ptr);
2788 else if (SvNOKp(sv)) {
2789 const int olderrno = errno;
2790 if (SvTYPE(sv) < SVt_PVNV)
2791 sv_upgrade(sv, SVt_PVNV);
2792 /* The +20 is pure guesswork. Configure test needed. --jhi */
2793 s = SvGROW_mutable(sv, NV_DIG + 20);
2794 /* some Xenix systems wipe out errno here */
2796 if (SvNVX(sv) == 0.0)
2797 (void)strcpy(s,"0");
2801 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2804 #ifdef FIXNEGATIVEZERO
2805 if (*s == '-' && s[1] == '0' && !s[2])
2815 if (isGV_with_GP(sv)) {
2816 return glob_2inpuv((GV *)sv, lp, FALSE);
2819 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2823 if (SvTYPE(sv) < SVt_PV)
2824 /* Typically the caller expects that sv_any is not NULL now. */
2825 sv_upgrade(sv, SVt_PV);
2829 const STRLEN len = s - SvPVX_const(sv);
2835 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2836 PTR2UV(sv),SvPVX_const(sv)));
2837 if (flags & SV_CONST_RETURN)
2838 return (char *)SvPVX_const(sv);
2839 if (flags & SV_MUTABLE_RETURN)
2840 return SvPVX_mutable(sv);
2845 =for apidoc sv_copypv
2847 Copies a stringified representation of the source SV into the
2848 destination SV. Automatically performs any necessary mg_get and
2849 coercion of numeric values into strings. Guaranteed to preserve
2850 UTF-8 flag even from overloaded objects. Similar in nature to
2851 sv_2pv[_flags] but operates directly on an SV instead of just the
2852 string. Mostly uses sv_2pv_flags to do its work, except when that
2853 would lose the UTF-8'ness of the PV.
2859 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
2862 const char * const s = SvPV_const(ssv,len);
2863 sv_setpvn(dsv,s,len);
2871 =for apidoc sv_2pvbyte
2873 Return a pointer to the byte-encoded representation of the SV, and set *lp
2874 to its length. May cause the SV to be downgraded from UTF-8 as a
2877 Usually accessed via the C<SvPVbyte> macro.
2883 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2885 sv_utf8_downgrade(sv,0);
2886 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
2890 =for apidoc sv_2pvutf8
2892 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
2893 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
2895 Usually accessed via the C<SvPVutf8> macro.
2901 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2903 sv_utf8_upgrade(sv);
2904 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
2909 =for apidoc sv_2bool
2911 This function is only called on magical items, and is only used by
2912 sv_true() or its macro equivalent.
2918 Perl_sv_2bool(pTHX_ register SV *sv)
2927 SV * const tmpsv = AMG_CALLun(sv,bool_);
2928 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2929 return (bool)SvTRUE(tmpsv);
2931 return SvRV(sv) != 0;
2934 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
2936 (*sv->sv_u.svu_pv > '0' ||
2937 Xpvtmp->xpv_cur > 1 ||
2938 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
2945 return SvIVX(sv) != 0;
2948 return SvNVX(sv) != 0.0;
2950 if (isGV_with_GP(sv))
2960 =for apidoc sv_utf8_upgrade
2962 Converts the PV of an SV to its UTF-8-encoded form.
2963 Forces the SV to string form if it is not already.
2964 Always sets the SvUTF8 flag to avoid future validity checks even
2965 if all the bytes have hibit clear.
2967 This is not as a general purpose byte encoding to Unicode interface:
2968 use the Encode extension for that.
2970 =for apidoc sv_utf8_upgrade_flags
2972 Converts the PV of an SV to its UTF-8-encoded form.
2973 Forces the SV to string form if it is not already.
2974 Always sets the SvUTF8 flag to avoid future validity checks even
2975 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
2976 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
2977 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
2979 This is not as a general purpose byte encoding to Unicode interface:
2980 use the Encode extension for that.
2986 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
2989 if (sv == &PL_sv_undef)
2993 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
2994 (void) sv_2pv_flags(sv,&len, flags);
2998 (void) SvPV_force(sv,len);
3007 sv_force_normal_flags(sv, 0);
3010 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3011 sv_recode_to_utf8(sv, PL_encoding);
3012 else { /* Assume Latin-1/EBCDIC */
3013 /* This function could be much more efficient if we
3014 * had a FLAG in SVs to signal if there are any hibit
3015 * chars in the PV. Given that there isn't such a flag
3016 * make the loop as fast as possible. */
3017 const U8 * const s = (U8 *) SvPVX_const(sv);
3018 const U8 * const e = (U8 *) SvEND(sv);
3023 /* Check for hi bit */
3024 if (!NATIVE_IS_INVARIANT(ch)) {
3025 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3026 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
3028 SvPV_free(sv); /* No longer using what was there before. */
3029 SvPV_set(sv, (char*)recoded);
3030 SvCUR_set(sv, len - 1);
3031 SvLEN_set(sv, len); /* No longer know the real size. */
3035 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3042 =for apidoc sv_utf8_downgrade
3044 Attempts to convert the PV of an SV from characters to bytes.
3045 If the PV contains a character beyond byte, this conversion will fail;
3046 in this case, either returns false or, if C<fail_ok> is not
3049 This is not as a general purpose Unicode to byte encoding interface:
3050 use the Encode extension for that.
3056 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3059 if (SvPOKp(sv) && SvUTF8(sv)) {
3065 sv_force_normal_flags(sv, 0);
3067 s = (U8 *) SvPV(sv, len);
3068 if (!utf8_to_bytes(s, &len)) {
3073 Perl_croak(aTHX_ "Wide character in %s",
3076 Perl_croak(aTHX_ "Wide character");
3087 =for apidoc sv_utf8_encode
3089 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3090 flag off so that it looks like octets again.
3096 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3098 (void) sv_utf8_upgrade(sv);
3100 sv_force_normal_flags(sv, 0);
3102 if (SvREADONLY(sv)) {
3103 Perl_croak(aTHX_ PL_no_modify);
3109 =for apidoc sv_utf8_decode
3111 If the PV of the SV is an octet sequence in UTF-8
3112 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3113 so that it looks like a character. If the PV contains only single-byte
3114 characters, the C<SvUTF8> flag stays being off.
3115 Scans PV for validity and returns false if the PV is invalid UTF-8.
3121 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3127 /* The octets may have got themselves encoded - get them back as
3130 if (!sv_utf8_downgrade(sv, TRUE))
3133 /* it is actually just a matter of turning the utf8 flag on, but
3134 * we want to make sure everything inside is valid utf8 first.
3136 c = (const U8 *) SvPVX_const(sv);
3137 if (!is_utf8_string(c, SvCUR(sv)+1))
3139 e = (const U8 *) SvEND(sv);
3142 if (!UTF8_IS_INVARIANT(ch)) {
3152 =for apidoc sv_setsv
3154 Copies the contents of the source SV C<ssv> into the destination SV
3155 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3156 function if the source SV needs to be reused. Does not handle 'set' magic.
3157 Loosely speaking, it performs a copy-by-value, obliterating any previous
3158 content of the destination.
3160 You probably want to use one of the assortment of wrappers, such as
3161 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3162 C<SvSetMagicSV_nosteal>.
3164 =for apidoc sv_setsv_flags
3166 Copies the contents of the source SV C<ssv> into the destination SV
3167 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3168 function if the source SV needs to be reused. Does not handle 'set' magic.
3169 Loosely speaking, it performs a copy-by-value, obliterating any previous
3170 content of the destination.
3171 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3172 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3173 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3174 and C<sv_setsv_nomg> are implemented in terms of this function.
3176 You probably want to use one of the assortment of wrappers, such as
3177 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3178 C<SvSetMagicSV_nosteal>.
3180 This is the primary function for copying scalars, and most other
3181 copy-ish functions and macros use this underneath.
3187 S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype)
3189 if (dtype != SVt_PVGV) {
3190 const char * const name = GvNAME(sstr);
3191 const STRLEN len = GvNAMELEN(sstr);
3192 /* don't upgrade SVt_PVLV: it can hold a glob */
3193 if (dtype != SVt_PVLV) {
3194 if (dtype >= SVt_PV) {
3200 sv_upgrade(dstr, SVt_PVGV);
3201 (void)SvOK_off(dstr);
3204 GvSTASH(dstr) = GvSTASH(sstr);
3206 Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3207 GvNAME(dstr) = savepvn(name, len);
3208 GvNAMELEN(dstr) = len;
3209 SvFAKE_on(dstr); /* can coerce to non-glob */
3212 #ifdef GV_UNIQUE_CHECK
3213 if (GvUNIQUE((GV*)dstr)) {
3214 Perl_croak(aTHX_ PL_no_modify);
3220 (void)SvOK_off(dstr);
3222 GvINTRO_off(dstr); /* one-shot flag */
3223 GvGP(dstr) = gp_ref(GvGP(sstr));
3224 if (SvTAINTED(sstr))
3226 if (GvIMPORTED(dstr) != GVf_IMPORTED
3227 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3229 GvIMPORTED_on(dstr);
3236 S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) {
3237 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3239 const int intro = GvINTRO(dstr);
3242 const U32 stype = SvTYPE(sref);
3245 #ifdef GV_UNIQUE_CHECK
3246 if (GvUNIQUE((GV*)dstr)) {
3247 Perl_croak(aTHX_ PL_no_modify);
3252 GvINTRO_off(dstr); /* one-shot flag */
3253 GvLINE(dstr) = CopLINE(PL_curcop);
3254 GvEGV(dstr) = (GV*)dstr;
3259 location = (SV **) &GvCV(dstr);
3260 import_flag = GVf_IMPORTED_CV;
3263 location = (SV **) &GvHV(dstr);
3264 import_flag = GVf_IMPORTED_HV;
3267 location = (SV **) &GvAV(dstr);
3268 import_flag = GVf_IMPORTED_AV;
3271 location = (SV **) &GvIOp(dstr);
3274 location = (SV **) &GvFORM(dstr);
3276 location = &GvSV(dstr);
3277 import_flag = GVf_IMPORTED_SV;
3280 if (stype == SVt_PVCV) {
3281 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3282 SvREFCNT_dec(GvCV(dstr));
3284 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3285 PL_sub_generation++;
3288 SAVEGENERICSV(*location);
3292 if (stype == SVt_PVCV && *location != sref) {
3293 CV* const cv = (CV*)*location;
3295 if (!GvCVGEN((GV*)dstr) &&
3296 (CvROOT(cv) || CvXSUB(cv)))
3298 /* Redefining a sub - warning is mandatory if
3299 it was a const and its value changed. */
3300 if (CvCONST(cv) && CvCONST((CV*)sref)
3301 && cv_const_sv(cv) == cv_const_sv((CV*)sref)) {
3303 /* They are 2 constant subroutines generated from
3304 the same constant. This probably means that
3305 they are really the "same" proxy subroutine
3306 instantiated in 2 places. Most likely this is
3307 when a constant is exported twice. Don't warn.
3310 else if (ckWARN(WARN_REDEFINE)
3312 && (!CvCONST((CV*)sref)
3313 || sv_cmp(cv_const_sv(cv),
3314 cv_const_sv((CV*)sref))))) {
3315 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3317 ? "Constant subroutine %s::%s redefined"
3318 : "Subroutine %s::%s redefined",
3319 HvNAME_get(GvSTASH((GV*)dstr)),
3320 GvENAME((GV*)dstr));
3324 cv_ckproto(cv, (GV*)dstr,
3325 SvPOK(sref) ? SvPVX_const(sref) : NULL);
3327 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3328 GvASSUMECV_on(dstr);
3329 PL_sub_generation++;
3332 if (import_flag && !(GvFLAGS(dstr) & import_flag)
3333 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3334 GvFLAGS(dstr) |= import_flag;
3339 if (SvTAINTED(sstr))
3345 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3348 register U32 sflags;
3354 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3356 sstr = &PL_sv_undef;
3357 stype = SvTYPE(sstr);
3358 dtype = SvTYPE(dstr);
3363 /* need to nuke the magic */
3365 SvRMAGICAL_off(dstr);
3368 /* There's a lot of redundancy below but we're going for speed here */
3373 if (dtype != SVt_PVGV) {
3374 (void)SvOK_off(dstr);
3382 sv_upgrade(dstr, SVt_IV);
3387 sv_upgrade(dstr, SVt_PVIV);
3390 (void)SvIOK_only(dstr);
3391 SvIV_set(dstr, SvIVX(sstr));
3394 /* SvTAINTED can only be true if the SV has taint magic, which in
3395 turn means that the SV type is PVMG (or greater). This is the
3396 case statement for SVt_IV, so this cannot be true (whatever gcov
3398 assert(!SvTAINTED(sstr));
3408 sv_upgrade(dstr, SVt_NV);
3413 sv_upgrade(dstr, SVt_PVNV);
3416 SvNV_set(dstr, SvNVX(sstr));
3417 (void)SvNOK_only(dstr);
3418 /* SvTAINTED can only be true if the SV has taint magic, which in
3419 turn means that the SV type is PVMG (or greater). This is the
3420 case statement for SVt_NV, so this cannot be true (whatever gcov
3422 assert(!SvTAINTED(sstr));
3429 sv_upgrade(dstr, SVt_RV);
3432 #ifdef PERL_OLD_COPY_ON_WRITE
3433 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3434 if (dtype < SVt_PVIV)
3435 sv_upgrade(dstr, SVt_PVIV);
3442 sv_upgrade(dstr, SVt_PV);
3445 if (dtype < SVt_PVIV)
3446 sv_upgrade(dstr, SVt_PVIV);
3449 if (dtype < SVt_PVNV)
3450 sv_upgrade(dstr, SVt_PVNV);
3457 const char * const type = sv_reftype(sstr,0);
3459 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3461 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3466 if (dtype <= SVt_PVGV) {
3467 S_glob_assign_glob(aTHX_ dstr, sstr, dtype);
3473 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3475 if ((int)SvTYPE(sstr) != stype) {
3476 stype = SvTYPE(sstr);
3477 if (stype == SVt_PVGV && dtype <= SVt_PVGV) {
3478 S_glob_assign_glob(aTHX_ dstr, sstr, dtype);
3483 if (stype == SVt_PVLV)
3484 SvUPGRADE(dstr, SVt_PVNV);
3486 SvUPGRADE(dstr, (U32)stype);
3489 /* dstr may have been upgraded. */
3490 dtype = SvTYPE(dstr);
3491 sflags = SvFLAGS(sstr);
3493 if (sflags & SVf_ROK) {
3494 if (dtype == SVt_PVGV &&
3495 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3498 if (GvIMPORTED(dstr) != GVf_IMPORTED
3499 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3501 GvIMPORTED_on(dstr);
3506 S_glob_assign_glob(aTHX_ dstr, sstr, dtype);
3510 if (dtype >= SVt_PV) {
3511 if (dtype == SVt_PVGV) {
3512 S_glob_assign_ref(aTHX_ dstr, sstr);
3515 if (SvPVX_const(dstr)) {
3521 (void)SvOK_off(dstr);
3522 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3523 SvFLAGS(dstr) |= sflags & (SVf_ROK|SVf_AMAGIC);
3524 assert(!(sflags & SVp_NOK));
3525 assert(!(sflags & SVp_IOK));
3526 assert(!(sflags & SVf_NOK));
3527 assert(!(sflags & SVf_IOK));
3529 else if (dtype == SVt_PVGV) {
3530 if (!(sflags & SVf_OK)) {
3531 if (ckWARN(WARN_MISC))
3532 Perl_warner(aTHX_ packWARN(WARN_MISC),
3533 "Undefined value assigned to typeglob");
3536 GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
3537 if (dstr != (SV*)gv) {
3540 GvGP(dstr) = gp_ref(GvGP(gv));
3544 else if (sflags & SVp_POK) {
3548 * Check to see if we can just swipe the string. If so, it's a
3549 * possible small lose on short strings, but a big win on long ones.
3550 * It might even be a win on short strings if SvPVX_const(dstr)
3551 * has to be allocated and SvPVX_const(sstr) has to be freed.
3554 /* Whichever path we take through the next code, we want this true,
3555 and doing it now facilitates the COW check. */
3556 (void)SvPOK_only(dstr);
3559 /* We're not already COW */
3560 ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
3561 #ifndef PERL_OLD_COPY_ON_WRITE
3562 /* or we are, but dstr isn't a suitable target. */
3563 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
3568 (sflags & SVs_TEMP) && /* slated for free anyway? */
3569 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3570 (!(flags & SV_NOSTEAL)) &&
3571 /* and we're allowed to steal temps */
3572 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3573 SvLEN(sstr) && /* and really is a string */
3574 /* and won't be needed again, potentially */
3575 !(PL_op && PL_op->op_type == OP_AASSIGN))
3576 #ifdef PERL_OLD_COPY_ON_WRITE
3577 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
3578 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
3579 && SvTYPE(sstr) >= SVt_PVIV)
3582 /* Failed the swipe test, and it's not a shared hash key either.
3583 Have to copy the string. */
3584 STRLEN len = SvCUR(sstr);
3585 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3586 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
3587 SvCUR_set(dstr, len);
3588 *SvEND(dstr) = '\0';
3590 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
3592 /* Either it's a shared hash key, or it's suitable for
3593 copy-on-write or we can swipe the string. */
3595 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
3599 #ifdef PERL_OLD_COPY_ON_WRITE
3601 /* I believe I should acquire a global SV mutex if
3602 it's a COW sv (not a shared hash key) to stop
3603 it going un copy-on-write.
3604 If the source SV has gone un copy on write between up there
3605 and down here, then (assert() that) it is of the correct
3606 form to make it copy on write again */
3607 if ((sflags & (SVf_FAKE | SVf_READONLY))
3608 != (SVf_FAKE | SVf_READONLY)) {
3609 SvREADONLY_on(sstr);
3611 /* Make the source SV into a loop of 1.
3612 (about to become 2) */
3613 SV_COW_NEXT_SV_SET(sstr, sstr);
3617 /* Initial code is common. */
3618 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
3623 /* making another shared SV. */
3624 STRLEN cur = SvCUR(sstr);
3625 STRLEN len = SvLEN(sstr);
3626 #ifdef PERL_OLD_COPY_ON_WRITE
3628 assert (SvTYPE(dstr) >= SVt_PVIV);
3629 /* SvIsCOW_normal */
3630 /* splice us in between source and next-after-source. */
3631 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3632 SV_COW_NEXT_SV_SET(sstr, dstr);
3633 SvPV_set(dstr, SvPVX_mutable(sstr));
3637 /* SvIsCOW_shared_hash */
3638 DEBUG_C(PerlIO_printf(Perl_debug_log,
3639 "Copy on write: Sharing hash\n"));
3641 assert (SvTYPE(dstr) >= SVt_PV);
3643 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
3645 SvLEN_set(dstr, len);
3646 SvCUR_set(dstr, cur);
3647 SvREADONLY_on(dstr);
3649 /* Relesase a global SV mutex. */
3652 { /* Passes the swipe test. */
3653 SvPV_set(dstr, SvPVX_mutable(sstr));
3654 SvLEN_set(dstr, SvLEN(sstr));
3655 SvCUR_set(dstr, SvCUR(sstr));
3658 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3659 SvPV_set(sstr, NULL);
3665 if (sflags & SVp_NOK) {
3666 SvNV_set(dstr, SvNVX(sstr));
3668 if (sflags & SVp_IOK) {
3669 SvRELEASE_IVX(dstr);
3670 SvIV_set(dstr, SvIVX(sstr));
3671 /* Must do this otherwise some other overloaded use of 0x80000000
3672 gets confused. I guess SVpbm_VALID */
3673 if (sflags & SVf_IVisUV)
3676 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
3678 const MAGIC * const smg = SvVOK(sstr);
3680 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
3681 smg->mg_ptr, smg->mg_len);
3682 SvRMAGICAL_on(dstr);
3686 else if (sflags & (SVp_IOK|SVp_NOK)) {
3687 (void)SvOK_off(dstr);
3688 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
3689 if (sflags & SVp_IOK) {
3690 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3691 SvIV_set(dstr, SvIVX(sstr));
3693 if (sflags & SVp_NOK) {
3694 SvNV_set(dstr, SvNVX(sstr));
3698 if (isGV_with_GP(sstr)) {
3699 /* This stringification rule for globs is spread in 3 places.
3700 This feels bad. FIXME. */
3701 const U32 wasfake = sflags & SVf_FAKE;
3703 /* FAKE globs can get coerced, so need to turn this off
3704 temporarily if it is on. */
3706 gv_efullname3(dstr, (GV *)sstr, "*");
3707 SvFLAGS(sstr) |= wasfake;
3710 (void)SvOK_off(dstr);
3712 if (SvTAINTED(sstr))
3717 =for apidoc sv_setsv_mg
3719 Like C<sv_setsv>, but also handles 'set' magic.
3725 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3727 sv_setsv(dstr,sstr);
3731 #ifdef PERL_OLD_COPY_ON_WRITE
3733 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
3735 STRLEN cur = SvCUR(sstr);
3736 STRLEN len = SvLEN(sstr);
3737 register char *new_pv;
3740 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
3748 if (SvTHINKFIRST(dstr))
3749 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
3750 else if (SvPVX_const(dstr))
3751 Safefree(SvPVX_const(dstr));
3755 SvUPGRADE(dstr, SVt_PVIV);
3757 assert (SvPOK(sstr));
3758 assert (SvPOKp(sstr));
3759 assert (!SvIOK(sstr));
3760 assert (!SvIOKp(sstr));
3761 assert (!SvNOK(sstr));
3762 assert (!SvNOKp(sstr));
3764 if (SvIsCOW(sstr)) {
3766 if (SvLEN(sstr) == 0) {
3767 /* source is a COW shared hash key. */
3768 DEBUG_C(PerlIO_printf(Perl_debug_log,
3769 "Fast copy on write: Sharing hash\n"));
3770 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
3773 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3775 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
3776 SvUPGRADE(sstr, SVt_PVIV);
3777 SvREADONLY_on(sstr);
3779 DEBUG_C(PerlIO_printf(Perl_debug_log,
3780 "Fast copy on write: Converting sstr to COW\n"));
3781 SV_COW_NEXT_SV_SET(dstr, sstr);
3783 SV_COW_NEXT_SV_SET(sstr, dstr);
3784 new_pv = SvPVX_mutable(sstr);
3787 SvPV_set(dstr, new_pv);
3788 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
3791 SvLEN_set(dstr, len);
3792 SvCUR_set(dstr, cur);
3801 =for apidoc sv_setpvn
3803 Copies a string into an SV. The C<len> parameter indicates the number of
3804 bytes to be copied. If the C<ptr> argument is NULL the SV will become
3805 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3811 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3814 register char *dptr;
3816 SV_CHECK_THINKFIRST_COW_DROP(sv);
3822 /* len is STRLEN which is unsigned, need to copy to signed */
3825 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3827 SvUPGRADE(sv, SVt_PV);
3829 dptr = SvGROW(sv, len + 1);
3830 Move(ptr,dptr,len,char);
3833 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3838 =for apidoc sv_setpvn_mg
3840 Like C<sv_setpvn>, but also handles 'set' magic.
3846 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3848 sv_setpvn(sv,ptr,len);
3853 =for apidoc sv_setpv
3855 Copies a string into an SV. The string must be null-terminated. Does not
3856 handle 'set' magic. See C<sv_setpv_mg>.
3862 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3865 register STRLEN len;
3867 SV_CHECK_THINKFIRST_COW_DROP(sv);
3873 SvUPGRADE(sv, SVt_PV);
3875 SvGROW(sv, len + 1);
3876 Move(ptr,SvPVX(sv),len+1,char);
3878 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3883 =for apidoc sv_setpv_mg
3885 Like C<sv_setpv>, but also handles 'set' magic.
3891 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3898 =for apidoc sv_usepvn
3900 Tells an SV to use C<ptr> to find its string value. Normally the string is
3901 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3902 The C<ptr> should point to memory that was allocated by C<malloc>. The
3903 string length, C<len>, must be supplied. This function will realloc the
3904 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3905 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3906 See C<sv_usepvn_mg>.
3912 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3916 SV_CHECK_THINKFIRST_COW_DROP(sv);
3917 SvUPGRADE(sv, SVt_PV);
3922 if (SvPVX_const(sv))
3925 allocate = PERL_STRLEN_ROUNDUP(len + 1);
3926 ptr = saferealloc (ptr, allocate);
3929 SvLEN_set(sv, allocate);
3931 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3936 =for apidoc sv_usepvn_mg
3938 Like C<sv_usepvn>, but also handles 'set' magic.
3944 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3946 sv_usepvn(sv,ptr,len);
3950 #ifdef PERL_OLD_COPY_ON_WRITE
3951 /* Need to do this *after* making the SV normal, as we need the buffer
3952 pointer to remain valid until after we've copied it. If we let go too early,
3953 another thread could invalidate it by unsharing last of the same hash key
3954 (which it can do by means other than releasing copy-on-write Svs)
3955 or by changing the other copy-on-write SVs in the loop. */
3957 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
3959 if (len) { /* this SV was SvIsCOW_normal(sv) */
3960 /* we need to find the SV pointing to us. */
3961 SV *current = SV_COW_NEXT_SV(after);
3963 if (current == sv) {
3964 /* The SV we point to points back to us (there were only two of us
3966 Hence other SV is no longer copy on write either. */
3968 SvREADONLY_off(after);
3970 /* We need to follow the pointers around the loop. */
3972 while ((next = SV_COW_NEXT_SV(current)) != sv) {
3975 /* don't loop forever if the structure is bust, and we have
3976 a pointer into a closed loop. */
3977 assert (current != after);
3978 assert (SvPVX_const(current) == pvx);
3980 /* Make the SV before us point to the SV after us. */
3981 SV_COW_NEXT_SV_SET(current, after);
3984 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
3989 Perl_sv_release_IVX(pTHX_ register SV *sv)
3992 sv_force_normal_flags(sv, 0);
3998 =for apidoc sv_force_normal_flags
4000 Undo various types of fakery on an SV: if the PV is a shared string, make
4001 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4002 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4003 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4004 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4005 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4006 set to some other value.) In addition, the C<flags> parameter gets passed to
4007 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4008 with flags set to 0.
4014 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4017 #ifdef PERL_OLD_COPY_ON_WRITE
4018 if (SvREADONLY(sv)) {
4019 /* At this point I believe I should acquire a global SV mutex. */
4021 const char * const pvx = SvPVX_const(sv);
4022 const STRLEN len = SvLEN(sv);
4023 const STRLEN cur = SvCUR(sv);
4024 SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
4026 PerlIO_printf(Perl_debug_log,
4027 "Copy on write: Force normal %ld\n",
4033 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4036 if (flags & SV_COW_DROP_PV) {
4037 /* OK, so we don't need to copy our buffer. */
4040 SvGROW(sv, cur + 1);
4041 Move(pvx,SvPVX(sv),cur,char);
4045 sv_release_COW(sv, pvx, len, next);
4050 else if (IN_PERL_RUNTIME)
4051 Perl_croak(aTHX_ PL_no_modify);
4052 /* At this point I believe that I can drop the global SV mutex. */
4055 if (SvREADONLY(sv)) {
4057 const char * const pvx = SvPVX_const(sv);
4058 const STRLEN len = SvCUR(sv);
4063 SvGROW(sv, len + 1);
4064 Move(pvx,SvPVX(sv),len,char);
4066 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4068 else if (IN_PERL_RUNTIME)
4069 Perl_croak(aTHX_ PL_no_modify);
4073 sv_unref_flags(sv, flags);
4074 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4081 Efficient removal of characters from the beginning of the string buffer.
4082 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4083 the string buffer. The C<ptr> becomes the first character of the adjusted
4084 string. Uses the "OOK hack".
4085 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4086 refer to the same chunk of data.
4092 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
4094 register STRLEN delta;
4095 if (!ptr || !SvPOKp(sv))
4097 delta = ptr - SvPVX_const(sv);
4098 SV_CHECK_THINKFIRST(sv);
4099 if (SvTYPE(sv) < SVt_PVIV)
4100 sv_upgrade(sv,SVt_PVIV);
4103 if (!SvLEN(sv)) { /* make copy of shared string */
4104 const char *pvx = SvPVX_const(sv);
4105 const STRLEN len = SvCUR(sv);
4106 SvGROW(sv, len + 1);
4107 Move(pvx,SvPVX(sv),len,char);
4111 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
4112 and we do that anyway inside the SvNIOK_off
4114 SvFLAGS(sv) |= SVf_OOK;
4117 SvLEN_set(sv, SvLEN(sv) - delta);
4118 SvCUR_set(sv, SvCUR(sv) - delta);
4119 SvPV_set(sv, SvPVX(sv) + delta);
4120 SvIV_set(sv, SvIVX(sv) + delta);
4124 =for apidoc sv_catpvn
4126 Concatenates the string onto the end of the string which is in the SV. The
4127 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4128 status set, then the bytes appended should be valid UTF-8.
4129 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4131 =for apidoc sv_catpvn_flags
4133 Concatenates the string onto the end of the string which is in the SV. The
4134 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4135 status set, then the bytes appended should be valid UTF-8.
4136 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4137 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4138 in terms of this function.
4144 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4148 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4150 SvGROW(dsv, dlen + slen + 1);
4152 sstr = SvPVX_const(dsv);
4153 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4154 SvCUR_set(dsv, SvCUR(dsv) + slen);
4156 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4158 if (flags & SV_SMAGIC)
4163 =for apidoc sv_catsv
4165 Concatenates the string from SV C<ssv> onto the end of the string in
4166 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4167 not 'set' magic. See C<sv_catsv_mg>.
4169 =for apidoc sv_catsv_flags
4171 Concatenates the string from SV C<ssv> onto the end of the string in
4172 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4173 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4174 and C<sv_catsv_nomg> are implemented in terms of this function.
4179 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4184 const char *spv = SvPV_const(ssv, slen);
4186 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4187 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4188 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4189 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4190 dsv->sv_flags doesn't have that bit set.
4191 Andy Dougherty 12 Oct 2001
4193 const I32 sutf8 = DO_UTF8(ssv);
4196 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4198 dutf8 = DO_UTF8(dsv);
4200 if (dutf8 != sutf8) {
4202 /* Not modifying source SV, so taking a temporary copy. */
4203 SV* const csv = sv_2mortal(newSVpvn(spv, slen));
4205 sv_utf8_upgrade(csv);
4206 spv = SvPV_const(csv, slen);
4209 sv_utf8_upgrade_nomg(dsv);
4211 sv_catpvn_nomg(dsv, spv, slen);
4214 if (flags & SV_SMAGIC)
4219 =for apidoc sv_catpv
4221 Concatenates the string onto the end of the string which is in the SV.
4222 If the SV has the UTF-8 status set, then the bytes appended should be
4223 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4228 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4231 register STRLEN len;
4237 junk = SvPV_force(sv, tlen);
4239 SvGROW(sv, tlen + len + 1);
4241 ptr = SvPVX_const(sv);
4242 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4243 SvCUR_set(sv, SvCUR(sv) + len);
4244 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4249 =for apidoc sv_catpv_mg
4251 Like C<sv_catpv>, but also handles 'set' magic.
4257 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4266 Creates a new SV. A non-zero C<len> parameter indicates the number of
4267 bytes of preallocated string space the SV should have. An extra byte for a
4268 trailing NUL is also reserved. (SvPOK is not set for the SV even if string
4269 space is allocated.) The reference count for the new SV is set to 1.
4271 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
4272 parameter, I<x>, a debug aid which allowed callers to identify themselves.
4273 This aid has been superseded by a new build option, PERL_MEM_LOG (see
4274 L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
4275 modules supporting older perls.
4281 Perl_newSV(pTHX_ STRLEN len)
4288 sv_upgrade(sv, SVt_PV);
4289 SvGROW(sv, len + 1);
4294 =for apidoc sv_magicext
4296 Adds magic to an SV, upgrading it if necessary. Applies the
4297 supplied vtable and returns a pointer to the magic added.
4299 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4300 In particular, you can add magic to SvREADONLY SVs, and add more than
4301 one instance of the same 'how'.
4303 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4304 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4305 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4306 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4308 (This is now used as a subroutine by C<sv_magic>.)
4313 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
4314 const char* name, I32 namlen)
4319 if (SvTYPE(sv) < SVt_PVMG) {
4320 SvUPGRADE(sv, SVt_PVMG);
4322 Newxz(mg, 1, MAGIC);
4323 mg->mg_moremagic = SvMAGIC(sv);
4324 SvMAGIC_set(sv, mg);
4326 /* Sometimes a magic contains a reference loop, where the sv and
4327 object refer to each other. To prevent a reference loop that
4328 would prevent such objects being freed, we look for such loops
4329 and if we find one we avoid incrementing the object refcount.
4331 Note we cannot do this to avoid self-tie loops as intervening RV must
4332 have its REFCNT incremented to keep it in existence.
4335 if (!obj || obj == sv ||
4336 how == PERL_MAGIC_arylen ||
4337 how == PERL_MAGIC_qr ||
4338 how == PERL_MAGIC_symtab ||
4339 (SvTYPE(obj) == SVt_PVGV &&
4340 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4341 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4342 GvFORM(obj) == (CV*)sv)))
4347 mg->mg_obj = SvREFCNT_inc_simple(obj);
4348 mg->mg_flags |= MGf_REFCOUNTED;
4351 /* Normal self-ties simply pass a null object, and instead of
4352 using mg_obj directly, use the SvTIED_obj macro to produce a
4353 new RV as needed. For glob "self-ties", we are tieing the PVIO
4354 with an RV obj pointing to the glob containing the PVIO. In
4355 this case, to avoid a reference loop, we need to weaken the
4359 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4360 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4366 mg->mg_len = namlen;
4369 mg->mg_ptr = savepvn(name, namlen);
4370 else if (namlen == HEf_SVKEY)
4371 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV*)name);
4373 mg->mg_ptr = (char *) name;
4375 mg->mg_virtual = vtable;
4379 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4384 =for apidoc sv_magic
4386 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4387 then adds a new magic item of type C<how> to the head of the magic list.
4389 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4390 handling of the C<name> and C<namlen> arguments.
4392 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4393 to add more than one instance of the same 'how'.
4399 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4405 #ifdef PERL_OLD_COPY_ON_WRITE
4407 sv_force_normal_flags(sv, 0);
4409 if (SvREADONLY(sv)) {
4411 /* its okay to attach magic to shared strings; the subsequent
4412 * upgrade to PVMG will unshare the string */
4413 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4416 && how != PERL_MAGIC_regex_global
4417 && how != PERL_MAGIC_bm
4418 && how != PERL_MAGIC_fm
4419 && how != PERL_MAGIC_sv
4420 && how != PERL_MAGIC_backref
4423 Perl_croak(aTHX_ PL_no_modify);
4426 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4427 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4428 /* sv_magic() refuses to add a magic of the same 'how' as an
4431 if (how == PERL_MAGIC_taint) {
4433 /* Any scalar which already had taint magic on which someone
4434 (erroneously?) did SvIOK_on() or similar will now be
4435 incorrectly sporting public "OK" flags. */
4436 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4444 vtable = &PL_vtbl_sv;
4446 case PERL_MAGIC_overload:
4447 vtable = &PL_vtbl_amagic;
4449 case PERL_MAGIC_overload_elem:
4450 vtable = &PL_vtbl_amagicelem;
4452 case PERL_MAGIC_overload_table:
4453 vtable = &PL_vtbl_ovrld;
4456 vtable = &PL_vtbl_bm;
4458 case PERL_MAGIC_regdata:
4459 vtable = &PL_vtbl_regdata;
4461 case PERL_MAGIC_regdatum:
4462 vtable = &PL_vtbl_regdatum;
4464 case PERL_MAGIC_env:
4465 vtable = &PL_vtbl_env;
4468 vtable = &PL_vtbl_fm;
4470 case PERL_MAGIC_envelem:
4471 vtable = &PL_vtbl_envelem;
4473 case PERL_MAGIC_regex_global:
4474 vtable = &PL_vtbl_mglob;
4476 case PERL_MAGIC_isa:
4477 vtable = &PL_vtbl_isa;
4479 case PERL_MAGIC_isaelem:
4480 vtable = &PL_vtbl_isaelem;
4482 case PERL_MAGIC_nkeys:
4483 vtable = &PL_vtbl_nkeys;
4485 case PERL_MAGIC_dbfile:
4488 case PERL_MAGIC_dbline:
4489 vtable = &PL_vtbl_dbline;
4491 #ifdef USE_LOCALE_COLLATE
4492 case PERL_MAGIC_collxfrm:
4493 vtable = &PL_vtbl_collxfrm;
4495 #endif /* USE_LOCALE_COLLATE */
4496 case PERL_MAGIC_tied:
4497 vtable = &PL_vtbl_pack;
4499 case PERL_MAGIC_tiedelem:
4500 case PERL_MAGIC_tiedscalar:
4501 vtable = &PL_vtbl_packelem;
4504 vtable = &PL_vtbl_regexp;
4506 case PERL_MAGIC_sig:
4507 vtable = &PL_vtbl_sig;
4509 case PERL_MAGIC_sigelem:
4510 vtable = &PL_vtbl_sigelem;
4512 case PERL_MAGIC_taint:
4513 vtable = &PL_vtbl_taint;
4515 case PERL_MAGIC_uvar:
4516 vtable = &PL_vtbl_uvar;
4518 case PERL_MAGIC_vec:
4519 vtable = &PL_vtbl_vec;
4521 case PERL_MAGIC_arylen_p:
4522 case PERL_MAGIC_rhash:
4523 case PERL_MAGIC_symtab:
4524 case PERL_MAGIC_vstring:
4527 case PERL_MAGIC_utf8:
4528 vtable = &PL_vtbl_utf8;
4530 case PERL_MAGIC_substr:
4531 vtable = &PL_vtbl_substr;
4533 case PERL_MAGIC_defelem:
4534 vtable = &PL_vtbl_defelem;
4536 case PERL_MAGIC_arylen:
4537 vtable = &PL_vtbl_arylen;
4539 case PERL_MAGIC_pos:
4540 vtable = &PL_vtbl_pos;
4542 case PERL_MAGIC_backref:
4543 vtable = &PL_vtbl_backref;
4545 case PERL_MAGIC_ext:
4546 /* Reserved for use by extensions not perl internals. */
4547 /* Useful for attaching extension internal data to perl vars. */
4548 /* Note that multiple extensions may clash if magical scalars */
4549 /* etc holding private data from one are passed to another. */
4553 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4556 /* Rest of work is done else where */
4557 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4560 case PERL_MAGIC_taint:
4563 case PERL_MAGIC_ext:
4564 case PERL_MAGIC_dbfile:
4571 =for apidoc sv_unmagic
4573 Removes all magic of type C<type> from an SV.
4579 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4583 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4585 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
4586 for (mg = *mgp; mg; mg = *mgp) {
4587 if (mg->mg_type == type) {
4588 const MGVTBL* const vtbl = mg->mg_virtual;
4589 *mgp = mg->mg_moremagic;
4590 if (vtbl && vtbl->svt_free)
4591 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4592 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4594 Safefree(mg->mg_ptr);
4595 else if (mg->mg_len == HEf_SVKEY)
4596 SvREFCNT_dec((SV*)mg->mg_ptr);
4597 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
4598 Safefree(mg->mg_ptr);
4600 if (mg->mg_flags & MGf_REFCOUNTED)
4601 SvREFCNT_dec(mg->mg_obj);
4605 mgp = &mg->mg_moremagic;
4609 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4610 SvMAGIC_set(sv, NULL);
4617 =for apidoc sv_rvweaken
4619 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4620 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4621 push a back-reference to this RV onto the array of backreferences
4622 associated with that magic.
4628 Perl_sv_rvweaken(pTHX_ SV *sv)
4631 if (!SvOK(sv)) /* let undefs pass */
4634 Perl_croak(aTHX_ "Can't weaken a nonreference");
4635 else if (SvWEAKREF(sv)) {
4636 if (ckWARN(WARN_MISC))
4637 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
4641 Perl_sv_add_backref(aTHX_ tsv, sv);
4647 /* Give tsv backref magic if it hasn't already got it, then push a
4648 * back-reference to sv onto the array associated with the backref magic.
4652 Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4657 if (SvTYPE(tsv) == SVt_PVHV) {
4658 AV **const avp = Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
4662 /* There is no AV in the offical place - try a fixup. */
4663 MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
4666 /* Aha. They've got it stowed in magic. Bring it back. */
4667 av = (AV*)mg->mg_obj;
4668 /* Stop mg_free decreasing the refernce count. */
4670 /* Stop mg_free even calling the destructor, given that
4671 there's no AV to free up. */
4673 sv_unmagic(tsv, PERL_MAGIC_backref);
4677 SvREFCNT_inc_simple_void(av);
4682 const MAGIC *const mg
4683 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
4685 av = (AV*)mg->mg_obj;
4689 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4690 /* av now has a refcnt of 2, which avoids it getting freed
4691 * before us during global cleanup. The extra ref is removed
4692 * by magic_killbackrefs() when tsv is being freed */
4695 if (AvFILLp(av) >= AvMAX(av)) {
4696 av_extend(av, AvFILLp(av)+1);
4698 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
4701 /* delete a back-reference to ourselves from the backref magic associated
4702 * with the SV we point to.
4706 S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
4713 if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
4714 av = *Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
4715 /* We mustn't attempt to "fix up" the hash here by moving the
4716 backreference array back to the hv_aux structure, as that is stored
4717 in the main HvARRAY(), and hfreentries assumes that no-one
4718 reallocates HvARRAY() while it is running. */
4721 const MAGIC *const mg
4722 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
4724 av = (AV *)mg->mg_obj;
4727 if (PL_in_clean_all)
4729 Perl_croak(aTHX_ "panic: del_backref");
4736 /* We shouldn't be in here more than once, but for paranoia reasons lets
4738 for (i = AvFILLp(av); i >= 0; i--) {
4740 const SSize_t fill = AvFILLp(av);
4742 /* We weren't the last entry.
4743 An unordered list has this property that you can take the
4744 last element off the end to fill the hole, and it's still
4745 an unordered list :-)
4750 AvFILLp(av) = fill - 1;
4756 Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *av)
4758 SV **svp = AvARRAY(av);
4760 PERL_UNUSED_ARG(sv);
4762 /* Not sure why the av can get freed ahead of its sv, but somehow it does
4763 in ext/B/t/bytecode.t test 15 (involving print <DATA>) */
4764 if (svp && !SvIS_FREED(av)) {
4765 SV *const *const last = svp + AvFILLp(av);
4767 while (svp <= last) {
4769 SV *const referrer = *svp;
4770 if (SvWEAKREF(referrer)) {
4771 /* XXX Should we check that it hasn't changed? */
4772 SvRV_set(referrer, 0);
4774 SvWEAKREF_off(referrer);
4775 } else if (SvTYPE(referrer) == SVt_PVGV ||
4776 SvTYPE(referrer) == SVt_PVLV) {
4777 /* You lookin' at me? */
4778 assert(GvSTASH(referrer));
4779 assert(GvSTASH(referrer) == (HV*)sv);
4780 GvSTASH(referrer) = 0;
4783 "panic: magic_killbackrefs (flags=%"UVxf")",
4784 (UV)SvFLAGS(referrer));
4792 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
4797 =for apidoc sv_insert
4799 Inserts a string at the specified offset/length within the SV. Similar to
4800 the Perl substr() function.
4806 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
4811 register char *midend;
4812 register char *bigend;
4818 Perl_croak(aTHX_ "Can't modify non-existent substring");
4819 SvPV_force(bigstr, curlen);
4820 (void)SvPOK_only_UTF8(bigstr);
4821 if (offset + len > curlen) {
4822 SvGROW(bigstr, offset+len+1);
4823 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4824 SvCUR_set(bigstr, offset+len);
4828 i = littlelen - len;
4829 if (i > 0) { /* string might grow */
4830 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4831 mid = big + offset + len;
4832 midend = bigend = big + SvCUR(bigstr);
4835 while (midend > mid) /* shove everything down */
4836 *--bigend = *--midend;
4837 Move(little,big+offset,littlelen,char);
4838 SvCUR_set(bigstr, SvCUR(bigstr) + i);
4843 Move(little,SvPVX(bigstr)+offset,len,char);
4848 big = SvPVX(bigstr);
4851 bigend = big + SvCUR(bigstr);
4853 if (midend > bigend)
4854 Perl_croak(aTHX_ "panic: sv_insert");
4856 if (mid - big > bigend - midend) { /* faster to shorten from end */
4858 Move(little, mid, littlelen,char);
4861 i = bigend - midend;
4863 Move(midend, mid, i,char);
4867 SvCUR_set(bigstr, mid - big);
4869 else if ((i = mid - big)) { /* faster from front */
4870 midend -= littlelen;
4872 sv_chop(bigstr,midend-i);
4877 Move(little, mid, littlelen,char);
4879 else if (littlelen) {
4880 midend -= littlelen;
4881 sv_chop(bigstr,midend);
4882 Move(little,midend,littlelen,char);
4885 sv_chop(bigstr,midend);
4891 =for apidoc sv_replace
4893 Make the first argument a copy of the second, then delete the original.
4894 The target SV physically takes over ownership of the body of the source SV
4895 and inherits its flags; however, the target keeps any magic it owns,
4896 and any magic in the source is discarded.
4897 Note that this is a rather specialist SV copying operation; most of the
4898 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
4904 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4907 const U32 refcnt = SvREFCNT(sv);
4908 SV_CHECK_THINKFIRST_COW_DROP(sv);
4909 if (SvREFCNT(nsv) != 1) {
4910 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
4911 UVuf " != 1)", (UV) SvREFCNT(nsv));
4913 if (SvMAGICAL(sv)) {
4917 sv_upgrade(nsv, SVt_PVMG);
4918 SvMAGIC_set(nsv, SvMAGIC(sv));
4919 SvFLAGS(nsv) |= SvMAGICAL(sv);
4921 SvMAGIC_set(sv, NULL);
4925 assert(!SvREFCNT(sv));
4926 #ifdef DEBUG_LEAKING_SCALARS
4927 sv->sv_flags = nsv->sv_flags;
4928 sv->sv_any = nsv->sv_any;
4929 sv->sv_refcnt = nsv->sv_refcnt;
4930 sv->sv_u = nsv->sv_u;
4932 StructCopy(nsv,sv,SV);
4934 /* Currently could join these into one piece of pointer arithmetic, but
4935 it would be unclear. */
4936 if(SvTYPE(sv) == SVt_IV)
4938 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
4939 else if (SvTYPE(sv) == SVt_RV) {
4940 SvANY(sv) = &sv->sv_u.svu_rv;
4944 #ifdef PERL_OLD_COPY_ON_WRITE
4945 if (SvIsCOW_normal(nsv)) {
4946 /* We need to follow the pointers around the loop to make the
4947 previous SV point to sv, rather than nsv. */
4950 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
4953 assert(SvPVX_const(current) == SvPVX_const(nsv));
4955 /* Make the SV before us point to the SV after us. */
4957 PerlIO_printf(Perl_debug_log, "previous is\n");
4959 PerlIO_printf(Perl_debug_log,
4960 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
4961 (UV) SV_COW_NEXT_SV(current), (UV) sv);
4963 SV_COW_NEXT_SV_SET(current, sv);
4966 SvREFCNT(sv) = refcnt;
4967 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4973 =for apidoc sv_clear
4975 Clear an SV: call any destructors, free up any memory used by the body,
4976 and free the body itself. The SV's head is I<not> freed, although
4977 its type is set to all 1's so that it won't inadvertently be assumed
4978 to be live during global destruction etc.
4979 This function should only be called when REFCNT is zero. Most of the time
4980 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
4987 Perl_sv_clear(pTHX_ register SV *sv)
4990 const U32 type = SvTYPE(sv);
4991 const struct body_details *const sv_type_details
4992 = bodies_by_type + type;
4995 assert(SvREFCNT(sv) == 0);
4997 if (type <= SVt_IV) {
4998 /* See the comment in sv.h about the collusion between this early
4999 return and the overloading of the NULL and IV slots in the size
5005 if (PL_defstash) { /* Still have a symbol table? */
5010 stash = SvSTASH(sv);
5011 destructor = StashHANDLER(stash,DESTROY);
5013 SV* const tmpref = newRV(sv);
5014 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5016 PUSHSTACKi(PERLSI_DESTROY);
5021 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5027 if(SvREFCNT(tmpref) < 2) {
5028 /* tmpref is not kept alive! */
5030 SvRV_set(tmpref, NULL);
5033 SvREFCNT_dec(tmpref);
5035 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5039 if (PL_in_clean_objs)
5040 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5042 /* DESTROY gave object new lease on life */
5048 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5049 SvOBJECT_off(sv); /* Curse the object. */
5050 if (type != SVt_PVIO)
5051 --PL_sv_objcount; /* XXX Might want something more general */
5054 if (type >= SVt_PVMG) {
5056 if ((type == SVt_PVMG || type == SVt_PVGV) &&
5057 (ourstash = OURSTASH(sv))) {
5058 SvREFCNT_dec(ourstash);
5059 } else if (SvMAGIC(sv))
5061 if (type == SVt_PVMG && SvPAD_TYPED(sv))
5062 SvREFCNT_dec(SvSTASH(sv));
5067 IoIFP(sv) != PerlIO_stdin() &&
5068 IoIFP(sv) != PerlIO_stdout() &&
5069 IoIFP(sv) != PerlIO_stderr())
5071 io_close((IO*)sv, FALSE);
5073 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5074 PerlDir_close(IoDIRP(sv));
5075 IoDIRP(sv) = (DIR*)NULL;
5076 Safefree(IoTOP_NAME(sv));
5077 Safefree(IoFMT_NAME(sv));
5078 Safefree(IoBOTTOM_NAME(sv));
5087 Perl_hv_kill_backrefs(aTHX_ (HV*)sv);
5094 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5095 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5096 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5097 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5099 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5100 SvREFCNT_dec(LvTARG(sv));
5104 Safefree(GvNAME(sv));
5105 /* If we're in a stash, we don't own a reference to it. However it does
5106 have a back reference to us, which needs to be cleared. */
5108 sv_del_backref((SV*)GvSTASH(sv), sv);
5113 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5115 SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
5116 /* Don't even bother with turning off the OOK flag. */
5121 SV * const target = SvRV(sv);
5123 sv_del_backref(target, sv);
5125 SvREFCNT_dec(target);
5127 #ifdef PERL_OLD_COPY_ON_WRITE
5128 else if (SvPVX_const(sv)) {
5130 /* I believe I need to grab the global SV mutex here and
5131 then recheck the COW status. */
5133 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5136 sv_release_COW(sv, SvPVX_const(sv), SvLEN(sv),
5137 SV_COW_NEXT_SV(sv));
5138 /* And drop it here. */
5140 } else if (SvLEN(sv)) {
5141 Safefree(SvPVX_const(sv));
5145 else if (SvPVX_const(sv) && SvLEN(sv))
5146 Safefree(SvPVX_mutable(sv));
5147 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5148 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5157 SvFLAGS(sv) &= SVf_BREAK;
5158 SvFLAGS(sv) |= SVTYPEMASK;
5160 if (sv_type_details->arena) {
5161 del_body(((char *)SvANY(sv) + sv_type_details->offset),
5162 &PL_body_roots[type]);
5164 else if (sv_type_details->body_size) {
5165 my_safefree(SvANY(sv));
5170 =for apidoc sv_newref
5172 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5179 Perl_sv_newref(pTHX_ SV *sv)
5181 PERL_UNUSED_CONTEXT;
5190 Decrement an SV's reference count, and if it drops to zero, call
5191 C<sv_clear> to invoke destructors and free up any memory used by
5192 the body; finally, deallocate the SV's head itself.
5193 Normally called via a wrapper macro C<SvREFCNT_dec>.
5199 Perl_sv_free(pTHX_ SV *sv)
5204 if (SvREFCNT(sv) == 0) {
5205 if (SvFLAGS(sv) & SVf_BREAK)
5206 /* this SV's refcnt has been artificially decremented to
5207 * trigger cleanup */
5209 if (PL_in_clean_all) /* All is fair */
5211 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5212 /* make sure SvREFCNT(sv)==0 happens very seldom */
5213 SvREFCNT(sv) = (~(U32)0)/2;
5216 if (ckWARN_d(WARN_INTERNAL)) {
5217 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5218 "Attempt to free unreferenced scalar: SV 0x%"UVxf
5219 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5220 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5221 Perl_dump_sv_child(aTHX_ sv);
5226 if (--(SvREFCNT(sv)) > 0)
5228 Perl_sv_free2(aTHX_ sv);
5232 Perl_sv_free2(pTHX_ SV *sv)
5237 if (ckWARN_d(WARN_DEBUGGING))
5238 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5239 "Attempt to free temp prematurely: SV 0x%"UVxf
5240 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5244 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5245 /* make sure SvREFCNT(sv)==0 happens very seldom */
5246 SvREFCNT(sv) = (~(U32)0)/2;
5257 Returns the length of the string in the SV. Handles magic and type
5258 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5264 Perl_sv_len(pTHX_ register SV *sv)
5272 len = mg_length(sv);
5274 (void)SvPV_const(sv, len);
5279 =for apidoc sv_len_utf8
5281 Returns the number of characters in the string in an SV, counting wide
5282 UTF-8 bytes as a single character. Handles magic and type coercion.
5288 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
5289 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
5290 * (Note that the mg_len is not the length of the mg_ptr field.)
5295 Perl_sv_len_utf8(pTHX_ register SV *sv)
5301 return mg_length(sv);
5305 const U8 *s = (U8*)SvPV_const(sv, len);
5306 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
5308 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
5310 #ifdef PERL_UTF8_CACHE_ASSERT
5311 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
5315 ulen = Perl_utf8_length(aTHX_ s, s + len);
5316 if (!mg && !SvREADONLY(sv)) {
5317 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5318 mg = mg_find(sv, PERL_MAGIC_utf8);
5328 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
5329 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5330 * between UTF-8 and byte offsets. There are two (substr offset and substr
5331 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
5332 * and byte offset) cache positions.
5334 * The mg_len field is used by sv_len_utf8(), see its comments.
5335 * Note that the mg_len is not the length of the mg_ptr field.
5339 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i,
5340 I32 offsetp, const U8 *s, const U8 *start)
5344 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5346 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
5350 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5352 Newxz(*cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5353 (*mgp)->mg_ptr = (char *) *cachep;
5357 (*cachep)[i] = offsetp;
5358 (*cachep)[i+1] = s - start;
5366 * S_utf8_mg_pos() is used to query and update mg_ptr field of
5367 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5368 * between UTF-8 and byte offsets. See also the comments of
5369 * S_utf8_mg_pos_init().
5373 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)
5377 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5379 *mgp = mg_find(sv, PERL_MAGIC_utf8);
5380 if (*mgp && (*mgp)->mg_ptr) {
5381 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5382 ASSERT_UTF8_CACHE(*cachep);
5383 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
5385 else { /* We will skip to the right spot. */
5390 /* The assumption is that going backward is half
5391 * the speed of going forward (that's where the
5392 * 2 * backw in the below comes from). (The real
5393 * figure of course depends on the UTF-8 data.) */
5395 if ((*cachep)[i] > (STRLEN)uoff) {
5397 backw = (*cachep)[i] - (STRLEN)uoff;
5399 if (forw < 2 * backw)
5402 p = start + (*cachep)[i+1];
5404 /* Try this only for the substr offset (i == 0),
5405 * not for the substr length (i == 2). */
5406 else if (i == 0) { /* (*cachep)[i] < uoff */
5407 const STRLEN ulen = sv_len_utf8(sv);
5409 if ((STRLEN)uoff < ulen) {
5410 forw = (STRLEN)uoff - (*cachep)[i];
5411 backw = ulen - (STRLEN)uoff;
5413 if (forw < 2 * backw)
5414 p = start + (*cachep)[i+1];
5419 /* If the string is not long enough for uoff,
5420 * we could extend it, but not at this low a level. */
5424 if (forw < 2 * backw) {
5431 while (UTF8_IS_CONTINUATION(*p))
5436 /* Update the cache. */
5437 (*cachep)[i] = (STRLEN)uoff;
5438 (*cachep)[i+1] = p - start;
5440 /* Drop the stale "length" cache */
5449 if (found) { /* Setup the return values. */
5450 *offsetp = (*cachep)[i+1];
5451 *sp = start + *offsetp;
5454 *offsetp = send - start;
5456 else if (*sp < start) {
5462 #ifdef PERL_UTF8_CACHE_ASSERT
5467 while (n-- && s < send)
5471 assert(*offsetp == s - start);
5472 assert((*cachep)[0] == (STRLEN)uoff);
5473 assert((*cachep)[1] == *offsetp);
5475 ASSERT_UTF8_CACHE(*cachep);
5484 =for apidoc sv_pos_u2b
5486 Converts the value pointed to by offsetp from a count of UTF-8 chars from
5487 the start of the string, to a count of the equivalent number of bytes; if
5488 lenp is non-zero, it does the same to lenp, but this time starting from
5489 the offset, rather than from the start of the string. Handles magic and
5496 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
5497 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5498 * byte offsets. See also the comments of S_utf8_mg_pos().
5503 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5511 start = (U8*)SvPV_const(sv, len);
5514 STRLEN *cache = NULL;
5515 const U8 *s = start;
5516 I32 uoffset = *offsetp;
5517 const U8 * const send = s + len;
5519 bool found = utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send);
5521 if (!found && uoffset > 0) {
5522 while (s < send && uoffset--)
5526 if (utf8_mg_pos_init(sv, &mg, &cache, 0, *offsetp, s, start))
5528 *offsetp = s - start;
5533 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) {
5537 if (!found && *lenp > 0) {
5540 while (s < send && ulen--)
5544 utf8_mg_pos_init(sv, &mg, &cache, 2, *lenp, s, start);
5548 ASSERT_UTF8_CACHE(cache);
5560 =for apidoc sv_pos_b2u
5562 Converts the value pointed to by offsetp from a count of bytes from the
5563 start of the string, to a count of the equivalent number of UTF-8 chars.
5564 Handles magic and type coercion.
5570 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
5571 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5572 * byte offsets. See also the comments of S_utf8_mg_pos().
5577 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
5585 s = (const U8*)SvPV_const(sv, len);
5586 if ((I32)len < *offsetp)
5587 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5589 const U8* send = s + *offsetp;
5591 STRLEN *cache = NULL;
5595 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5596 mg = mg_find(sv, PERL_MAGIC_utf8);
5597 if (mg && mg->mg_ptr) {
5598 cache = (STRLEN *) mg->mg_ptr;
5599 if (cache[1] == (STRLEN)*offsetp) {
5600 /* An exact match. */
5601 *offsetp = cache[0];
5605 else if (cache[1] < (STRLEN)*offsetp) {
5606 /* We already know part of the way. */
5609 /* Let the below loop do the rest. */
5611 else { /* cache[1] > *offsetp */
5612 /* We already know all of the way, now we may
5613 * be able to walk back. The same assumption
5614 * is made as in S_utf8_mg_pos(), namely that
5615 * walking backward is twice slower than
5616 * walking forward. */
5617 const STRLEN forw = *offsetp;
5618 STRLEN backw = cache[1] - *offsetp;
5620 if (!(forw < 2 * backw)) {
5621 const U8 *p = s + cache[1];
5628 while (UTF8_IS_CONTINUATION(*p)) {
5636 *offsetp = cache[0];
5638 /* Drop the stale "length" cache */
5646 ASSERT_UTF8_CACHE(cache);
5652 /* Call utf8n_to_uvchr() to validate the sequence
5653 * (unless a simple non-UTF character) */
5654 if (!UTF8_IS_INVARIANT(*s))
5655 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
5664 if (!SvREADONLY(sv)) {
5666 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5667 mg = mg_find(sv, PERL_MAGIC_utf8);
5672 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5673 mg->mg_ptr = (char *) cache;
5678 cache[1] = *offsetp;
5679 /* Drop the stale "length" cache */
5692 Returns a boolean indicating whether the strings in the two SVs are
5693 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5694 coerce its args to strings if necessary.
5700 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5709 SV* svrecode = NULL;
5716 pv1 = SvPV_const(sv1, cur1);
5723 pv2 = SvPV_const(sv2, cur2);
5725 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5726 /* Differing utf8ness.
5727 * Do not UTF8size the comparands as a side-effect. */
5730 svrecode = newSVpvn(pv2, cur2);
5731 sv_recode_to_utf8(svrecode, PL_encoding);
5732 pv2 = SvPV_const(svrecode, cur2);
5735 svrecode = newSVpvn(pv1, cur1);
5736 sv_recode_to_utf8(svrecode, PL_encoding);
5737 pv1 = SvPV_const(svrecode, cur1);
5739 /* Now both are in UTF-8. */
5741 SvREFCNT_dec(svrecode);
5746 bool is_utf8 = TRUE;
5749 /* sv1 is the UTF-8 one,
5750 * if is equal it must be downgrade-able */
5751 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
5757 /* sv2 is the UTF-8 one,
5758 * if is equal it must be downgrade-able */
5759 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
5765 /* Downgrade not possible - cannot be eq */
5773 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
5775 SvREFCNT_dec(svrecode);
5785 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
5786 string in C<sv1> is less than, equal to, or greater than the string in
5787 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5788 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
5794 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
5798 const char *pv1, *pv2;
5801 SV *svrecode = NULL;
5808 pv1 = SvPV_const(sv1, cur1);
5815 pv2 = SvPV_const(sv2, cur2);
5817 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5818 /* Differing utf8ness.
5819 * Do not UTF8size the comparands as a side-effect. */
5822 svrecode = newSVpvn(pv2, cur2);
5823 sv_recode_to_utf8(svrecode, PL_encoding);
5824 pv2 = SvPV_const(svrecode, cur2);
5827 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
5832 svrecode = newSVpvn(pv1, cur1);
5833 sv_recode_to_utf8(svrecode, PL_encoding);
5834 pv1 = SvPV_const(svrecode, cur1);
5837 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
5843 cmp = cur2 ? -1 : 0;
5847 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
5850 cmp = retval < 0 ? -1 : 1;
5851 } else if (cur1 == cur2) {
5854 cmp = cur1 < cur2 ? -1 : 1;
5858 SvREFCNT_dec(svrecode);
5866 =for apidoc sv_cmp_locale
5868 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
5869 'use bytes' aware, handles get magic, and will coerce its args to strings
5870 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
5876 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5879 #ifdef USE_LOCALE_COLLATE
5885 if (PL_collation_standard)
5889 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5891 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5893 if (!pv1 || !len1) {
5904 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5907 return retval < 0 ? -1 : 1;
5910 * When the result of collation is equality, that doesn't mean
5911 * that there are no differences -- some locales exclude some
5912 * characters from consideration. So to avoid false equalities,
5913 * we use the raw string as a tiebreaker.
5919 #endif /* USE_LOCALE_COLLATE */
5921 return sv_cmp(sv1, sv2);
5925 #ifdef USE_LOCALE_COLLATE
5928 =for apidoc sv_collxfrm
5930 Add Collate Transform magic to an SV if it doesn't already have it.
5932 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5933 scalar data of the variable, but transformed to such a format that a normal
5934 memory comparison can be used to compare the data according to the locale
5941 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5946 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5947 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5953 Safefree(mg->mg_ptr);
5954 s = SvPV_const(sv, len);
5955 if ((xf = mem_collxfrm(s, len, &xlen))) {
5956 if (SvREADONLY(sv)) {
5959 return xf + sizeof(PL_collation_ix);
5962 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5963 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5976 if (mg && mg->mg_ptr) {
5978 return mg->mg_ptr + sizeof(PL_collation_ix);
5986 #endif /* USE_LOCALE_COLLATE */
5991 Get a line from the filehandle and store it into the SV, optionally
5992 appending to the currently-stored string.
5998 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6003 register STDCHAR rslast;
6004 register STDCHAR *bp;
6010 if (SvTHINKFIRST(sv))
6011 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6012 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6014 However, perlbench says it's slower, because the existing swipe code
6015 is faster than copy on write.
6016 Swings and roundabouts. */
6017 SvUPGRADE(sv, SVt_PV);
6022 if (PerlIO_isutf8(fp)) {
6024 sv_utf8_upgrade_nomg(sv);
6025 sv_pos_u2b(sv,&append,0);
6027 } else if (SvUTF8(sv)) {
6028 SV * const tsv = newSV(0);
6029 sv_gets(tsv, fp, 0);
6030 sv_utf8_upgrade_nomg(tsv);
6031 SvCUR_set(sv,append);
6034 goto return_string_or_null;
6039 if (PerlIO_isutf8(fp))
6042 if (IN_PERL_COMPILETIME) {
6043 /* we always read code in line mode */
6047 else if (RsSNARF(PL_rs)) {
6048 /* If it is a regular disk file use size from stat() as estimate
6049 of amount we are going to read - may result in malloc-ing
6050 more memory than we realy need if layers bellow reduce
6051 size we read (e.g. CRLF or a gzip layer)
6054 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6055 const Off_t offset = PerlIO_tell(fp);
6056 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6057 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6063 else if (RsRECORD(PL_rs)) {
6067 /* Grab the size of the record we're getting */
6068 recsize = SvIV(SvRV(PL_rs));
6069 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6072 /* VMS wants read instead of fread, because fread doesn't respect */
6073 /* RMS record boundaries. This is not necessarily a good thing to be */
6074 /* doing, but we've got no other real choice - except avoid stdio
6075 as implementation - perhaps write a :vms layer ?
6077 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6079 bytesread = PerlIO_read(fp, buffer, recsize);
6083 SvCUR_set(sv, bytesread += append);
6084 buffer[bytesread] = '\0';
6085 goto return_string_or_null;
6087 else if (RsPARA(PL_rs)) {
6093 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6094 if (PerlIO_isutf8(fp)) {
6095 rsptr = SvPVutf8(PL_rs, rslen);
6098 if (SvUTF8(PL_rs)) {
6099 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6100 Perl_croak(aTHX_ "Wide character in $/");
6103 rsptr = SvPV_const(PL_rs, rslen);
6107 rslast = rslen ? rsptr[rslen - 1] : '\0';
6109 if (rspara) { /* have to do this both before and after */
6110 do { /* to make sure file boundaries work right */
6113 i = PerlIO_getc(fp);
6117 PerlIO_ungetc(fp,i);
6123 /* See if we know enough about I/O mechanism to cheat it ! */
6125 /* This used to be #ifdef test - it is made run-time test for ease
6126 of abstracting out stdio interface. One call should be cheap
6127 enough here - and may even be a macro allowing compile
6131 if (PerlIO_fast_gets(fp)) {
6134 * We're going to steal some values from the stdio struct
6135 * and put EVERYTHING in the innermost loop into registers.
6137 register STDCHAR *ptr;
6141 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6142 /* An ungetc()d char is handled separately from the regular
6143 * buffer, so we getc() it back out and stuff it in the buffer.
6145 i = PerlIO_getc(fp);
6146 if (i == EOF) return 0;
6147 *(--((*fp)->_ptr)) = (unsigned char) i;
6151 /* Here is some breathtakingly efficient cheating */
6153 cnt = PerlIO_get_cnt(fp); /* get count into register */
6154 /* make sure we have the room */
6155 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
6156 /* Not room for all of it
6157 if we are looking for a separator and room for some
6159 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
6160 /* just process what we have room for */
6161 shortbuffered = cnt - SvLEN(sv) + append + 1;
6162 cnt -= shortbuffered;
6166 /* remember that cnt can be negative */
6167 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
6172 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
6173 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
6174 DEBUG_P(PerlIO_printf(Perl_debug_log,
6175 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6176 DEBUG_P(PerlIO_printf(Perl_debug_log,
6177 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6178 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6179 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6184 while (cnt > 0) { /* this | eat */
6186 if ((*bp++ = *ptr++) == rslast) /* really | dust */
6187 goto thats_all_folks; /* screams | sed :-) */
6191 Copy(ptr, bp, cnt, char); /* this | eat */
6192 bp += cnt; /* screams | dust */
6193 ptr += cnt; /* louder | sed :-) */
6198 if (shortbuffered) { /* oh well, must extend */
6199 cnt = shortbuffered;
6201 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6203 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6204 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6208 DEBUG_P(PerlIO_printf(Perl_debug_log,
6209 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6210 PTR2UV(ptr),(long)cnt));
6211 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6213 DEBUG_P(PerlIO_printf(Perl_debug_log,
6214 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6215 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6216 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6218 /* This used to call 'filbuf' in stdio form, but as that behaves like
6219 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6220 another abstraction. */
6221 i = PerlIO_getc(fp); /* get more characters */
6223 DEBUG_P(PerlIO_printf(Perl_debug_log,
6224 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6225 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6226 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6228 cnt = PerlIO_get_cnt(fp);
6229 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
6230 DEBUG_P(PerlIO_printf(Perl_debug_log,
6231 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6233 if (i == EOF) /* all done for ever? */
6234 goto thats_really_all_folks;
6236 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6238 SvGROW(sv, bpx + cnt + 2);
6239 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6241 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
6243 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
6244 goto thats_all_folks;
6248 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
6249 memNE((char*)bp - rslen, rsptr, rslen))
6250 goto screamer; /* go back to the fray */
6251 thats_really_all_folks:
6253 cnt += shortbuffered;
6254 DEBUG_P(PerlIO_printf(Perl_debug_log,
6255 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6256 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
6257 DEBUG_P(PerlIO_printf(Perl_debug_log,
6258 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6259 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6260 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6262 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
6263 DEBUG_P(PerlIO_printf(Perl_debug_log,
6264 "Screamer: done, len=%ld, string=|%.*s|\n",
6265 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
6269 /*The big, slow, and stupid way. */
6270 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
6271 STDCHAR *buf = NULL;
6272 Newx(buf, 8192, STDCHAR);
6280 register const STDCHAR * const bpe = buf + sizeof(buf);
6282 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6283 ; /* keep reading */
6287 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6288 /* Accomodate broken VAXC compiler, which applies U8 cast to
6289 * both args of ?: operator, causing EOF to change into 255
6292 i = (U8)buf[cnt - 1];
6298 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
6300 sv_catpvn(sv, (char *) buf, cnt);
6302 sv_setpvn(sv, (char *) buf, cnt);
6304 if (i != EOF && /* joy */
6306 SvCUR(sv) < rslen ||
6307 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6311 * If we're reading from a TTY and we get a short read,
6312 * indicating that the user hit his EOF character, we need
6313 * to notice it now, because if we try to read from the TTY
6314 * again, the EOF condition will disappear.
6316 * The comparison of cnt to sizeof(buf) is an optimization
6317 * that prevents unnecessary calls to feof().
6321 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
6325 #ifdef USE_HEAP_INSTEAD_OF_STACK
6330 if (rspara) { /* have to do this both before and after */
6331 while (i != EOF) { /* to make sure file boundaries work right */
6332 i = PerlIO_getc(fp);
6334 PerlIO_ungetc(fp,i);
6340 return_string_or_null:
6341 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
6347 Auto-increment of the value in the SV, doing string to numeric conversion
6348 if necessary. Handles 'get' magic.
6354 Perl_sv_inc(pTHX_ register SV *sv)
6363 if (SvTHINKFIRST(sv)) {
6365 sv_force_normal_flags(sv, 0);
6366 if (SvREADONLY(sv)) {
6367 if (IN_PERL_RUNTIME)
6368 Perl_croak(aTHX_ PL_no_modify);
6372 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6374 i = PTR2IV(SvRV(sv));
6379 flags = SvFLAGS(sv);
6380 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6381 /* It's (privately or publicly) a float, but not tested as an
6382 integer, so test it to see. */
6384 flags = SvFLAGS(sv);
6386 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6387 /* It's publicly an integer, or privately an integer-not-float */
6388 #ifdef PERL_PRESERVE_IVUV
6392 if (SvUVX(sv) == UV_MAX)
6393 sv_setnv(sv, UV_MAX_P1);
6395 (void)SvIOK_only_UV(sv);
6396 SvUV_set(sv, SvUVX(sv) + 1);
6398 if (SvIVX(sv) == IV_MAX)
6399 sv_setuv(sv, (UV)IV_MAX + 1);
6401 (void)SvIOK_only(sv);
6402 SvIV_set(sv, SvIVX(sv) + 1);
6407 if (flags & SVp_NOK) {
6408 (void)SvNOK_only(sv);
6409 SvNV_set(sv, SvNVX(sv) + 1.0);
6413 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
6414 if ((flags & SVTYPEMASK) < SVt_PVIV)
6415 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
6416 (void)SvIOK_only(sv);
6421 while (isALPHA(*d)) d++;
6422 while (isDIGIT(*d)) d++;
6424 #ifdef PERL_PRESERVE_IVUV
6425 /* Got to punt this as an integer if needs be, but we don't issue
6426 warnings. Probably ought to make the sv_iv_please() that does
6427 the conversion if possible, and silently. */
6428 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6429 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6430 /* Need to try really hard to see if it's an integer.
6431 9.22337203685478e+18 is an integer.
6432 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6433 so $a="9.22337203685478e+18"; $a+0; $a++
6434 needs to be the same as $a="9.22337203685478e+18"; $a++
6441 /* sv_2iv *should* have made this an NV */
6442 if (flags & SVp_NOK) {
6443 (void)SvNOK_only(sv);
6444 SvNV_set(sv, SvNVX(sv) + 1.0);
6447 /* I don't think we can get here. Maybe I should assert this
6448 And if we do get here I suspect that sv_setnv will croak. NWC
6450 #if defined(USE_LONG_DOUBLE)
6451 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",
6452 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6454 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6455 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6458 #endif /* PERL_PRESERVE_IVUV */
6459 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
6463 while (d >= SvPVX_const(sv)) {
6471 /* MKS: The original code here died if letters weren't consecutive.
6472 * at least it didn't have to worry about non-C locales. The
6473 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6474 * arranged in order (although not consecutively) and that only
6475 * [A-Za-z] are accepted by isALPHA in the C locale.
6477 if (*d != 'z' && *d != 'Z') {
6478 do { ++*d; } while (!isALPHA(*d));
6481 *(d--) -= 'z' - 'a';
6486 *(d--) -= 'z' - 'a' + 1;
6490 /* oh,oh, the number grew */
6491 SvGROW(sv, SvCUR(sv) + 2);
6492 SvCUR_set(sv, SvCUR(sv) + 1);
6493 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
6504 Auto-decrement of the value in the SV, doing string to numeric conversion
6505 if necessary. Handles 'get' magic.
6511 Perl_sv_dec(pTHX_ register SV *sv)
6519 if (SvTHINKFIRST(sv)) {
6521 sv_force_normal_flags(sv, 0);
6522 if (SvREADONLY(sv)) {
6523 if (IN_PERL_RUNTIME)
6524 Perl_croak(aTHX_ PL_no_modify);
6528 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6530 i = PTR2IV(SvRV(sv));
6535 /* Unlike sv_inc we don't have to worry about string-never-numbers
6536 and keeping them magic. But we mustn't warn on punting */
6537 flags = SvFLAGS(sv);
6538 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6539 /* It's publicly an integer, or privately an integer-not-float */
6540 #ifdef PERL_PRESERVE_IVUV
6544 if (SvUVX(sv) == 0) {
6545 (void)SvIOK_only(sv);
6549 (void)SvIOK_only_UV(sv);
6550 SvUV_set(sv, SvUVX(sv) - 1);
6553 if (SvIVX(sv) == IV_MIN)
6554 sv_setnv(sv, (NV)IV_MIN - 1.0);
6556 (void)SvIOK_only(sv);
6557 SvIV_set(sv, SvIVX(sv) - 1);
6562 if (flags & SVp_NOK) {
6563 SvNV_set(sv, SvNVX(sv) - 1.0);
6564 (void)SvNOK_only(sv);
6567 if (!(flags & SVp_POK)) {
6568 if ((flags & SVTYPEMASK) < SVt_PVIV)
6569 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
6571 (void)SvIOK_only(sv);
6574 #ifdef PERL_PRESERVE_IVUV
6576 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6577 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6578 /* Need to try really hard to see if it's an integer.
6579 9.22337203685478e+18 is an integer.
6580 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6581 so $a="9.22337203685478e+18"; $a+0; $a--
6582 needs to be the same as $a="9.22337203685478e+18"; $a--
6589 /* sv_2iv *should* have made this an NV */
6590 if (flags & SVp_NOK) {
6591 (void)SvNOK_only(sv);
6592 SvNV_set(sv, SvNVX(sv) - 1.0);
6595 /* I don't think we can get here. Maybe I should assert this
6596 And if we do get here I suspect that sv_setnv will croak. NWC
6598 #if defined(USE_LONG_DOUBLE)
6599 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",
6600 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6602 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6603 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6607 #endif /* PERL_PRESERVE_IVUV */
6608 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
6612 =for apidoc sv_mortalcopy
6614 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6615 The new SV is marked as mortal. It will be destroyed "soon", either by an
6616 explicit call to FREETMPS, or by an implicit call at places such as
6617 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
6622 /* Make a string that will exist for the duration of the expression
6623 * evaluation. Actually, it may have to last longer than that, but
6624 * hopefully we won't free it until it has been assigned to a
6625 * permanent location. */
6628 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6634 sv_setsv(sv,oldstr);
6636 PL_tmps_stack[++PL_tmps_ix] = sv;
6642 =for apidoc sv_newmortal
6644 Creates a new null SV which is mortal. The reference count of the SV is
6645 set to 1. It will be destroyed "soon", either by an explicit call to
6646 FREETMPS, or by an implicit call at places such as statement boundaries.
6647 See also C<sv_mortalcopy> and C<sv_2mortal>.
6653 Perl_sv_newmortal(pTHX)
6659 SvFLAGS(sv) = SVs_TEMP;
6661 PL_tmps_stack[++PL_tmps_ix] = sv;
6666 =for apidoc sv_2mortal
6668 Marks an existing SV as mortal. The SV will be destroyed "soon", either
6669 by an explicit call to FREETMPS, or by an implicit call at places such as
6670 statement boundaries. SvTEMP() is turned on which means that the SV's
6671 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
6672 and C<sv_mortalcopy>.
6678 Perl_sv_2mortal(pTHX_ register SV *sv)
6683 if (SvREADONLY(sv) && SvIMMORTAL(sv))
6686 PL_tmps_stack[++PL_tmps_ix] = sv;
6694 Creates a new SV and copies a string into it. The reference count for the
6695 SV is set to 1. If C<len> is zero, Perl will compute the length using
6696 strlen(). For efficiency, consider using C<newSVpvn> instead.
6702 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6708 sv_setpvn(sv,s,len ? len : strlen(s));
6713 =for apidoc newSVpvn
6715 Creates a new SV and copies a string into it. The reference count for the
6716 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
6717 string. You are responsible for ensuring that the source string is at least
6718 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
6724 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
6730 sv_setpvn(sv,s,len);
6736 =for apidoc newSVhek
6738 Creates a new SV from the hash key structure. It will generate scalars that
6739 point to the shared string table where possible. Returns a new (undefined)
6740 SV if the hek is NULL.
6746 Perl_newSVhek(pTHX_ const HEK *hek)
6756 if (HEK_LEN(hek) == HEf_SVKEY) {
6757 return newSVsv(*(SV**)HEK_KEY(hek));
6759 const int flags = HEK_FLAGS(hek);
6760 if (flags & HVhek_WASUTF8) {
6762 Andreas would like keys he put in as utf8 to come back as utf8
6764 STRLEN utf8_len = HEK_LEN(hek);
6765 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
6766 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
6769 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
6771 } else if (flags & HVhek_REHASH) {
6772 /* We don't have a pointer to the hv, so we have to replicate the
6773 flag into every HEK. This hv is using custom a hasing
6774 algorithm. Hence we can't return a shared string scalar, as
6775 that would contain the (wrong) hash value, and might get passed
6776 into an hv routine with a regular hash */
6778 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
6783 /* This will be overwhelminly the most common case. */
6784 return newSVpvn_share(HEK_KEY(hek),
6785 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
6791 =for apidoc newSVpvn_share
6793 Creates a new SV with its SvPVX_const pointing to a shared string in the string
6794 table. If the string does not already exist in the table, it is created
6795 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
6796 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
6797 otherwise the hash is computed. The idea here is that as the string table
6798 is used for shared hash keys these strings will have SvPVX_const == HeKEY and
6799 hash lookup will avoid string compare.
6805 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
6809 bool is_utf8 = FALSE;
6811 STRLEN tmplen = -len;
6813 /* See the note in hv.c:hv_fetch() --jhi */
6814 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
6818 PERL_HASH(hash, src, len);
6820 sv_upgrade(sv, SVt_PV);
6821 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
6833 #if defined(PERL_IMPLICIT_CONTEXT)
6835 /* pTHX_ magic can't cope with varargs, so this is a no-context
6836 * version of the main function, (which may itself be aliased to us).
6837 * Don't access this version directly.
6841 Perl_newSVpvf_nocontext(const char* pat, ...)
6846 va_start(args, pat);
6847 sv = vnewSVpvf(pat, &args);
6854 =for apidoc newSVpvf
6856 Creates a new SV and initializes it with the string formatted like
6863 Perl_newSVpvf(pTHX_ const char* pat, ...)
6867 va_start(args, pat);
6868 sv = vnewSVpvf(pat, &args);
6873 /* backend for newSVpvf() and newSVpvf_nocontext() */
6876 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
6881 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
6888 Creates a new SV and copies a floating point value into it.
6889 The reference count for the SV is set to 1.
6895 Perl_newSVnv(pTHX_ NV n)
6908 Creates a new SV and copies an integer into it. The reference count for the
6915 Perl_newSViv(pTHX_ IV i)
6928 Creates a new SV and copies an unsigned integer into it.
6929 The reference count for the SV is set to 1.
6935 Perl_newSVuv(pTHX_ UV u)
6946 =for apidoc newRV_noinc
6948 Creates an RV wrapper for an SV. The reference count for the original
6949 SV is B<not> incremented.
6955 Perl_newRV_noinc(pTHX_ SV *tmpRef)
6961 sv_upgrade(sv, SVt_RV);
6963 SvRV_set(sv, tmpRef);
6968 /* newRV_inc is the official function name to use now.
6969 * newRV_inc is in fact #defined to newRV in sv.h
6973 Perl_newRV(pTHX_ SV *tmpRef)
6976 return newRV_noinc(SvREFCNT_inc_simple(tmpRef));
6982 Creates a new SV which is an exact duplicate of the original SV.
6989 Perl_newSVsv(pTHX_ register SV *old)
6996 if (SvTYPE(old) == SVTYPEMASK) {
6997 if (ckWARN_d(WARN_INTERNAL))
6998 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7002 /* SV_GMAGIC is the default for sv_setv()
7003 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7004 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7005 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7010 =for apidoc sv_reset
7012 Underlying implementation for the C<reset> Perl function.
7013 Note that the perl-level function is vaguely deprecated.
7019 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
7022 char todo[PERL_UCHAR_MAX+1];
7027 if (!*s) { /* reset ?? searches */
7028 MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
7030 PMOP *pm = (PMOP *) mg->mg_obj;
7032 pm->op_pmdynflags &= ~PMdf_USED;
7039 /* reset variables */
7041 if (!HvARRAY(stash))
7044 Zero(todo, 256, char);
7047 I32 i = (unsigned char)*s;
7051 max = (unsigned char)*s++;
7052 for ( ; i <= max; i++) {
7055 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7057 for (entry = HvARRAY(stash)[i];
7059 entry = HeNEXT(entry))
7064 if (!todo[(U8)*HeKEY(entry)])
7066 gv = (GV*)HeVAL(entry);
7069 if (SvTHINKFIRST(sv)) {
7070 if (!SvREADONLY(sv) && SvROK(sv))
7072 /* XXX Is this continue a bug? Why should THINKFIRST
7073 exempt us from resetting arrays and hashes? */
7077 if (SvTYPE(sv) >= SVt_PV) {
7079 if (SvPVX_const(sv) != NULL)
7087 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
7089 Perl_die(aTHX_ "Can't reset %%ENV on this system");
7092 # if defined(USE_ENVIRON_ARRAY)
7095 # endif /* USE_ENVIRON_ARRAY */
7106 Using various gambits, try to get an IO from an SV: the IO slot if its a
7107 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7108 named after the PV if we're a string.
7114 Perl_sv_2io(pTHX_ SV *sv)
7119 switch (SvTYPE(sv)) {
7127 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7131 Perl_croak(aTHX_ PL_no_usym, "filehandle");
7133 return sv_2io(SvRV(sv));
7134 gv = gv_fetchsv(sv, 0, SVt_PVIO);
7140 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
7149 Using various gambits, try to get a CV from an SV; in addition, try if
7150 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7151 The flags in C<lref> are passed to sv_fetchsv.
7157 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7168 switch (SvTYPE(sv)) {
7187 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
7188 tryAMAGICunDEREF(to_cv);
7191 if (SvTYPE(sv) == SVt_PVCV) {
7200 Perl_croak(aTHX_ "Not a subroutine reference");
7205 gv = gv_fetchsv(sv, lref, SVt_PVCV);
7211 /* Some flags to gv_fetchsv mean don't really create the GV */
7212 if (SvTYPE(gv) != SVt_PVGV) {
7218 if (lref && !GvCVu(gv)) {
7222 gv_efullname3(tmpsv, gv, NULL);
7223 /* XXX this is probably not what they think they're getting.
7224 * It has the same effect as "sub name;", i.e. just a forward
7226 newSUB(start_subparse(FALSE, 0),
7227 newSVOP(OP_CONST, 0, tmpsv),
7231 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
7241 Returns true if the SV has a true value by Perl's rules.
7242 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
7243 instead use an in-line version.
7249 Perl_sv_true(pTHX_ register SV *sv)
7254 register const XPV* const tXpv = (XPV*)SvANY(sv);
7256 (tXpv->xpv_cur > 1 ||
7257 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
7264 return SvIVX(sv) != 0;
7267 return SvNVX(sv) != 0.0;
7269 return sv_2bool(sv);
7275 =for apidoc sv_pvn_force
7277 Get a sensible string out of the SV somehow.
7278 A private implementation of the C<SvPV_force> macro for compilers which
7279 can't cope with complex macro expressions. Always use the macro instead.
7281 =for apidoc sv_pvn_force_flags
7283 Get a sensible string out of the SV somehow.
7284 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
7285 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
7286 implemented in terms of this function.
7287 You normally want to use the various wrapper macros instead: see
7288 C<SvPV_force> and C<SvPV_force_nomg>
7294 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
7297 if (SvTHINKFIRST(sv) && !SvROK(sv))
7298 sv_force_normal_flags(sv, 0);
7308 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
7309 const char * const ref = sv_reftype(sv,0);
7311 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
7312 ref, OP_NAME(PL_op));
7314 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
7316 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
7317 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
7319 s = sv_2pv_flags(sv, &len, flags);
7323 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
7326 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
7327 SvGROW(sv, len + 1);
7328 Move(s,SvPVX(sv),len,char);
7333 SvPOK_on(sv); /* validate pointer */
7335 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
7336 PTR2UV(sv),SvPVX_const(sv)));
7339 return SvPVX_mutable(sv);
7343 =for apidoc sv_pvbyten_force
7345 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
7351 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
7353 sv_pvn_force(sv,lp);
7354 sv_utf8_downgrade(sv,0);
7360 =for apidoc sv_pvutf8n_force
7362 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
7368 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
7370 sv_pvn_force(sv,lp);
7371 sv_utf8_upgrade(sv);
7377 =for apidoc sv_reftype
7379 Returns a string describing what the SV is a reference to.
7385 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
7387 /* The fact that I don't need to downcast to char * everywhere, only in ?:
7388 inside return suggests a const propagation bug in g++. */
7389 if (ob && SvOBJECT(sv)) {
7390 char * const name = HvNAME_get(SvSTASH(sv));
7391 return name ? name : (char *) "__ANON__";
7394 switch (SvTYPE(sv)) {
7411 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
7412 /* tied lvalues should appear to be
7413 * scalars for backwards compatitbility */
7414 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
7415 ? "SCALAR" : "LVALUE");
7416 case SVt_PVAV: return "ARRAY";
7417 case SVt_PVHV: return "HASH";
7418 case SVt_PVCV: return "CODE";
7419 case SVt_PVGV: return "GLOB";
7420 case SVt_PVFM: return "FORMAT";
7421 case SVt_PVIO: return "IO";
7422 default: return "UNKNOWN";
7428 =for apidoc sv_isobject
7430 Returns a boolean indicating whether the SV is an RV pointing to a blessed
7431 object. If the SV is not an RV, or if the object is not blessed, then this
7438 Perl_sv_isobject(pTHX_ SV *sv)
7454 Returns a boolean indicating whether the SV is blessed into the specified
7455 class. This does not check for subtypes; use C<sv_derived_from> to verify
7456 an inheritance relationship.
7462 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7473 hvname = HvNAME_get(SvSTASH(sv));
7477 return strEQ(hvname, name);
7483 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
7484 it will be upgraded to one. If C<classname> is non-null then the new SV will
7485 be blessed in the specified package. The new SV is returned and its
7486 reference count is 1.
7492 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7499 SV_CHECK_THINKFIRST_COW_DROP(rv);
7502 if (SvTYPE(rv) >= SVt_PVMG) {
7503 const U32 refcnt = SvREFCNT(rv);
7507 SvREFCNT(rv) = refcnt;
7510 if (SvTYPE(rv) < SVt_RV)
7511 sv_upgrade(rv, SVt_RV);
7512 else if (SvTYPE(rv) > SVt_RV) {
7523 HV* const stash = gv_stashpv(classname, TRUE);
7524 (void)sv_bless(rv, stash);
7530 =for apidoc sv_setref_pv
7532 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7533 argument will be upgraded to an RV. That RV will be modified to point to
7534 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7535 into the SV. The C<classname> argument indicates the package for the
7536 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
7537 will have a reference count of 1, and the RV will be returned.
7539 Do not use with other Perl types such as HV, AV, SV, CV, because those
7540 objects will become corrupted by the pointer copy process.
7542 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7548 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7552 sv_setsv(rv, &PL_sv_undef);
7556 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7561 =for apidoc sv_setref_iv
7563 Copies an integer 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_iv(pTHX_ SV *rv, const char *classname, IV iv)
7575 sv_setiv(newSVrv(rv,classname), iv);
7580 =for apidoc sv_setref_uv
7582 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7583 argument will be upgraded to an RV. That RV will be modified to point to
7584 the new SV. The C<classname> argument indicates the package for the
7585 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
7586 will have a reference count of 1, and the RV will be returned.
7592 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7594 sv_setuv(newSVrv(rv,classname), uv);
7599 =for apidoc sv_setref_nv
7601 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7602 argument will be upgraded to an RV. That RV will be modified to point to
7603 the new SV. The C<classname> argument indicates the package for the
7604 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
7605 will have a reference count of 1, and the RV will be returned.
7611 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7613 sv_setnv(newSVrv(rv,classname), nv);
7618 =for apidoc sv_setref_pvn
7620 Copies a string into a new SV, optionally blessing the SV. The length of the
7621 string must be specified with C<n>. The C<rv> argument will be upgraded to
7622 an RV. That RV will be modified to point to the new SV. The C<classname>
7623 argument indicates the package for the blessing. Set C<classname> to
7624 C<NULL> to avoid the blessing. The new SV will have a reference count
7625 of 1, and the RV will be returned.
7627 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7633 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n)
7635 sv_setpvn(newSVrv(rv,classname), pv, n);
7640 =for apidoc sv_bless
7642 Blesses an SV into a specified package. The SV must be an RV. The package
7643 must be designated by its stash (see C<gv_stashpv()>). The reference count
7644 of the SV is unaffected.
7650 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7655 Perl_croak(aTHX_ "Can't bless non-reference value");
7657 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7658 if (SvREADONLY(tmpRef))
7659 Perl_croak(aTHX_ PL_no_modify);
7660 if (SvOBJECT(tmpRef)) {
7661 if (SvTYPE(tmpRef) != SVt_PVIO)
7663 SvREFCNT_dec(SvSTASH(tmpRef));
7666 SvOBJECT_on(tmpRef);
7667 if (SvTYPE(tmpRef) != SVt_PVIO)
7669 SvUPGRADE(tmpRef, SVt_PVMG);
7670 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc_simple(stash));
7677 if(SvSMAGICAL(tmpRef))
7678 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
7686 /* Downgrades a PVGV to a PVMG.
7690 S_sv_unglob(pTHX_ SV *sv)
7694 SV * const temp = sv_newmortal();
7696 assert(SvTYPE(sv) == SVt_PVGV);
7698 gv_efullname3(temp, (GV *) sv, "*");
7704 sv_del_backref((SV*)GvSTASH(sv), sv);
7708 Safefree(GvNAME(sv));
7711 /* need to keep SvANY(sv) in the right arena */
7712 xpvmg = new_XPVMG();
7713 StructCopy(SvANY(sv), xpvmg, XPVMG);
7714 del_XPVGV(SvANY(sv));
7717 SvFLAGS(sv) &= ~SVTYPEMASK;
7718 SvFLAGS(sv) |= SVt_PVMG;
7720 /* Intentionally not calling any local SET magic, as this isn't so much a
7721 set operation as merely an internal storage change. */
7722 sv_setsv_flags(sv, temp, 0);
7726 =for apidoc sv_unref_flags
7728 Unsets the RV status of the SV, and decrements the reference count of
7729 whatever was being referenced by the RV. This can almost be thought of
7730 as a reversal of C<newSVrv>. The C<cflags> argument can contain
7731 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
7732 (otherwise the decrementing is conditional on the reference count being
7733 different from one or the reference being a readonly SV).
7740 Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags)
7742 SV* const target = SvRV(ref);
7744 if (SvWEAKREF(ref)) {
7745 sv_del_backref(target, ref);
7747 SvRV_set(ref, NULL);
7750 SvRV_set(ref, NULL);
7752 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
7753 assigned to as BEGIN {$a = \"Foo"} will fail. */
7754 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
7755 SvREFCNT_dec(target);
7756 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
7757 sv_2mortal(target); /* Schedule for freeing later */
7761 =for apidoc sv_untaint
7763 Untaint an SV. Use C<SvTAINTED_off> instead.
7768 Perl_sv_untaint(pTHX_ SV *sv)
7770 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7771 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
7778 =for apidoc sv_tainted
7780 Test an SV for taintedness. Use C<SvTAINTED> instead.
7785 Perl_sv_tainted(pTHX_ SV *sv)
7787 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7788 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
7789 if (mg && (mg->mg_len & 1) )
7796 =for apidoc sv_setpviv
7798 Copies an integer into the given SV, also updating its string value.
7799 Does not handle 'set' magic. See C<sv_setpviv_mg>.
7805 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
7807 char buf[TYPE_CHARS(UV)];
7809 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7811 sv_setpvn(sv, ptr, ebuf - ptr);
7815 =for apidoc sv_setpviv_mg
7817 Like C<sv_setpviv>, but also handles 'set' magic.
7823 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
7829 #if defined(PERL_IMPLICIT_CONTEXT)
7831 /* pTHX_ magic can't cope with varargs, so this is a no-context
7832 * version of the main function, (which may itself be aliased to us).
7833 * Don't access this version directly.
7837 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
7841 va_start(args, pat);
7842 sv_vsetpvf(sv, pat, &args);
7846 /* pTHX_ magic can't cope with varargs, so this is a no-context
7847 * version of the main function, (which may itself be aliased to us).
7848 * Don't access this version directly.
7852 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
7856 va_start(args, pat);
7857 sv_vsetpvf_mg(sv, pat, &args);
7863 =for apidoc sv_setpvf
7865 Works like C<sv_catpvf> but copies the text into the SV instead of
7866 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
7872 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
7875 va_start(args, pat);
7876 sv_vsetpvf(sv, pat, &args);
7881 =for apidoc sv_vsetpvf
7883 Works like C<sv_vcatpvf> but copies the text into the SV instead of
7884 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
7886 Usually used via its frontend C<sv_setpvf>.
7892 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7894 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7898 =for apidoc sv_setpvf_mg
7900 Like C<sv_setpvf>, but also handles 'set' magic.
7906 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7909 va_start(args, pat);
7910 sv_vsetpvf_mg(sv, pat, &args);
7915 =for apidoc sv_vsetpvf_mg
7917 Like C<sv_vsetpvf>, but also handles 'set' magic.
7919 Usually used via its frontend C<sv_setpvf_mg>.
7925 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7927 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7931 #if defined(PERL_IMPLICIT_CONTEXT)
7933 /* pTHX_ magic can't cope with varargs, so this is a no-context
7934 * version of the main function, (which may itself be aliased to us).
7935 * Don't access this version directly.
7939 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
7943 va_start(args, pat);
7944 sv_vcatpvf(sv, pat, &args);
7948 /* pTHX_ magic can't cope with varargs, so this is a no-context
7949 * version of the main function, (which may itself be aliased to us).
7950 * Don't access this version directly.
7954 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
7958 va_start(args, pat);
7959 sv_vcatpvf_mg(sv, pat, &args);
7965 =for apidoc sv_catpvf
7967 Processes its arguments like C<sprintf> and appends the formatted
7968 output to an SV. If the appended data contains "wide" characters
7969 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
7970 and characters >255 formatted with %c), the original SV might get
7971 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
7972 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
7973 valid UTF-8; if the original SV was bytes, the pattern should be too.
7978 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
7981 va_start(args, pat);
7982 sv_vcatpvf(sv, pat, &args);
7987 =for apidoc sv_vcatpvf
7989 Processes its arguments like C<vsprintf> and appends the formatted output
7990 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
7992 Usually used via its frontend C<sv_catpvf>.
7998 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8000 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8004 =for apidoc sv_catpvf_mg
8006 Like C<sv_catpvf>, but also handles 'set' magic.
8012 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8015 va_start(args, pat);
8016 sv_vcatpvf_mg(sv, pat, &args);
8021 =for apidoc sv_vcatpvf_mg
8023 Like C<sv_vcatpvf>, but also handles 'set' magic.
8025 Usually used via its frontend C<sv_catpvf_mg>.
8031 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8033 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8038 =for apidoc sv_vsetpvfn
8040 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
8043 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
8049 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8051 sv_setpvn(sv, "", 0);
8052 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8056 S_expect_number(pTHX_ char** pattern)
8060 switch (**pattern) {
8061 case '1': case '2': case '3':
8062 case '4': case '5': case '6':
8063 case '7': case '8': case '9':
8064 var = *(*pattern)++ - '0';
8065 while (isDIGIT(**pattern)) {
8066 const I32 tmp = var * 10 + (*(*pattern)++ - '0');
8068 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn"));
8076 S_F0convert(NV nv, char *endbuf, STRLEN *len)
8078 const int neg = nv < 0;
8087 if (uv & 1 && uv == nv)
8088 uv--; /* Round to even */
8090 const unsigned dig = uv % 10;
8103 =for apidoc sv_vcatpvfn
8105 Processes its arguments like C<vsprintf> and appends the formatted output
8106 to an SV. Uses an array of SVs if the C style variable argument list is
8107 missing (NULL). When running with taint checks enabled, indicates via
8108 C<maybe_tainted> if results are untrustworthy (often due to the use of
8111 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
8117 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
8118 vecstr = (U8*)SvPV_const(vecsv,veclen);\
8119 vec_utf8 = DO_UTF8(vecsv);
8121 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
8124 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8132 static const char nullstr[] = "(null)";
8134 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
8135 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
8137 /* Times 4: a decimal digit takes more than 3 binary digits.
8138 * NV_DIG: mantissa takes than many decimal digits.
8139 * Plus 32: Playing safe. */
8140 char ebuf[IV_DIG * 4 + NV_DIG + 32];
8141 /* large enough for "%#.#f" --chip */
8142 /* what about long double NVs? --jhi */
8144 PERL_UNUSED_ARG(maybe_tainted);
8146 /* no matter what, this is a string now */
8147 (void)SvPV_force(sv, origlen);
8149 /* special-case "", "%s", and "%-p" (SVf - see below) */
8152 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
8154 const char * const s = va_arg(*args, char*);
8155 sv_catpv(sv, s ? s : nullstr);
8157 else if (svix < svmax) {
8158 sv_catsv(sv, *svargs);
8162 if (args && patlen == 3 && pat[0] == '%' &&
8163 pat[1] == '-' && pat[2] == 'p') {
8164 argsv = va_arg(*args, SV*);
8165 sv_catsv(sv, argsv);
8169 #ifndef USE_LONG_DOUBLE
8170 /* special-case "%.<number>[gf]" */
8171 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
8172 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
8173 unsigned digits = 0;
8177 while (*pp >= '0' && *pp <= '9')
8178 digits = 10 * digits + (*pp++ - '0');
8179 if (pp - pat == (int)patlen - 1) {
8187 /* Add check for digits != 0 because it seems that some
8188 gconverts are buggy in this case, and we don't yet have
8189 a Configure test for this. */
8190 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
8191 /* 0, point, slack */
8192 Gconvert(nv, (int)digits, 0, ebuf);
8194 if (*ebuf) /* May return an empty string for digits==0 */
8197 } else if (!digits) {
8200 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
8201 sv_catpvn(sv, p, l);
8207 #endif /* !USE_LONG_DOUBLE */
8209 if (!args && svix < svmax && DO_UTF8(*svargs))
8212 patend = (char*)pat + patlen;
8213 for (p = (char*)pat; p < patend; p = q) {
8216 bool vectorize = FALSE;
8217 bool vectorarg = FALSE;
8218 bool vec_utf8 = FALSE;
8224 bool has_precis = FALSE;
8226 const I32 osvix = svix;
8227 bool is_utf8 = FALSE; /* is this item utf8? */
8228 #ifdef HAS_LDBL_SPRINTF_BUG
8229 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8230 with sfio - Allen <allens@cpan.org> */
8231 bool fix_ldbl_sprintf_bug = FALSE;
8235 U8 utf8buf[UTF8_MAXBYTES+1];
8236 STRLEN esignlen = 0;
8238 const char *eptr = NULL;
8241 const U8 *vecstr = NULL;
8248 /* we need a long double target in case HAS_LONG_DOUBLE but
8251 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
8259 const char *dotstr = ".";
8260 STRLEN dotstrlen = 1;
8261 I32 efix = 0; /* explicit format parameter index */
8262 I32 ewix = 0; /* explicit width index */
8263 I32 epix = 0; /* explicit precision index */
8264 I32 evix = 0; /* explicit vector index */
8265 bool asterisk = FALSE;
8267 /* echo everything up to the next format specification */
8268 for (q = p; q < patend && *q != '%'; ++q) ;
8270 if (has_utf8 && !pat_utf8)
8271 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
8273 sv_catpvn(sv, p, q - p);
8280 We allow format specification elements in this order:
8281 \d+\$ explicit format parameter index
8283 v|\*(\d+\$)?v vector with optional (optionally specified) arg
8284 0 flag (as above): repeated to allow "v02"
8285 \d+|\*(\d+\$)? width using optional (optionally specified) arg
8286 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8288 [%bcdefginopsuxDFOUX] format (mandatory)
8293 As of perl5.9.3, printf format checking is on by default.
8294 Internally, perl uses %p formats to provide an escape to
8295 some extended formatting. This block deals with those
8296 extensions: if it does not match, (char*)q is reset and
8297 the normal format processing code is used.
8299 Currently defined extensions are:
8300 %p include pointer address (standard)
8301 %-p (SVf) include an SV (previously %_)
8302 %-<num>p include an SV with precision <num>
8303 %1p (VDf) include a v-string (as %vd)
8304 %<num>p reserved for future extensions
8306 Robin Barker 2005-07-14
8313 n = expect_number(&q);
8320 argsv = va_arg(*args, SV*);
8321 eptr = SvPVx_const(argsv, elen);
8327 else if (n == vdNUMBER) { /* VDf */
8334 if (ckWARN_d(WARN_INTERNAL))
8335 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
8336 "internal %%<num>p might conflict with future printf extensions");
8342 if ( (width = expect_number(&q)) ) {
8383 if ( (ewix = expect_number(&q)) )
8392 if ((vectorarg = asterisk)) {
8405 width = expect_number(&q);
8411 vecsv = va_arg(*args, SV*);
8413 vecsv = (evix > 0 && evix <= svmax)
8414 ? svargs[evix-1] : &PL_sv_undef;
8416 vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef;
8418 dotstr = SvPV_const(vecsv, dotstrlen);
8419 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
8420 bad with tied or overloaded values that return UTF8. */
8423 else if (has_utf8) {
8424 vecsv = sv_mortalcopy(vecsv);
8425 sv_utf8_upgrade(vecsv);
8426 dotstr = SvPV_const(vecsv, dotstrlen);
8433 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
8434 vecsv = svargs[efix ? efix-1 : svix++];
8435 vecstr = (U8*)SvPV_const(vecsv,veclen);
8436 vec_utf8 = DO_UTF8(vecsv);
8438 /* if this is a version object, we need to convert
8439 * back into v-string notation and then let the
8440 * vectorize happen normally
8442 if (sv_derived_from(vecsv, "version")) {
8443 char *version = savesvpv(vecsv);
8444 if ( hv_exists((HV*)SvRV(vecsv), "alpha", 5 ) ) {
8445 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
8446 "vector argument not supported with alpha versions");
8449 vecsv = sv_newmortal();
8450 /* scan_vstring is expected to be called during
8451 * tokenization, so we need to fake up the end
8452 * of the buffer for it
8454 PL_bufend = version + veclen;
8455 scan_vstring(version, vecsv);
8456 vecstr = (U8*)SvPV_const(vecsv, veclen);
8457 vec_utf8 = DO_UTF8(vecsv);
8469 i = va_arg(*args, int);
8471 i = (ewix ? ewix <= svmax : svix < svmax) ?
8472 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8474 width = (i < 0) ? -i : i;
8484 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
8486 /* XXX: todo, support specified precision parameter */
8490 i = va_arg(*args, int);
8492 i = (ewix ? ewix <= svmax : svix < svmax)
8493 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8494 precis = (i < 0) ? 0 : i;
8499 precis = precis * 10 + (*q++ - '0');
8508 case 'I': /* Ix, I32x, and I64x */
8510 if (q[1] == '6' && q[2] == '4') {
8516 if (q[1] == '3' && q[2] == '2') {
8526 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8537 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8538 if (*(q + 1) == 'l') { /* lld, llf */
8564 if (!vectorize && !args) {
8566 const I32 i = efix-1;
8567 argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef;
8569 argsv = (svix >= 0 && svix < svmax)
8570 ? svargs[svix++] : &PL_sv_undef;
8581 uv = (args) ? va_arg(*args, int) : SvIVx(argsv);
8583 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
8585 eptr = (char*)utf8buf;
8586 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
8600 eptr = va_arg(*args, char*);
8602 #ifdef MACOS_TRADITIONAL
8603 /* On MacOS, %#s format is used for Pascal strings */
8608 elen = strlen(eptr);
8610 eptr = (char *)nullstr;
8611 elen = sizeof nullstr - 1;
8615 eptr = SvPVx_const(argsv, elen);
8616 if (DO_UTF8(argsv)) {
8617 if (has_precis && precis < elen) {
8619 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
8622 if (width) { /* fudge width (can't fudge elen) */
8623 width += elen - sv_len_utf8(argsv);
8630 if (has_precis && elen > precis)
8637 if (alt || vectorize)
8639 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
8660 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8669 esignbuf[esignlen++] = plus;
8673 case 'h': iv = (short)va_arg(*args, int); break;
8674 case 'l': iv = va_arg(*args, long); break;
8675 case 'V': iv = va_arg(*args, IV); break;
8676 default: iv = va_arg(*args, int); break;
8678 case 'q': iv = va_arg(*args, Quad_t); break;
8683 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
8685 case 'h': iv = (short)tiv; break;
8686 case 'l': iv = (long)tiv; break;
8688 default: iv = tiv; break;
8690 case 'q': iv = (Quad_t)tiv; break;
8694 if ( !vectorize ) /* we already set uv above */
8699 esignbuf[esignlen++] = plus;
8703 esignbuf[esignlen++] = '-';
8746 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8757 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
8758 case 'l': uv = va_arg(*args, unsigned long); break;
8759 case 'V': uv = va_arg(*args, UV); break;
8760 default: uv = va_arg(*args, unsigned); break;
8762 case 'q': uv = va_arg(*args, Uquad_t); break;
8767 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
8769 case 'h': uv = (unsigned short)tuv; break;
8770 case 'l': uv = (unsigned long)tuv; break;
8772 default: uv = tuv; break;
8774 case 'q': uv = (Uquad_t)tuv; break;
8781 char *ptr = ebuf + sizeof ebuf;
8787 p = (char*)((c == 'X')
8788 ? "0123456789ABCDEF" : "0123456789abcdef");
8794 esignbuf[esignlen++] = '0';
8795 esignbuf[esignlen++] = c; /* 'x' or 'X' */
8803 if (alt && *ptr != '0')
8814 esignbuf[esignlen++] = '0';
8815 esignbuf[esignlen++] = 'b';
8818 default: /* it had better be ten or less */
8822 } while (uv /= base);
8825 elen = (ebuf + sizeof ebuf) - ptr;
8829 zeros = precis - elen;
8830 else if (precis == 0 && elen == 1 && *eptr == '0')
8836 /* FLOATING POINT */
8839 c = 'f'; /* maybe %F isn't supported here */
8847 /* This is evil, but floating point is even more evil */
8849 /* for SV-style calling, we can only get NV
8850 for C-style calling, we assume %f is double;
8851 for simplicity we allow any of %Lf, %llf, %qf for long double
8855 #if defined(USE_LONG_DOUBLE)
8859 /* [perl #20339] - we should accept and ignore %lf rather than die */
8863 #if defined(USE_LONG_DOUBLE)
8864 intsize = args ? 0 : 'q';
8868 #if defined(HAS_LONG_DOUBLE)
8877 /* now we need (long double) if intsize == 'q', else (double) */
8879 #if LONG_DOUBLESIZE > DOUBLESIZE
8881 va_arg(*args, long double) :
8882 va_arg(*args, double)
8884 va_arg(*args, double)
8889 if (c != 'e' && c != 'E') {
8891 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
8892 will cast our (long double) to (double) */
8893 (void)Perl_frexp(nv, &i);
8894 if (i == PERL_INT_MIN)
8895 Perl_die(aTHX_ "panic: frexp");
8897 need = BIT_DIGITS(i);
8899 need += has_precis ? precis : 6; /* known default */
8904 #ifdef HAS_LDBL_SPRINTF_BUG
8905 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8906 with sfio - Allen <allens@cpan.org> */
8909 # define MY_DBL_MAX DBL_MAX
8910 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
8911 # if DOUBLESIZE >= 8
8912 # define MY_DBL_MAX 1.7976931348623157E+308L
8914 # define MY_DBL_MAX 3.40282347E+38L
8918 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
8919 # define MY_DBL_MAX_BUG 1L
8921 # define MY_DBL_MAX_BUG MY_DBL_MAX
8925 # define MY_DBL_MIN DBL_MIN
8926 # else /* XXX guessing! -Allen */
8927 # if DOUBLESIZE >= 8
8928 # define MY_DBL_MIN 2.2250738585072014E-308L
8930 # define MY_DBL_MIN 1.17549435E-38L
8934 if ((intsize == 'q') && (c == 'f') &&
8935 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
8937 /* it's going to be short enough that
8938 * long double precision is not needed */
8940 if ((nv <= 0L) && (nv >= -0L))
8941 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
8943 /* would use Perl_fp_class as a double-check but not
8944 * functional on IRIX - see perl.h comments */
8946 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
8947 /* It's within the range that a double can represent */
8948 #if defined(DBL_MAX) && !defined(DBL_MIN)
8949 if ((nv >= ((long double)1/DBL_MAX)) ||
8950 (nv <= (-(long double)1/DBL_MAX)))
8952 fix_ldbl_sprintf_bug = TRUE;
8955 if (fix_ldbl_sprintf_bug == TRUE) {
8965 # undef MY_DBL_MAX_BUG
8968 #endif /* HAS_LDBL_SPRINTF_BUG */
8970 need += 20; /* fudge factor */
8971 if (PL_efloatsize < need) {
8972 Safefree(PL_efloatbuf);
8973 PL_efloatsize = need + 20; /* more fudge */
8974 Newx(PL_efloatbuf, PL_efloatsize, char);
8975 PL_efloatbuf[0] = '\0';
8978 if ( !(width || left || plus || alt) && fill != '0'
8979 && has_precis && intsize != 'q' ) { /* Shortcuts */
8980 /* See earlier comment about buggy Gconvert when digits,
8982 if ( c == 'g' && precis) {
8983 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
8984 /* May return an empty string for digits==0 */
8985 if (*PL_efloatbuf) {
8986 elen = strlen(PL_efloatbuf);
8987 goto float_converted;
8989 } else if ( c == 'f' && !precis) {
8990 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
8995 char *ptr = ebuf + sizeof ebuf;
8998 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
8999 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9000 if (intsize == 'q') {
9001 /* Copy the one or more characters in a long double
9002 * format before the 'base' ([efgEFG]) character to
9003 * the format string. */
9004 static char const prifldbl[] = PERL_PRIfldbl;
9005 char const *p = prifldbl + sizeof(prifldbl) - 3;
9006 while (p >= prifldbl) { *--ptr = *p--; }
9011 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9016 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9028 /* No taint. Otherwise we are in the strange situation
9029 * where printf() taints but print($float) doesn't.
9031 #if defined(HAS_LONG_DOUBLE)
9032 elen = ((intsize == 'q')
9033 ? my_sprintf(PL_efloatbuf, ptr, nv)
9034 : my_sprintf(PL_efloatbuf, ptr, (double)nv));
9036 elen = my_sprintf(PL_efloatbuf, ptr, nv);
9040 eptr = PL_efloatbuf;
9048 i = SvCUR(sv) - origlen;
9051 case 'h': *(va_arg(*args, short*)) = i; break;
9052 default: *(va_arg(*args, int*)) = i; break;
9053 case 'l': *(va_arg(*args, long*)) = i; break;
9054 case 'V': *(va_arg(*args, IV*)) = i; break;
9056 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
9061 sv_setuv_mg(argsv, (UV)i);
9062 continue; /* not "break" */
9069 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
9070 && ckWARN(WARN_PRINTF))
9072 SV * const msg = sv_newmortal();
9073 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9074 (PL_op->op_type == OP_PRTF) ? "" : "s");
9077 Perl_sv_catpvf(aTHX_ msg,
9078 "\"%%%c\"", c & 0xFF);
9080 Perl_sv_catpvf(aTHX_ msg,
9081 "\"%%\\%03"UVof"\"",
9084 sv_catpvs(msg, "end of string");
9085 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
9088 /* output mangled stuff ... */
9094 /* ... right here, because formatting flags should not apply */
9095 SvGROW(sv, SvCUR(sv) + elen + 1);
9097 Copy(eptr, p, elen, char);
9100 SvCUR_set(sv, p - SvPVX_const(sv));
9102 continue; /* not "break" */
9105 /* calculate width before utf8_upgrade changes it */
9106 have = esignlen + zeros + elen;
9108 Perl_croak_nocontext(PL_memory_wrap);
9110 if (is_utf8 != has_utf8) {
9113 sv_utf8_upgrade(sv);
9116 SV * const nsv = sv_2mortal(newSVpvn(eptr, elen));
9117 sv_utf8_upgrade(nsv);
9118 eptr = SvPVX_const(nsv);
9121 SvGROW(sv, SvCUR(sv) + elen + 1);
9126 need = (have > width ? have : width);
9129 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
9130 Perl_croak_nocontext(PL_memory_wrap);
9131 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
9133 if (esignlen && fill == '0') {
9135 for (i = 0; i < (int)esignlen; i++)
9139 memset(p, fill, gap);
9142 if (esignlen && fill != '0') {
9144 for (i = 0; i < (int)esignlen; i++)
9149 for (i = zeros; i; i--)
9153 Copy(eptr, p, elen, char);
9157 memset(p, ' ', gap);
9162 Copy(dotstr, p, dotstrlen, char);
9166 vectorize = FALSE; /* done iterating over vecstr */
9173 SvCUR_set(sv, p - SvPVX_const(sv));
9181 /* =========================================================================
9183 =head1 Cloning an interpreter
9185 All the macros and functions in this section are for the private use of
9186 the main function, perl_clone().
9188 The foo_dup() functions make an exact copy of an existing foo thinngy.
9189 During the course of a cloning, a hash table is used to map old addresses
9190 to new addresses. The table is created and manipulated with the
9191 ptr_table_* functions.
9195 ============================================================================*/
9198 #if defined(USE_ITHREADS)
9200 #ifndef GpREFCNT_inc
9201 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
9205 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
9206 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
9207 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9208 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
9209 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9210 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
9211 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9212 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
9213 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
9214 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
9215 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9216 #define SAVEPV(p) ((p) ? savepv(p) : NULL)
9217 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
9220 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
9221 regcomp.c. AMS 20010712 */
9224 Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
9229 struct reg_substr_datum *s;
9232 return (REGEXP *)NULL;
9234 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
9237 len = r->offsets[0];
9238 npar = r->nparens+1;
9240 Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
9241 Copy(r->program, ret->program, len+1, regnode);
9243 Newx(ret->startp, npar, I32);
9244 Copy(r->startp, ret->startp, npar, I32);
9245 Newx(ret->endp, npar, I32);
9246 Copy(r->startp, ret->startp, npar, I32);
9248 Newx(ret->substrs, 1, struct reg_substr_data);
9249 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
9250 s->min_offset = r->substrs->data[i].min_offset;
9251 s->max_offset = r->substrs->data[i].max_offset;
9252 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
9253 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
9256 ret->regstclass = NULL;
9259 const int count = r->data->count;
9262 Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
9263 char, struct reg_data);
9264 Newx(d->what, count, U8);
9267 for (i = 0; i < count; i++) {
9268 d->what[i] = r->data->what[i];
9269 switch (d->what[i]) {
9270 /* legal options are one of: sfpont
9271 see also regcomp.h and pregfree() */
9273 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
9276 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
9279 /* This is cheating. */
9280 Newx(d->data[i], 1, struct regnode_charclass_class);
9281 StructCopy(r->data->data[i], d->data[i],
9282 struct regnode_charclass_class);
9283 ret->regstclass = (regnode*)d->data[i];
9286 /* Compiled op trees are readonly, and can thus be
9287 shared without duplication. */
9289 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
9293 d->data[i] = r->data->data[i];
9296 d->data[i] = r->data->data[i];
9298 ((reg_trie_data*)d->data[i])->refcount++;
9302 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
9311 Newx(ret->offsets, 2*len+1, U32);
9312 Copy(r->offsets, ret->offsets, 2*len+1, U32);
9314 ret->precomp = SAVEPVN(r->precomp, r->prelen);
9315 ret->refcnt = r->refcnt;
9316 ret->minlen = r->minlen;
9317 ret->prelen = r->prelen;
9318 ret->nparens = r->nparens;
9319 ret->lastparen = r->lastparen;
9320 ret->lastcloseparen = r->lastcloseparen;
9321 ret->reganch = r->reganch;
9323 ret->sublen = r->sublen;
9325 if (RX_MATCH_COPIED(ret))
9326 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
9329 #ifdef PERL_OLD_COPY_ON_WRITE
9330 ret->saved_copy = NULL;
9333 ptr_table_store(PL_ptr_table, r, ret);
9337 /* duplicate a file handle */
9340 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
9344 PERL_UNUSED_ARG(type);
9347 return (PerlIO*)NULL;
9349 /* look for it in the table first */
9350 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
9354 /* create anew and remember what it is */
9355 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
9356 ptr_table_store(PL_ptr_table, fp, ret);
9360 /* duplicate a directory handle */
9363 Perl_dirp_dup(pTHX_ DIR *dp)
9365 PERL_UNUSED_CONTEXT;
9372 /* duplicate a typeglob */
9375 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
9381 /* look for it in the table first */
9382 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
9386 /* create anew and remember what it is */
9388 ptr_table_store(PL_ptr_table, gp, ret);
9391 ret->gp_refcnt = 0; /* must be before any other dups! */
9392 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
9393 ret->gp_io = io_dup_inc(gp->gp_io, param);
9394 ret->gp_form = cv_dup_inc(gp->gp_form, param);
9395 ret->gp_av = av_dup_inc(gp->gp_av, param);
9396 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
9397 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
9398 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
9399 ret->gp_cvgen = gp->gp_cvgen;
9400 ret->gp_line = gp->gp_line;
9401 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
9405 /* duplicate a chain of magic */
9408 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
9410 MAGIC *mgprev = (MAGIC*)NULL;
9413 return (MAGIC*)NULL;
9414 /* look for it in the table first */
9415 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
9419 for (; mg; mg = mg->mg_moremagic) {
9421 Newxz(nmg, 1, MAGIC);
9423 mgprev->mg_moremagic = nmg;
9426 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
9427 nmg->mg_private = mg->mg_private;
9428 nmg->mg_type = mg->mg_type;
9429 nmg->mg_flags = mg->mg_flags;
9430 if (mg->mg_type == PERL_MAGIC_qr) {
9431 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
9433 else if(mg->mg_type == PERL_MAGIC_backref) {
9434 /* The backref AV has its reference count deliberately bumped by
9436 nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param));
9438 else if (mg->mg_type == PERL_MAGIC_symtab) {
9439 nmg->mg_obj = mg->mg_obj;
9442 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
9443 ? sv_dup_inc(mg->mg_obj, param)
9444 : sv_dup(mg->mg_obj, param);
9446 nmg->mg_len = mg->mg_len;
9447 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
9448 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
9449 if (mg->mg_len > 0) {
9450 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
9451 if (mg->mg_type == PERL_MAGIC_overload_table &&
9452 AMT_AMAGIC((AMT*)mg->mg_ptr))
9454 const AMT * const amtp = (AMT*)mg->mg_ptr;
9455 AMT * const namtp = (AMT*)nmg->mg_ptr;
9457 for (i = 1; i < NofAMmeth; i++) {
9458 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
9462 else if (mg->mg_len == HEf_SVKEY)
9463 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
9465 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
9466 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
9473 /* create a new pointer-mapping table */
9476 Perl_ptr_table_new(pTHX)
9479 PERL_UNUSED_CONTEXT;
9481 Newxz(tbl, 1, PTR_TBL_t);
9484 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
9488 #define PTR_TABLE_HASH(ptr) \
9489 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
9492 we use the PTE_SVSLOT 'reservation' made above, both here (in the
9493 following define) and at call to new_body_inline made below in
9494 Perl_ptr_table_store()
9497 #define del_pte(p) del_body_type(p, PTE_SVSLOT)
9499 /* map an existing pointer using a table */
9501 STATIC PTR_TBL_ENT_t *
9502 S_ptr_table_find(PTR_TBL_t *tbl, const void *sv) {
9503 PTR_TBL_ENT_t *tblent;
9504 const UV hash = PTR_TABLE_HASH(sv);
9506 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
9507 for (; tblent; tblent = tblent->next) {
9508 if (tblent->oldval == sv)
9515 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
9517 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
9518 PERL_UNUSED_CONTEXT;
9519 return tblent ? tblent->newval : (void *) 0;
9522 /* add a new entry to a pointer-mapping table */
9525 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
9527 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
9528 PERL_UNUSED_CONTEXT;
9531 tblent->newval = newsv;
9533 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
9535 new_body_inline(tblent, PTE_SVSLOT);
9537 tblent->oldval = oldsv;
9538 tblent->newval = newsv;
9539 tblent->next = tbl->tbl_ary[entry];
9540 tbl->tbl_ary[entry] = tblent;
9542 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
9543 ptr_table_split(tbl);
9547 /* double the hash bucket size of an existing ptr table */
9550 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
9552 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
9553 const UV oldsize = tbl->tbl_max + 1;
9554 UV newsize = oldsize * 2;
9556 PERL_UNUSED_CONTEXT;
9558 Renew(ary, newsize, PTR_TBL_ENT_t*);
9559 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
9560 tbl->tbl_max = --newsize;
9562 for (i=0; i < oldsize; i++, ary++) {
9563 PTR_TBL_ENT_t **curentp, **entp, *ent;
9566 curentp = ary + oldsize;
9567 for (entp = ary, ent = *ary; ent; ent = *entp) {
9568 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
9570 ent->next = *curentp;
9580 /* remove all the entries from a ptr table */
9583 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
9585 if (tbl && tbl->tbl_items) {
9586 register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary;
9587 UV riter = tbl->tbl_max;
9590 PTR_TBL_ENT_t *entry = array[riter];
9593 PTR_TBL_ENT_t * const oentry = entry;
9594 entry = entry->next;
9603 /* clear and free a ptr table */
9606 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
9611 ptr_table_clear(tbl);
9612 Safefree(tbl->tbl_ary);
9618 Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param)
9621 SvRV_set(dstr, SvWEAKREF(sstr)
9622 ? sv_dup(SvRV(sstr), param)
9623 : sv_dup_inc(SvRV(sstr), param));
9626 else if (SvPVX_const(sstr)) {
9627 /* Has something there */
9629 /* Normal PV - clone whole allocated space */
9630 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
9631 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9632 /* Not that normal - actually sstr is copy on write.
9633 But we are a true, independant SV, so: */
9634 SvREADONLY_off(dstr);
9639 /* Special case - not normally malloced for some reason */
9640 if (isGV_with_GP(sstr)) {
9641 /* Don't need to do anything here. */
9643 else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
9644 /* A "shared" PV - clone it as "shared" PV */
9646 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
9650 /* Some other special case - random pointer */
9651 SvPV_set(dstr, SvPVX(sstr));
9657 if (SvTYPE(dstr) == SVt_RV)
9658 SvRV_set(dstr, NULL);
9660 SvPV_set(dstr, NULL);
9664 /* duplicate an SV of any type (including AV, HV etc) */
9667 Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
9672 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
9674 /* look for it in the table first */
9675 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
9679 if(param->flags & CLONEf_JOIN_IN) {
9680 /** We are joining here so we don't want do clone
9681 something that is bad **/
9682 if (SvTYPE(sstr) == SVt_PVHV) {
9683 const char * const hvname = HvNAME_get(sstr);
9685 /** don't clone stashes if they already exist **/
9686 return (SV*)gv_stashpv(hvname,0);
9690 /* create anew and remember what it is */
9693 #ifdef DEBUG_LEAKING_SCALARS
9694 dstr->sv_debug_optype = sstr->sv_debug_optype;
9695 dstr->sv_debug_line = sstr->sv_debug_line;
9696 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
9697 dstr->sv_debug_cloned = 1;
9698 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
9701 ptr_table_store(PL_ptr_table, sstr, dstr);
9704 SvFLAGS(dstr) = SvFLAGS(sstr);
9705 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
9706 SvREFCNT(dstr) = 0; /* must be before any other dups! */
9709 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
9710 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
9711 PL_watch_pvx, SvPVX_const(sstr));
9714 /* don't clone objects whose class has asked us not to */
9715 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
9716 SvFLAGS(dstr) &= ~SVTYPEMASK;
9721 switch (SvTYPE(sstr)) {
9726 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
9727 SvIV_set(dstr, SvIVX(sstr));
9730 SvANY(dstr) = new_XNV();
9731 SvNV_set(dstr, SvNVX(sstr));
9734 SvANY(dstr) = &(dstr->sv_u.svu_rv);
9735 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9739 /* These are all the types that need complex bodies allocating. */
9741 const svtype sv_type = SvTYPE(sstr);
9742 const struct body_details *const sv_type_details
9743 = bodies_by_type + sv_type;
9747 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
9751 if (GvUNIQUE((GV*)sstr)) {
9752 /*EMPTY*/; /* Do sharing here, and fall through */
9765 assert(sv_type_details->body_size);
9766 if (sv_type_details->arena) {
9767 new_body_inline(new_body, sv_type);
9769 = (void*)((char*)new_body - sv_type_details->offset);
9771 new_body = new_NOARENA(sv_type_details);
9775 SvANY(dstr) = new_body;
9778 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
9779 ((char*)SvANY(dstr)) + sv_type_details->offset,
9780 sv_type_details->copy, char);
9782 Copy(((char*)SvANY(sstr)),
9783 ((char*)SvANY(dstr)),
9784 sv_type_details->body_size + sv_type_details->offset, char);
9787 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
9788 && !isGV_with_GP(dstr))
9789 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9791 /* The Copy above means that all the source (unduplicated) pointers
9792 are now in the destination. We can check the flags and the
9793 pointers in either, but it's possible that there's less cache
9794 missing by always going for the destination.
9795 FIXME - instrument and check that assumption */
9796 if (sv_type >= SVt_PVMG) {
9798 if ((sv_type == SVt_PVMG) && (ourstash = OURSTASH(dstr))) {
9799 OURSTASH_set(dstr, hv_dup_inc(ourstash, param));
9800 } else if (SvMAGIC(dstr))
9801 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
9803 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
9806 /* The cast silences a GCC warning about unhandled types. */
9807 switch ((int)sv_type) {
9819 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
9820 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
9821 LvTARG(dstr) = dstr;
9822 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
9823 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
9825 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
9828 GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr));
9829 /* Don't call sv_add_backref here as it's going to be created
9830 as part of the magic cloning of the symbol table. */
9831 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
9832 if(isGV_with_GP(sstr)) {
9833 /* Danger Will Robinson - GvGP(dstr) isn't initialised
9834 at the point of this comment. */
9835 GvGP(dstr) = gp_dup(GvGP(sstr), param);
9836 (void)GpREFCNT_inc(GvGP(dstr));
9838 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9841 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
9842 if (IoOFP(dstr) == IoIFP(sstr))
9843 IoOFP(dstr) = IoIFP(dstr);
9845 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
9846 /* PL_rsfp_filters entries have fake IoDIRP() */
9847 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
9848 /* I have no idea why fake dirp (rsfps)
9849 should be treated differently but otherwise
9850 we end up with leaks -- sky*/
9851 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
9852 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
9853 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
9855 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
9856 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
9857 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
9859 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
9862 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
9865 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
9866 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
9867 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
9870 if (AvARRAY((AV*)sstr)) {
9871 SV **dst_ary, **src_ary;
9872 SSize_t items = AvFILLp((AV*)sstr) + 1;
9874 src_ary = AvARRAY((AV*)sstr);
9875 Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*);
9876 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
9877 SvPV_set(dstr, (char*)dst_ary);
9878 AvALLOC((AV*)dstr) = dst_ary;
9879 if (AvREAL((AV*)sstr)) {
9881 *dst_ary++ = sv_dup_inc(*src_ary++, param);
9885 *dst_ary++ = sv_dup(*src_ary++, param);
9887 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
9888 while (items-- > 0) {
9889 *dst_ary++ = &PL_sv_undef;
9893 SvPV_set(dstr, NULL);
9894 AvALLOC((AV*)dstr) = (SV**)NULL;
9901 if (HvARRAY((HV*)sstr)) {
9903 const bool sharekeys = !!HvSHAREKEYS(sstr);
9904 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
9905 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
9907 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
9908 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
9910 HvARRAY(dstr) = (HE**)darray;
9911 while (i <= sxhv->xhv_max) {
9912 const HE *source = HvARRAY(sstr)[i];
9913 HvARRAY(dstr)[i] = source
9914 ? he_dup(source, sharekeys, param) : 0;
9918 struct xpvhv_aux * const saux = HvAUX(sstr);
9919 struct xpvhv_aux * const daux = HvAUX(dstr);
9920 /* This flag isn't copied. */
9921 /* SvOOK_on(hv) attacks the IV flags. */
9922 SvFLAGS(dstr) |= SVf_OOK;
9924 hvname = saux->xhv_name;
9926 = hvname ? hek_dup(hvname, param) : hvname;
9928 daux->xhv_riter = saux->xhv_riter;
9929 daux->xhv_eiter = saux->xhv_eiter
9930 ? he_dup(saux->xhv_eiter,
9931 (bool)!!HvSHAREKEYS(sstr), param) : 0;
9932 daux->xhv_backreferences = saux->xhv_backreferences
9933 ? (AV*) SvREFCNT_inc(
9941 SvPV_set(dstr, NULL);
9943 /* Record stashes for possible cloning in Perl_clone(). */
9945 av_push(param->stashes, dstr);
9949 if (!(param->flags & CLONEf_COPY_STACKS)) {
9953 /* NOTE: not refcounted */
9954 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
9956 if (!CvISXSUB(dstr))
9957 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
9959 if (CvCONST(dstr) && CvISXSUB(dstr)) {
9960 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
9961 SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
9962 sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
9964 /* don't dup if copying back - CvGV isn't refcounted, so the
9965 * duped GV may never be freed. A bit of a hack! DAPM */
9966 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
9967 NULL : gv_dup(CvGV(dstr), param) ;
9968 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
9971 ? cv_dup( CvOUTSIDE(dstr), param)
9972 : cv_dup_inc(CvOUTSIDE(dstr), param);
9973 if (!CvISXSUB(dstr))
9974 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
9980 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
9986 /* duplicate a context */
9989 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
9994 return (PERL_CONTEXT*)NULL;
9996 /* look for it in the table first */
9997 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10001 /* create anew and remember what it is */
10002 Newxz(ncxs, max + 1, PERL_CONTEXT);
10003 ptr_table_store(PL_ptr_table, cxs, ncxs);
10006 PERL_CONTEXT * const cx = &cxs[ix];
10007 PERL_CONTEXT * const ncx = &ncxs[ix];
10008 ncx->cx_type = cx->cx_type;
10009 if (CxTYPE(cx) == CXt_SUBST) {
10010 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10013 ncx->blk_oldsp = cx->blk_oldsp;
10014 ncx->blk_oldcop = cx->blk_oldcop;
10015 ncx->blk_oldmarksp = cx->blk_oldmarksp;
10016 ncx->blk_oldscopesp = cx->blk_oldscopesp;
10017 ncx->blk_oldpm = cx->blk_oldpm;
10018 ncx->blk_gimme = cx->blk_gimme;
10019 switch (CxTYPE(cx)) {
10021 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
10022 ? cv_dup_inc(cx->blk_sub.cv, param)
10023 : cv_dup(cx->blk_sub.cv,param));
10024 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
10025 ? av_dup_inc(cx->blk_sub.argarray, param)
10027 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
10028 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
10029 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10030 ncx->blk_sub.lval = cx->blk_sub.lval;
10031 ncx->blk_sub.retop = cx->blk_sub.retop;
10034 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
10035 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
10036 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
10037 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
10038 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
10039 ncx->blk_eval.retop = cx->blk_eval.retop;
10042 ncx->blk_loop.label = cx->blk_loop.label;
10043 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
10044 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
10045 ncx->blk_loop.next_op = cx->blk_loop.next_op;
10046 ncx->blk_loop.last_op = cx->blk_loop.last_op;
10047 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
10048 ? cx->blk_loop.iterdata
10049 : gv_dup((GV*)cx->blk_loop.iterdata, param));
10050 ncx->blk_loop.oldcomppad
10051 = (PAD*)ptr_table_fetch(PL_ptr_table,
10052 cx->blk_loop.oldcomppad);
10053 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
10054 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
10055 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
10056 ncx->blk_loop.iterix = cx->blk_loop.iterix;
10057 ncx->blk_loop.itermax = cx->blk_loop.itermax;
10060 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
10061 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
10062 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
10063 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10064 ncx->blk_sub.retop = cx->blk_sub.retop;
10076 /* duplicate a stack info structure */
10079 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10084 return (PERL_SI*)NULL;
10086 /* look for it in the table first */
10087 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10091 /* create anew and remember what it is */
10092 Newxz(nsi, 1, PERL_SI);
10093 ptr_table_store(PL_ptr_table, si, nsi);
10095 nsi->si_stack = av_dup_inc(si->si_stack, param);
10096 nsi->si_cxix = si->si_cxix;
10097 nsi->si_cxmax = si->si_cxmax;
10098 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
10099 nsi->si_type = si->si_type;
10100 nsi->si_prev = si_dup(si->si_prev, param);
10101 nsi->si_next = si_dup(si->si_next, param);
10102 nsi->si_markoff = si->si_markoff;
10107 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
10108 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
10109 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
10110 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
10111 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
10112 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
10113 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
10114 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
10115 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
10116 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
10117 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
10118 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
10119 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
10120 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
10123 #define pv_dup_inc(p) SAVEPV(p)
10124 #define pv_dup(p) SAVEPV(p)
10125 #define svp_dup_inc(p,pp) any_dup(p,pp)
10127 /* map any object to the new equivent - either something in the
10128 * ptr table, or something in the interpreter structure
10132 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
10137 return (void*)NULL;
10139 /* look for it in the table first */
10140 ret = ptr_table_fetch(PL_ptr_table, v);
10144 /* see if it is part of the interpreter structure */
10145 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
10146 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
10154 /* duplicate the save stack */
10157 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
10159 ANY * const ss = proto_perl->Tsavestack;
10160 const I32 max = proto_perl->Tsavestack_max;
10161 I32 ix = proto_perl->Tsavestack_ix;
10173 void (*dptr) (void*);
10174 void (*dxptr) (pTHX_ void*);
10176 Newxz(nss, max, ANY);
10179 I32 i = POPINT(ss,ix);
10180 TOPINT(nss,ix) = i;
10182 case SAVEt_ITEM: /* normal string */
10183 sv = (SV*)POPPTR(ss,ix);
10184 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10185 sv = (SV*)POPPTR(ss,ix);
10186 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10188 case SAVEt_SV: /* scalar reference */
10189 sv = (SV*)POPPTR(ss,ix);
10190 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10191 gv = (GV*)POPPTR(ss,ix);
10192 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10194 case SAVEt_GENERIC_PVREF: /* generic char* */
10195 c = (char*)POPPTR(ss,ix);
10196 TOPPTR(nss,ix) = pv_dup(c);
10197 ptr = POPPTR(ss,ix);
10198 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10200 case SAVEt_SHARED_PVREF: /* char* in shared space */
10201 c = (char*)POPPTR(ss,ix);
10202 TOPPTR(nss,ix) = savesharedpv(c);
10203 ptr = POPPTR(ss,ix);
10204 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10206 case SAVEt_GENERIC_SVREF: /* generic sv */
10207 case SAVEt_SVREF: /* scalar reference */
10208 sv = (SV*)POPPTR(ss,ix);
10209 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10210 ptr = POPPTR(ss,ix);
10211 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
10213 case SAVEt_AV: /* array reference */
10214 av = (AV*)POPPTR(ss,ix);
10215 TOPPTR(nss,ix) = av_dup_inc(av, param);
10216 gv = (GV*)POPPTR(ss,ix);
10217 TOPPTR(nss,ix) = gv_dup(gv, param);
10219 case SAVEt_HV: /* hash reference */
10220 hv = (HV*)POPPTR(ss,ix);
10221 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10222 gv = (GV*)POPPTR(ss,ix);
10223 TOPPTR(nss,ix) = gv_dup(gv, param);
10225 case SAVEt_INT: /* int reference */
10226 ptr = POPPTR(ss,ix);
10227 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10228 intval = (int)POPINT(ss,ix);
10229 TOPINT(nss,ix) = intval;
10231 case SAVEt_LONG: /* long reference */
10232 ptr = POPPTR(ss,ix);
10233 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10234 longval = (long)POPLONG(ss,ix);
10235 TOPLONG(nss,ix) = longval;
10237 case SAVEt_I32: /* I32 reference */
10238 case SAVEt_I16: /* I16 reference */
10239 case SAVEt_I8: /* I8 reference */
10240 ptr = POPPTR(ss,ix);
10241 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10243 TOPINT(nss,ix) = i;
10245 case SAVEt_IV: /* IV reference */
10246 ptr = POPPTR(ss,ix);
10247 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10249 TOPIV(nss,ix) = iv;
10251 case SAVEt_SPTR: /* SV* reference */
10252 ptr = POPPTR(ss,ix);
10253 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10254 sv = (SV*)POPPTR(ss,ix);
10255 TOPPTR(nss,ix) = sv_dup(sv, param);
10257 case SAVEt_VPTR: /* random* reference */
10258 ptr = POPPTR(ss,ix);
10259 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10260 ptr = POPPTR(ss,ix);
10261 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10263 case SAVEt_PPTR: /* char* reference */
10264 ptr = POPPTR(ss,ix);
10265 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10266 c = (char*)POPPTR(ss,ix);
10267 TOPPTR(nss,ix) = pv_dup(c);
10269 case SAVEt_HPTR: /* HV* reference */
10270 ptr = POPPTR(ss,ix);
10271 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10272 hv = (HV*)POPPTR(ss,ix);
10273 TOPPTR(nss,ix) = hv_dup(hv, param);
10275 case SAVEt_APTR: /* AV* reference */
10276 ptr = POPPTR(ss,ix);
10277 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10278 av = (AV*)POPPTR(ss,ix);
10279 TOPPTR(nss,ix) = av_dup(av, param);
10282 gv = (GV*)POPPTR(ss,ix);
10283 TOPPTR(nss,ix) = gv_dup(gv, param);
10285 case SAVEt_GP: /* scalar reference */
10286 gp = (GP*)POPPTR(ss,ix);
10287 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
10288 (void)GpREFCNT_inc(gp);
10289 gv = (GV*)POPPTR(ss,ix);
10290 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10291 c = (char*)POPPTR(ss,ix);
10292 TOPPTR(nss,ix) = pv_dup(c);
10294 TOPIV(nss,ix) = iv;
10296 TOPIV(nss,ix) = iv;
10299 case SAVEt_MORTALIZESV:
10300 sv = (SV*)POPPTR(ss,ix);
10301 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10304 ptr = POPPTR(ss,ix);
10305 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
10306 /* these are assumed to be refcounted properly */
10308 switch (((OP*)ptr)->op_type) {
10310 case OP_LEAVESUBLV:
10314 case OP_LEAVEWRITE:
10315 TOPPTR(nss,ix) = ptr;
10320 TOPPTR(nss,ix) = NULL;
10325 TOPPTR(nss,ix) = NULL;
10328 c = (char*)POPPTR(ss,ix);
10329 TOPPTR(nss,ix) = pv_dup_inc(c);
10331 case SAVEt_CLEARSV:
10332 longval = POPLONG(ss,ix);
10333 TOPLONG(nss,ix) = longval;
10336 hv = (HV*)POPPTR(ss,ix);
10337 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10338 c = (char*)POPPTR(ss,ix);
10339 TOPPTR(nss,ix) = pv_dup_inc(c);
10341 TOPINT(nss,ix) = i;
10343 case SAVEt_DESTRUCTOR:
10344 ptr = POPPTR(ss,ix);
10345 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10346 dptr = POPDPTR(ss,ix);
10347 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
10348 any_dup(FPTR2DPTR(void *, dptr),
10351 case SAVEt_DESTRUCTOR_X:
10352 ptr = POPPTR(ss,ix);
10353 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10354 dxptr = POPDXPTR(ss,ix);
10355 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
10356 any_dup(FPTR2DPTR(void *, dxptr),
10359 case SAVEt_REGCONTEXT:
10362 TOPINT(nss,ix) = i;
10365 case SAVEt_STACK_POS: /* Position on Perl stack */
10367 TOPINT(nss,ix) = i;
10369 case SAVEt_AELEM: /* array element */
10370 sv = (SV*)POPPTR(ss,ix);
10371 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10373 TOPINT(nss,ix) = i;
10374 av = (AV*)POPPTR(ss,ix);
10375 TOPPTR(nss,ix) = av_dup_inc(av, param);
10377 case SAVEt_HELEM: /* hash element */
10378 sv = (SV*)POPPTR(ss,ix);
10379 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10380 sv = (SV*)POPPTR(ss,ix);
10381 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10382 hv = (HV*)POPPTR(ss,ix);
10383 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10386 ptr = POPPTR(ss,ix);
10387 TOPPTR(nss,ix) = ptr;
10391 TOPINT(nss,ix) = i;
10393 case SAVEt_COMPPAD:
10394 av = (AV*)POPPTR(ss,ix);
10395 TOPPTR(nss,ix) = av_dup(av, param);
10398 longval = (long)POPLONG(ss,ix);
10399 TOPLONG(nss,ix) = longval;
10400 ptr = POPPTR(ss,ix);
10401 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10402 sv = (SV*)POPPTR(ss,ix);
10403 TOPPTR(nss,ix) = sv_dup(sv, param);
10406 ptr = POPPTR(ss,ix);
10407 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10408 longval = (long)POPBOOL(ss,ix);
10409 TOPBOOL(nss,ix) = (bool)longval;
10411 case SAVEt_SET_SVFLAGS:
10413 TOPINT(nss,ix) = i;
10415 TOPINT(nss,ix) = i;
10416 sv = (SV*)POPPTR(ss,ix);
10417 TOPPTR(nss,ix) = sv_dup(sv, param);
10420 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
10428 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
10429 * flag to the result. This is done for each stash before cloning starts,
10430 * so we know which stashes want their objects cloned */
10433 do_mark_cloneable_stash(pTHX_ SV *sv)
10435 const HEK * const hvname = HvNAME_HEK((HV*)sv);
10437 GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
10438 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
10439 if (cloner && GvCV(cloner)) {
10446 XPUSHs(sv_2mortal(newSVhek(hvname)));
10448 call_sv((SV*)GvCV(cloner), G_SCALAR);
10455 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
10463 =for apidoc perl_clone
10465 Create and return a new interpreter by cloning the current one.
10467 perl_clone takes these flags as parameters:
10469 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
10470 without it we only clone the data and zero the stacks,
10471 with it we copy the stacks and the new perl interpreter is
10472 ready to run at the exact same point as the previous one.
10473 The pseudo-fork code uses COPY_STACKS while the
10474 threads->new doesn't.
10476 CLONEf_KEEP_PTR_TABLE
10477 perl_clone keeps a ptr_table with the pointer of the old
10478 variable as a key and the new variable as a value,
10479 this allows it to check if something has been cloned and not
10480 clone it again but rather just use the value and increase the
10481 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
10482 the ptr_table using the function
10483 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
10484 reason to keep it around is if you want to dup some of your own
10485 variable who are outside the graph perl scans, example of this
10486 code is in threads.xs create
10489 This is a win32 thing, it is ignored on unix, it tells perls
10490 win32host code (which is c++) to clone itself, this is needed on
10491 win32 if you want to run two threads at the same time,
10492 if you just want to do some stuff in a separate perl interpreter
10493 and then throw it away and return to the original one,
10494 you don't need to do anything.
10499 /* XXX the above needs expanding by someone who actually understands it ! */
10500 EXTERN_C PerlInterpreter *
10501 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
10504 perl_clone(PerlInterpreter *proto_perl, UV flags)
10507 #ifdef PERL_IMPLICIT_SYS
10509 /* perlhost.h so we need to call into it
10510 to clone the host, CPerlHost should have a c interface, sky */
10512 if (flags & CLONEf_CLONE_HOST) {
10513 return perl_clone_host(proto_perl,flags);
10515 return perl_clone_using(proto_perl, flags,
10517 proto_perl->IMemShared,
10518 proto_perl->IMemParse,
10520 proto_perl->IStdIO,
10524 proto_perl->IProc);
10528 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
10529 struct IPerlMem* ipM, struct IPerlMem* ipMS,
10530 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
10531 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
10532 struct IPerlDir* ipD, struct IPerlSock* ipS,
10533 struct IPerlProc* ipP)
10535 /* XXX many of the string copies here can be optimized if they're
10536 * constants; they need to be allocated as common memory and just
10537 * their pointers copied. */
10540 CLONE_PARAMS clone_params;
10541 CLONE_PARAMS* const param = &clone_params;
10543 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
10544 /* for each stash, determine whether its objects should be cloned */
10545 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10546 PERL_SET_THX(my_perl);
10549 Poison(my_perl, 1, PerlInterpreter);
10555 PL_savestack_ix = 0;
10556 PL_savestack_max = -1;
10557 PL_sig_pending = 0;
10558 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10559 # else /* !DEBUGGING */
10560 Zero(my_perl, 1, PerlInterpreter);
10561 # endif /* DEBUGGING */
10563 /* host pointers */
10565 PL_MemShared = ipMS;
10566 PL_MemParse = ipMP;
10573 #else /* !PERL_IMPLICIT_SYS */
10575 CLONE_PARAMS clone_params;
10576 CLONE_PARAMS* param = &clone_params;
10577 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
10578 /* for each stash, determine whether its objects should be cloned */
10579 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10580 PERL_SET_THX(my_perl);
10583 Poison(my_perl, 1, PerlInterpreter);
10589 PL_savestack_ix = 0;
10590 PL_savestack_max = -1;
10591 PL_sig_pending = 0;
10592 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10593 # else /* !DEBUGGING */
10594 Zero(my_perl, 1, PerlInterpreter);
10595 # endif /* DEBUGGING */
10596 #endif /* PERL_IMPLICIT_SYS */
10597 param->flags = flags;
10598 param->proto_perl = proto_perl;
10600 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
10602 PL_body_arenas = NULL;
10603 Zero(&PL_body_roots, 1, PL_body_roots);
10605 PL_nice_chunk = NULL;
10606 PL_nice_chunk_size = 0;
10608 PL_sv_objcount = 0;
10610 PL_sv_arenaroot = NULL;
10612 PL_debug = proto_perl->Idebug;
10614 PL_hash_seed = proto_perl->Ihash_seed;
10615 PL_rehash_seed = proto_perl->Irehash_seed;
10617 #ifdef USE_REENTRANT_API
10618 /* XXX: things like -Dm will segfault here in perlio, but doing
10619 * PERL_SET_CONTEXT(proto_perl);
10620 * breaks too many other things
10622 Perl_reentrant_init(aTHX);
10625 /* create SV map for pointer relocation */
10626 PL_ptr_table = ptr_table_new();
10628 /* initialize these special pointers as early as possible */
10629 SvANY(&PL_sv_undef) = NULL;
10630 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
10631 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
10632 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
10634 SvANY(&PL_sv_no) = new_XPVNV();
10635 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
10636 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
10637 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10638 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
10639 SvCUR_set(&PL_sv_no, 0);
10640 SvLEN_set(&PL_sv_no, 1);
10641 SvIV_set(&PL_sv_no, 0);
10642 SvNV_set(&PL_sv_no, 0);
10643 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
10645 SvANY(&PL_sv_yes) = new_XPVNV();
10646 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
10647 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
10648 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10649 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
10650 SvCUR_set(&PL_sv_yes, 1);
10651 SvLEN_set(&PL_sv_yes, 2);
10652 SvIV_set(&PL_sv_yes, 1);
10653 SvNV_set(&PL_sv_yes, 1);
10654 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
10656 /* create (a non-shared!) shared string table */
10657 PL_strtab = newHV();
10658 HvSHAREKEYS_off(PL_strtab);
10659 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
10660 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
10662 PL_compiling = proto_perl->Icompiling;
10664 /* These two PVs will be free'd special way so must set them same way op.c does */
10665 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
10666 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
10668 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
10669 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
10671 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
10672 if (!specialWARN(PL_compiling.cop_warnings))
10673 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
10674 if (!specialCopIO(PL_compiling.cop_io))
10675 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
10676 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
10678 /* pseudo environmental stuff */
10679 PL_origargc = proto_perl->Iorigargc;
10680 PL_origargv = proto_perl->Iorigargv;
10682 param->stashes = newAV(); /* Setup array of objects to call clone on */
10684 /* Set tainting stuff before PerlIO_debug can possibly get called */
10685 PL_tainting = proto_perl->Itainting;
10686 PL_taint_warn = proto_perl->Itaint_warn;
10688 #ifdef PERLIO_LAYERS
10689 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
10690 PerlIO_clone(aTHX_ proto_perl, param);
10693 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
10694 PL_incgv = gv_dup(proto_perl->Iincgv, param);
10695 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
10696 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
10697 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
10698 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
10701 PL_minus_c = proto_perl->Iminus_c;
10702 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
10703 PL_localpatches = proto_perl->Ilocalpatches;
10704 PL_splitstr = proto_perl->Isplitstr;
10705 PL_preprocess = proto_perl->Ipreprocess;
10706 PL_minus_n = proto_perl->Iminus_n;
10707 PL_minus_p = proto_perl->Iminus_p;
10708 PL_minus_l = proto_perl->Iminus_l;
10709 PL_minus_a = proto_perl->Iminus_a;
10710 PL_minus_E = proto_perl->Iminus_E;
10711 PL_minus_F = proto_perl->Iminus_F;
10712 PL_doswitches = proto_perl->Idoswitches;
10713 PL_dowarn = proto_perl->Idowarn;
10714 PL_doextract = proto_perl->Idoextract;
10715 PL_sawampersand = proto_perl->Isawampersand;
10716 PL_unsafe = proto_perl->Iunsafe;
10717 PL_inplace = SAVEPV(proto_perl->Iinplace);
10718 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
10719 PL_perldb = proto_perl->Iperldb;
10720 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
10721 PL_exit_flags = proto_perl->Iexit_flags;
10723 /* magical thingies */
10724 /* XXX time(&PL_basetime) when asked for? */
10725 PL_basetime = proto_perl->Ibasetime;
10726 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
10728 PL_maxsysfd = proto_perl->Imaxsysfd;
10729 PL_multiline = proto_perl->Imultiline;
10730 PL_statusvalue = proto_perl->Istatusvalue;
10732 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
10734 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
10736 PL_encoding = sv_dup(proto_perl->Iencoding, param);
10738 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
10739 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
10740 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
10742 /* Clone the regex array */
10743 PL_regex_padav = newAV();
10745 const I32 len = av_len((AV*)proto_perl->Iregex_padav);
10746 SV* const * const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
10748 av_push(PL_regex_padav,
10749 sv_dup_inc(regexen[0],param));
10750 for(i = 1; i <= len; i++) {
10751 const SV * const regex = regexen[i];
10754 ? sv_dup_inc(regex, param)
10756 newSViv(PTR2IV(re_dup(
10757 INT2PTR(REGEXP *, SvIVX(regex)), param))))
10759 av_push(PL_regex_padav, sv);
10762 PL_regex_pad = AvARRAY(PL_regex_padav);
10764 /* shortcuts to various I/O objects */
10765 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
10766 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
10767 PL_defgv = gv_dup(proto_perl->Idefgv, param);
10768 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
10769 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
10770 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
10772 /* shortcuts to regexp stuff */
10773 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
10775 /* shortcuts to misc objects */
10776 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
10778 /* shortcuts to debugging objects */
10779 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
10780 PL_DBline = gv_dup(proto_perl->IDBline, param);
10781 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
10782 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
10783 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
10784 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
10785 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
10786 PL_lineary = av_dup(proto_perl->Ilineary, param);
10787 PL_dbargs = av_dup(proto_perl->Idbargs, param);
10789 /* symbol tables */
10790 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
10791 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
10792 PL_debstash = hv_dup(proto_perl->Idebstash, param);
10793 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
10794 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
10796 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
10797 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
10798 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
10799 PL_endav = av_dup_inc(proto_perl->Iendav, param);
10800 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
10801 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
10803 PL_sub_generation = proto_perl->Isub_generation;
10805 /* funky return mechanisms */
10806 PL_forkprocess = proto_perl->Iforkprocess;
10808 /* subprocess state */
10809 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
10811 /* internal state */
10812 PL_maxo = proto_perl->Imaxo;
10813 if (proto_perl->Iop_mask)
10814 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
10817 /* PL_asserting = proto_perl->Iasserting; */
10819 /* current interpreter roots */
10820 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
10821 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
10822 PL_main_start = proto_perl->Imain_start;
10823 PL_eval_root = proto_perl->Ieval_root;
10824 PL_eval_start = proto_perl->Ieval_start;
10826 /* runtime control stuff */
10827 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
10828 PL_copline = proto_perl->Icopline;
10830 PL_filemode = proto_perl->Ifilemode;
10831 PL_lastfd = proto_perl->Ilastfd;
10832 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
10835 PL_gensym = proto_perl->Igensym;
10836 PL_preambled = proto_perl->Ipreambled;
10837 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
10838 PL_laststatval = proto_perl->Ilaststatval;
10839 PL_laststype = proto_perl->Ilaststype;
10842 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
10844 /* interpreter atexit processing */
10845 PL_exitlistlen = proto_perl->Iexitlistlen;
10846 if (PL_exitlistlen) {
10847 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10848 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10851 PL_exitlist = (PerlExitListEntry*)NULL;
10853 PL_my_cxt_size = proto_perl->Imy_cxt_size;
10854 if (PL_my_cxt_size) {
10855 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
10856 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
10859 PL_my_cxt_list = (void**)NULL;
10860 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
10861 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
10862 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
10864 PL_profiledata = NULL;
10865 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
10866 /* PL_rsfp_filters entries have fake IoDIRP() */
10867 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
10869 PL_compcv = cv_dup(proto_perl->Icompcv, param);
10871 PAD_CLONE_VARS(proto_perl, param);
10873 #ifdef HAVE_INTERP_INTERN
10874 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
10877 /* more statics moved here */
10878 PL_generation = proto_perl->Igeneration;
10879 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
10881 PL_in_clean_objs = proto_perl->Iin_clean_objs;
10882 PL_in_clean_all = proto_perl->Iin_clean_all;
10884 PL_uid = proto_perl->Iuid;
10885 PL_euid = proto_perl->Ieuid;
10886 PL_gid = proto_perl->Igid;
10887 PL_egid = proto_perl->Iegid;
10888 PL_nomemok = proto_perl->Inomemok;
10889 PL_an = proto_perl->Ian;
10890 PL_evalseq = proto_perl->Ievalseq;
10891 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
10892 PL_origalen = proto_perl->Iorigalen;
10893 #ifdef PERL_USES_PL_PIDSTATUS
10894 PL_pidstatus = newHV(); /* XXX flag for cloning? */
10896 PL_osname = SAVEPV(proto_perl->Iosname);
10897 PL_sighandlerp = proto_perl->Isighandlerp;
10899 PL_runops = proto_perl->Irunops;
10901 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
10904 PL_cshlen = proto_perl->Icshlen;
10905 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
10908 PL_lex_state = proto_perl->Ilex_state;
10909 PL_lex_defer = proto_perl->Ilex_defer;
10910 PL_lex_expect = proto_perl->Ilex_expect;
10911 PL_lex_formbrack = proto_perl->Ilex_formbrack;
10912 PL_lex_dojoin = proto_perl->Ilex_dojoin;
10913 PL_lex_starts = proto_perl->Ilex_starts;
10914 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
10915 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
10916 PL_lex_op = proto_perl->Ilex_op;
10917 PL_lex_inpat = proto_perl->Ilex_inpat;
10918 PL_lex_inwhat = proto_perl->Ilex_inwhat;
10919 PL_lex_brackets = proto_perl->Ilex_brackets;
10920 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
10921 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
10922 PL_lex_casemods = proto_perl->Ilex_casemods;
10923 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
10924 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
10926 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
10927 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
10928 PL_nexttoke = proto_perl->Inexttoke;
10930 /* XXX This is probably masking the deeper issue of why
10931 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
10932 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
10933 * (A little debugging with a watchpoint on it may help.)
10935 if (SvANY(proto_perl->Ilinestr)) {
10936 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
10937 i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
10938 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10939 i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
10940 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10941 i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
10942 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10943 i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
10944 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10947 PL_linestr = newSV(79);
10948 sv_upgrade(PL_linestr,SVt_PVIV);
10949 sv_setpvn(PL_linestr,"",0);
10950 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
10952 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10953 PL_pending_ident = proto_perl->Ipending_ident;
10954 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
10956 PL_expect = proto_perl->Iexpect;
10958 PL_multi_start = proto_perl->Imulti_start;
10959 PL_multi_end = proto_perl->Imulti_end;
10960 PL_multi_open = proto_perl->Imulti_open;
10961 PL_multi_close = proto_perl->Imulti_close;
10963 PL_error_count = proto_perl->Ierror_count;
10964 PL_subline = proto_perl->Isubline;
10965 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
10967 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
10968 if (SvANY(proto_perl->Ilinestr)) {
10969 i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
10970 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10971 i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
10972 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10973 PL_last_lop_op = proto_perl->Ilast_lop_op;
10976 PL_last_uni = SvPVX(PL_linestr);
10977 PL_last_lop = SvPVX(PL_linestr);
10978 PL_last_lop_op = 0;
10980 PL_in_my = proto_perl->Iin_my;
10981 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
10983 PL_cryptseen = proto_perl->Icryptseen;
10986 PL_hints = proto_perl->Ihints;
10988 PL_amagic_generation = proto_perl->Iamagic_generation;
10990 #ifdef USE_LOCALE_COLLATE
10991 PL_collation_ix = proto_perl->Icollation_ix;
10992 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
10993 PL_collation_standard = proto_perl->Icollation_standard;
10994 PL_collxfrm_base = proto_perl->Icollxfrm_base;
10995 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
10996 #endif /* USE_LOCALE_COLLATE */
10998 #ifdef USE_LOCALE_NUMERIC
10999 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
11000 PL_numeric_standard = proto_perl->Inumeric_standard;
11001 PL_numeric_local = proto_perl->Inumeric_local;
11002 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11003 #endif /* !USE_LOCALE_NUMERIC */
11005 /* utf8 character classes */
11006 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11007 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11008 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11009 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11010 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
11011 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11012 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
11013 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
11014 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
11015 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
11016 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
11017 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
11018 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11019 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
11020 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11021 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11022 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11023 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11024 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11025 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11027 /* Did the locale setup indicate UTF-8? */
11028 PL_utf8locale = proto_perl->Iutf8locale;
11029 /* Unicode features (see perlrun/-C) */
11030 PL_unicode = proto_perl->Iunicode;
11032 /* Pre-5.8 signals control */
11033 PL_signals = proto_perl->Isignals;
11035 /* times() ticks per second */
11036 PL_clocktick = proto_perl->Iclocktick;
11038 /* Recursion stopper for PerlIO_find_layer */
11039 PL_in_load_module = proto_perl->Iin_load_module;
11041 /* sort() routine */
11042 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
11044 /* Not really needed/useful since the reenrant_retint is "volatile",
11045 * but do it for consistency's sake. */
11046 PL_reentrant_retint = proto_perl->Ireentrant_retint;
11048 /* Hooks to shared SVs and locks. */
11049 PL_sharehook = proto_perl->Isharehook;
11050 PL_lockhook = proto_perl->Ilockhook;
11051 PL_unlockhook = proto_perl->Iunlockhook;
11052 PL_threadhook = proto_perl->Ithreadhook;
11054 PL_runops_std = proto_perl->Irunops_std;
11055 PL_runops_dbg = proto_perl->Irunops_dbg;
11057 #ifdef THREADS_HAVE_PIDS
11058 PL_ppid = proto_perl->Ippid;
11062 PL_last_swash_hv = NULL; /* reinits on demand */
11063 PL_last_swash_klen = 0;
11064 PL_last_swash_key[0]= '\0';
11065 PL_last_swash_tmps = (U8*)NULL;
11066 PL_last_swash_slen = 0;
11068 PL_glob_index = proto_perl->Iglob_index;
11069 PL_srand_called = proto_perl->Isrand_called;
11070 PL_uudmap['M'] = 0; /* reinits on demand */
11071 PL_bitcount = NULL; /* reinits on demand */
11073 if (proto_perl->Ipsig_pend) {
11074 Newxz(PL_psig_pend, SIG_SIZE, int);
11077 PL_psig_pend = (int*)NULL;
11080 if (proto_perl->Ipsig_ptr) {
11081 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
11082 Newxz(PL_psig_name, SIG_SIZE, SV*);
11083 for (i = 1; i < SIG_SIZE; i++) {
11084 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11085 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11089 PL_psig_ptr = (SV**)NULL;
11090 PL_psig_name = (SV**)NULL;
11093 /* thrdvar.h stuff */
11095 if (flags & CLONEf_COPY_STACKS) {
11096 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11097 PL_tmps_ix = proto_perl->Ttmps_ix;
11098 PL_tmps_max = proto_perl->Ttmps_max;
11099 PL_tmps_floor = proto_perl->Ttmps_floor;
11100 Newxz(PL_tmps_stack, PL_tmps_max, SV*);
11102 while (i <= PL_tmps_ix) {
11103 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
11107 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11108 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
11109 Newxz(PL_markstack, i, I32);
11110 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
11111 - proto_perl->Tmarkstack);
11112 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
11113 - proto_perl->Tmarkstack);
11114 Copy(proto_perl->Tmarkstack, PL_markstack,
11115 PL_markstack_ptr - PL_markstack + 1, I32);
11117 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
11118 * NOTE: unlike the others! */
11119 PL_scopestack_ix = proto_perl->Tscopestack_ix;
11120 PL_scopestack_max = proto_perl->Tscopestack_max;
11121 Newxz(PL_scopestack, PL_scopestack_max, I32);
11122 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
11124 /* NOTE: si_dup() looks at PL_markstack */
11125 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
11127 /* PL_curstack = PL_curstackinfo->si_stack; */
11128 PL_curstack = av_dup(proto_perl->Tcurstack, param);
11129 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
11131 /* next PUSHs() etc. set *(PL_stack_sp+1) */
11132 PL_stack_base = AvARRAY(PL_curstack);
11133 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
11134 - proto_perl->Tstack_base);
11135 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
11137 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
11138 * NOTE: unlike the others! */
11139 PL_savestack_ix = proto_perl->Tsavestack_ix;
11140 PL_savestack_max = proto_perl->Tsavestack_max;
11141 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
11142 PL_savestack = ss_dup(proto_perl, param);
11146 ENTER; /* perl_destruct() wants to LEAVE; */
11148 /* although we're not duplicating the tmps stack, we should still
11149 * add entries for any SVs on the tmps stack that got cloned by a
11150 * non-refcount means (eg a temp in @_); otherwise they will be
11153 for (i = 0; i<= proto_perl->Ttmps_ix; i++) {
11154 SV * const nsv = (SV*)ptr_table_fetch(PL_ptr_table,
11155 proto_perl->Ttmps_stack[i]);
11156 if (nsv && !SvREFCNT(nsv)) {
11158 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv);
11163 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
11164 PL_top_env = &PL_start_env;
11166 PL_op = proto_perl->Top;
11169 PL_Xpv = (XPV*)NULL;
11170 PL_na = proto_perl->Tna;
11172 PL_statbuf = proto_perl->Tstatbuf;
11173 PL_statcache = proto_perl->Tstatcache;
11174 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
11175 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
11177 PL_timesbuf = proto_perl->Ttimesbuf;
11180 PL_tainted = proto_perl->Ttainted;
11181 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
11182 PL_rs = sv_dup_inc(proto_perl->Trs, param);
11183 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
11184 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
11185 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
11186 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
11187 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
11188 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
11189 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
11191 PL_restartop = proto_perl->Trestartop;
11192 PL_in_eval = proto_perl->Tin_eval;
11193 PL_delaymagic = proto_perl->Tdelaymagic;
11194 PL_dirty = proto_perl->Tdirty;
11195 PL_localizing = proto_perl->Tlocalizing;
11197 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
11198 PL_hv_fetch_ent_mh = NULL;
11199 PL_modcount = proto_perl->Tmodcount;
11200 PL_lastgotoprobe = NULL;
11201 PL_dumpindent = proto_perl->Tdumpindent;
11203 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
11204 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
11205 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
11206 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
11207 PL_efloatbuf = NULL; /* reinits on demand */
11208 PL_efloatsize = 0; /* reinits on demand */
11212 PL_screamfirst = NULL;
11213 PL_screamnext = NULL;
11214 PL_maxscream = -1; /* reinits on demand */
11215 PL_lastscream = NULL;
11217 PL_watchaddr = NULL;
11220 PL_regdummy = proto_perl->Tregdummy;
11221 PL_regprecomp = NULL;
11224 PL_colorset = 0; /* reinits PL_colors[] */
11225 /*PL_colors[6] = {0,0,0,0,0,0};*/
11226 PL_reginput = NULL;
11229 PL_regstartp = (I32*)NULL;
11230 PL_regendp = (I32*)NULL;
11231 PL_reglastparen = (U32*)NULL;
11232 PL_reglastcloseparen = (U32*)NULL;
11234 PL_reg_start_tmp = (char**)NULL;
11235 PL_reg_start_tmpl = 0;
11236 PL_regdata = (struct reg_data*)NULL;
11239 PL_reg_eval_set = 0;
11241 PL_regprogram = (regnode*)NULL;
11243 PL_regcc = (CURCUR*)NULL;
11244 PL_reg_call_cc = (struct re_cc_state*)NULL;
11245 PL_reg_re = (regexp*)NULL;
11246 PL_reg_ganch = NULL;
11248 PL_reg_match_utf8 = FALSE;
11249 PL_reg_magic = (MAGIC*)NULL;
11251 PL_reg_oldcurpm = (PMOP*)NULL;
11252 PL_reg_curpm = (PMOP*)NULL;
11253 PL_reg_oldsaved = NULL;
11254 PL_reg_oldsavedlen = 0;
11255 #ifdef PERL_OLD_COPY_ON_WRITE
11258 PL_reg_maxiter = 0;
11259 PL_reg_leftiter = 0;
11260 PL_reg_poscache = NULL;
11261 PL_reg_poscache_size= 0;
11263 /* RE engine - function pointers */
11264 PL_regcompp = proto_perl->Tregcompp;
11265 PL_regexecp = proto_perl->Tregexecp;
11266 PL_regint_start = proto_perl->Tregint_start;
11267 PL_regint_string = proto_perl->Tregint_string;
11268 PL_regfree = proto_perl->Tregfree;
11270 PL_reginterp_cnt = 0;
11271 PL_reg_starttry = 0;
11273 /* Pluggable optimizer */
11274 PL_peepp = proto_perl->Tpeepp;
11276 PL_stashcache = newHV();
11278 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
11279 ptr_table_free(PL_ptr_table);
11280 PL_ptr_table = NULL;
11283 /* Call the ->CLONE method, if it exists, for each of the stashes
11284 identified by sv_dup() above.
11286 while(av_len(param->stashes) != -1) {
11287 HV* const stash = (HV*) av_shift(param->stashes);
11288 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
11289 if (cloner && GvCV(cloner)) {
11294 XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
11296 call_sv((SV*)GvCV(cloner), G_DISCARD);
11302 SvREFCNT_dec(param->stashes);
11304 /* orphaned? eg threads->new inside BEGIN or use */
11305 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
11306 SvREFCNT_inc_simple_void(PL_compcv);
11307 SAVEFREESV(PL_compcv);
11313 #endif /* USE_ITHREADS */
11316 =head1 Unicode Support
11318 =for apidoc sv_recode_to_utf8
11320 The encoding is assumed to be an Encode object, on entry the PV
11321 of the sv is assumed to be octets in that encoding, and the sv
11322 will be converted into Unicode (and UTF-8).
11324 If the sv already is UTF-8 (or if it is not POK), or if the encoding
11325 is not a reference, nothing is done to the sv. If the encoding is not
11326 an C<Encode::XS> Encoding object, bad things will happen.
11327 (See F<lib/encoding.pm> and L<Encode>).
11329 The PV of the sv is returned.
11334 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
11337 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
11351 Passing sv_yes is wrong - it needs to be or'ed set of constants
11352 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
11353 remove converted chars from source.
11355 Both will default the value - let them.
11357 XPUSHs(&PL_sv_yes);
11360 call_method("decode", G_SCALAR);
11364 s = SvPV_const(uni, len);
11365 if (s != SvPVX_const(sv)) {
11366 SvGROW(sv, len + 1);
11367 Move(s, SvPVX(sv), len + 1, char);
11368 SvCUR_set(sv, len);
11375 return SvPOKp(sv) ? SvPVX(sv) : NULL;
11379 =for apidoc sv_cat_decode
11381 The encoding is assumed to be an Encode object, the PV of the ssv is
11382 assumed to be octets in that encoding and decoding the input starts
11383 from the position which (PV + *offset) pointed to. The dsv will be
11384 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
11385 when the string tstr appears in decoding output or the input ends on
11386 the PV of the ssv. The value which the offset points will be modified
11387 to the last input position on the ssv.
11389 Returns TRUE if the terminator was found, else returns FALSE.
11394 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
11395 SV *ssv, int *offset, char *tstr, int tlen)
11399 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
11410 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
11411 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
11413 call_method("cat_decode", G_SCALAR);
11415 ret = SvTRUE(TOPs);
11416 *offset = SvIV(offsv);
11422 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
11427 /* ---------------------------------------------------------------------
11429 * support functions for report_uninit()
11432 /* the maxiumum size of array or hash where we will scan looking
11433 * for the undefined element that triggered the warning */
11435 #define FUV_MAX_SEARCH_SIZE 1000
11437 /* Look for an entry in the hash whose value has the same SV as val;
11438 * If so, return a mortal copy of the key. */
11441 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
11444 register HE **array;
11447 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
11448 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
11451 array = HvARRAY(hv);
11453 for (i=HvMAX(hv); i>0; i--) {
11454 register HE *entry;
11455 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
11456 if (HeVAL(entry) != val)
11458 if ( HeVAL(entry) == &PL_sv_undef ||
11459 HeVAL(entry) == &PL_sv_placeholder)
11463 if (HeKLEN(entry) == HEf_SVKEY)
11464 return sv_mortalcopy(HeKEY_sv(entry));
11465 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
11471 /* Look for an entry in the array whose value has the same SV as val;
11472 * If so, return the index, otherwise return -1. */
11475 S_find_array_subscript(pTHX_ AV *av, SV* val)
11480 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
11481 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
11485 for (i=AvFILLp(av); i>=0; i--) {
11486 if (svp[i] == val && svp[i] != &PL_sv_undef)
11492 /* S_varname(): return the name of a variable, optionally with a subscript.
11493 * If gv is non-zero, use the name of that global, along with gvtype (one
11494 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
11495 * targ. Depending on the value of the subscript_type flag, return:
11498 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
11499 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
11500 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
11501 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
11504 S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
11505 SV* keyname, I32 aindex, int subscript_type)
11508 SV * const name = sv_newmortal();
11511 buffer[0] = gvtype;
11514 /* as gv_fullname4(), but add literal '^' for $^FOO names */
11516 gv_fullname4(name, gv, buffer, 0);
11518 if ((unsigned int)SvPVX(name)[1] <= 26) {
11520 buffer[1] = SvPVX(name)[1] + 'A' - 1;
11522 /* Swap the 1 unprintable control character for the 2 byte pretty
11523 version - ie substr($name, 1, 1) = $buffer; */
11524 sv_insert(name, 1, 1, buffer, 2);
11529 CV * const cv = find_runcv(&unused);
11533 if (!cv || !CvPADLIST(cv))
11535 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
11536 sv = *av_fetch(av, targ, FALSE);
11537 /* SvLEN in a pad name is not to be trusted */
11538 sv_setpv(name, SvPV_nolen_const(sv));
11541 if (subscript_type == FUV_SUBSCRIPT_HASH) {
11542 SV * const sv = newSV(0);
11543 *SvPVX(name) = '$';
11544 Perl_sv_catpvf(aTHX_ name, "{%s}",
11545 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
11548 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
11549 *SvPVX(name) = '$';
11550 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
11552 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
11553 Perl_sv_insert(aTHX_ name, 0, 0, STR_WITH_LEN("within "));
11560 =for apidoc find_uninit_var
11562 Find the name of the undefined variable (if any) that caused the operator o
11563 to issue a "Use of uninitialized value" warning.
11564 If match is true, only return a name if it's value matches uninit_sv.
11565 So roughly speaking, if a unary operator (such as OP_COS) generates a
11566 warning, then following the direct child of the op may yield an
11567 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
11568 other hand, with OP_ADD there are two branches to follow, so we only print
11569 the variable name if we get an exact match.
11571 The name is returned as a mortal SV.
11573 Assumes that PL_op is the op that originally triggered the error, and that
11574 PL_comppad/PL_curpad points to the currently executing pad.
11580 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
11588 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
11589 uninit_sv == &PL_sv_placeholder)))
11592 switch (obase->op_type) {
11599 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
11600 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
11603 int subscript_type = FUV_SUBSCRIPT_WITHIN;
11605 if (pad) { /* @lex, %lex */
11606 sv = PAD_SVl(obase->op_targ);
11610 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
11611 /* @global, %global */
11612 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
11615 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
11617 else /* @{expr}, %{expr} */
11618 return find_uninit_var(cUNOPx(obase)->op_first,
11622 /* attempt to find a match within the aggregate */
11624 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
11626 subscript_type = FUV_SUBSCRIPT_HASH;
11629 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
11631 subscript_type = FUV_SUBSCRIPT_ARRAY;
11634 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
11637 return varname(gv, hash ? '%' : '@', obase->op_targ,
11638 keysv, index, subscript_type);
11642 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
11644 return varname(NULL, '$', obase->op_targ,
11645 NULL, 0, FUV_SUBSCRIPT_NONE);
11648 gv = cGVOPx_gv(obase);
11649 if (!gv || (match && GvSV(gv) != uninit_sv))
11651 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
11654 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
11657 av = (AV*)PAD_SV(obase->op_targ);
11658 if (!av || SvRMAGICAL(av))
11660 svp = av_fetch(av, (I32)obase->op_private, FALSE);
11661 if (!svp || *svp != uninit_sv)
11664 return varname(NULL, '$', obase->op_targ,
11665 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
11668 gv = cGVOPx_gv(obase);
11674 if (!av || SvRMAGICAL(av))
11676 svp = av_fetch(av, (I32)obase->op_private, FALSE);
11677 if (!svp || *svp != uninit_sv)
11680 return varname(gv, '$', 0,
11681 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
11686 o = cUNOPx(obase)->op_first;
11687 if (!o || o->op_type != OP_NULL ||
11688 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
11690 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
11694 if (PL_op == obase)
11695 /* $a[uninit_expr] or $h{uninit_expr} */
11696 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
11699 o = cBINOPx(obase)->op_first;
11700 kid = cBINOPx(obase)->op_last;
11702 /* get the av or hv, and optionally the gv */
11704 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
11705 sv = PAD_SV(o->op_targ);
11707 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
11708 && cUNOPo->op_first->op_type == OP_GV)
11710 gv = cGVOPx_gv(cUNOPo->op_first);
11713 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
11718 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
11719 /* index is constant */
11723 if (obase->op_type == OP_HELEM) {
11724 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
11725 if (!he || HeVAL(he) != uninit_sv)
11729 SV * const * const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
11730 if (!svp || *svp != uninit_sv)
11734 if (obase->op_type == OP_HELEM)
11735 return varname(gv, '%', o->op_targ,
11736 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
11738 return varname(gv, '@', o->op_targ, NULL,
11739 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
11742 /* index is an expression;
11743 * attempt to find a match within the aggregate */
11744 if (obase->op_type == OP_HELEM) {
11745 SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
11747 return varname(gv, '%', o->op_targ,
11748 keysv, 0, FUV_SUBSCRIPT_HASH);
11751 const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
11753 return varname(gv, '@', o->op_targ,
11754 NULL, index, FUV_SUBSCRIPT_ARRAY);
11759 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
11761 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
11766 /* only examine RHS */
11767 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
11770 o = cUNOPx(obase)->op_first;
11771 if (o->op_type == OP_PUSHMARK)
11774 if (!o->op_sibling) {
11775 /* one-arg version of open is highly magical */
11777 if (o->op_type == OP_GV) { /* open FOO; */
11779 if (match && GvSV(gv) != uninit_sv)
11781 return varname(gv, '$', 0,
11782 NULL, 0, FUV_SUBSCRIPT_NONE);
11784 /* other possibilities not handled are:
11785 * open $x; or open my $x; should return '${*$x}'
11786 * open expr; should return '$'.expr ideally
11792 /* ops where $_ may be an implicit arg */
11796 if ( !(obase->op_flags & OPf_STACKED)) {
11797 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
11798 ? PAD_SVl(obase->op_targ)
11801 sv = sv_newmortal();
11802 sv_setpvn(sv, "$_", 2);
11810 /* skip filehandle as it can't produce 'undef' warning */
11811 o = cUNOPx(obase)->op_first;
11812 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
11813 o = o->op_sibling->op_sibling;
11820 match = 1; /* XS or custom code could trigger random warnings */
11825 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
11826 return sv_2mortal(newSVpvs("${$/}"));
11831 if (!(obase->op_flags & OPf_KIDS))
11833 o = cUNOPx(obase)->op_first;
11839 /* if all except one arg are constant, or have no side-effects,
11840 * or are optimized away, then it's unambiguous */
11842 for (kid=o; kid; kid = kid->op_sibling) {
11844 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
11845 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
11846 || (kid->op_type == OP_PUSHMARK)
11850 if (o2) { /* more than one found */
11857 return find_uninit_var(o2, uninit_sv, match);
11859 /* scan all args */
11861 sv = find_uninit_var(o, uninit_sv, 1);
11873 =for apidoc report_uninit
11875 Print appropriate "Use of uninitialized variable" warning
11881 Perl_report_uninit(pTHX_ SV* uninit_sv)
11885 SV* varname = NULL;
11887 varname = find_uninit_var(PL_op, uninit_sv,0);
11889 sv_insert(varname, 0, 0, " ", 1);
11891 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
11892 varname ? SvPV_nolen_const(varname) : "",
11893 " in ", OP_DESC(PL_op));
11896 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
11902 * c-indentation-style: bsd
11903 * c-basic-offset: 4
11904 * indent-tabs-mode: t
11907 * ex: set ts=8 sts=4 sw=4 noet: