3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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 /* if adding more checks watch out for the following tests:
34 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
35 * lib/utf8.t lib/Unicode/Collate/t/index.t
38 # define ASSERT_UTF8_CACHE(cache) \
39 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
40 assert((cache)[2] <= (cache)[3]); \
41 assert((cache)[3] <= (cache)[1]);} \
44 # define ASSERT_UTF8_CACHE(cache) NOOP
47 #ifdef PERL_OLD_COPY_ON_WRITE
48 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
49 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
50 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
54 /* ============================================================================
56 =head1 Allocation and deallocation of SVs.
58 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
59 sv, av, hv...) contains type and reference count information, and for
60 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
61 contains fields specific to each type. Some types store all they need
62 in the head, so don't have a body.
64 In all but the most memory-paranoid configuations (ex: PURIFY), heads
65 and bodies are allocated out of arenas, which by default are
66 approximately 4K chunks of memory parcelled up into N heads or bodies.
67 Sv-bodies are allocated by their sv-type, guaranteeing size
68 consistency needed to allocate safely from arrays.
70 For SV-heads, the first slot in each arena is reserved, and holds a
71 link to the next arena, some flags, and a note of the number of slots.
72 Snaked through each arena chain is a linked list of free items; when
73 this becomes empty, an extra arena is allocated and divided up into N
74 items which are threaded into the free list.
76 SV-bodies are similar, but they use arena-sets by default, which
77 separate the link and info from the arena itself, and reclaim the 1st
78 slot in the arena. SV-bodies are further described later.
80 The following global variables are associated with arenas:
82 PL_sv_arenaroot pointer to list of SV arenas
83 PL_sv_root pointer to list of free SV structures
85 PL_body_arenas head of linked-list of body arenas
86 PL_body_roots[] array of pointers to list of free bodies of svtype
87 arrays are indexed by the svtype needed
89 A few special SV heads are not allocated from an arena, but are
90 instead directly created in the interpreter structure, eg PL_sv_undef.
91 The size of arenas can be changed from the default by setting
92 PERL_ARENA_SIZE appropriately at compile time.
94 The SV arena serves the secondary purpose of allowing still-live SVs
95 to be located and destroyed during final cleanup.
97 At the lowest level, the macros new_SV() and del_SV() grab and free
98 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
99 to return the SV to the free list with error checking.) new_SV() calls
100 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
101 SVs in the free list have their SvTYPE field set to all ones.
103 At the time of very final cleanup, sv_free_arenas() is called from
104 perl_destruct() to physically free all the arenas allocated since the
105 start of the interpreter.
107 The function visit() scans the SV arenas list, and calls a specified
108 function for each SV it finds which is still live - ie which has an SvTYPE
109 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
110 following functions (specified as [function that calls visit()] / [function
111 called by visit() for each SV]):
113 sv_report_used() / do_report_used()
114 dump all remaining SVs (debugging aid)
116 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
117 Attempt to free all objects pointed to by RVs,
118 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
119 try to do the same for all objects indirectly
120 referenced by typeglobs too. Called once from
121 perl_destruct(), prior to calling sv_clean_all()
124 sv_clean_all() / do_clean_all()
125 SvREFCNT_dec(sv) each remaining SV, possibly
126 triggering an sv_free(). It also sets the
127 SVf_BREAK flag on the SV to indicate that the
128 refcnt has been artificially lowered, and thus
129 stopping sv_free() from giving spurious warnings
130 about SVs which unexpectedly have a refcnt
131 of zero. called repeatedly from perl_destruct()
132 until there are no SVs left.
134 =head2 Arena allocator API Summary
136 Private API to rest of sv.c
140 new_XIV(), del_XIV(),
141 new_XNV(), del_XNV(),
146 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
150 ============================================================================ */
153 * "A time to plant, and a time to uproot what was planted..."
157 Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
162 new_chunk = (void *)(chunk);
163 new_chunk_size = (chunk_size);
164 if (new_chunk_size > PL_nice_chunk_size) {
165 Safefree(PL_nice_chunk);
166 PL_nice_chunk = (char *) new_chunk;
167 PL_nice_chunk_size = new_chunk_size;
173 #ifdef DEBUG_LEAKING_SCALARS
174 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
176 # define FREE_SV_DEBUG_FILE(sv)
180 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
181 /* Whilst I'd love to do this, it seems that things like to check on
183 # define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
185 # define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
186 PoisonNew(&SvREFCNT(sv), 1, U32)
188 # define SvARENA_CHAIN(sv) SvANY(sv)
189 # define POSION_SV_HEAD(sv)
192 #define plant_SV(p) \
194 FREE_SV_DEBUG_FILE(p); \
196 SvARENA_CHAIN(p) = (void *)PL_sv_root; \
197 SvFLAGS(p) = SVTYPEMASK; \
202 #define uproot_SV(p) \
205 PL_sv_root = (SV*)SvARENA_CHAIN(p); \
210 /* make some more SVs by adding another arena */
219 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
220 PL_nice_chunk = NULL;
221 PL_nice_chunk_size = 0;
224 char *chunk; /* must use New here to match call to */
225 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
226 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
232 /* new_SV(): return a new, empty SV head */
234 #ifdef DEBUG_LEAKING_SCALARS
235 /* provide a real function for a debugger to play with */
244 sv = S_more_sv(aTHX);
248 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
249 sv->sv_debug_line = (U16) (PL_parser
250 ? PL_parser->copline == NOLINE
256 sv->sv_debug_inpad = 0;
257 sv->sv_debug_cloned = 0;
258 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
262 # define new_SV(p) (p)=S_new_SV(aTHX)
270 (p) = S_more_sv(aTHX); \
278 /* del_SV(): return an empty SV head to the free list */
291 S_del_sv(pTHX_ SV *p)
297 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
298 const SV * const sv = sva + 1;
299 const SV * const svend = &sva[SvREFCNT(sva)];
300 if (p >= sv && p < svend) {
306 if (ckWARN_d(WARN_INTERNAL))
307 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
308 "Attempt to free non-arena SV: 0x%"UVxf
309 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
316 #else /* ! DEBUGGING */
318 #define del_SV(p) plant_SV(p)
320 #endif /* DEBUGGING */
324 =head1 SV Manipulation Functions
326 =for apidoc sv_add_arena
328 Given a chunk of memory, link it to the head of the list of arenas,
329 and split it into a list of free SVs.
335 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
338 SV* const sva = (SV*)ptr;
342 /* The first SV in an arena isn't an SV. */
343 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
344 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
345 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
347 PL_sv_arenaroot = sva;
348 PL_sv_root = sva + 1;
350 svend = &sva[SvREFCNT(sva) - 1];
353 SvARENA_CHAIN(sv) = (void *)(SV*)(sv + 1);
357 /* Must always set typemask because it's always checked in on cleanup
358 when the arenas are walked looking for objects. */
359 SvFLAGS(sv) = SVTYPEMASK;
362 SvARENA_CHAIN(sv) = 0;
366 SvFLAGS(sv) = SVTYPEMASK;
369 /* visit(): call the named function for each non-free SV in the arenas
370 * whose flags field matches the flags/mask args. */
373 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
379 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
380 register const SV * const svend = &sva[SvREFCNT(sva)];
382 for (sv = sva + 1; sv < svend; ++sv) {
383 if (SvTYPE(sv) != SVTYPEMASK
384 && (sv->sv_flags & mask) == flags
397 /* called by sv_report_used() for each live SV */
400 do_report_used(pTHX_ SV *sv)
402 if (SvTYPE(sv) != SVTYPEMASK) {
403 PerlIO_printf(Perl_debug_log, "****\n");
410 =for apidoc sv_report_used
412 Dump the contents of all SVs not yet freed. (Debugging aid).
418 Perl_sv_report_used(pTHX)
421 visit(do_report_used, 0, 0);
427 /* called by sv_clean_objs() for each live SV */
430 do_clean_objs(pTHX_ SV *ref)
435 SV * const target = SvRV(ref);
436 if (SvOBJECT(target)) {
437 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
438 if (SvWEAKREF(ref)) {
439 sv_del_backref(target, ref);
445 SvREFCNT_dec(target);
450 /* XXX Might want to check arrays, etc. */
453 /* called by sv_clean_objs() for each live SV */
455 #ifndef DISABLE_DESTRUCTOR_KLUDGE
457 do_clean_named_objs(pTHX_ SV *sv)
460 assert(SvTYPE(sv) == SVt_PVGV);
461 assert(isGV_with_GP(sv));
464 #ifdef PERL_DONT_CREATE_GVSV
467 SvOBJECT(GvSV(sv))) ||
468 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
469 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
470 /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */
471 (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) ||
472 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
474 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
475 SvFLAGS(sv) |= SVf_BREAK;
483 =for apidoc sv_clean_objs
485 Attempt to destroy all objects not yet freed
491 Perl_sv_clean_objs(pTHX)
494 PL_in_clean_objs = TRUE;
495 visit(do_clean_objs, SVf_ROK, SVf_ROK);
496 #ifndef DISABLE_DESTRUCTOR_KLUDGE
497 /* some barnacles may yet remain, clinging to typeglobs */
498 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
500 PL_in_clean_objs = FALSE;
503 /* called by sv_clean_all() for each live SV */
506 do_clean_all(pTHX_ SV *sv)
509 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
510 SvFLAGS(sv) |= SVf_BREAK;
515 =for apidoc sv_clean_all
517 Decrement the refcnt of each remaining SV, possibly triggering a
518 cleanup. This function may have to be called multiple times to free
519 SVs which are in complex self-referential hierarchies.
525 Perl_sv_clean_all(pTHX)
529 PL_in_clean_all = TRUE;
530 cleaned = visit(do_clean_all, 0,0);
531 PL_in_clean_all = FALSE;
536 ARENASETS: a meta-arena implementation which separates arena-info
537 into struct arena_set, which contains an array of struct
538 arena_descs, each holding info for a single arena. By separating
539 the meta-info from the arena, we recover the 1st slot, formerly
540 borrowed for list management. The arena_set is about the size of an
541 arena, avoiding the needless malloc overhead of a naive linked-list.
543 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
544 memory in the last arena-set (1/2 on average). In trade, we get
545 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
546 smaller types). The recovery of the wasted space allows use of
547 small arenas for large, rare body types, by changing array* fields
548 in body_details_by_type[] below.
551 char *arena; /* the raw storage, allocated aligned */
552 size_t size; /* its size ~4k typ */
553 U32 misc; /* type, and in future other things. */
558 /* Get the maximum number of elements in set[] such that struct arena_set
559 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
560 therefore likely to be 1 aligned memory page. */
562 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
563 - 2 * sizeof(int)) / sizeof (struct arena_desc))
566 struct arena_set* next;
567 unsigned int set_size; /* ie ARENAS_PER_SET */
568 unsigned int curr; /* index of next available arena-desc */
569 struct arena_desc set[ARENAS_PER_SET];
573 =for apidoc sv_free_arenas
575 Deallocate the memory used by all arenas. Note that all the individual SV
576 heads and bodies within the arenas must already have been freed.
581 Perl_sv_free_arenas(pTHX)
588 /* Free arenas here, but be careful about fake ones. (We assume
589 contiguity of the fake ones with the corresponding real ones.) */
591 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
592 svanext = (SV*) SvANY(sva);
593 while (svanext && SvFAKE(svanext))
594 svanext = (SV*) SvANY(svanext);
601 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
604 struct arena_set *current = aroot;
607 assert(aroot->set[i].arena);
608 Safefree(aroot->set[i].arena);
616 i = PERL_ARENA_ROOTS_SIZE;
618 PL_body_roots[i] = 0;
620 Safefree(PL_nice_chunk);
621 PL_nice_chunk = NULL;
622 PL_nice_chunk_size = 0;
628 Here are mid-level routines that manage the allocation of bodies out
629 of the various arenas. There are 5 kinds of arenas:
631 1. SV-head arenas, which are discussed and handled above
632 2. regular body arenas
633 3. arenas for reduced-size bodies
635 5. pte arenas (thread related)
637 Arena types 2 & 3 are chained by body-type off an array of
638 arena-root pointers, which is indexed by svtype. Some of the
639 larger/less used body types are malloced singly, since a large
640 unused block of them is wasteful. Also, several svtypes dont have
641 bodies; the data fits into the sv-head itself. The arena-root
642 pointer thus has a few unused root-pointers (which may be hijacked
643 later for arena types 4,5)
645 3 differs from 2 as an optimization; some body types have several
646 unused fields in the front of the structure (which are kept in-place
647 for consistency). These bodies can be allocated in smaller chunks,
648 because the leading fields arent accessed. Pointers to such bodies
649 are decremented to point at the unused 'ghost' memory, knowing that
650 the pointers are used with offsets to the real memory.
652 HE, HEK arenas are managed separately, with separate code, but may
653 be merge-able later..
655 PTE arenas are not sv-bodies, but they share these mid-level
656 mechanics, so are considered here. The new mid-level mechanics rely
657 on the sv_type of the body being allocated, so we just reserve one
658 of the unused body-slots for PTEs, then use it in those (2) PTE
659 contexts below (line ~10k)
662 /* get_arena(size): this creates custom-sized arenas
663 TBD: export properly for hv.c: S_more_he().
666 Perl_get_arena(pTHX_ size_t arena_size, U32 misc)
669 struct arena_desc* adesc;
670 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
673 /* shouldnt need this
674 if (!arena_size) arena_size = PERL_ARENA_SIZE;
677 /* may need new arena-set to hold new arena */
678 if (!aroot || aroot->curr >= aroot->set_size) {
679 struct arena_set *newroot;
680 Newxz(newroot, 1, struct arena_set);
681 newroot->set_size = ARENAS_PER_SET;
682 newroot->next = aroot;
684 PL_body_arenas = (void *) newroot;
685 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
688 /* ok, now have arena-set with at least 1 empty/available arena-desc */
689 curr = aroot->curr++;
690 adesc = &(aroot->set[curr]);
691 assert(!adesc->arena);
693 Newx(adesc->arena, arena_size, char);
694 adesc->size = arena_size;
696 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
697 curr, (void*)adesc->arena, (UV)arena_size));
703 /* return a thing to the free list */
705 #define del_body(thing, root) \
707 void ** const thing_copy = (void **)thing;\
708 *thing_copy = *root; \
709 *root = (void*)thing_copy; \
714 =head1 SV-Body Allocation
716 Allocation of SV-bodies is similar to SV-heads, differing as follows;
717 the allocation mechanism is used for many body types, so is somewhat
718 more complicated, it uses arena-sets, and has no need for still-live
721 At the outermost level, (new|del)_X*V macros return bodies of the
722 appropriate type. These macros call either (new|del)_body_type or
723 (new|del)_body_allocated macro pairs, depending on specifics of the
724 type. Most body types use the former pair, the latter pair is used to
725 allocate body types with "ghost fields".
727 "ghost fields" are fields that are unused in certain types, and
728 consequently dont need to actually exist. They are declared because
729 they're part of a "base type", which allows use of functions as
730 methods. The simplest examples are AVs and HVs, 2 aggregate types
731 which don't use the fields which support SCALAR semantics.
733 For these types, the arenas are carved up into *_allocated size
734 chunks, we thus avoid wasted memory for those unaccessed members.
735 When bodies are allocated, we adjust the pointer back in memory by the
736 size of the bit not allocated, so it's as if we allocated the full
737 structure. (But things will all go boom if you write to the part that
738 is "not there", because you'll be overwriting the last members of the
739 preceding structure in memory.)
741 We calculate the correction using the STRUCT_OFFSET macro. For
742 example, if xpv_allocated is the same structure as XPV then the two
743 OFFSETs sum to zero, and the pointer is unchanged. If the allocated
744 structure is smaller (no initial NV actually allocated) then the net
745 effect is to subtract the size of the NV from the pointer, to return a
746 new pointer as if an initial NV were actually allocated.
748 This is the same trick as was used for NV and IV bodies. Ironically it
749 doesn't need to be used for NV bodies any more, because NV is now at
750 the start of the structure. IV bodies don't need it either, because
751 they are no longer allocated.
753 In turn, the new_body_* allocators call S_new_body(), which invokes
754 new_body_inline macro, which takes a lock, and takes a body off the
755 linked list at PL_body_roots[sv_type], calling S_more_bodies() if
756 necessary to refresh an empty list. Then the lock is released, and
757 the body is returned.
759 S_more_bodies calls get_arena(), and carves it up into an array of N
760 bodies, which it strings into a linked list. It looks up arena-size
761 and body-size from the body_details table described below, thus
762 supporting the multiple body-types.
764 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
765 the (new|del)_X*V macros are mapped directly to malloc/free.
771 For each sv-type, struct body_details bodies_by_type[] carries
772 parameters which control these aspects of SV handling:
774 Arena_size determines whether arenas are used for this body type, and if
775 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
776 zero, forcing individual mallocs and frees.
778 Body_size determines how big a body is, and therefore how many fit into
779 each arena. Offset carries the body-pointer adjustment needed for
780 *_allocated body types, and is used in *_allocated macros.
782 But its main purpose is to parameterize info needed in
783 Perl_sv_upgrade(). The info here dramatically simplifies the function
784 vs the implementation in 5.8.7, making it table-driven. All fields
785 are used for this, except for arena_size.
787 For the sv-types that have no bodies, arenas are not used, so those
788 PL_body_roots[sv_type] are unused, and can be overloaded. In
789 something of a special case, SVt_NULL is borrowed for HE arenas;
790 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
791 bodies_by_type[SVt_NULL] slot is not used, as the table is not
794 PTEs also use arenas, but are never seen in Perl_sv_upgrade. Nonetheless,
795 they get their own slot in bodies_by_type[PTE_SVSLOT =SVt_IV], so they can
796 just use the same allocation semantics. At first, PTEs were also
797 overloaded to a non-body sv-type, but this yielded hard-to-find malloc
798 bugs, so was simplified by claiming a new slot. This choice has no
799 consequence at this time.
803 struct body_details {
804 U8 body_size; /* Size to allocate */
805 U8 copy; /* Size of structure to copy (may be shorter) */
807 unsigned int type : 4; /* We have space for a sanity check. */
808 unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
809 unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
810 unsigned int arena : 1; /* Allocated from an arena */
811 size_t arena_size; /* Size of arena to allocate */
819 /* With -DPURFIY we allocate everything directly, and don't use arenas.
820 This seems a rather elegant way to simplify some of the code below. */
821 #define HASARENA FALSE
823 #define HASARENA TRUE
825 #define NOARENA FALSE
827 /* Size the arenas to exactly fit a given number of bodies. A count
828 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
829 simplifying the default. If count > 0, the arena is sized to fit
830 only that many bodies, allowing arenas to be used for large, rare
831 bodies (XPVFM, XPVIO) without undue waste. The arena size is
832 limited by PERL_ARENA_SIZE, so we can safely oversize the
835 #define FIT_ARENA0(body_size) \
836 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
837 #define FIT_ARENAn(count,body_size) \
838 ( count * body_size <= PERL_ARENA_SIZE) \
839 ? count * body_size \
840 : FIT_ARENA0 (body_size)
841 #define FIT_ARENA(count,body_size) \
843 ? FIT_ARENAn (count, body_size) \
844 : FIT_ARENA0 (body_size)
846 /* A macro to work out the offset needed to subtract from a pointer to (say)
853 to make its members accessible via a pointer to (say)
863 #define relative_STRUCT_OFFSET(longer, shorter, member) \
864 (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member))
866 /* Calculate the length to copy. Specifically work out the length less any
867 final padding the compiler needed to add. See the comment in sv_upgrade
868 for why copying the padding proved to be a bug. */
870 #define copy_length(type, last_member) \
871 STRUCT_OFFSET(type, last_member) \
872 + sizeof (((type*)SvANY((SV*)0))->last_member)
874 static const struct body_details bodies_by_type[] = {
875 { sizeof(HE), 0, 0, SVt_NULL,
876 FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
878 /* The bind placeholder pretends to be an RV for now.
879 Also it's marked as "can't upgrade" to stop anyone using it before it's
881 { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
883 /* IVs are in the head, so the allocation size is 0.
884 However, the slot is overloaded for PTEs. */
885 { sizeof(struct ptr_tbl_ent), /* This is used for PTEs. */
886 sizeof(IV), /* This is used to copy out the IV body. */
887 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
888 NOARENA /* IVS don't need an arena */,
889 /* But PTEs need to know the size of their arena */
890 FIT_ARENA(0, sizeof(struct ptr_tbl_ent))
893 /* 8 bytes on most ILP32 with IEEE doubles */
894 { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA,
895 FIT_ARENA(0, sizeof(NV)) },
897 /* RVs are in the head now. */
898 { 0, 0, 0, SVt_RV, FALSE, NONV, NOARENA, 0 },
900 /* 8 bytes on most ILP32 with IEEE doubles */
901 { sizeof(xpv_allocated),
902 copy_length(XPV, xpv_len)
903 - relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
904 + relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
905 SVt_PV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpv_allocated)) },
908 { sizeof(xpviv_allocated),
909 copy_length(XPVIV, xiv_u)
910 - relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
911 + relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
912 SVt_PVIV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpviv_allocated)) },
915 { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, SVt_PVNV, FALSE, HADNV,
916 HASARENA, FIT_ARENA(0, sizeof(XPVNV)) },
919 { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
920 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
923 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
924 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
927 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
928 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
930 { sizeof(xpvav_allocated),
931 copy_length(XPVAV, xmg_stash)
932 - relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
933 + relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
934 SVt_PVAV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) },
936 { sizeof(xpvhv_allocated),
937 copy_length(XPVHV, xmg_stash)
938 - relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
939 + relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
940 SVt_PVHV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) },
943 { sizeof(xpvcv_allocated), sizeof(xpvcv_allocated),
944 + relative_STRUCT_OFFSET(xpvcv_allocated, XPVCV, xpv_cur),
945 SVt_PVCV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvcv_allocated)) },
947 { sizeof(xpvfm_allocated), sizeof(xpvfm_allocated),
948 + relative_STRUCT_OFFSET(xpvfm_allocated, XPVFM, xpv_cur),
949 SVt_PVFM, TRUE, NONV, NOARENA, FIT_ARENA(20, sizeof(xpvfm_allocated)) },
951 /* XPVIO is 84 bytes, fits 48x */
952 { sizeof(XPVIO), sizeof(XPVIO), 0, SVt_PVIO, TRUE, HADNV,
953 HASARENA, FIT_ARENA(24, sizeof(XPVIO)) },
956 #define new_body_type(sv_type) \
957 (void *)((char *)S_new_body(aTHX_ sv_type))
959 #define del_body_type(p, sv_type) \
960 del_body(p, &PL_body_roots[sv_type])
963 #define new_body_allocated(sv_type) \
964 (void *)((char *)S_new_body(aTHX_ sv_type) \
965 - bodies_by_type[sv_type].offset)
967 #define del_body_allocated(p, sv_type) \
968 del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
971 #define my_safemalloc(s) (void*)safemalloc(s)
972 #define my_safecalloc(s) (void*)safecalloc(s, 1)
973 #define my_safefree(p) safefree((char*)p)
977 #define new_XNV() my_safemalloc(sizeof(XPVNV))
978 #define del_XNV(p) my_safefree(p)
980 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
981 #define del_XPVNV(p) my_safefree(p)
983 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
984 #define del_XPVAV(p) my_safefree(p)
986 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
987 #define del_XPVHV(p) my_safefree(p)
989 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
990 #define del_XPVMG(p) my_safefree(p)
992 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
993 #define del_XPVGV(p) my_safefree(p)
997 #define new_XNV() new_body_type(SVt_NV)
998 #define del_XNV(p) del_body_type(p, SVt_NV)
1000 #define new_XPVNV() new_body_type(SVt_PVNV)
1001 #define del_XPVNV(p) del_body_type(p, SVt_PVNV)
1003 #define new_XPVAV() new_body_allocated(SVt_PVAV)
1004 #define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
1006 #define new_XPVHV() new_body_allocated(SVt_PVHV)
1007 #define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
1009 #define new_XPVMG() new_body_type(SVt_PVMG)
1010 #define del_XPVMG(p) del_body_type(p, SVt_PVMG)
1012 #define new_XPVGV() new_body_type(SVt_PVGV)
1013 #define del_XPVGV(p) del_body_type(p, SVt_PVGV)
1017 /* no arena for you! */
1019 #define new_NOARENA(details) \
1020 my_safemalloc((details)->body_size + (details)->offset)
1021 #define new_NOARENAZ(details) \
1022 my_safecalloc((details)->body_size + (details)->offset)
1025 S_more_bodies (pTHX_ svtype sv_type)
1028 void ** const root = &PL_body_roots[sv_type];
1029 const struct body_details * const bdp = &bodies_by_type[sv_type];
1030 const size_t body_size = bdp->body_size;
1033 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1034 static bool done_sanity_check;
1036 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1037 * variables like done_sanity_check. */
1038 if (!done_sanity_check) {
1039 unsigned int i = SVt_LAST;
1041 done_sanity_check = TRUE;
1044 assert (bodies_by_type[i].type == i);
1048 assert(bdp->arena_size);
1050 start = (char*) Perl_get_arena(aTHX_ bdp->arena_size, sv_type);
1052 end = start + bdp->arena_size - body_size;
1054 /* computed count doesnt reflect the 1st slot reservation */
1055 DEBUG_m(PerlIO_printf(Perl_debug_log,
1056 "arena %p end %p arena-size %d type %d size %d ct %d\n",
1057 (void*)start, (void*)end,
1058 (int)bdp->arena_size, sv_type, (int)body_size,
1059 (int)bdp->arena_size / (int)body_size));
1061 *root = (void *)start;
1063 while (start < end) {
1064 char * const next = start + body_size;
1065 *(void**) start = (void *)next;
1068 *(void **)start = 0;
1073 /* grab a new thing from the free list, allocating more if necessary.
1074 The inline version is used for speed in hot routines, and the
1075 function using it serves the rest (unless PURIFY).
1077 #define new_body_inline(xpv, sv_type) \
1079 void ** const r3wt = &PL_body_roots[sv_type]; \
1080 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
1081 ? *((void **)(r3wt)) : more_bodies(sv_type)); \
1082 *(r3wt) = *(void**)(xpv); \
1088 S_new_body(pTHX_ svtype sv_type)
1092 new_body_inline(xpv, sv_type);
1099 =for apidoc sv_upgrade
1101 Upgrade an SV to a more complex form. Generally adds a new body type to the
1102 SV, then copies across as much information as possible from the old body.
1103 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1109 Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type)
1114 const svtype old_type = SvTYPE(sv);
1115 const struct body_details *new_type_details;
1116 const struct body_details *const old_type_details
1117 = bodies_by_type + old_type;
1119 if (new_type != SVt_PV && SvIsCOW(sv)) {
1120 sv_force_normal_flags(sv, 0);
1123 if (old_type == new_type)
1126 if (old_type > new_type)
1127 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1128 (int)old_type, (int)new_type);
1131 old_body = SvANY(sv);
1133 /* Copying structures onto other structures that have been neatly zeroed
1134 has a subtle gotcha. Consider XPVMG
1136 +------+------+------+------+------+-------+-------+
1137 | NV | CUR | LEN | IV | MAGIC | STASH |
1138 +------+------+------+------+------+-------+-------+
1139 0 4 8 12 16 20 24 28
1141 where NVs are aligned to 8 bytes, so that sizeof that structure is
1142 actually 32 bytes long, with 4 bytes of padding at the end:
1144 +------+------+------+------+------+-------+-------+------+
1145 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1146 +------+------+------+------+------+-------+-------+------+
1147 0 4 8 12 16 20 24 28 32
1149 so what happens if you allocate memory for this structure:
1151 +------+------+------+------+------+-------+-------+------+------+...
1152 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1153 +------+------+------+------+------+-------+-------+------+------+...
1154 0 4 8 12 16 20 24 28 32 36
1156 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1157 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1158 started out as zero once, but it's quite possible that it isn't. So now,
1159 rather than a nicely zeroed GP, you have it pointing somewhere random.
1162 (In fact, GP ends up pointing at a previous GP structure, because the
1163 principle cause of the padding in XPVMG getting garbage is a copy of
1164 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1165 this happens to be moot because XPVGV has been re-ordered, with GP
1166 no longer after STASH)
1168 So we are careful and work out the size of used parts of all the
1175 if (new_type < SVt_PVIV) {
1176 new_type = (new_type == SVt_NV)
1177 ? SVt_PVNV : SVt_PVIV;
1181 if (new_type < SVt_PVNV) {
1182 new_type = SVt_PVNV;
1188 assert(new_type > SVt_PV);
1189 assert(SVt_IV < SVt_PV);
1190 assert(SVt_NV < SVt_PV);
1197 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1198 there's no way that it can be safely upgraded, because perl.c
1199 expects to Safefree(SvANY(PL_mess_sv)) */
1200 assert(sv != PL_mess_sv);
1201 /* This flag bit is used to mean other things in other scalar types.
1202 Given that it only has meaning inside the pad, it shouldn't be set
1203 on anything that can get upgraded. */
1204 assert(!SvPAD_TYPED(sv));
1207 if (old_type_details->cant_upgrade)
1208 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1209 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1211 new_type_details = bodies_by_type + new_type;
1213 SvFLAGS(sv) &= ~SVTYPEMASK;
1214 SvFLAGS(sv) |= new_type;
1216 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1217 the return statements above will have triggered. */
1218 assert (new_type != SVt_NULL);
1221 assert(old_type == SVt_NULL);
1222 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1226 assert(old_type == SVt_NULL);
1227 SvANY(sv) = new_XNV();
1231 assert(old_type == SVt_NULL);
1232 SvANY(sv) = &sv->sv_u.svu_rv;
1237 assert(new_type_details->body_size);
1240 assert(new_type_details->arena);
1241 assert(new_type_details->arena_size);
1242 /* This points to the start of the allocated area. */
1243 new_body_inline(new_body, new_type);
1244 Zero(new_body, new_type_details->body_size, char);
1245 new_body = ((char *)new_body) - new_type_details->offset;
1247 /* We always allocated the full length item with PURIFY. To do this
1248 we fake things so that arena is false for all 16 types.. */
1249 new_body = new_NOARENAZ(new_type_details);
1251 SvANY(sv) = new_body;
1252 if (new_type == SVt_PVAV) {
1256 if (old_type_details->body_size) {
1259 /* It will have been zeroed when the new body was allocated.
1260 Lets not write to it, in case it confuses a write-back
1266 #ifndef NODEFAULT_SHAREKEYS
1267 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1269 HvMAX(sv) = 7; /* (start with 8 buckets) */
1270 if (old_type_details->body_size) {
1273 /* It will have been zeroed when the new body was allocated.
1274 Lets not write to it, in case it confuses a write-back
1279 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1280 The target created by newSVrv also is, and it can have magic.
1281 However, it never has SvPVX set.
1283 if (old_type >= SVt_RV) {
1284 assert(SvPVX_const(sv) == 0);
1287 if (old_type >= SVt_PVMG) {
1288 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1289 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1291 sv->sv_u.svu_array = NULL; /* or svu_hash */
1297 /* XXX Is this still needed? Was it ever needed? Surely as there is
1298 no route from NV to PVIV, NOK can never be true */
1299 assert(!SvNOKp(sv));
1310 assert(new_type_details->body_size);
1311 /* We always allocated the full length item with PURIFY. To do this
1312 we fake things so that arena is false for all 16 types.. */
1313 if(new_type_details->arena) {
1314 /* This points to the start of the allocated area. */
1315 new_body_inline(new_body, new_type);
1316 Zero(new_body, new_type_details->body_size, char);
1317 new_body = ((char *)new_body) - new_type_details->offset;
1319 new_body = new_NOARENAZ(new_type_details);
1321 SvANY(sv) = new_body;
1323 if (old_type_details->copy) {
1324 /* There is now the potential for an upgrade from something without
1325 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1326 int offset = old_type_details->offset;
1327 int length = old_type_details->copy;
1329 if (new_type_details->offset > old_type_details->offset) {
1330 const int difference
1331 = new_type_details->offset - old_type_details->offset;
1332 offset += difference;
1333 length -= difference;
1335 assert (length >= 0);
1337 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1341 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1342 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1343 * correct 0.0 for us. Otherwise, if the old body didn't have an
1344 * NV slot, but the new one does, then we need to initialise the
1345 * freshly created NV slot with whatever the correct bit pattern is
1347 if (old_type_details->zero_nv && !new_type_details->zero_nv
1348 && !isGV_with_GP(sv))
1352 if (new_type == SVt_PVIO)
1353 IoPAGE_LEN(sv) = 60;
1354 if (old_type < SVt_RV)
1358 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1359 (unsigned long)new_type);
1362 if (old_type_details->arena) {
1363 /* If there was an old body, then we need to free it.
1364 Note that there is an assumption that all bodies of types that
1365 can be upgraded came from arenas. Only the more complex non-
1366 upgradable types are allowed to be directly malloc()ed. */
1368 my_safefree(old_body);
1370 del_body((void*)((char*)old_body + old_type_details->offset),
1371 &PL_body_roots[old_type]);
1377 =for apidoc sv_backoff
1379 Remove any string offset. You should normally use the C<SvOOK_off> macro
1386 Perl_sv_backoff(pTHX_ register SV *sv)
1388 PERL_UNUSED_CONTEXT;
1390 assert(SvTYPE(sv) != SVt_PVHV);
1391 assert(SvTYPE(sv) != SVt_PVAV);
1393 const char * const s = SvPVX_const(sv);
1394 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1395 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1397 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1399 SvFLAGS(sv) &= ~SVf_OOK;
1406 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1407 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1408 Use the C<SvGROW> wrapper instead.
1414 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1418 if (PL_madskills && newlen >= 0x100000) {
1419 PerlIO_printf(Perl_debug_log,
1420 "Allocation too large: %"UVxf"\n", (UV)newlen);
1422 #ifdef HAS_64K_LIMIT
1423 if (newlen >= 0x10000) {
1424 PerlIO_printf(Perl_debug_log,
1425 "Allocation too large: %"UVxf"\n", (UV)newlen);
1428 #endif /* HAS_64K_LIMIT */
1431 if (SvTYPE(sv) < SVt_PV) {
1432 sv_upgrade(sv, SVt_PV);
1433 s = SvPVX_mutable(sv);
1435 else if (SvOOK(sv)) { /* pv is offset? */
1437 s = SvPVX_mutable(sv);
1438 if (newlen > SvLEN(sv))
1439 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1440 #ifdef HAS_64K_LIMIT
1441 if (newlen >= 0x10000)
1446 s = SvPVX_mutable(sv);
1448 if (newlen > SvLEN(sv)) { /* need more room? */
1449 newlen = PERL_STRLEN_ROUNDUP(newlen);
1450 if (SvLEN(sv) && s) {
1452 const STRLEN l = malloced_size((void*)SvPVX_const(sv));
1458 s = (char*)saferealloc(s, newlen);
1461 s = (char*)safemalloc(newlen);
1462 if (SvPVX_const(sv) && SvCUR(sv)) {
1463 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1467 SvLEN_set(sv, newlen);
1473 =for apidoc sv_setiv
1475 Copies an integer into the given SV, upgrading first if necessary.
1476 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1482 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1485 SV_CHECK_THINKFIRST_COW_DROP(sv);
1486 switch (SvTYPE(sv)) {
1488 sv_upgrade(sv, SVt_IV);
1491 sv_upgrade(sv, SVt_PVNV);
1495 sv_upgrade(sv, SVt_PVIV);
1504 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1508 (void)SvIOK_only(sv); /* validate number */
1514 =for apidoc sv_setiv_mg
1516 Like C<sv_setiv>, but also handles 'set' magic.
1522 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1529 =for apidoc sv_setuv
1531 Copies an unsigned integer into the given SV, upgrading first if necessary.
1532 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1538 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1540 /* With these two if statements:
1541 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1544 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1546 If you wish to remove them, please benchmark to see what the effect is
1548 if (u <= (UV)IV_MAX) {
1549 sv_setiv(sv, (IV)u);
1558 =for apidoc sv_setuv_mg
1560 Like C<sv_setuv>, but also handles 'set' magic.
1566 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1573 =for apidoc sv_setnv
1575 Copies a double into the given SV, upgrading first if necessary.
1576 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1582 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1585 SV_CHECK_THINKFIRST_COW_DROP(sv);
1586 switch (SvTYPE(sv)) {
1589 sv_upgrade(sv, SVt_NV);
1594 sv_upgrade(sv, SVt_PVNV);
1603 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1608 (void)SvNOK_only(sv); /* validate number */
1613 =for apidoc sv_setnv_mg
1615 Like C<sv_setnv>, but also handles 'set' magic.
1621 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1627 /* Print an "isn't numeric" warning, using a cleaned-up,
1628 * printable version of the offending string
1632 S_not_a_number(pTHX_ SV *sv)
1640 dsv = sv_2mortal(newSVpvs(""));
1641 pv = sv_uni_display(dsv, sv, 10, 0);
1644 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1645 /* each *s can expand to 4 chars + "...\0",
1646 i.e. need room for 8 chars */
1648 const char *s = SvPVX_const(sv);
1649 const char * const end = s + SvCUR(sv);
1650 for ( ; s < end && d < limit; s++ ) {
1652 if (ch & 128 && !isPRINT_LC(ch)) {
1661 else if (ch == '\r') {
1665 else if (ch == '\f') {
1669 else if (ch == '\\') {
1673 else if (ch == '\0') {
1677 else if (isPRINT_LC(ch))
1694 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1695 "Argument \"%s\" isn't numeric in %s", pv,
1698 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1699 "Argument \"%s\" isn't numeric", pv);
1703 =for apidoc looks_like_number
1705 Test if the content of an SV looks like a number (or is a number).
1706 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1707 non-numeric warning), even if your atof() doesn't grok them.
1713 Perl_looks_like_number(pTHX_ SV *sv)
1715 register const char *sbegin;
1719 sbegin = SvPVX_const(sv);
1722 else if (SvPOKp(sv))
1723 sbegin = SvPV_const(sv, len);
1725 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1726 return grok_number(sbegin, len, NULL);
1730 S_glob_2number(pTHX_ GV * const gv)
1732 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1733 SV *const buffer = sv_newmortal();
1735 /* FAKE globs can get coerced, so need to turn this off temporarily if it
1738 gv_efullname3(buffer, gv, "*");
1739 SvFLAGS(gv) |= wasfake;
1741 /* We know that all GVs stringify to something that is not-a-number,
1742 so no need to test that. */
1743 if (ckWARN(WARN_NUMERIC))
1744 not_a_number(buffer);
1745 /* We just want something true to return, so that S_sv_2iuv_common
1746 can tail call us and return true. */
1751 S_glob_2pv(pTHX_ GV * const gv, STRLEN * const len)
1753 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1754 SV *const buffer = sv_newmortal();
1756 /* FAKE globs can get coerced, so need to turn this off temporarily if it
1759 gv_efullname3(buffer, gv, "*");
1760 SvFLAGS(gv) |= wasfake;
1762 assert(SvPOK(buffer));
1764 *len = SvCUR(buffer);
1766 return SvPVX(buffer);
1769 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1770 until proven guilty, assume that things are not that bad... */
1775 As 64 bit platforms often have an NV that doesn't preserve all bits of
1776 an IV (an assumption perl has been based on to date) it becomes necessary
1777 to remove the assumption that the NV always carries enough precision to
1778 recreate the IV whenever needed, and that the NV is the canonical form.
1779 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1780 precision as a side effect of conversion (which would lead to insanity
1781 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1782 1) to distinguish between IV/UV/NV slots that have cached a valid
1783 conversion where precision was lost and IV/UV/NV slots that have a
1784 valid conversion which has lost no precision
1785 2) to ensure that if a numeric conversion to one form is requested that
1786 would lose precision, the precise conversion (or differently
1787 imprecise conversion) is also performed and cached, to prevent
1788 requests for different numeric formats on the same SV causing
1789 lossy conversion chains. (lossless conversion chains are perfectly
1794 SvIOKp is true if the IV slot contains a valid value
1795 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1796 SvNOKp is true if the NV slot contains a valid value
1797 SvNOK is true only if the NV value is accurate
1800 while converting from PV to NV, check to see if converting that NV to an
1801 IV(or UV) would lose accuracy over a direct conversion from PV to
1802 IV(or UV). If it would, cache both conversions, return NV, but mark
1803 SV as IOK NOKp (ie not NOK).
1805 While converting from PV to IV, check to see if converting that IV to an
1806 NV would lose accuracy over a direct conversion from PV to NV. If it
1807 would, cache both conversions, flag similarly.
1809 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1810 correctly because if IV & NV were set NV *always* overruled.
1811 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1812 changes - now IV and NV together means that the two are interchangeable:
1813 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1815 The benefit of this is that operations such as pp_add know that if
1816 SvIOK is true for both left and right operands, then integer addition
1817 can be used instead of floating point (for cases where the result won't
1818 overflow). Before, floating point was always used, which could lead to
1819 loss of precision compared with integer addition.
1821 * making IV and NV equal status should make maths accurate on 64 bit
1823 * may speed up maths somewhat if pp_add and friends start to use
1824 integers when possible instead of fp. (Hopefully the overhead in
1825 looking for SvIOK and checking for overflow will not outweigh the
1826 fp to integer speedup)
1827 * will slow down integer operations (callers of SvIV) on "inaccurate"
1828 values, as the change from SvIOK to SvIOKp will cause a call into
1829 sv_2iv each time rather than a macro access direct to the IV slot
1830 * should speed up number->string conversion on integers as IV is
1831 favoured when IV and NV are equally accurate
1833 ####################################################################
1834 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1835 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1836 On the other hand, SvUOK is true iff UV.
1837 ####################################################################
1839 Your mileage will vary depending your CPU's relative fp to integer
1843 #ifndef NV_PRESERVES_UV
1844 # define IS_NUMBER_UNDERFLOW_IV 1
1845 # define IS_NUMBER_UNDERFLOW_UV 2
1846 # define IS_NUMBER_IV_AND_UV 2
1847 # define IS_NUMBER_OVERFLOW_IV 4
1848 # define IS_NUMBER_OVERFLOW_UV 5
1850 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1852 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1854 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
1857 PERL_UNUSED_ARG(numtype); /* Used only under DEBUGGING? */
1858 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));
1859 if (SvNVX(sv) < (NV)IV_MIN) {
1860 (void)SvIOKp_on(sv);
1862 SvIV_set(sv, IV_MIN);
1863 return IS_NUMBER_UNDERFLOW_IV;
1865 if (SvNVX(sv) > (NV)UV_MAX) {
1866 (void)SvIOKp_on(sv);
1869 SvUV_set(sv, UV_MAX);
1870 return IS_NUMBER_OVERFLOW_UV;
1872 (void)SvIOKp_on(sv);
1874 /* Can't use strtol etc to convert this string. (See truth table in
1876 if (SvNVX(sv) <= (UV)IV_MAX) {
1877 SvIV_set(sv, I_V(SvNVX(sv)));
1878 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1879 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1881 /* Integer is imprecise. NOK, IOKp */
1883 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1886 SvUV_set(sv, U_V(SvNVX(sv)));
1887 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1888 if (SvUVX(sv) == UV_MAX) {
1889 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1890 possibly be preserved by NV. Hence, it must be overflow.
1892 return IS_NUMBER_OVERFLOW_UV;
1894 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1896 /* Integer is imprecise. NOK, IOKp */
1898 return IS_NUMBER_OVERFLOW_IV;
1900 #endif /* !NV_PRESERVES_UV*/
1903 S_sv_2iuv_common(pTHX_ SV *sv) {
1906 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1907 * without also getting a cached IV/UV from it at the same time
1908 * (ie PV->NV conversion should detect loss of accuracy and cache
1909 * IV or UV at same time to avoid this. */
1910 /* IV-over-UV optimisation - choose to cache IV if possible */
1912 if (SvTYPE(sv) == SVt_NV)
1913 sv_upgrade(sv, SVt_PVNV);
1915 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1916 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1917 certainly cast into the IV range at IV_MAX, whereas the correct
1918 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1920 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1921 if (Perl_isnan(SvNVX(sv))) {
1927 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1928 SvIV_set(sv, I_V(SvNVX(sv)));
1929 if (SvNVX(sv) == (NV) SvIVX(sv)
1930 #ifndef NV_PRESERVES_UV
1931 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1932 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1933 /* Don't flag it as "accurately an integer" if the number
1934 came from a (by definition imprecise) NV operation, and
1935 we're outside the range of NV integer precision */
1938 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1939 DEBUG_c(PerlIO_printf(Perl_debug_log,
1940 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
1946 /* IV not precise. No need to convert from PV, as NV
1947 conversion would already have cached IV if it detected
1948 that PV->IV would be better than PV->NV->IV
1949 flags already correct - don't set public IOK. */
1950 DEBUG_c(PerlIO_printf(Perl_debug_log,
1951 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
1956 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1957 but the cast (NV)IV_MIN rounds to a the value less (more
1958 negative) than IV_MIN which happens to be equal to SvNVX ??
1959 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1960 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1961 (NV)UVX == NVX are both true, but the values differ. :-(
1962 Hopefully for 2s complement IV_MIN is something like
1963 0x8000000000000000 which will be exact. NWC */
1966 SvUV_set(sv, U_V(SvNVX(sv)));
1968 (SvNVX(sv) == (NV) SvUVX(sv))
1969 #ifndef NV_PRESERVES_UV
1970 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1971 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1972 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1973 /* Don't flag it as "accurately an integer" if the number
1974 came from a (by definition imprecise) NV operation, and
1975 we're outside the range of NV integer precision */
1980 DEBUG_c(PerlIO_printf(Perl_debug_log,
1981 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1987 else if (SvPOKp(sv) && SvLEN(sv)) {
1989 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
1990 /* We want to avoid a possible problem when we cache an IV/ a UV which
1991 may be later translated to an NV, and the resulting NV is not
1992 the same as the direct translation of the initial string
1993 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
1994 be careful to ensure that the value with the .456 is around if the
1995 NV value is requested in the future).
1997 This means that if we cache such an IV/a UV, we need to cache the
1998 NV as well. Moreover, we trade speed for space, and do not
1999 cache the NV if we are sure it's not needed.
2002 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2003 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2004 == IS_NUMBER_IN_UV) {
2005 /* It's definitely an integer, only upgrade to PVIV */
2006 if (SvTYPE(sv) < SVt_PVIV)
2007 sv_upgrade(sv, SVt_PVIV);
2009 } else if (SvTYPE(sv) < SVt_PVNV)
2010 sv_upgrade(sv, SVt_PVNV);
2012 /* If NVs preserve UVs then we only use the UV value if we know that
2013 we aren't going to call atof() below. If NVs don't preserve UVs
2014 then the value returned may have more precision than atof() will
2015 return, even though value isn't perfectly accurate. */
2016 if ((numtype & (IS_NUMBER_IN_UV
2017 #ifdef NV_PRESERVES_UV
2020 )) == IS_NUMBER_IN_UV) {
2021 /* This won't turn off the public IOK flag if it was set above */
2022 (void)SvIOKp_on(sv);
2024 if (!(numtype & IS_NUMBER_NEG)) {
2026 if (value <= (UV)IV_MAX) {
2027 SvIV_set(sv, (IV)value);
2029 /* it didn't overflow, and it was positive. */
2030 SvUV_set(sv, value);
2034 /* 2s complement assumption */
2035 if (value <= (UV)IV_MIN) {
2036 SvIV_set(sv, -(IV)value);
2038 /* Too negative for an IV. This is a double upgrade, but
2039 I'm assuming it will be rare. */
2040 if (SvTYPE(sv) < SVt_PVNV)
2041 sv_upgrade(sv, SVt_PVNV);
2045 SvNV_set(sv, -(NV)value);
2046 SvIV_set(sv, IV_MIN);
2050 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2051 will be in the previous block to set the IV slot, and the next
2052 block to set the NV slot. So no else here. */
2054 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2055 != IS_NUMBER_IN_UV) {
2056 /* It wasn't an (integer that doesn't overflow the UV). */
2057 SvNV_set(sv, Atof(SvPVX_const(sv)));
2059 if (! numtype && ckWARN(WARN_NUMERIC))
2062 #if defined(USE_LONG_DOUBLE)
2063 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2064 PTR2UV(sv), SvNVX(sv)));
2066 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2067 PTR2UV(sv), SvNVX(sv)));
2070 #ifdef NV_PRESERVES_UV
2071 (void)SvIOKp_on(sv);
2073 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2074 SvIV_set(sv, I_V(SvNVX(sv)));
2075 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2078 NOOP; /* Integer is imprecise. NOK, IOKp */
2080 /* UV will not work better than IV */
2082 if (SvNVX(sv) > (NV)UV_MAX) {
2084 /* Integer is inaccurate. NOK, IOKp, is UV */
2085 SvUV_set(sv, UV_MAX);
2087 SvUV_set(sv, U_V(SvNVX(sv)));
2088 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2089 NV preservse UV so can do correct comparison. */
2090 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2093 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
2098 #else /* NV_PRESERVES_UV */
2099 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2100 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2101 /* The IV/UV slot will have been set from value returned by
2102 grok_number above. The NV slot has just been set using
2105 assert (SvIOKp(sv));
2107 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2108 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2109 /* Small enough to preserve all bits. */
2110 (void)SvIOKp_on(sv);
2112 SvIV_set(sv, I_V(SvNVX(sv)));
2113 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2115 /* Assumption: first non-preserved integer is < IV_MAX,
2116 this NV is in the preserved range, therefore: */
2117 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2119 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);
2123 0 0 already failed to read UV.
2124 0 1 already failed to read UV.
2125 1 0 you won't get here in this case. IV/UV
2126 slot set, public IOK, Atof() unneeded.
2127 1 1 already read UV.
2128 so there's no point in sv_2iuv_non_preserve() attempting
2129 to use atol, strtol, strtoul etc. */
2130 sv_2iuv_non_preserve (sv, numtype);
2133 #endif /* NV_PRESERVES_UV */
2137 if (isGV_with_GP(sv))
2138 return glob_2number((GV *)sv);
2140 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2141 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2144 if (SvTYPE(sv) < SVt_IV)
2145 /* Typically the caller expects that sv_any is not NULL now. */
2146 sv_upgrade(sv, SVt_IV);
2147 /* Return 0 from the caller. */
2154 =for apidoc sv_2iv_flags
2156 Return the integer value of an SV, doing any necessary string
2157 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2158 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2164 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2169 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2170 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2171 cache IVs just in case. In practice it seems that they never
2172 actually anywhere accessible by user Perl code, let alone get used
2173 in anything other than a string context. */
2174 if (flags & SV_GMAGIC)
2179 return I_V(SvNVX(sv));
2181 if (SvPOKp(sv) && SvLEN(sv)) {
2184 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2186 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2187 == IS_NUMBER_IN_UV) {
2188 /* It's definitely an integer */
2189 if (numtype & IS_NUMBER_NEG) {
2190 if (value < (UV)IV_MIN)
2193 if (value < (UV)IV_MAX)
2198 if (ckWARN(WARN_NUMERIC))
2201 return I_V(Atof(SvPVX_const(sv)));
2206 assert(SvTYPE(sv) >= SVt_PVMG);
2207 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2208 } else if (SvTHINKFIRST(sv)) {
2212 SV * const tmpstr=AMG_CALLun(sv,numer);
2213 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2214 return SvIV(tmpstr);
2217 return PTR2IV(SvRV(sv));
2220 sv_force_normal_flags(sv, 0);
2222 if (SvREADONLY(sv) && !SvOK(sv)) {
2223 if (ckWARN(WARN_UNINITIALIZED))
2229 if (S_sv_2iuv_common(aTHX_ sv))
2232 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2233 PTR2UV(sv),SvIVX(sv)));
2234 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2238 =for apidoc sv_2uv_flags
2240 Return the unsigned integer value of an SV, doing any necessary string
2241 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2242 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2248 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2253 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2254 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2255 cache IVs just in case. */
2256 if (flags & SV_GMAGIC)
2261 return U_V(SvNVX(sv));
2262 if (SvPOKp(sv) && SvLEN(sv)) {
2265 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2267 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2268 == IS_NUMBER_IN_UV) {
2269 /* It's definitely an integer */
2270 if (!(numtype & IS_NUMBER_NEG))
2274 if (ckWARN(WARN_NUMERIC))
2277 return U_V(Atof(SvPVX_const(sv)));
2282 assert(SvTYPE(sv) >= SVt_PVMG);
2283 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2284 } else if (SvTHINKFIRST(sv)) {
2288 SV *const tmpstr = AMG_CALLun(sv,numer);
2289 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2290 return SvUV(tmpstr);
2293 return PTR2UV(SvRV(sv));
2296 sv_force_normal_flags(sv, 0);
2298 if (SvREADONLY(sv) && !SvOK(sv)) {
2299 if (ckWARN(WARN_UNINITIALIZED))
2305 if (S_sv_2iuv_common(aTHX_ sv))
2309 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2310 PTR2UV(sv),SvUVX(sv)));
2311 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2317 Return the num value of an SV, doing any necessary string or integer
2318 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2325 Perl_sv_2nv(pTHX_ register SV *sv)
2330 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2331 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2332 cache IVs just in case. */
2336 if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2337 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2338 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2340 return Atof(SvPVX_const(sv));
2344 return (NV)SvUVX(sv);
2346 return (NV)SvIVX(sv);
2351 assert(SvTYPE(sv) >= SVt_PVMG);
2352 /* This falls through to the report_uninit near the end of the
2354 } else if (SvTHINKFIRST(sv)) {
2358 SV *const tmpstr = AMG_CALLun(sv,numer);
2359 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2360 return SvNV(tmpstr);
2363 return PTR2NV(SvRV(sv));
2366 sv_force_normal_flags(sv, 0);
2368 if (SvREADONLY(sv) && !SvOK(sv)) {
2369 if (ckWARN(WARN_UNINITIALIZED))
2374 if (SvTYPE(sv) < SVt_NV) {
2375 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2376 sv_upgrade(sv, SVt_NV);
2377 #ifdef USE_LONG_DOUBLE
2379 STORE_NUMERIC_LOCAL_SET_STANDARD();
2380 PerlIO_printf(Perl_debug_log,
2381 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2382 PTR2UV(sv), SvNVX(sv));
2383 RESTORE_NUMERIC_LOCAL();
2387 STORE_NUMERIC_LOCAL_SET_STANDARD();
2388 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2389 PTR2UV(sv), SvNVX(sv));
2390 RESTORE_NUMERIC_LOCAL();
2394 else if (SvTYPE(sv) < SVt_PVNV)
2395 sv_upgrade(sv, SVt_PVNV);
2400 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2401 #ifdef NV_PRESERVES_UV
2404 /* Only set the public NV OK flag if this NV preserves the IV */
2405 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2406 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2407 : (SvIVX(sv) == I_V(SvNVX(sv))))
2413 else if (SvPOKp(sv) && SvLEN(sv)) {
2415 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2416 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2418 #ifdef NV_PRESERVES_UV
2419 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2420 == IS_NUMBER_IN_UV) {
2421 /* It's definitely an integer */
2422 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2424 SvNV_set(sv, Atof(SvPVX_const(sv)));
2427 SvNV_set(sv, Atof(SvPVX_const(sv)));
2428 /* Only set the public NV OK flag if this NV preserves the value in
2429 the PV at least as well as an IV/UV would.
2430 Not sure how to do this 100% reliably. */
2431 /* if that shift count is out of range then Configure's test is
2432 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2434 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2435 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2436 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2437 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2438 /* Can't use strtol etc to convert this string, so don't try.
2439 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2442 /* value has been set. It may not be precise. */
2443 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2444 /* 2s complement assumption for (UV)IV_MIN */
2445 SvNOK_on(sv); /* Integer is too negative. */
2450 if (numtype & IS_NUMBER_NEG) {
2451 SvIV_set(sv, -(IV)value);
2452 } else if (value <= (UV)IV_MAX) {
2453 SvIV_set(sv, (IV)value);
2455 SvUV_set(sv, value);
2459 if (numtype & IS_NUMBER_NOT_INT) {
2460 /* I believe that even if the original PV had decimals,
2461 they are lost beyond the limit of the FP precision.
2462 However, neither is canonical, so both only get p
2463 flags. NWC, 2000/11/25 */
2464 /* Both already have p flags, so do nothing */
2466 const NV nv = SvNVX(sv);
2467 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2468 if (SvIVX(sv) == I_V(nv)) {
2471 /* It had no "." so it must be integer. */
2475 /* between IV_MAX and NV(UV_MAX).
2476 Could be slightly > UV_MAX */
2478 if (numtype & IS_NUMBER_NOT_INT) {
2479 /* UV and NV both imprecise. */
2481 const UV nv_as_uv = U_V(nv);
2483 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2492 #endif /* NV_PRESERVES_UV */
2495 if (isGV_with_GP(sv)) {
2496 glob_2number((GV *)sv);
2500 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2502 assert (SvTYPE(sv) >= SVt_NV);
2503 /* Typically the caller expects that sv_any is not NULL now. */
2504 /* XXX Ilya implies that this is a bug in callers that assume this
2505 and ideally should be fixed. */
2508 #if defined(USE_LONG_DOUBLE)
2510 STORE_NUMERIC_LOCAL_SET_STANDARD();
2511 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2512 PTR2UV(sv), SvNVX(sv));
2513 RESTORE_NUMERIC_LOCAL();
2517 STORE_NUMERIC_LOCAL_SET_STANDARD();
2518 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2519 PTR2UV(sv), SvNVX(sv));
2520 RESTORE_NUMERIC_LOCAL();
2529 Return an SV with the numeric value of the source SV, doing any necessary
2530 reference or overload conversion. You must use the C<SvNUM(sv)> macro to
2531 access this function.
2537 Perl_sv_2num(pTHX_ register SV *sv)
2542 SV * const tmpsv = AMG_CALLun(sv,numer);
2543 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2544 return sv_2num(tmpsv);
2546 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2549 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2550 * UV as a string towards the end of buf, and return pointers to start and
2553 * We assume that buf is at least TYPE_CHARS(UV) long.
2557 S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2559 char *ptr = buf + TYPE_CHARS(UV);
2560 char * const ebuf = ptr;
2573 *--ptr = '0' + (char)(uv % 10);
2582 =for apidoc sv_2pv_flags
2584 Returns a pointer to the string value of an SV, and sets *lp to its length.
2585 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2587 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2588 usually end up here too.
2594 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2604 if (SvGMAGICAL(sv)) {
2605 if (flags & SV_GMAGIC)
2610 if (flags & SV_MUTABLE_RETURN)
2611 return SvPVX_mutable(sv);
2612 if (flags & SV_CONST_RETURN)
2613 return (char *)SvPVX_const(sv);
2616 if (SvIOKp(sv) || SvNOKp(sv)) {
2617 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2622 ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2623 : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2625 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2632 #ifdef FIXNEGATIVEZERO
2633 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2639 SvUPGRADE(sv, SVt_PV);
2642 s = SvGROW_mutable(sv, len + 1);
2645 return (char*)memcpy(s, tbuf, len + 1);
2651 assert(SvTYPE(sv) >= SVt_PVMG);
2652 /* This falls through to the report_uninit near the end of the
2654 } else if (SvTHINKFIRST(sv)) {
2658 SV *const tmpstr = AMG_CALLun(sv,string);
2659 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2661 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2665 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2666 if (flags & SV_CONST_RETURN) {
2667 pv = (char *) SvPVX_const(tmpstr);
2669 pv = (flags & SV_MUTABLE_RETURN)
2670 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2673 *lp = SvCUR(tmpstr);
2675 pv = sv_2pv_flags(tmpstr, lp, flags);
2689 const SV *const referent = (SV*)SvRV(sv);
2693 retval = buffer = savepvn("NULLREF", len);
2694 } else if (SvTYPE(referent) == SVt_PVMG
2695 && ((SvFLAGS(referent) &
2696 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2697 == (SVs_OBJECT|SVs_SMG))
2698 && (mg = mg_find(referent, PERL_MAGIC_qr)))
2703 (str) = CALLREG_AS_STR(mg,lp,&flags,&haseval);
2708 PL_reginterp_cnt += haseval;
2711 const char *const typestr = sv_reftype(referent, 0);
2712 const STRLEN typelen = strlen(typestr);
2713 UV addr = PTR2UV(referent);
2714 const char *stashname = NULL;
2715 STRLEN stashnamelen = 0; /* hush, gcc */
2716 const char *buffer_end;
2718 if (SvOBJECT(referent)) {
2719 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2722 stashname = HEK_KEY(name);
2723 stashnamelen = HEK_LEN(name);
2725 if (HEK_UTF8(name)) {
2731 stashname = "__ANON__";
2734 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2735 + 2 * sizeof(UV) + 2 /* )\0 */;
2737 len = typelen + 3 /* (0x */
2738 + 2 * sizeof(UV) + 2 /* )\0 */;
2741 Newx(buffer, len, char);
2742 buffer_end = retval = buffer + len;
2744 /* Working backwards */
2748 *--retval = PL_hexdigit[addr & 15];
2749 } while (addr >>= 4);
2755 memcpy(retval, typestr, typelen);
2759 retval -= stashnamelen;
2760 memcpy(retval, stashname, stashnamelen);
2762 /* retval may not neccesarily have reached the start of the
2764 assert (retval >= buffer);
2766 len = buffer_end - retval - 1; /* -1 for that \0 */
2774 if (SvREADONLY(sv) && !SvOK(sv)) {
2775 if (ckWARN(WARN_UNINITIALIZED))
2782 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2783 /* I'm assuming that if both IV and NV are equally valid then
2784 converting the IV is going to be more efficient */
2785 const U32 isUIOK = SvIsUV(sv);
2786 char buf[TYPE_CHARS(UV)];
2790 if (SvTYPE(sv) < SVt_PVIV)
2791 sv_upgrade(sv, SVt_PVIV);
2792 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2794 /* inlined from sv_setpvn */
2795 s = SvGROW_mutable(sv, len + 1);
2796 Move(ptr, s, len, char);
2800 else if (SvNOKp(sv)) {
2801 const int olderrno = errno;
2802 if (SvTYPE(sv) < SVt_PVNV)
2803 sv_upgrade(sv, SVt_PVNV);
2804 /* The +20 is pure guesswork. Configure test needed. --jhi */
2805 s = SvGROW_mutable(sv, NV_DIG + 20);
2806 /* some Xenix systems wipe out errno here */
2808 if (SvNVX(sv) == 0.0)
2809 my_strlcpy(s, "0", SvLEN(sv));
2813 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2816 #ifdef FIXNEGATIVEZERO
2817 if (*s == '-' && s[1] == '0' && !s[2]) {
2829 if (isGV_with_GP(sv))
2830 return glob_2pv((GV *)sv, lp);
2832 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2836 if (SvTYPE(sv) < SVt_PV)
2837 /* Typically the caller expects that sv_any is not NULL now. */
2838 sv_upgrade(sv, SVt_PV);
2842 const STRLEN len = s - SvPVX_const(sv);
2848 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2849 PTR2UV(sv),SvPVX_const(sv)));
2850 if (flags & SV_CONST_RETURN)
2851 return (char *)SvPVX_const(sv);
2852 if (flags & SV_MUTABLE_RETURN)
2853 return SvPVX_mutable(sv);
2858 =for apidoc sv_copypv
2860 Copies a stringified representation of the source SV into the
2861 destination SV. Automatically performs any necessary mg_get and
2862 coercion of numeric values into strings. Guaranteed to preserve
2863 UTF8 flag even from overloaded objects. Similar in nature to
2864 sv_2pv[_flags] but operates directly on an SV instead of just the
2865 string. Mostly uses sv_2pv_flags to do its work, except when that
2866 would lose the UTF-8'ness of the PV.
2872 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
2875 const char * const s = SvPV_const(ssv,len);
2876 sv_setpvn(dsv,s,len);
2884 =for apidoc sv_2pvbyte
2886 Return a pointer to the byte-encoded representation of the SV, and set *lp
2887 to its length. May cause the SV to be downgraded from UTF-8 as a
2890 Usually accessed via the C<SvPVbyte> macro.
2896 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2898 sv_utf8_downgrade(sv,0);
2899 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
2903 =for apidoc sv_2pvutf8
2905 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
2906 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
2908 Usually accessed via the C<SvPVutf8> macro.
2914 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2916 sv_utf8_upgrade(sv);
2917 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
2922 =for apidoc sv_2bool
2924 This function is only called on magical items, and is only used by
2925 sv_true() or its macro equivalent.
2931 Perl_sv_2bool(pTHX_ register SV *sv)
2940 SV * const tmpsv = AMG_CALLun(sv,bool_);
2941 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2942 return (bool)SvTRUE(tmpsv);
2944 return SvRV(sv) != 0;
2947 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
2949 (*sv->sv_u.svu_pv > '0' ||
2950 Xpvtmp->xpv_cur > 1 ||
2951 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
2958 return SvIVX(sv) != 0;
2961 return SvNVX(sv) != 0.0;
2963 if (isGV_with_GP(sv))
2973 =for apidoc sv_utf8_upgrade
2975 Converts the PV of an SV to its UTF-8-encoded form.
2976 Forces the SV to string form if it is not already.
2977 Always sets the SvUTF8 flag to avoid future validity checks even
2978 if all the bytes have hibit clear.
2980 This is not as a general purpose byte encoding to Unicode interface:
2981 use the Encode extension for that.
2983 =for apidoc sv_utf8_upgrade_flags
2985 Converts the PV of an SV to its UTF-8-encoded form.
2986 Forces the SV to string form if it is not already.
2987 Always sets the SvUTF8 flag to avoid future validity checks even
2988 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
2989 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
2990 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
2992 This is not as a general purpose byte encoding to Unicode interface:
2993 use the Encode extension for that.
2999 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3002 if (sv == &PL_sv_undef)
3006 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3007 (void) sv_2pv_flags(sv,&len, flags);
3011 (void) SvPV_force(sv,len);
3020 sv_force_normal_flags(sv, 0);
3023 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3024 sv_recode_to_utf8(sv, PL_encoding);
3025 else { /* Assume Latin-1/EBCDIC */
3026 /* This function could be much more efficient if we
3027 * had a FLAG in SVs to signal if there are any hibit
3028 * chars in the PV. Given that there isn't such a flag
3029 * make the loop as fast as possible. */
3030 const U8 * const s = (U8 *) SvPVX_const(sv);
3031 const U8 * const e = (U8 *) SvEND(sv);
3036 /* Check for hi bit */
3037 if (!NATIVE_IS_INVARIANT(ch)) {
3038 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3039 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
3041 SvPV_free(sv); /* No longer using what was there before. */
3042 SvPV_set(sv, (char*)recoded);
3043 SvCUR_set(sv, len - 1);
3044 SvLEN_set(sv, len); /* No longer know the real size. */
3048 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3055 =for apidoc sv_utf8_downgrade
3057 Attempts to convert the PV of an SV from characters to bytes.
3058 If the PV contains a character beyond byte, this conversion will fail;
3059 in this case, either returns false or, if C<fail_ok> is not
3062 This is not as a general purpose Unicode to byte encoding interface:
3063 use the Encode extension for that.
3069 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3072 if (SvPOKp(sv) && SvUTF8(sv)) {
3078 sv_force_normal_flags(sv, 0);
3080 s = (U8 *) SvPV(sv, len);
3081 if (!utf8_to_bytes(s, &len)) {
3086 Perl_croak(aTHX_ "Wide character in %s",
3089 Perl_croak(aTHX_ "Wide character");
3100 =for apidoc sv_utf8_encode
3102 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3103 flag off so that it looks like octets again.
3109 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3112 sv_force_normal_flags(sv, 0);
3114 if (SvREADONLY(sv)) {
3115 Perl_croak(aTHX_ PL_no_modify);
3117 (void) sv_utf8_upgrade(sv);
3122 =for apidoc sv_utf8_decode
3124 If the PV of the SV is an octet sequence in UTF-8
3125 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3126 so that it looks like a character. If the PV contains only single-byte
3127 characters, the C<SvUTF8> flag stays being off.
3128 Scans PV for validity and returns false if the PV is invalid UTF-8.
3134 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3140 /* The octets may have got themselves encoded - get them back as
3143 if (!sv_utf8_downgrade(sv, TRUE))
3146 /* it is actually just a matter of turning the utf8 flag on, but
3147 * we want to make sure everything inside is valid utf8 first.
3149 c = (const U8 *) SvPVX_const(sv);
3150 if (!is_utf8_string(c, SvCUR(sv)+1))
3152 e = (const U8 *) SvEND(sv);
3155 if (!UTF8_IS_INVARIANT(ch)) {
3165 =for apidoc sv_setsv
3167 Copies the contents of the source SV C<ssv> into the destination SV
3168 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3169 function if the source SV needs to be reused. Does not handle 'set' magic.
3170 Loosely speaking, it performs a copy-by-value, obliterating any previous
3171 content of the destination.
3173 You probably want to use one of the assortment of wrappers, such as
3174 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3175 C<SvSetMagicSV_nosteal>.
3177 =for apidoc sv_setsv_flags
3179 Copies the contents of the source SV C<ssv> into the destination SV
3180 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3181 function if the source SV needs to be reused. Does not handle 'set' magic.
3182 Loosely speaking, it performs a copy-by-value, obliterating any previous
3183 content of the destination.
3184 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3185 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3186 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3187 and C<sv_setsv_nomg> are implemented in terms of this function.
3189 You probably want to use one of the assortment of wrappers, such as
3190 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3191 C<SvSetMagicSV_nosteal>.
3193 This is the primary function for copying scalars, and most other
3194 copy-ish functions and macros use this underneath.
3200 S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype)
3202 I32 mro_changes = 0; /* 1 = method, 2 = isa */
3204 if (dtype != SVt_PVGV) {
3205 const char * const name = GvNAME(sstr);
3206 const STRLEN len = GvNAMELEN(sstr);
3208 if (dtype >= SVt_PV) {
3214 SvUPGRADE(dstr, SVt_PVGV);
3215 (void)SvOK_off(dstr);
3216 /* FIXME - why are we doing this, then turning it off and on again
3218 isGV_with_GP_on(dstr);
3220 GvSTASH(dstr) = GvSTASH(sstr);
3222 Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3223 gv_name_set((GV *)dstr, name, len, GV_ADD);
3224 SvFAKE_on(dstr); /* can coerce to non-glob */
3227 #ifdef GV_UNIQUE_CHECK
3228 if (GvUNIQUE((GV*)dstr)) {
3229 Perl_croak(aTHX_ PL_no_modify);
3233 if(GvGP((GV*)sstr)) {
3234 /* If source has method cache entry, clear it */
3236 SvREFCNT_dec(GvCV(sstr));
3240 /* If source has a real method, then a method is
3242 else if(GvCV((GV*)sstr)) {
3247 /* If dest already had a real method, that's a change as well */
3248 if(!mro_changes && GvGP((GV*)dstr) && GvCVu((GV*)dstr)) {
3252 if(strEQ(GvNAME((GV*)dstr),"ISA"))
3256 isGV_with_GP_off(dstr);
3257 (void)SvOK_off(dstr);
3258 isGV_with_GP_on(dstr);
3259 GvINTRO_off(dstr); /* one-shot flag */
3260 GvGP(dstr) = gp_ref(GvGP(sstr));
3261 if (SvTAINTED(sstr))
3263 if (GvIMPORTED(dstr) != GVf_IMPORTED
3264 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3266 GvIMPORTED_on(dstr);
3269 if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
3270 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3275 S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) {
3276 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3278 const int intro = GvINTRO(dstr);
3281 const U32 stype = SvTYPE(sref);
3284 #ifdef GV_UNIQUE_CHECK
3285 if (GvUNIQUE((GV*)dstr)) {
3286 Perl_croak(aTHX_ PL_no_modify);
3291 GvINTRO_off(dstr); /* one-shot flag */
3292 GvLINE(dstr) = CopLINE(PL_curcop);
3293 GvEGV(dstr) = (GV*)dstr;
3298 location = (SV **) &GvCV(dstr);
3299 import_flag = GVf_IMPORTED_CV;
3302 location = (SV **) &GvHV(dstr);
3303 import_flag = GVf_IMPORTED_HV;
3306 location = (SV **) &GvAV(dstr);
3307 import_flag = GVf_IMPORTED_AV;
3310 location = (SV **) &GvIOp(dstr);
3313 location = (SV **) &GvFORM(dstr);
3315 location = &GvSV(dstr);
3316 import_flag = GVf_IMPORTED_SV;
3319 if (stype == SVt_PVCV) {
3320 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (CV*)sref || GvCVGEN(dstr))) {*/
3321 if (GvCVGEN(dstr)) {
3322 SvREFCNT_dec(GvCV(dstr));
3324 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3327 SAVEGENERICSV(*location);
3331 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3332 CV* const cv = (CV*)*location;
3334 if (!GvCVGEN((GV*)dstr) &&
3335 (CvROOT(cv) || CvXSUB(cv)))
3337 /* Redefining a sub - warning is mandatory if
3338 it was a const and its value changed. */
3339 if (CvCONST(cv) && CvCONST((CV*)sref)
3340 && cv_const_sv(cv) == cv_const_sv((CV*)sref)) {
3342 /* They are 2 constant subroutines generated from
3343 the same constant. This probably means that
3344 they are really the "same" proxy subroutine
3345 instantiated in 2 places. Most likely this is
3346 when a constant is exported twice. Don't warn.
3349 else if (ckWARN(WARN_REDEFINE)
3351 && (!CvCONST((CV*)sref)
3352 || sv_cmp(cv_const_sv(cv),
3353 cv_const_sv((CV*)sref))))) {
3354 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3357 ? "Constant subroutine %s::%s redefined"
3358 : "Subroutine %s::%s redefined"),
3359 HvNAME_get(GvSTASH((GV*)dstr)),
3360 GvENAME((GV*)dstr));
3364 cv_ckproto_len(cv, (GV*)dstr,
3365 SvPOK(sref) ? SvPVX_const(sref) : NULL,
3366 SvPOK(sref) ? SvCUR(sref) : 0);
3368 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3369 GvASSUMECV_on(dstr);
3370 if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3373 if (import_flag && !(GvFLAGS(dstr) & import_flag)
3374 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3375 GvFLAGS(dstr) |= import_flag;
3380 if (SvTAINTED(sstr))
3386 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3389 register U32 sflags;
3391 register svtype stype;
3396 if (SvIS_FREED(dstr)) {
3397 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3398 " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3400 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3402 sstr = &PL_sv_undef;
3403 if (SvIS_FREED(sstr)) {
3404 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3405 (void*)sstr, (void*)dstr);
3407 stype = SvTYPE(sstr);
3408 dtype = SvTYPE(dstr);
3410 (void)SvAMAGIC_off(dstr);
3413 /* need to nuke the magic */
3415 SvRMAGICAL_off(dstr);
3418 /* There's a lot of redundancy below but we're going for speed here */
3423 if (dtype != SVt_PVGV) {
3424 (void)SvOK_off(dstr);
3432 sv_upgrade(dstr, SVt_IV);
3437 sv_upgrade(dstr, SVt_PVIV);
3440 goto end_of_first_switch;
3442 (void)SvIOK_only(dstr);
3443 SvIV_set(dstr, SvIVX(sstr));
3446 /* SvTAINTED can only be true if the SV has taint magic, which in
3447 turn means that the SV type is PVMG (or greater). This is the
3448 case statement for SVt_IV, so this cannot be true (whatever gcov
3450 assert(!SvTAINTED(sstr));
3460 sv_upgrade(dstr, SVt_NV);
3465 sv_upgrade(dstr, SVt_PVNV);
3468 goto end_of_first_switch;
3470 SvNV_set(dstr, SvNVX(sstr));
3471 (void)SvNOK_only(dstr);
3472 /* SvTAINTED can only be true if the SV has taint magic, which in
3473 turn means that the SV type is PVMG (or greater). This is the
3474 case statement for SVt_NV, so this cannot be true (whatever gcov
3476 assert(!SvTAINTED(sstr));
3483 sv_upgrade(dstr, SVt_RV);
3486 #ifdef PERL_OLD_COPY_ON_WRITE
3487 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3488 if (dtype < SVt_PVIV)
3489 sv_upgrade(dstr, SVt_PVIV);
3496 sv_upgrade(dstr, SVt_PV);
3499 if (dtype < SVt_PVIV)
3500 sv_upgrade(dstr, SVt_PVIV);
3503 if (dtype < SVt_PVNV)
3504 sv_upgrade(dstr, SVt_PVNV);
3508 const char * const type = sv_reftype(sstr,0);
3510 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3512 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3516 /* case SVt_BIND: */
3519 if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
3520 glob_assign_glob(dstr, sstr, dtype);
3523 /* SvVALID means that this PVGV is playing at being an FBM. */
3527 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3529 if (SvTYPE(sstr) != stype) {
3530 stype = SvTYPE(sstr);
3531 if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
3532 glob_assign_glob(dstr, sstr, dtype);
3537 if (stype == SVt_PVLV)
3538 SvUPGRADE(dstr, SVt_PVNV);
3540 SvUPGRADE(dstr, (svtype)stype);
3542 end_of_first_switch:
3544 /* dstr may have been upgraded. */
3545 dtype = SvTYPE(dstr);
3546 sflags = SvFLAGS(sstr);
3548 if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
3549 /* Assigning to a subroutine sets the prototype. */
3552 const char *const ptr = SvPV_const(sstr, len);
3554 SvGROW(dstr, len + 1);
3555 Copy(ptr, SvPVX(dstr), len + 1, char);
3556 SvCUR_set(dstr, len);
3558 SvFLAGS(dstr) |= sflags & SVf_UTF8;
3562 } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
3563 const char * const type = sv_reftype(dstr,0);
3565 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op));
3567 Perl_croak(aTHX_ "Cannot copy to %s", type);
3568 } else if (sflags & SVf_ROK) {
3569 if (isGV_with_GP(dstr) && dtype == SVt_PVGV
3570 && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3573 if (GvIMPORTED(dstr) != GVf_IMPORTED
3574 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3576 GvIMPORTED_on(dstr);
3581 glob_assign_glob(dstr, sstr, dtype);
3585 if (dtype >= SVt_PV) {
3586 if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3587 glob_assign_ref(dstr, sstr);
3590 if (SvPVX_const(dstr)) {
3596 (void)SvOK_off(dstr);
3597 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3598 SvFLAGS(dstr) |= sflags & SVf_ROK;
3599 assert(!(sflags & SVp_NOK));
3600 assert(!(sflags & SVp_IOK));
3601 assert(!(sflags & SVf_NOK));
3602 assert(!(sflags & SVf_IOK));
3604 else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3605 if (!(sflags & SVf_OK)) {
3606 if (ckWARN(WARN_MISC))
3607 Perl_warner(aTHX_ packWARN(WARN_MISC),
3608 "Undefined value assigned to typeglob");
3611 GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
3612 if (dstr != (SV*)gv) {
3615 GvGP(dstr) = gp_ref(GvGP(gv));
3619 else if (sflags & SVp_POK) {
3623 * Check to see if we can just swipe the string. If so, it's a
3624 * possible small lose on short strings, but a big win on long ones.
3625 * It might even be a win on short strings if SvPVX_const(dstr)
3626 * has to be allocated and SvPVX_const(sstr) has to be freed.
3627 * Likewise if we can set up COW rather than doing an actual copy, we
3628 * drop to the else clause, as the swipe code and the COW setup code
3629 * have much in common.
3632 /* Whichever path we take through the next code, we want this true,
3633 and doing it now facilitates the COW check. */
3634 (void)SvPOK_only(dstr);
3637 /* If we're already COW then this clause is not true, and if COW
3638 is allowed then we drop down to the else and make dest COW
3639 with us. If caller hasn't said that we're allowed to COW
3640 shared hash keys then we don't do the COW setup, even if the
3641 source scalar is a shared hash key scalar. */
3642 (((flags & SV_COW_SHARED_HASH_KEYS)
3643 ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
3644 : 1 /* If making a COW copy is forbidden then the behaviour we
3645 desire is as if the source SV isn't actually already
3646 COW, even if it is. So we act as if the source flags
3647 are not COW, rather than actually testing them. */
3649 #ifndef PERL_OLD_COPY_ON_WRITE
3650 /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
3651 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
3652 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
3653 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
3654 but in turn, it's somewhat dead code, never expected to go
3655 live, but more kept as a placeholder on how to do it better
3656 in a newer implementation. */
3657 /* If we are COW and dstr is a suitable target then we drop down
3658 into the else and make dest a COW of us. */
3659 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
3664 (sflags & SVs_TEMP) && /* slated for free anyway? */
3665 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3666 (!(flags & SV_NOSTEAL)) &&
3667 /* and we're allowed to steal temps */
3668 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3669 SvLEN(sstr) && /* and really is a string */
3670 /* and won't be needed again, potentially */
3671 !(PL_op && PL_op->op_type == OP_AASSIGN))
3672 #ifdef PERL_OLD_COPY_ON_WRITE
3673 && ((flags & SV_COW_SHARED_HASH_KEYS)
3674 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
3675 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
3676 && SvTYPE(sstr) >= SVt_PVIV))
3680 /* Failed the swipe test, and it's not a shared hash key either.
3681 Have to copy the string. */
3682 STRLEN len = SvCUR(sstr);
3683 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3684 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
3685 SvCUR_set(dstr, len);
3686 *SvEND(dstr) = '\0';
3688 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
3690 /* Either it's a shared hash key, or it's suitable for
3691 copy-on-write or we can swipe the string. */
3693 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
3697 #ifdef PERL_OLD_COPY_ON_WRITE
3699 /* I believe I should acquire a global SV mutex if
3700 it's a COW sv (not a shared hash key) to stop
3701 it going un copy-on-write.
3702 If the source SV has gone un copy on write between up there
3703 and down here, then (assert() that) it is of the correct
3704 form to make it copy on write again */
3705 if ((sflags & (SVf_FAKE | SVf_READONLY))
3706 != (SVf_FAKE | SVf_READONLY)) {
3707 SvREADONLY_on(sstr);
3709 /* Make the source SV into a loop of 1.
3710 (about to become 2) */
3711 SV_COW_NEXT_SV_SET(sstr, sstr);
3715 /* Initial code is common. */
3716 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
3721 /* making another shared SV. */
3722 STRLEN cur = SvCUR(sstr);
3723 STRLEN len = SvLEN(sstr);
3724 #ifdef PERL_OLD_COPY_ON_WRITE
3726 assert (SvTYPE(dstr) >= SVt_PVIV);
3727 /* SvIsCOW_normal */
3728 /* splice us in between source and next-after-source. */
3729 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3730 SV_COW_NEXT_SV_SET(sstr, dstr);
3731 SvPV_set(dstr, SvPVX_mutable(sstr));
3735 /* SvIsCOW_shared_hash */
3736 DEBUG_C(PerlIO_printf(Perl_debug_log,
3737 "Copy on write: Sharing hash\n"));
3739 assert (SvTYPE(dstr) >= SVt_PV);
3741 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
3743 SvLEN_set(dstr, len);
3744 SvCUR_set(dstr, cur);
3745 SvREADONLY_on(dstr);
3747 /* Relesase a global SV mutex. */
3750 { /* Passes the swipe test. */
3751 SvPV_set(dstr, SvPVX_mutable(sstr));
3752 SvLEN_set(dstr, SvLEN(sstr));
3753 SvCUR_set(dstr, SvCUR(sstr));
3756 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3757 SvPV_set(sstr, NULL);
3763 if (sflags & SVp_NOK) {
3764 SvNV_set(dstr, SvNVX(sstr));
3766 if (sflags & SVp_IOK) {
3768 SvIV_set(dstr, SvIVX(sstr));
3769 /* Must do this otherwise some other overloaded use of 0x80000000
3770 gets confused. I guess SVpbm_VALID */
3771 if (sflags & SVf_IVisUV)
3774 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
3776 const MAGIC * const smg = SvVSTRING_mg(sstr);
3778 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
3779 smg->mg_ptr, smg->mg_len);
3780 SvRMAGICAL_on(dstr);
3784 else if (sflags & (SVp_IOK|SVp_NOK)) {
3785 (void)SvOK_off(dstr);
3786 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
3787 if (sflags & SVp_IOK) {
3788 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3789 SvIV_set(dstr, SvIVX(sstr));
3791 if (sflags & SVp_NOK) {
3792 SvNV_set(dstr, SvNVX(sstr));
3796 if (isGV_with_GP(sstr)) {
3797 /* This stringification rule for globs is spread in 3 places.
3798 This feels bad. FIXME. */
3799 const U32 wasfake = sflags & SVf_FAKE;
3801 /* FAKE globs can get coerced, so need to turn this off
3802 temporarily if it is on. */
3804 gv_efullname3(dstr, (GV *)sstr, "*");
3805 SvFLAGS(sstr) |= wasfake;
3808 (void)SvOK_off(dstr);
3810 if (SvTAINTED(sstr))
3815 =for apidoc sv_setsv_mg
3817 Like C<sv_setsv>, but also handles 'set' magic.
3823 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3825 sv_setsv(dstr,sstr);
3829 #ifdef PERL_OLD_COPY_ON_WRITE
3831 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
3833 STRLEN cur = SvCUR(sstr);
3834 STRLEN len = SvLEN(sstr);
3835 register char *new_pv;
3838 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
3839 (void*)sstr, (void*)dstr);
3846 if (SvTHINKFIRST(dstr))
3847 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
3848 else if (SvPVX_const(dstr))
3849 Safefree(SvPVX_const(dstr));
3853 SvUPGRADE(dstr, SVt_PVIV);
3855 assert (SvPOK(sstr));
3856 assert (SvPOKp(sstr));
3857 assert (!SvIOK(sstr));
3858 assert (!SvIOKp(sstr));
3859 assert (!SvNOK(sstr));
3860 assert (!SvNOKp(sstr));
3862 if (SvIsCOW(sstr)) {
3864 if (SvLEN(sstr) == 0) {
3865 /* source is a COW shared hash key. */
3866 DEBUG_C(PerlIO_printf(Perl_debug_log,
3867 "Fast copy on write: Sharing hash\n"));
3868 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
3871 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3873 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
3874 SvUPGRADE(sstr, SVt_PVIV);
3875 SvREADONLY_on(sstr);
3877 DEBUG_C(PerlIO_printf(Perl_debug_log,
3878 "Fast copy on write: Converting sstr to COW\n"));
3879 SV_COW_NEXT_SV_SET(dstr, sstr);
3881 SV_COW_NEXT_SV_SET(sstr, dstr);
3882 new_pv = SvPVX_mutable(sstr);
3885 SvPV_set(dstr, new_pv);
3886 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
3889 SvLEN_set(dstr, len);
3890 SvCUR_set(dstr, cur);
3899 =for apidoc sv_setpvn
3901 Copies a string into an SV. The C<len> parameter indicates the number of
3902 bytes to be copied. If the C<ptr> argument is NULL the SV will become
3903 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3909 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3912 register char *dptr;
3914 SV_CHECK_THINKFIRST_COW_DROP(sv);
3920 /* len is STRLEN which is unsigned, need to copy to signed */
3923 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3925 SvUPGRADE(sv, SVt_PV);
3927 dptr = SvGROW(sv, len + 1);
3928 Move(ptr,dptr,len,char);
3931 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3936 =for apidoc sv_setpvn_mg
3938 Like C<sv_setpvn>, but also handles 'set' magic.
3944 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3946 sv_setpvn(sv,ptr,len);
3951 =for apidoc sv_setpv
3953 Copies a string into an SV. The string must be null-terminated. Does not
3954 handle 'set' magic. See C<sv_setpv_mg>.
3960 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3963 register STRLEN len;
3965 SV_CHECK_THINKFIRST_COW_DROP(sv);
3971 SvUPGRADE(sv, SVt_PV);
3973 SvGROW(sv, len + 1);
3974 Move(ptr,SvPVX(sv),len+1,char);
3976 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3981 =for apidoc sv_setpv_mg
3983 Like C<sv_setpv>, but also handles 'set' magic.
3989 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3996 =for apidoc sv_usepvn_flags
3998 Tells an SV to use C<ptr> to find its string value. Normally the
3999 string is stored inside the SV but sv_usepvn allows the SV to use an
4000 outside string. The C<ptr> should point to memory that was allocated
4001 by C<malloc>. The string length, C<len>, must be supplied. By default
4002 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4003 so that pointer should not be freed or used by the programmer after
4004 giving it to sv_usepvn, and neither should any pointers from "behind"
4005 that pointer (e.g. ptr + 1) be used.
4007 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4008 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4009 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4010 C<len>, and already meets the requirements for storing in C<SvPVX>)
4016 Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags)
4020 SV_CHECK_THINKFIRST_COW_DROP(sv);
4021 SvUPGRADE(sv, SVt_PV);
4024 if (flags & SV_SMAGIC)
4028 if (SvPVX_const(sv))
4032 if (flags & SV_HAS_TRAILING_NUL)
4033 assert(ptr[len] == '\0');
4036 allocate = (flags & SV_HAS_TRAILING_NUL)
4037 ? len + 1: PERL_STRLEN_ROUNDUP(len + 1);
4038 if (flags & SV_HAS_TRAILING_NUL) {
4039 /* It's long enough - do nothing.
4040 Specfically Perl_newCONSTSUB is relying on this. */
4043 /* Force a move to shake out bugs in callers. */
4044 char *new_ptr = (char*)safemalloc(allocate);
4045 Copy(ptr, new_ptr, len, char);
4046 PoisonFree(ptr,len,char);
4050 ptr = (char*) saferealloc (ptr, allocate);
4055 SvLEN_set(sv, allocate);
4056 if (!(flags & SV_HAS_TRAILING_NUL)) {
4059 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4061 if (flags & SV_SMAGIC)
4065 #ifdef PERL_OLD_COPY_ON_WRITE
4066 /* Need to do this *after* making the SV normal, as we need the buffer
4067 pointer to remain valid until after we've copied it. If we let go too early,
4068 another thread could invalidate it by unsharing last of the same hash key
4069 (which it can do by means other than releasing copy-on-write Svs)
4070 or by changing the other copy-on-write SVs in the loop. */
4072 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4074 { /* this SV was SvIsCOW_normal(sv) */
4075 /* we need to find the SV pointing to us. */
4076 SV *current = SV_COW_NEXT_SV(after);
4078 if (current == sv) {
4079 /* The SV we point to points back to us (there were only two of us
4081 Hence other SV is no longer copy on write either. */
4083 SvREADONLY_off(after);
4085 /* We need to follow the pointers around the loop. */
4087 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4090 /* don't loop forever if the structure is bust, and we have
4091 a pointer into a closed loop. */
4092 assert (current != after);
4093 assert (SvPVX_const(current) == pvx);
4095 /* Make the SV before us point to the SV after us. */
4096 SV_COW_NEXT_SV_SET(current, after);
4102 =for apidoc sv_force_normal_flags
4104 Undo various types of fakery on an SV: if the PV is a shared string, make
4105 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4106 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4107 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4108 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4109 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4110 set to some other value.) In addition, the C<flags> parameter gets passed to
4111 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4112 with flags set to 0.
4118 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4121 #ifdef PERL_OLD_COPY_ON_WRITE
4122 if (SvREADONLY(sv)) {
4123 /* At this point I believe I should acquire a global SV mutex. */
4125 const char * const pvx = SvPVX_const(sv);
4126 const STRLEN len = SvLEN(sv);
4127 const STRLEN cur = SvCUR(sv);
4128 /* next COW sv in the loop. If len is 0 then this is a shared-hash
4129 key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4130 we'll fail an assertion. */
4131 SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4134 PerlIO_printf(Perl_debug_log,
4135 "Copy on write: Force normal %ld\n",
4141 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4144 if (flags & SV_COW_DROP_PV) {
4145 /* OK, so we don't need to copy our buffer. */
4148 SvGROW(sv, cur + 1);
4149 Move(pvx,SvPVX(sv),cur,char);
4154 sv_release_COW(sv, pvx, next);
4156 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4162 else if (IN_PERL_RUNTIME)
4163 Perl_croak(aTHX_ PL_no_modify);
4164 /* At this point I believe that I can drop the global SV mutex. */
4167 if (SvREADONLY(sv)) {
4169 const char * const pvx = SvPVX_const(sv);
4170 const STRLEN len = SvCUR(sv);
4175 SvGROW(sv, len + 1);
4176 Move(pvx,SvPVX(sv),len,char);
4178 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4180 else if (IN_PERL_RUNTIME)
4181 Perl_croak(aTHX_ PL_no_modify);
4185 sv_unref_flags(sv, flags);
4186 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4193 Efficient removal of characters from the beginning of the string buffer.
4194 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4195 the string buffer. The C<ptr> becomes the first character of the adjusted
4196 string. Uses the "OOK hack".
4197 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4198 refer to the same chunk of data.
4204 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
4206 register STRLEN delta;
4207 if (!ptr || !SvPOKp(sv))
4209 delta = ptr - SvPVX_const(sv);
4210 SV_CHECK_THINKFIRST(sv);
4211 if (SvTYPE(sv) < SVt_PVIV)
4212 sv_upgrade(sv,SVt_PVIV);
4215 if (!SvLEN(sv)) { /* make copy of shared string */
4216 const char *pvx = SvPVX_const(sv);
4217 const STRLEN len = SvCUR(sv);
4218 SvGROW(sv, len + 1);
4219 Move(pvx,SvPVX(sv),len,char);
4223 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
4224 and we do that anyway inside the SvNIOK_off
4226 SvFLAGS(sv) |= SVf_OOK;
4229 SvLEN_set(sv, SvLEN(sv) - delta);
4230 SvCUR_set(sv, SvCUR(sv) - delta);
4231 SvPV_set(sv, SvPVX(sv) + delta);
4232 SvIV_set(sv, SvIVX(sv) + delta);
4236 =for apidoc sv_catpvn
4238 Concatenates the string onto the end of the string which is in the SV. The
4239 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4240 status set, then the bytes appended should be valid UTF-8.
4241 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4243 =for apidoc sv_catpvn_flags
4245 Concatenates the string onto the end of the string which is in the SV. The
4246 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4247 status set, then the bytes appended should be valid UTF-8.
4248 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4249 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4250 in terms of this function.
4256 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4260 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4262 SvGROW(dsv, dlen + slen + 1);
4264 sstr = SvPVX_const(dsv);
4265 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4266 SvCUR_set(dsv, SvCUR(dsv) + slen);
4268 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4270 if (flags & SV_SMAGIC)
4275 =for apidoc sv_catsv
4277 Concatenates the string from SV C<ssv> onto the end of the string in
4278 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4279 not 'set' magic. See C<sv_catsv_mg>.
4281 =for apidoc sv_catsv_flags
4283 Concatenates the string from SV C<ssv> onto the end of the string in
4284 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4285 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4286 and C<sv_catsv_nomg> are implemented in terms of this function.
4291 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4296 const char *spv = SvPV_const(ssv, slen);
4298 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4299 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4300 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4301 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4302 dsv->sv_flags doesn't have that bit set.
4303 Andy Dougherty 12 Oct 2001
4305 const I32 sutf8 = DO_UTF8(ssv);
4308 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4310 dutf8 = DO_UTF8(dsv);
4312 if (dutf8 != sutf8) {
4314 /* Not modifying source SV, so taking a temporary copy. */
4315 SV* const csv = sv_2mortal(newSVpvn(spv, slen));
4317 sv_utf8_upgrade(csv);
4318 spv = SvPV_const(csv, slen);
4321 sv_utf8_upgrade_nomg(dsv);
4323 sv_catpvn_nomg(dsv, spv, slen);
4326 if (flags & SV_SMAGIC)
4331 =for apidoc sv_catpv
4333 Concatenates the string onto the end of the string which is in the SV.
4334 If the SV has the UTF-8 status set, then the bytes appended should be
4335 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4340 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4343 register STRLEN len;
4349 junk = SvPV_force(sv, tlen);
4351 SvGROW(sv, tlen + len + 1);
4353 ptr = SvPVX_const(sv);
4354 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4355 SvCUR_set(sv, SvCUR(sv) + len);
4356 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4361 =for apidoc sv_catpv_mg
4363 Like C<sv_catpv>, but also handles 'set' magic.
4369 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4378 Creates a new SV. A non-zero C<len> parameter indicates the number of
4379 bytes of preallocated string space the SV should have. An extra byte for a
4380 trailing NUL is also reserved. (SvPOK is not set for the SV even if string
4381 space is allocated.) The reference count for the new SV is set to 1.
4383 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
4384 parameter, I<x>, a debug aid which allowed callers to identify themselves.
4385 This aid has been superseded by a new build option, PERL_MEM_LOG (see
4386 L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
4387 modules supporting older perls.
4393 Perl_newSV(pTHX_ STRLEN len)
4400 sv_upgrade(sv, SVt_PV);
4401 SvGROW(sv, len + 1);
4406 =for apidoc sv_magicext
4408 Adds magic to an SV, upgrading it if necessary. Applies the
4409 supplied vtable and returns a pointer to the magic added.
4411 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4412 In particular, you can add magic to SvREADONLY SVs, and add more than
4413 one instance of the same 'how'.
4415 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4416 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4417 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4418 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4420 (This is now used as a subroutine by C<sv_magic>.)
4425 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
4426 const char* name, I32 namlen)
4431 SvUPGRADE(sv, SVt_PVMG);
4432 Newxz(mg, 1, MAGIC);
4433 mg->mg_moremagic = SvMAGIC(sv);
4434 SvMAGIC_set(sv, mg);
4436 /* Sometimes a magic contains a reference loop, where the sv and
4437 object refer to each other. To prevent a reference loop that
4438 would prevent such objects being freed, we look for such loops
4439 and if we find one we avoid incrementing the object refcount.
4441 Note we cannot do this to avoid self-tie loops as intervening RV must
4442 have its REFCNT incremented to keep it in existence.
4445 if (!obj || obj == sv ||
4446 how == PERL_MAGIC_arylen ||
4447 how == PERL_MAGIC_qr ||
4448 how == PERL_MAGIC_symtab ||
4449 (SvTYPE(obj) == SVt_PVGV &&
4450 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4451 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4452 GvFORM(obj) == (CV*)sv)))
4457 mg->mg_obj = SvREFCNT_inc_simple(obj);
4458 mg->mg_flags |= MGf_REFCOUNTED;
4461 /* Normal self-ties simply pass a null object, and instead of
4462 using mg_obj directly, use the SvTIED_obj macro to produce a
4463 new RV as needed. For glob "self-ties", we are tieing the PVIO
4464 with an RV obj pointing to the glob containing the PVIO. In
4465 this case, to avoid a reference loop, we need to weaken the
4469 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4470 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4476 mg->mg_len = namlen;
4479 mg->mg_ptr = savepvn(name, namlen);
4480 else if (namlen == HEf_SVKEY)
4481 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV*)name);
4483 mg->mg_ptr = (char *) name;
4485 mg->mg_virtual = (MGVTBL *) vtable;
4489 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4494 =for apidoc sv_magic
4496 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4497 then adds a new magic item of type C<how> to the head of the magic list.
4499 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4500 handling of the C<name> and C<namlen> arguments.
4502 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4503 to add more than one instance of the same 'how'.
4509 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4512 const MGVTBL *vtable;
4515 #ifdef PERL_OLD_COPY_ON_WRITE
4517 sv_force_normal_flags(sv, 0);
4519 if (SvREADONLY(sv)) {
4521 /* its okay to attach magic to shared strings; the subsequent
4522 * upgrade to PVMG will unshare the string */
4523 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4526 && how != PERL_MAGIC_regex_global
4527 && how != PERL_MAGIC_bm
4528 && how != PERL_MAGIC_fm
4529 && how != PERL_MAGIC_sv
4530 && how != PERL_MAGIC_backref
4533 Perl_croak(aTHX_ PL_no_modify);
4536 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4537 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4538 /* sv_magic() refuses to add a magic of the same 'how' as an
4541 if (how == PERL_MAGIC_taint) {
4543 /* Any scalar which already had taint magic on which someone
4544 (erroneously?) did SvIOK_on() or similar will now be
4545 incorrectly sporting public "OK" flags. */
4546 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4554 vtable = &PL_vtbl_sv;
4556 case PERL_MAGIC_overload:
4557 vtable = &PL_vtbl_amagic;
4559 case PERL_MAGIC_overload_elem:
4560 vtable = &PL_vtbl_amagicelem;
4562 case PERL_MAGIC_overload_table:
4563 vtable = &PL_vtbl_ovrld;
4566 vtable = &PL_vtbl_bm;
4568 case PERL_MAGIC_regdata:
4569 vtable = &PL_vtbl_regdata;
4571 case PERL_MAGIC_regdatum:
4572 vtable = &PL_vtbl_regdatum;
4574 case PERL_MAGIC_env:
4575 vtable = &PL_vtbl_env;
4578 vtable = &PL_vtbl_fm;
4580 case PERL_MAGIC_envelem:
4581 vtable = &PL_vtbl_envelem;
4583 case PERL_MAGIC_regex_global:
4584 vtable = &PL_vtbl_mglob;
4586 case PERL_MAGIC_isa:
4587 vtable = &PL_vtbl_isa;
4589 case PERL_MAGIC_isaelem:
4590 vtable = &PL_vtbl_isaelem;
4592 case PERL_MAGIC_nkeys:
4593 vtable = &PL_vtbl_nkeys;
4595 case PERL_MAGIC_dbfile:
4598 case PERL_MAGIC_dbline:
4599 vtable = &PL_vtbl_dbline;
4601 #ifdef USE_LOCALE_COLLATE
4602 case PERL_MAGIC_collxfrm:
4603 vtable = &PL_vtbl_collxfrm;
4605 #endif /* USE_LOCALE_COLLATE */
4606 case PERL_MAGIC_tied:
4607 vtable = &PL_vtbl_pack;
4609 case PERL_MAGIC_tiedelem:
4610 case PERL_MAGIC_tiedscalar:
4611 vtable = &PL_vtbl_packelem;
4614 vtable = &PL_vtbl_regexp;
4616 case PERL_MAGIC_hints:
4617 /* As this vtable is all NULL, we can reuse it. */
4618 case PERL_MAGIC_sig:
4619 vtable = &PL_vtbl_sig;
4621 case PERL_MAGIC_sigelem:
4622 vtable = &PL_vtbl_sigelem;
4624 case PERL_MAGIC_taint:
4625 vtable = &PL_vtbl_taint;
4627 case PERL_MAGIC_uvar:
4628 vtable = &PL_vtbl_uvar;
4630 case PERL_MAGIC_vec:
4631 vtable = &PL_vtbl_vec;
4633 case PERL_MAGIC_arylen_p:
4634 case PERL_MAGIC_rhash:
4635 case PERL_MAGIC_symtab:
4636 case PERL_MAGIC_vstring:
4639 case PERL_MAGIC_utf8:
4640 vtable = &PL_vtbl_utf8;
4642 case PERL_MAGIC_substr:
4643 vtable = &PL_vtbl_substr;
4645 case PERL_MAGIC_defelem:
4646 vtable = &PL_vtbl_defelem;
4648 case PERL_MAGIC_arylen:
4649 vtable = &PL_vtbl_arylen;
4651 case PERL_MAGIC_pos:
4652 vtable = &PL_vtbl_pos;
4654 case PERL_MAGIC_backref:
4655 vtable = &PL_vtbl_backref;
4657 case PERL_MAGIC_hintselem:
4658 vtable = &PL_vtbl_hintselem;
4660 case PERL_MAGIC_ext:
4661 /* Reserved for use by extensions not perl internals. */
4662 /* Useful for attaching extension internal data to perl vars. */
4663 /* Note that multiple extensions may clash if magical scalars */
4664 /* etc holding private data from one are passed to another. */
4668 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4671 /* Rest of work is done else where */
4672 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4675 case PERL_MAGIC_taint:
4678 case PERL_MAGIC_ext:
4679 case PERL_MAGIC_dbfile:
4686 =for apidoc sv_unmagic
4688 Removes all magic of type C<type> from an SV.
4694 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4698 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4700 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
4701 for (mg = *mgp; mg; mg = *mgp) {
4702 if (mg->mg_type == type) {
4703 const MGVTBL* const vtbl = mg->mg_virtual;
4704 *mgp = mg->mg_moremagic;
4705 if (vtbl && vtbl->svt_free)
4706 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4707 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4709 Safefree(mg->mg_ptr);
4710 else if (mg->mg_len == HEf_SVKEY)
4711 SvREFCNT_dec((SV*)mg->mg_ptr);
4712 else if (mg->mg_type == PERL_MAGIC_utf8)
4713 Safefree(mg->mg_ptr);
4715 if (mg->mg_flags & MGf_REFCOUNTED)
4716 SvREFCNT_dec(mg->mg_obj);
4720 mgp = &mg->mg_moremagic;
4724 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4725 SvMAGIC_set(sv, NULL);
4732 =for apidoc sv_rvweaken
4734 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4735 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4736 push a back-reference to this RV onto the array of backreferences
4737 associated with that magic. If the RV is magical, set magic will be
4738 called after the RV is cleared.
4744 Perl_sv_rvweaken(pTHX_ SV *sv)
4747 if (!SvOK(sv)) /* let undefs pass */
4750 Perl_croak(aTHX_ "Can't weaken a nonreference");
4751 else if (SvWEAKREF(sv)) {
4752 if (ckWARN(WARN_MISC))
4753 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
4757 Perl_sv_add_backref(aTHX_ tsv, sv);
4763 /* Give tsv backref magic if it hasn't already got it, then push a
4764 * back-reference to sv onto the array associated with the backref magic.
4768 Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4773 if (SvTYPE(tsv) == SVt_PVHV) {
4774 AV **const avp = Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
4778 /* There is no AV in the offical place - try a fixup. */
4779 MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
4782 /* Aha. They've got it stowed in magic. Bring it back. */
4783 av = (AV*)mg->mg_obj;
4784 /* Stop mg_free decreasing the refernce count. */
4786 /* Stop mg_free even calling the destructor, given that
4787 there's no AV to free up. */
4789 sv_unmagic(tsv, PERL_MAGIC_backref);
4793 SvREFCNT_inc_simple_void(av);
4798 const MAGIC *const mg
4799 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
4801 av = (AV*)mg->mg_obj;
4805 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4806 /* av now has a refcnt of 2, which avoids it getting freed
4807 * before us during global cleanup. The extra ref is removed
4808 * by magic_killbackrefs() when tsv is being freed */
4811 if (AvFILLp(av) >= AvMAX(av)) {
4812 av_extend(av, AvFILLp(av)+1);
4814 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
4817 /* delete a back-reference to ourselves from the backref magic associated
4818 * with the SV we point to.
4822 S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
4829 if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
4830 av = *Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
4831 /* We mustn't attempt to "fix up" the hash here by moving the
4832 backreference array back to the hv_aux structure, as that is stored
4833 in the main HvARRAY(), and hfreentries assumes that no-one
4834 reallocates HvARRAY() while it is running. */
4837 const MAGIC *const mg
4838 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
4840 av = (AV *)mg->mg_obj;
4843 if (PL_in_clean_all)
4845 Perl_croak(aTHX_ "panic: del_backref");
4852 /* We shouldn't be in here more than once, but for paranoia reasons lets
4854 for (i = AvFILLp(av); i >= 0; i--) {
4856 const SSize_t fill = AvFILLp(av);
4858 /* We weren't the last entry.
4859 An unordered list has this property that you can take the
4860 last element off the end to fill the hole, and it's still
4861 an unordered list :-)
4866 AvFILLp(av) = fill - 1;
4872 Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *av)
4874 SV **svp = AvARRAY(av);
4876 PERL_UNUSED_ARG(sv);
4878 /* Not sure why the av can get freed ahead of its sv, but somehow it does
4879 in ext/B/t/bytecode.t test 15 (involving print <DATA>) */
4880 if (svp && !SvIS_FREED(av)) {
4881 SV *const *const last = svp + AvFILLp(av);
4883 while (svp <= last) {
4885 SV *const referrer = *svp;
4886 if (SvWEAKREF(referrer)) {
4887 /* XXX Should we check that it hasn't changed? */
4888 SvRV_set(referrer, 0);
4890 SvWEAKREF_off(referrer);
4891 SvSETMAGIC(referrer);
4892 } else if (SvTYPE(referrer) == SVt_PVGV ||
4893 SvTYPE(referrer) == SVt_PVLV) {
4894 /* You lookin' at me? */
4895 assert(GvSTASH(referrer));
4896 assert(GvSTASH(referrer) == (HV*)sv);
4897 GvSTASH(referrer) = 0;
4900 "panic: magic_killbackrefs (flags=%"UVxf")",
4901 (UV)SvFLAGS(referrer));
4909 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
4914 =for apidoc sv_insert
4916 Inserts a string at the specified offset/length within the SV. Similar to
4917 the Perl substr() function.
4923 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
4928 register char *midend;
4929 register char *bigend;
4935 Perl_croak(aTHX_ "Can't modify non-existent substring");
4936 SvPV_force(bigstr, curlen);
4937 (void)SvPOK_only_UTF8(bigstr);
4938 if (offset + len > curlen) {
4939 SvGROW(bigstr, offset+len+1);
4940 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4941 SvCUR_set(bigstr, offset+len);
4945 i = littlelen - len;
4946 if (i > 0) { /* string might grow */
4947 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4948 mid = big + offset + len;
4949 midend = bigend = big + SvCUR(bigstr);
4952 while (midend > mid) /* shove everything down */
4953 *--bigend = *--midend;
4954 Move(little,big+offset,littlelen,char);
4955 SvCUR_set(bigstr, SvCUR(bigstr) + i);
4960 Move(little,SvPVX(bigstr)+offset,len,char);
4965 big = SvPVX(bigstr);
4968 bigend = big + SvCUR(bigstr);
4970 if (midend > bigend)
4971 Perl_croak(aTHX_ "panic: sv_insert");
4973 if (mid - big > bigend - midend) { /* faster to shorten from end */
4975 Move(little, mid, littlelen,char);
4978 i = bigend - midend;
4980 Move(midend, mid, i,char);
4984 SvCUR_set(bigstr, mid - big);
4986 else if ((i = mid - big)) { /* faster from front */
4987 midend -= littlelen;
4989 sv_chop(bigstr,midend-i);
4994 Move(little, mid, littlelen,char);
4996 else if (littlelen) {
4997 midend -= littlelen;
4998 sv_chop(bigstr,midend);
4999 Move(little,midend,littlelen,char);
5002 sv_chop(bigstr,midend);
5008 =for apidoc sv_replace
5010 Make the first argument a copy of the second, then delete the original.
5011 The target SV physically takes over ownership of the body of the source SV
5012 and inherits its flags; however, the target keeps any magic it owns,
5013 and any magic in the source is discarded.
5014 Note that this is a rather specialist SV copying operation; most of the
5015 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5021 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5024 const U32 refcnt = SvREFCNT(sv);
5025 SV_CHECK_THINKFIRST_COW_DROP(sv);
5026 if (SvREFCNT(nsv) != 1) {
5027 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
5028 UVuf " != 1)", (UV) SvREFCNT(nsv));
5030 if (SvMAGICAL(sv)) {
5034 sv_upgrade(nsv, SVt_PVMG);
5035 SvMAGIC_set(nsv, SvMAGIC(sv));
5036 SvFLAGS(nsv) |= SvMAGICAL(sv);
5038 SvMAGIC_set(sv, NULL);
5042 assert(!SvREFCNT(sv));
5043 #ifdef DEBUG_LEAKING_SCALARS
5044 sv->sv_flags = nsv->sv_flags;
5045 sv->sv_any = nsv->sv_any;
5046 sv->sv_refcnt = nsv->sv_refcnt;
5047 sv->sv_u = nsv->sv_u;
5049 StructCopy(nsv,sv,SV);
5051 /* Currently could join these into one piece of pointer arithmetic, but
5052 it would be unclear. */
5053 if(SvTYPE(sv) == SVt_IV)
5055 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5056 else if (SvTYPE(sv) == SVt_RV) {
5057 SvANY(sv) = &sv->sv_u.svu_rv;
5061 #ifdef PERL_OLD_COPY_ON_WRITE
5062 if (SvIsCOW_normal(nsv)) {
5063 /* We need to follow the pointers around the loop to make the
5064 previous SV point to sv, rather than nsv. */
5067 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5070 assert(SvPVX_const(current) == SvPVX_const(nsv));
5072 /* Make the SV before us point to the SV after us. */
5074 PerlIO_printf(Perl_debug_log, "previous is\n");
5076 PerlIO_printf(Perl_debug_log,
5077 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5078 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5080 SV_COW_NEXT_SV_SET(current, sv);
5083 SvREFCNT(sv) = refcnt;
5084 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5090 =for apidoc sv_clear
5092 Clear an SV: call any destructors, free up any memory used by the body,
5093 and free the body itself. The SV's head is I<not> freed, although
5094 its type is set to all 1's so that it won't inadvertently be assumed
5095 to be live during global destruction etc.
5096 This function should only be called when REFCNT is zero. Most of the time
5097 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5104 Perl_sv_clear(pTHX_ register SV *sv)
5107 const U32 type = SvTYPE(sv);
5108 const struct body_details *const sv_type_details
5109 = bodies_by_type + type;
5113 assert(SvREFCNT(sv) == 0);
5115 if (type <= SVt_IV) {
5116 /* See the comment in sv.h about the collusion between this early
5117 return and the overloading of the NULL and IV slots in the size
5123 if (PL_defstash && /* Still have a symbol table? */
5130 stash = SvSTASH(sv);
5131 destructor = StashHANDLER(stash,DESTROY);
5133 SV* const tmpref = newRV(sv);
5134 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5136 PUSHSTACKi(PERLSI_DESTROY);
5141 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5147 if(SvREFCNT(tmpref) < 2) {
5148 /* tmpref is not kept alive! */
5150 SvRV_set(tmpref, NULL);
5153 SvREFCNT_dec(tmpref);
5155 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5159 if (PL_in_clean_objs)
5160 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5162 /* DESTROY gave object new lease on life */
5168 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5169 SvOBJECT_off(sv); /* Curse the object. */
5170 if (type != SVt_PVIO)
5171 --PL_sv_objcount; /* XXX Might want something more general */
5174 if (type >= SVt_PVMG) {
5175 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
5176 SvREFCNT_dec(SvOURSTASH(sv));
5177 } else if (SvMAGIC(sv))
5179 if (type == SVt_PVMG && SvPAD_TYPED(sv))
5180 SvREFCNT_dec(SvSTASH(sv));
5183 /* case SVt_BIND: */
5186 IoIFP(sv) != PerlIO_stdin() &&
5187 IoIFP(sv) != PerlIO_stdout() &&
5188 IoIFP(sv) != PerlIO_stderr())
5190 io_close((IO*)sv, FALSE);
5192 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5193 PerlDir_close(IoDIRP(sv));
5194 IoDIRP(sv) = (DIR*)NULL;
5195 Safefree(IoTOP_NAME(sv));
5196 Safefree(IoFMT_NAME(sv));
5197 Safefree(IoBOTTOM_NAME(sv));
5204 Perl_hv_kill_backrefs(aTHX_ (HV*)sv);
5208 if (PL_comppad == (AV*)sv) {
5215 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5216 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5217 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5218 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5220 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5221 SvREFCNT_dec(LvTARG(sv));
5223 if (isGV_with_GP(sv)) {
5224 if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash))
5225 mro_method_changed_in(stash);
5228 unshare_hek(GvNAME_HEK(sv));
5229 /* If we're in a stash, we don't own a reference to it. However it does
5230 have a back reference to us, which needs to be cleared. */
5231 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
5232 sv_del_backref((SV*)stash, sv);
5234 /* FIXME. There are probably more unreferenced pointers to SVs in the
5235 interpreter struct that we should check and tidy in a similar
5237 if ((GV*)sv == PL_last_in_gv)
5238 PL_last_in_gv = NULL;
5243 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5245 SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
5246 /* Don't even bother with turning off the OOK flag. */
5251 SV * const target = SvRV(sv);
5253 sv_del_backref(target, sv);
5255 SvREFCNT_dec(target);
5257 #ifdef PERL_OLD_COPY_ON_WRITE
5258 else if (SvPVX_const(sv)) {
5260 /* I believe I need to grab the global SV mutex here and
5261 then recheck the COW status. */
5263 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5267 sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
5269 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5272 /* And drop it here. */
5274 } else if (SvLEN(sv)) {
5275 Safefree(SvPVX_const(sv));
5279 else if (SvPVX_const(sv) && SvLEN(sv))
5280 Safefree(SvPVX_mutable(sv));
5281 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5282 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5291 SvFLAGS(sv) &= SVf_BREAK;
5292 SvFLAGS(sv) |= SVTYPEMASK;
5294 if (sv_type_details->arena) {
5295 del_body(((char *)SvANY(sv) + sv_type_details->offset),
5296 &PL_body_roots[type]);
5298 else if (sv_type_details->body_size) {
5299 my_safefree(SvANY(sv));
5304 =for apidoc sv_newref
5306 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5313 Perl_sv_newref(pTHX_ SV *sv)
5315 PERL_UNUSED_CONTEXT;
5324 Decrement an SV's reference count, and if it drops to zero, call
5325 C<sv_clear> to invoke destructors and free up any memory used by
5326 the body; finally, deallocate the SV's head itself.
5327 Normally called via a wrapper macro C<SvREFCNT_dec>.
5333 Perl_sv_free(pTHX_ SV *sv)
5338 if (SvREFCNT(sv) == 0) {
5339 if (SvFLAGS(sv) & SVf_BREAK)
5340 /* this SV's refcnt has been artificially decremented to
5341 * trigger cleanup */
5343 if (PL_in_clean_all) /* All is fair */
5345 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5346 /* make sure SvREFCNT(sv)==0 happens very seldom */
5347 SvREFCNT(sv) = (~(U32)0)/2;
5350 if (ckWARN_d(WARN_INTERNAL)) {
5351 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5352 "Attempt to free unreferenced scalar: SV 0x%"UVxf
5353 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5354 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5355 Perl_dump_sv_child(aTHX_ sv);
5357 #ifdef DEBUG_LEAKING_SCALARS
5364 if (--(SvREFCNT(sv)) > 0)
5366 Perl_sv_free2(aTHX_ sv);
5370 Perl_sv_free2(pTHX_ SV *sv)
5375 if (ckWARN_d(WARN_DEBUGGING))
5376 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5377 "Attempt to free temp prematurely: SV 0x%"UVxf
5378 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5382 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5383 /* make sure SvREFCNT(sv)==0 happens very seldom */
5384 SvREFCNT(sv) = (~(U32)0)/2;
5395 Returns the length of the string in the SV. Handles magic and type
5396 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5402 Perl_sv_len(pTHX_ register SV *sv)
5410 len = mg_length(sv);
5412 (void)SvPV_const(sv, len);
5417 =for apidoc sv_len_utf8
5419 Returns the number of characters in the string in an SV, counting wide
5420 UTF-8 bytes as a single character. Handles magic and type coercion.
5426 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
5427 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
5428 * (Note that the mg_len is not the length of the mg_ptr field.
5429 * This allows the cache to store the character length of the string without
5430 * needing to malloc() extra storage to attach to the mg_ptr.)
5435 Perl_sv_len_utf8(pTHX_ register SV *sv)
5441 return mg_length(sv);
5445 const U8 *s = (U8*)SvPV_const(sv, len);
5449 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
5451 if (mg && mg->mg_len != -1) {
5453 if (PL_utf8cache < 0) {
5454 const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
5456 /* Need to turn the assertions off otherwise we may
5457 recurse infinitely while printing error messages.
5459 SAVEI8(PL_utf8cache);
5461 Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
5462 " real %"UVuf" for %"SVf,
5463 (UV) ulen, (UV) real, SVfARG(sv));
5468 ulen = Perl_utf8_length(aTHX_ s, s + len);
5469 if (!SvREADONLY(sv)) {
5471 mg = sv_magicext(sv, 0, PERL_MAGIC_utf8,
5472 &PL_vtbl_utf8, 0, 0);
5480 return Perl_utf8_length(aTHX_ s, s + len);
5484 /* Walk forwards to find the byte corresponding to the passed in UTF-8
5487 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
5490 const U8 *s = start;
5492 while (s < send && uoffset--)
5495 /* This is the existing behaviour. Possibly it should be a croak, as
5496 it's actually a bounds error */
5502 /* Given the length of the string in both bytes and UTF-8 characters, decide
5503 whether to walk forwards or backwards to find the byte corresponding to
5504 the passed in UTF-8 offset. */
5506 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
5507 STRLEN uoffset, STRLEN uend)
5509 STRLEN backw = uend - uoffset;
5510 if (uoffset < 2 * backw) {
5511 /* The assumption is that going forwards is twice the speed of going
5512 forward (that's where the 2 * backw comes from).
5513 (The real figure of course depends on the UTF-8 data.) */
5514 return sv_pos_u2b_forwards(start, send, uoffset);
5519 while (UTF8_IS_CONTINUATION(*send))
5522 return send - start;
5525 /* For the string representation of the given scalar, find the byte
5526 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0
5527 give another position in the string, *before* the sought offset, which
5528 (which is always true, as 0, 0 is a valid pair of positions), which should
5529 help reduce the amount of linear searching.
5530 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
5531 will be used to reduce the amount of linear searching. The cache will be
5532 created if necessary, and the found value offered to it for update. */
5534 S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start,
5535 const U8 *const send, STRLEN uoffset,
5536 STRLEN uoffset0, STRLEN boffset0) {
5537 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
5540 assert (uoffset >= uoffset0);
5542 if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
5543 && (*mgp || (*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
5544 if ((*mgp)->mg_ptr) {
5545 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
5546 if (cache[0] == uoffset) {
5547 /* An exact match. */
5550 if (cache[2] == uoffset) {
5551 /* An exact match. */
5555 if (cache[0] < uoffset) {
5556 /* The cache already knows part of the way. */
5557 if (cache[0] > uoffset0) {
5558 /* The cache knows more than the passed in pair */
5559 uoffset0 = cache[0];
5560 boffset0 = cache[1];
5562 if ((*mgp)->mg_len != -1) {
5563 /* And we know the end too. */
5565 + sv_pos_u2b_midway(start + boffset0, send,
5567 (*mgp)->mg_len - uoffset0);
5570 + sv_pos_u2b_forwards(start + boffset0,
5571 send, uoffset - uoffset0);
5574 else if (cache[2] < uoffset) {
5575 /* We're between the two cache entries. */
5576 if (cache[2] > uoffset0) {
5577 /* and the cache knows more than the passed in pair */
5578 uoffset0 = cache[2];
5579 boffset0 = cache[3];
5583 + sv_pos_u2b_midway(start + boffset0,
5586 cache[0] - uoffset0);
5589 + sv_pos_u2b_midway(start + boffset0,
5592 cache[2] - uoffset0);
5596 else if ((*mgp)->mg_len != -1) {
5597 /* If we can take advantage of a passed in offset, do so. */
5598 /* In fact, offset0 is either 0, or less than offset, so don't
5599 need to worry about the other possibility. */
5601 + sv_pos_u2b_midway(start + boffset0, send,
5603 (*mgp)->mg_len - uoffset0);
5608 if (!found || PL_utf8cache < 0) {
5609 const STRLEN real_boffset
5610 = boffset0 + sv_pos_u2b_forwards(start + boffset0,
5611 send, uoffset - uoffset0);
5613 if (found && PL_utf8cache < 0) {
5614 if (real_boffset != boffset) {
5615 /* Need to turn the assertions off otherwise we may recurse
5616 infinitely while printing error messages. */
5617 SAVEI8(PL_utf8cache);
5619 Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
5620 " real %"UVuf" for %"SVf,
5621 (UV) boffset, (UV) real_boffset, SVfARG(sv));
5624 boffset = real_boffset;
5627 S_utf8_mg_pos_cache_update(aTHX_ sv, mgp, boffset, uoffset, send - start);
5633 =for apidoc sv_pos_u2b
5635 Converts the value pointed to by offsetp from a count of UTF-8 chars from
5636 the start of the string, to a count of the equivalent number of bytes; if
5637 lenp is non-zero, it does the same to lenp, but this time starting from
5638 the offset, rather than from the start of the string. Handles magic and
5645 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
5646 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5647 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
5652 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5660 start = (U8*)SvPV_const(sv, len);
5662 STRLEN uoffset = (STRLEN) *offsetp;
5663 const U8 * const send = start + len;
5665 const STRLEN boffset = sv_pos_u2b_cached(sv, &mg, start, send,
5668 *offsetp = (I32) boffset;
5671 /* Convert the relative offset to absolute. */
5672 const STRLEN uoffset2 = uoffset + (STRLEN) *lenp;
5673 const STRLEN boffset2
5674 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
5675 uoffset, boffset) - boffset;
5689 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
5690 byte length pairing. The (byte) length of the total SV is passed in too,
5691 as blen, because for some (more esoteric) SVs, the call to SvPV_const()
5692 may not have updated SvCUR, so we can't rely on reading it directly.
5694 The proffered utf8/byte length pairing isn't used if the cache already has
5695 two pairs, and swapping either for the proffered pair would increase the
5696 RMS of the intervals between known byte offsets.
5698 The cache itself consists of 4 STRLEN values
5699 0: larger UTF-8 offset
5700 1: corresponding byte offset
5701 2: smaller UTF-8 offset
5702 3: corresponding byte offset
5704 Unused cache pairs have the value 0, 0.
5705 Keeping the cache "backwards" means that the invariant of
5706 cache[0] >= cache[2] is maintained even with empty slots, which means that
5707 the code that uses it doesn't need to worry if only 1 entry has actually
5708 been set to non-zero. It also makes the "position beyond the end of the
5709 cache" logic much simpler, as the first slot is always the one to start
5713 S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8,
5721 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
5723 (*mgp)->mg_len = -1;
5727 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
5728 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5729 (*mgp)->mg_ptr = (char *) cache;
5733 if (PL_utf8cache < 0) {
5734 const U8 *start = (const U8 *) SvPVX_const(sv);
5735 const STRLEN realutf8 = utf8_length(start, start + byte);
5737 if (realutf8 != utf8) {
5738 /* Need to turn the assertions off otherwise we may recurse
5739 infinitely while printing error messages. */
5740 SAVEI8(PL_utf8cache);
5742 Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
5743 " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv));
5747 /* Cache is held with the later position first, to simplify the code
5748 that deals with unbounded ends. */
5750 ASSERT_UTF8_CACHE(cache);
5751 if (cache[1] == 0) {
5752 /* Cache is totally empty */
5755 } else if (cache[3] == 0) {
5756 if (byte > cache[1]) {
5757 /* New one is larger, so goes first. */
5758 cache[2] = cache[0];
5759 cache[3] = cache[1];
5767 #define THREEWAY_SQUARE(a,b,c,d) \
5768 ((float)((d) - (c))) * ((float)((d) - (c))) \
5769 + ((float)((c) - (b))) * ((float)((c) - (b))) \
5770 + ((float)((b) - (a))) * ((float)((b) - (a)))
5772 /* Cache has 2 slots in use, and we know three potential pairs.
5773 Keep the two that give the lowest RMS distance. Do the
5774 calcualation in bytes simply because we always know the byte
5775 length. squareroot has the same ordering as the positive value,
5776 so don't bother with the actual square root. */
5777 const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
5778 if (byte > cache[1]) {
5779 /* New position is after the existing pair of pairs. */
5780 const float keep_earlier
5781 = THREEWAY_SQUARE(0, cache[3], byte, blen);
5782 const float keep_later
5783 = THREEWAY_SQUARE(0, cache[1], byte, blen);
5785 if (keep_later < keep_earlier) {
5786 if (keep_later < existing) {
5787 cache[2] = cache[0];
5788 cache[3] = cache[1];
5794 if (keep_earlier < existing) {
5800 else if (byte > cache[3]) {
5801 /* New position is between the existing pair of pairs. */
5802 const float keep_earlier
5803 = THREEWAY_SQUARE(0, cache[3], byte, blen);
5804 const float keep_later
5805 = THREEWAY_SQUARE(0, byte, cache[1], blen);
5807 if (keep_later < keep_earlier) {
5808 if (keep_later < existing) {
5814 if (keep_earlier < existing) {
5821 /* New position is before the existing pair of pairs. */
5822 const float keep_earlier
5823 = THREEWAY_SQUARE(0, byte, cache[3], blen);
5824 const float keep_later
5825 = THREEWAY_SQUARE(0, byte, cache[1], blen);
5827 if (keep_later < keep_earlier) {
5828 if (keep_later < existing) {
5834 if (keep_earlier < existing) {
5835 cache[0] = cache[2];
5836 cache[1] = cache[3];
5843 ASSERT_UTF8_CACHE(cache);
5846 /* We already know all of the way, now we may be able to walk back. The same
5847 assumption is made as in S_sv_pos_u2b_midway(), namely that walking
5848 backward is half the speed of walking forward. */
5850 S_sv_pos_b2u_midway(pTHX_ const U8 *s, const U8 *const target, const U8 *end,
5853 const STRLEN forw = target - s;
5854 STRLEN backw = end - target;
5856 if (forw < 2 * backw) {
5857 return utf8_length(s, target);
5860 while (end > target) {
5862 while (UTF8_IS_CONTINUATION(*end)) {
5871 =for apidoc sv_pos_b2u
5873 Converts the value pointed to by offsetp from a count of bytes from the
5874 start of the string, to a count of the equivalent number of UTF-8 chars.
5875 Handles magic and type coercion.
5881 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
5882 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5887 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
5890 const STRLEN byte = *offsetp;
5891 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
5900 s = (const U8*)SvPV_const(sv, blen);
5903 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5907 if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
5908 && (mg = mg_find(sv, PERL_MAGIC_utf8))) {
5910 STRLEN * const cache = (STRLEN *) mg->mg_ptr;
5911 if (cache[1] == byte) {
5912 /* An exact match. */
5913 *offsetp = cache[0];
5916 if (cache[3] == byte) {
5917 /* An exact match. */
5918 *offsetp = cache[2];
5922 if (cache[1] < byte) {
5923 /* We already know part of the way. */
5924 if (mg->mg_len != -1) {
5925 /* Actually, we know the end too. */
5927 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
5928 s + blen, mg->mg_len - cache[0]);
5930 len = cache[0] + utf8_length(s + cache[1], send);
5933 else if (cache[3] < byte) {
5934 /* We're between the two cached pairs, so we do the calculation
5935 offset by the byte/utf-8 positions for the earlier pair,
5936 then add the utf-8 characters from the string start to
5938 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
5939 s + cache[1], cache[0] - cache[2])
5943 else { /* cache[3] > byte */
5944 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
5948 ASSERT_UTF8_CACHE(cache);
5950 } else if (mg->mg_len != -1) {
5951 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
5955 if (!found || PL_utf8cache < 0) {
5956 const STRLEN real_len = utf8_length(s, send);
5958 if (found && PL_utf8cache < 0) {
5959 if (len != real_len) {
5960 /* Need to turn the assertions off otherwise we may recurse
5961 infinitely while printing error messages. */
5962 SAVEI8(PL_utf8cache);
5964 Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
5965 " real %"UVuf" for %"SVf,
5966 (UV) len, (UV) real_len, SVfARG(sv));
5973 S_utf8_mg_pos_cache_update(aTHX_ sv, &mg, byte, len, blen);
5979 Returns a boolean indicating whether the strings in the two SVs are
5980 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5981 coerce its args to strings if necessary.
5987 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5996 SV* svrecode = NULL;
6003 /* if pv1 and pv2 are the same, second SvPV_const call may
6004 * invalidate pv1, so we may need to make a copy */
6005 if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
6006 pv1 = SvPV_const(sv1, cur1);
6007 sv1 = sv_2mortal(newSVpvn(pv1, cur1));
6008 if (SvUTF8(sv2)) SvUTF8_on(sv1);
6010 pv1 = SvPV_const(sv1, cur1);
6018 pv2 = SvPV_const(sv2, cur2);
6020 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6021 /* Differing utf8ness.
6022 * Do not UTF8size the comparands as a side-effect. */
6025 svrecode = newSVpvn(pv2, cur2);
6026 sv_recode_to_utf8(svrecode, PL_encoding);
6027 pv2 = SvPV_const(svrecode, cur2);
6030 svrecode = newSVpvn(pv1, cur1);
6031 sv_recode_to_utf8(svrecode, PL_encoding);
6032 pv1 = SvPV_const(svrecode, cur1);
6034 /* Now both are in UTF-8. */
6036 SvREFCNT_dec(svrecode);
6041 bool is_utf8 = TRUE;
6044 /* sv1 is the UTF-8 one,
6045 * if is equal it must be downgrade-able */
6046 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6052 /* sv2 is the UTF-8 one,
6053 * if is equal it must be downgrade-able */
6054 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6060 /* Downgrade not possible - cannot be eq */
6068 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6070 SvREFCNT_dec(svrecode);
6080 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6081 string in C<sv1> is less than, equal to, or greater than the string in
6082 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6083 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6089 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6093 const char *pv1, *pv2;
6096 SV *svrecode = NULL;
6103 pv1 = SvPV_const(sv1, cur1);
6110 pv2 = SvPV_const(sv2, cur2);
6112 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6113 /* Differing utf8ness.
6114 * Do not UTF8size the comparands as a side-effect. */
6117 svrecode = newSVpvn(pv2, cur2);
6118 sv_recode_to_utf8(svrecode, PL_encoding);
6119 pv2 = SvPV_const(svrecode, cur2);
6122 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6127 svrecode = newSVpvn(pv1, cur1);
6128 sv_recode_to_utf8(svrecode, PL_encoding);
6129 pv1 = SvPV_const(svrecode, cur1);
6132 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6138 cmp = cur2 ? -1 : 0;
6142 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6145 cmp = retval < 0 ? -1 : 1;
6146 } else if (cur1 == cur2) {
6149 cmp = cur1 < cur2 ? -1 : 1;
6153 SvREFCNT_dec(svrecode);
6161 =for apidoc sv_cmp_locale
6163 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6164 'use bytes' aware, handles get magic, and will coerce its args to strings
6165 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6171 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6174 #ifdef USE_LOCALE_COLLATE
6180 if (PL_collation_standard)
6184 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6186 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6188 if (!pv1 || !len1) {
6199 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6202 return retval < 0 ? -1 : 1;
6205 * When the result of collation is equality, that doesn't mean
6206 * that there are no differences -- some locales exclude some
6207 * characters from consideration. So to avoid false equalities,
6208 * we use the raw string as a tiebreaker.
6214 #endif /* USE_LOCALE_COLLATE */
6216 return sv_cmp(sv1, sv2);
6220 #ifdef USE_LOCALE_COLLATE
6223 =for apidoc sv_collxfrm
6225 Add Collate Transform magic to an SV if it doesn't already have it.
6227 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6228 scalar data of the variable, but transformed to such a format that a normal
6229 memory comparison can be used to compare the data according to the locale
6236 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6241 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6242 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6248 Safefree(mg->mg_ptr);
6249 s = SvPV_const(sv, len);
6250 if ((xf = mem_collxfrm(s, len, &xlen))) {
6251 if (SvREADONLY(sv)) {
6254 return xf + sizeof(PL_collation_ix);
6257 #ifdef PERL_OLD_COPY_ON_WRITE
6259 sv_force_normal_flags(sv, 0);
6261 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
6275 if (mg && mg->mg_ptr) {
6277 return mg->mg_ptr + sizeof(PL_collation_ix);
6285 #endif /* USE_LOCALE_COLLATE */
6290 Get a line from the filehandle and store it into the SV, optionally
6291 appending to the currently-stored string.
6297 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6302 register STDCHAR rslast;
6303 register STDCHAR *bp;
6308 if (SvTHINKFIRST(sv))
6309 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6310 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6312 However, perlbench says it's slower, because the existing swipe code
6313 is faster than copy on write.
6314 Swings and roundabouts. */
6315 SvUPGRADE(sv, SVt_PV);
6320 if (PerlIO_isutf8(fp)) {
6322 sv_utf8_upgrade_nomg(sv);
6323 sv_pos_u2b(sv,&append,0);
6325 } else if (SvUTF8(sv)) {
6326 SV * const tsv = newSV(0);
6327 sv_gets(tsv, fp, 0);
6328 sv_utf8_upgrade_nomg(tsv);
6329 SvCUR_set(sv,append);
6332 goto return_string_or_null;
6337 if (PerlIO_isutf8(fp))
6340 if (IN_PERL_COMPILETIME) {
6341 /* we always read code in line mode */
6345 else if (RsSNARF(PL_rs)) {
6346 /* If it is a regular disk file use size from stat() as estimate
6347 of amount we are going to read -- may result in mallocing
6348 more memory than we really need if the layers below reduce
6349 the size we read (e.g. CRLF or a gzip layer).
6352 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6353 const Off_t offset = PerlIO_tell(fp);
6354 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6355 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6361 else if (RsRECORD(PL_rs)) {
6366 /* Grab the size of the record we're getting */
6367 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
6368 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6371 /* VMS wants read instead of fread, because fread doesn't respect */
6372 /* RMS record boundaries. This is not necessarily a good thing to be */
6373 /* doing, but we've got no other real choice - except avoid stdio
6374 as implementation - perhaps write a :vms layer ?
6376 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6378 bytesread = PerlIO_read(fp, buffer, recsize);
6382 SvCUR_set(sv, bytesread += append);
6383 buffer[bytesread] = '\0';
6384 goto return_string_or_null;
6386 else if (RsPARA(PL_rs)) {
6392 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6393 if (PerlIO_isutf8(fp)) {
6394 rsptr = SvPVutf8(PL_rs, rslen);
6397 if (SvUTF8(PL_rs)) {
6398 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6399 Perl_croak(aTHX_ "Wide character in $/");
6402 rsptr = SvPV_const(PL_rs, rslen);
6406 rslast = rslen ? rsptr[rslen - 1] : '\0';
6408 if (rspara) { /* have to do this both before and after */
6409 do { /* to make sure file boundaries work right */
6412 i = PerlIO_getc(fp);
6416 PerlIO_ungetc(fp,i);
6422 /* See if we know enough about I/O mechanism to cheat it ! */
6424 /* This used to be #ifdef test - it is made run-time test for ease
6425 of abstracting out stdio interface. One call should be cheap
6426 enough here - and may even be a macro allowing compile
6430 if (PerlIO_fast_gets(fp)) {
6433 * We're going to steal some values from the stdio struct
6434 * and put EVERYTHING in the innermost loop into registers.
6436 register STDCHAR *ptr;
6440 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6441 /* An ungetc()d char is handled separately from the regular
6442 * buffer, so we getc() it back out and stuff it in the buffer.
6444 i = PerlIO_getc(fp);
6445 if (i == EOF) return 0;
6446 *(--((*fp)->_ptr)) = (unsigned char) i;
6450 /* Here is some breathtakingly efficient cheating */
6452 cnt = PerlIO_get_cnt(fp); /* get count into register */
6453 /* make sure we have the room */
6454 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
6455 /* Not room for all of it
6456 if we are looking for a separator and room for some
6458 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
6459 /* just process what we have room for */
6460 shortbuffered = cnt - SvLEN(sv) + append + 1;
6461 cnt -= shortbuffered;
6465 /* remember that cnt can be negative */
6466 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
6471 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
6472 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
6473 DEBUG_P(PerlIO_printf(Perl_debug_log,
6474 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6475 DEBUG_P(PerlIO_printf(Perl_debug_log,
6476 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6477 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6478 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6483 while (cnt > 0) { /* this | eat */
6485 if ((*bp++ = *ptr++) == rslast) /* really | dust */
6486 goto thats_all_folks; /* screams | sed :-) */
6490 Copy(ptr, bp, cnt, char); /* this | eat */
6491 bp += cnt; /* screams | dust */
6492 ptr += cnt; /* louder | sed :-) */
6497 if (shortbuffered) { /* oh well, must extend */
6498 cnt = shortbuffered;
6500 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6502 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6503 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6507 DEBUG_P(PerlIO_printf(Perl_debug_log,
6508 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6509 PTR2UV(ptr),(long)cnt));
6510 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6512 DEBUG_P(PerlIO_printf(Perl_debug_log,
6513 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6514 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6515 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6517 /* This used to call 'filbuf' in stdio form, but as that behaves like
6518 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6519 another abstraction. */
6520 i = PerlIO_getc(fp); /* get more characters */
6522 DEBUG_P(PerlIO_printf(Perl_debug_log,
6523 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6524 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6525 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6527 cnt = PerlIO_get_cnt(fp);
6528 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
6529 DEBUG_P(PerlIO_printf(Perl_debug_log,
6530 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6532 if (i == EOF) /* all done for ever? */
6533 goto thats_really_all_folks;
6535 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6537 SvGROW(sv, bpx + cnt + 2);
6538 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6540 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
6542 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
6543 goto thats_all_folks;
6547 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
6548 memNE((char*)bp - rslen, rsptr, rslen))
6549 goto screamer; /* go back to the fray */
6550 thats_really_all_folks:
6552 cnt += shortbuffered;
6553 DEBUG_P(PerlIO_printf(Perl_debug_log,
6554 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6555 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
6556 DEBUG_P(PerlIO_printf(Perl_debug_log,
6557 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6558 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6559 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6561 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
6562 DEBUG_P(PerlIO_printf(Perl_debug_log,
6563 "Screamer: done, len=%ld, string=|%.*s|\n",
6564 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
6568 /*The big, slow, and stupid way. */
6569 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
6570 STDCHAR *buf = NULL;
6571 Newx(buf, 8192, STDCHAR);
6579 register const STDCHAR * const bpe = buf + sizeof(buf);
6581 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6582 ; /* keep reading */
6586 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6587 /* Accomodate broken VAXC compiler, which applies U8 cast to
6588 * both args of ?: operator, causing EOF to change into 255
6591 i = (U8)buf[cnt - 1];
6597 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
6599 sv_catpvn(sv, (char *) buf, cnt);
6601 sv_setpvn(sv, (char *) buf, cnt);
6603 if (i != EOF && /* joy */
6605 SvCUR(sv) < rslen ||
6606 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6610 * If we're reading from a TTY and we get a short read,
6611 * indicating that the user hit his EOF character, we need
6612 * to notice it now, because if we try to read from the TTY
6613 * again, the EOF condition will disappear.
6615 * The comparison of cnt to sizeof(buf) is an optimization
6616 * that prevents unnecessary calls to feof().
6620 if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
6624 #ifdef USE_HEAP_INSTEAD_OF_STACK
6629 if (rspara) { /* have to do this both before and after */
6630 while (i != EOF) { /* to make sure file boundaries work right */
6631 i = PerlIO_getc(fp);
6633 PerlIO_ungetc(fp,i);
6639 return_string_or_null:
6640 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
6646 Auto-increment of the value in the SV, doing string to numeric conversion
6647 if necessary. Handles 'get' magic.
6653 Perl_sv_inc(pTHX_ register SV *sv)
6662 if (SvTHINKFIRST(sv)) {
6664 sv_force_normal_flags(sv, 0);
6665 if (SvREADONLY(sv)) {
6666 if (IN_PERL_RUNTIME)
6667 Perl_croak(aTHX_ PL_no_modify);
6671 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6673 i = PTR2IV(SvRV(sv));
6678 flags = SvFLAGS(sv);
6679 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6680 /* It's (privately or publicly) a float, but not tested as an
6681 integer, so test it to see. */
6683 flags = SvFLAGS(sv);
6685 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6686 /* It's publicly an integer, or privately an integer-not-float */
6687 #ifdef PERL_PRESERVE_IVUV
6691 if (SvUVX(sv) == UV_MAX)
6692 sv_setnv(sv, UV_MAX_P1);
6694 (void)SvIOK_only_UV(sv);
6695 SvUV_set(sv, SvUVX(sv) + 1);
6697 if (SvIVX(sv) == IV_MAX)
6698 sv_setuv(sv, (UV)IV_MAX + 1);
6700 (void)SvIOK_only(sv);
6701 SvIV_set(sv, SvIVX(sv) + 1);
6706 if (flags & SVp_NOK) {
6707 (void)SvNOK_only(sv);
6708 SvNV_set(sv, SvNVX(sv) + 1.0);
6712 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
6713 if ((flags & SVTYPEMASK) < SVt_PVIV)
6714 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
6715 (void)SvIOK_only(sv);
6720 while (isALPHA(*d)) d++;
6721 while (isDIGIT(*d)) d++;
6723 #ifdef PERL_PRESERVE_IVUV
6724 /* Got to punt this as an integer if needs be, but we don't issue
6725 warnings. Probably ought to make the sv_iv_please() that does
6726 the conversion if possible, and silently. */
6727 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6728 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6729 /* Need to try really hard to see if it's an integer.
6730 9.22337203685478e+18 is an integer.
6731 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6732 so $a="9.22337203685478e+18"; $a+0; $a++
6733 needs to be the same as $a="9.22337203685478e+18"; $a++
6740 /* sv_2iv *should* have made this an NV */
6741 if (flags & SVp_NOK) {
6742 (void)SvNOK_only(sv);
6743 SvNV_set(sv, SvNVX(sv) + 1.0);
6746 /* I don't think we can get here. Maybe I should assert this
6747 And if we do get here I suspect that sv_setnv will croak. NWC
6749 #if defined(USE_LONG_DOUBLE)
6750 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",
6751 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6753 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6754 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6757 #endif /* PERL_PRESERVE_IVUV */
6758 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
6762 while (d >= SvPVX_const(sv)) {
6770 /* MKS: The original code here died if letters weren't consecutive.
6771 * at least it didn't have to worry about non-C locales. The
6772 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6773 * arranged in order (although not consecutively) and that only
6774 * [A-Za-z] are accepted by isALPHA in the C locale.
6776 if (*d != 'z' && *d != 'Z') {
6777 do { ++*d; } while (!isALPHA(*d));
6780 *(d--) -= 'z' - 'a';
6785 *(d--) -= 'z' - 'a' + 1;
6789 /* oh,oh, the number grew */
6790 SvGROW(sv, SvCUR(sv) + 2);
6791 SvCUR_set(sv, SvCUR(sv) + 1);
6792 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
6803 Auto-decrement of the value in the SV, doing string to numeric conversion
6804 if necessary. Handles 'get' magic.
6810 Perl_sv_dec(pTHX_ register SV *sv)
6818 if (SvTHINKFIRST(sv)) {
6820 sv_force_normal_flags(sv, 0);
6821 if (SvREADONLY(sv)) {
6822 if (IN_PERL_RUNTIME)
6823 Perl_croak(aTHX_ PL_no_modify);
6827 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6829 i = PTR2IV(SvRV(sv));
6834 /* Unlike sv_inc we don't have to worry about string-never-numbers
6835 and keeping them magic. But we mustn't warn on punting */
6836 flags = SvFLAGS(sv);
6837 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6838 /* It's publicly an integer, or privately an integer-not-float */
6839 #ifdef PERL_PRESERVE_IVUV
6843 if (SvUVX(sv) == 0) {
6844 (void)SvIOK_only(sv);
6848 (void)SvIOK_only_UV(sv);
6849 SvUV_set(sv, SvUVX(sv) - 1);
6852 if (SvIVX(sv) == IV_MIN)
6853 sv_setnv(sv, (NV)IV_MIN - 1.0);
6855 (void)SvIOK_only(sv);
6856 SvIV_set(sv, SvIVX(sv) - 1);
6861 if (flags & SVp_NOK) {
6862 SvNV_set(sv, SvNVX(sv) - 1.0);
6863 (void)SvNOK_only(sv);
6866 if (!(flags & SVp_POK)) {
6867 if ((flags & SVTYPEMASK) < SVt_PVIV)
6868 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
6870 (void)SvIOK_only(sv);
6873 #ifdef PERL_PRESERVE_IVUV
6875 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6876 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6877 /* Need to try really hard to see if it's an integer.
6878 9.22337203685478e+18 is an integer.
6879 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6880 so $a="9.22337203685478e+18"; $a+0; $a--
6881 needs to be the same as $a="9.22337203685478e+18"; $a--
6888 /* sv_2iv *should* have made this an NV */
6889 if (flags & SVp_NOK) {
6890 (void)SvNOK_only(sv);
6891 SvNV_set(sv, SvNVX(sv) - 1.0);
6894 /* I don't think we can get here. Maybe I should assert this
6895 And if we do get here I suspect that sv_setnv will croak. NWC
6897 #if defined(USE_LONG_DOUBLE)
6898 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",
6899 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6901 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6902 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6906 #endif /* PERL_PRESERVE_IVUV */
6907 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
6911 =for apidoc sv_mortalcopy
6913 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6914 The new SV is marked as mortal. It will be destroyed "soon", either by an
6915 explicit call to FREETMPS, or by an implicit call at places such as
6916 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
6921 /* Make a string that will exist for the duration of the expression
6922 * evaluation. Actually, it may have to last longer than that, but
6923 * hopefully we won't free it until it has been assigned to a
6924 * permanent location. */
6927 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6933 sv_setsv(sv,oldstr);
6935 PL_tmps_stack[++PL_tmps_ix] = sv;
6941 =for apidoc sv_newmortal
6943 Creates a new null SV which is mortal. The reference count of the SV is
6944 set to 1. It will be destroyed "soon", either by an explicit call to
6945 FREETMPS, or by an implicit call at places such as statement boundaries.
6946 See also C<sv_mortalcopy> and C<sv_2mortal>.
6952 Perl_sv_newmortal(pTHX)
6958 SvFLAGS(sv) = SVs_TEMP;
6960 PL_tmps_stack[++PL_tmps_ix] = sv;
6965 =for apidoc sv_2mortal
6967 Marks an existing SV as mortal. The SV will be destroyed "soon", either
6968 by an explicit call to FREETMPS, or by an implicit call at places such as
6969 statement boundaries. SvTEMP() is turned on which means that the SV's
6970 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
6971 and C<sv_mortalcopy>.
6977 Perl_sv_2mortal(pTHX_ register SV *sv)
6982 if (SvREADONLY(sv) && SvIMMORTAL(sv))
6985 PL_tmps_stack[++PL_tmps_ix] = sv;
6993 Creates a new SV and copies a string into it. The reference count for the
6994 SV is set to 1. If C<len> is zero, Perl will compute the length using
6995 strlen(). For efficiency, consider using C<newSVpvn> instead.
7001 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
7007 sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
7012 =for apidoc newSVpvn
7014 Creates a new SV and copies a string into it. The reference count for the
7015 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7016 string. You are responsible for ensuring that the source string is at least
7017 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7023 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7029 sv_setpvn(sv,s,len);
7035 =for apidoc newSVhek
7037 Creates a new SV from the hash key structure. It will generate scalars that
7038 point to the shared string table where possible. Returns a new (undefined)
7039 SV if the hek is NULL.
7045 Perl_newSVhek(pTHX_ const HEK *hek)
7055 if (HEK_LEN(hek) == HEf_SVKEY) {
7056 return newSVsv(*(SV**)HEK_KEY(hek));
7058 const int flags = HEK_FLAGS(hek);
7059 if (flags & HVhek_WASUTF8) {
7061 Andreas would like keys he put in as utf8 to come back as utf8
7063 STRLEN utf8_len = HEK_LEN(hek);
7064 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7065 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
7068 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7070 } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
7071 /* We don't have a pointer to the hv, so we have to replicate the
7072 flag into every HEK. This hv is using custom a hasing
7073 algorithm. Hence we can't return a shared string scalar, as
7074 that would contain the (wrong) hash value, and might get passed
7075 into an hv routine with a regular hash.
7076 Similarly, a hash that isn't using shared hash keys has to have
7077 the flag in every key so that we know not to try to call
7078 share_hek_kek on it. */
7080 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7085 /* This will be overwhelminly the most common case. */
7087 /* Inline most of newSVpvn_share(), because share_hek_hek() is far
7088 more efficient than sharepvn(). */
7092 sv_upgrade(sv, SVt_PV);
7093 SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
7094 SvCUR_set(sv, HEK_LEN(hek));
7107 =for apidoc newSVpvn_share
7109 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7110 table. If the string does not already exist in the table, it is created
7111 first. Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
7112 value is used; otherwise the hash is computed. The string's hash can be later
7113 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
7114 that as the string table is used for shared hash keys these strings will have
7115 SvPVX_const == HeKEY and hash lookup will avoid string compare.
7121 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7125 bool is_utf8 = FALSE;
7126 const char *const orig_src = src;
7129 STRLEN tmplen = -len;
7131 /* See the note in hv.c:hv_fetch() --jhi */
7132 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7136 PERL_HASH(hash, src, len);
7138 sv_upgrade(sv, SVt_PV);
7139 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7147 if (src != orig_src)
7153 #if defined(PERL_IMPLICIT_CONTEXT)
7155 /* pTHX_ magic can't cope with varargs, so this is a no-context
7156 * version of the main function, (which may itself be aliased to us).
7157 * Don't access this version directly.
7161 Perl_newSVpvf_nocontext(const char* pat, ...)
7166 va_start(args, pat);
7167 sv = vnewSVpvf(pat, &args);
7174 =for apidoc newSVpvf
7176 Creates a new SV and initializes it with the string formatted like
7183 Perl_newSVpvf(pTHX_ const char* pat, ...)
7187 va_start(args, pat);
7188 sv = vnewSVpvf(pat, &args);
7193 /* backend for newSVpvf() and newSVpvf_nocontext() */
7196 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7201 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7208 Creates a new SV and copies a floating point value into it.
7209 The reference count for the SV is set to 1.
7215 Perl_newSVnv(pTHX_ NV n)
7228 Creates a new SV and copies an integer into it. The reference count for the
7235 Perl_newSViv(pTHX_ IV i)
7248 Creates a new SV and copies an unsigned integer into it.
7249 The reference count for the SV is set to 1.
7255 Perl_newSVuv(pTHX_ UV u)
7266 =for apidoc newSV_type
7268 Creates a new SV, of the type specified. The reference count for the new SV
7275 Perl_newSV_type(pTHX_ svtype type)
7280 sv_upgrade(sv, type);
7285 =for apidoc newRV_noinc
7287 Creates an RV wrapper for an SV. The reference count for the original
7288 SV is B<not> incremented.
7294 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7297 register SV *sv = newSV_type(SVt_RV);
7299 SvRV_set(sv, tmpRef);
7304 /* newRV_inc is the official function name to use now.
7305 * newRV_inc is in fact #defined to newRV in sv.h
7309 Perl_newRV(pTHX_ SV *sv)
7312 return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
7318 Creates a new SV which is an exact duplicate of the original SV.
7325 Perl_newSVsv(pTHX_ register SV *old)
7332 if (SvTYPE(old) == SVTYPEMASK) {
7333 if (ckWARN_d(WARN_INTERNAL))
7334 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7338 /* SV_GMAGIC is the default for sv_setv()
7339 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7340 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7341 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7346 =for apidoc sv_reset
7348 Underlying implementation for the C<reset> Perl function.
7349 Note that the perl-level function is vaguely deprecated.
7355 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
7358 char todo[PERL_UCHAR_MAX+1];
7363 if (!*s) { /* reset ?? searches */
7364 MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
7366 const U32 count = mg->mg_len / sizeof(PMOP**);
7367 PMOP **pmp = (PMOP**) mg->mg_ptr;
7368 PMOP *const *const end = pmp + count;
7372 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
7374 (*pmp)->op_pmflags &= ~PMf_USED;
7382 /* reset variables */
7384 if (!HvARRAY(stash))
7387 Zero(todo, 256, char);
7390 I32 i = (unsigned char)*s;
7394 max = (unsigned char)*s++;
7395 for ( ; i <= max; i++) {
7398 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7400 for (entry = HvARRAY(stash)[i];
7402 entry = HeNEXT(entry))
7407 if (!todo[(U8)*HeKEY(entry)])
7409 gv = (GV*)HeVAL(entry);
7412 if (SvTHINKFIRST(sv)) {
7413 if (!SvREADONLY(sv) && SvROK(sv))
7415 /* XXX Is this continue a bug? Why should THINKFIRST
7416 exempt us from resetting arrays and hashes? */
7420 if (SvTYPE(sv) >= SVt_PV) {
7422 if (SvPVX_const(sv) != NULL)
7430 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
7432 Perl_die(aTHX_ "Can't reset %%ENV on this system");
7435 # if defined(USE_ENVIRON_ARRAY)
7438 # endif /* USE_ENVIRON_ARRAY */
7449 Using various gambits, try to get an IO from an SV: the IO slot if its a
7450 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7451 named after the PV if we're a string.
7457 Perl_sv_2io(pTHX_ SV *sv)
7462 switch (SvTYPE(sv)) {
7470 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7474 Perl_croak(aTHX_ PL_no_usym, "filehandle");
7476 return sv_2io(SvRV(sv));
7477 gv = gv_fetchsv(sv, 0, SVt_PVIO);
7483 Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
7492 Using various gambits, try to get a CV from an SV; in addition, try if
7493 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7494 The flags in C<lref> are passed to sv_fetchsv.
7500 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7511 switch (SvTYPE(sv)) {
7530 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
7531 tryAMAGICunDEREF(to_cv);
7534 if (SvTYPE(sv) == SVt_PVCV) {
7543 Perl_croak(aTHX_ "Not a subroutine reference");
7548 gv = gv_fetchsv(sv, lref, SVt_PVCV);
7554 /* Some flags to gv_fetchsv mean don't really create the GV */
7555 if (SvTYPE(gv) != SVt_PVGV) {
7561 if (lref && !GvCVu(gv)) {
7565 gv_efullname3(tmpsv, gv, NULL);
7566 /* XXX this is probably not what they think they're getting.
7567 * It has the same effect as "sub name;", i.e. just a forward
7569 newSUB(start_subparse(FALSE, 0),
7570 newSVOP(OP_CONST, 0, tmpsv),
7574 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
7584 Returns true if the SV has a true value by Perl's rules.
7585 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
7586 instead use an in-line version.
7592 Perl_sv_true(pTHX_ register SV *sv)
7597 register const XPV* const tXpv = (XPV*)SvANY(sv);
7599 (tXpv->xpv_cur > 1 ||
7600 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
7607 return SvIVX(sv) != 0;
7610 return SvNVX(sv) != 0.0;
7612 return sv_2bool(sv);
7618 =for apidoc sv_pvn_force
7620 Get a sensible string out of the SV somehow.
7621 A private implementation of the C<SvPV_force> macro for compilers which
7622 can't cope with complex macro expressions. Always use the macro instead.
7624 =for apidoc sv_pvn_force_flags
7626 Get a sensible string out of the SV somehow.
7627 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
7628 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
7629 implemented in terms of this function.
7630 You normally want to use the various wrapper macros instead: see
7631 C<SvPV_force> and C<SvPV_force_nomg>
7637 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
7640 if (SvTHINKFIRST(sv) && !SvROK(sv))
7641 sv_force_normal_flags(sv, 0);
7651 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
7652 const char * const ref = sv_reftype(sv,0);
7654 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
7655 ref, OP_NAME(PL_op));
7657 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
7659 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
7660 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
7662 s = sv_2pv_flags(sv, &len, flags);
7666 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
7669 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
7670 SvGROW(sv, len + 1);
7671 Move(s,SvPVX(sv),len,char);
7673 SvPVX(sv)[len] = '\0';
7676 SvPOK_on(sv); /* validate pointer */
7678 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
7679 PTR2UV(sv),SvPVX_const(sv)));
7682 return SvPVX_mutable(sv);
7686 =for apidoc sv_pvbyten_force
7688 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
7694 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
7696 sv_pvn_force(sv,lp);
7697 sv_utf8_downgrade(sv,0);
7703 =for apidoc sv_pvutf8n_force
7705 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
7711 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
7713 sv_pvn_force(sv,lp);
7714 sv_utf8_upgrade(sv);
7720 =for apidoc sv_reftype
7722 Returns a string describing what the SV is a reference to.
7728 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
7730 /* The fact that I don't need to downcast to char * everywhere, only in ?:
7731 inside return suggests a const propagation bug in g++. */
7732 if (ob && SvOBJECT(sv)) {
7733 char * const name = HvNAME_get(SvSTASH(sv));
7734 return name ? name : (char *) "__ANON__";
7737 switch (SvTYPE(sv)) {
7753 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
7754 /* tied lvalues should appear to be
7755 * scalars for backwards compatitbility */
7756 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
7757 ? "SCALAR" : "LVALUE");
7758 case SVt_PVAV: return "ARRAY";
7759 case SVt_PVHV: return "HASH";
7760 case SVt_PVCV: return "CODE";
7761 case SVt_PVGV: return "GLOB";
7762 case SVt_PVFM: return "FORMAT";
7763 case SVt_PVIO: return "IO";
7764 case SVt_BIND: return "BIND";
7765 default: return "UNKNOWN";
7771 =for apidoc sv_isobject
7773 Returns a boolean indicating whether the SV is an RV pointing to a blessed
7774 object. If the SV is not an RV, or if the object is not blessed, then this
7781 Perl_sv_isobject(pTHX_ SV *sv)
7797 Returns a boolean indicating whether the SV is blessed into the specified
7798 class. This does not check for subtypes; use C<sv_derived_from> to verify
7799 an inheritance relationship.
7805 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7816 hvname = HvNAME_get(SvSTASH(sv));
7820 return strEQ(hvname, name);
7826 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
7827 it will be upgraded to one. If C<classname> is non-null then the new SV will
7828 be blessed in the specified package. The new SV is returned and its
7829 reference count is 1.
7835 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7842 SV_CHECK_THINKFIRST_COW_DROP(rv);
7843 (void)SvAMAGIC_off(rv);
7845 if (SvTYPE(rv) >= SVt_PVMG) {
7846 const U32 refcnt = SvREFCNT(rv);
7850 SvREFCNT(rv) = refcnt;
7852 sv_upgrade(rv, SVt_RV);
7853 } else if (SvROK(rv)) {
7854 SvREFCNT_dec(SvRV(rv));
7855 } else if (SvTYPE(rv) < SVt_RV)
7856 sv_upgrade(rv, SVt_RV);
7857 else if (SvTYPE(rv) > SVt_RV) {
7868 HV* const stash = gv_stashpv(classname, GV_ADD);
7869 (void)sv_bless(rv, stash);
7875 =for apidoc sv_setref_pv
7877 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7878 argument will be upgraded to an RV. That RV will be modified to point to
7879 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7880 into the SV. The C<classname> argument indicates the package for the
7881 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
7882 will have a reference count of 1, and the RV will be returned.
7884 Do not use with other Perl types such as HV, AV, SV, CV, because those
7885 objects will become corrupted by the pointer copy process.
7887 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7893 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7897 sv_setsv(rv, &PL_sv_undef);
7901 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7906 =for apidoc sv_setref_iv
7908 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7909 argument will be upgraded to an RV. That RV will be modified to point to
7910 the new SV. The C<classname> argument indicates the package for the
7911 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
7912 will have a reference count of 1, and the RV will be returned.
7918 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7920 sv_setiv(newSVrv(rv,classname), iv);
7925 =for apidoc sv_setref_uv
7927 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7928 argument will be upgraded to an RV. That RV will be modified to point to
7929 the new SV. The C<classname> argument indicates the package for the
7930 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
7931 will have a reference count of 1, and the RV will be returned.
7937 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7939 sv_setuv(newSVrv(rv,classname), uv);
7944 =for apidoc sv_setref_nv
7946 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7947 argument will be upgraded to an RV. That RV will be modified to point to
7948 the new SV. The C<classname> argument indicates the package for the
7949 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
7950 will have a reference count of 1, and the RV will be returned.
7956 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7958 sv_setnv(newSVrv(rv,classname), nv);
7963 =for apidoc sv_setref_pvn
7965 Copies a string into a new SV, optionally blessing the SV. The length of the
7966 string must be specified with C<n>. The C<rv> argument will be upgraded to
7967 an RV. That RV will be modified to point to the new SV. The C<classname>
7968 argument indicates the package for the blessing. Set C<classname> to
7969 C<NULL> to avoid the blessing. The new SV will have a reference count
7970 of 1, and the RV will be returned.
7972 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7978 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n)
7980 sv_setpvn(newSVrv(rv,classname), pv, n);
7985 =for apidoc sv_bless
7987 Blesses an SV into a specified package. The SV must be an RV. The package
7988 must be designated by its stash (see C<gv_stashpv()>). The reference count
7989 of the SV is unaffected.
7995 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8000 Perl_croak(aTHX_ "Can't bless non-reference value");
8002 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8003 if (SvIsCOW(tmpRef))
8004 sv_force_normal_flags(tmpRef, 0);
8005 if (SvREADONLY(tmpRef))
8006 Perl_croak(aTHX_ PL_no_modify);
8007 if (SvOBJECT(tmpRef)) {
8008 if (SvTYPE(tmpRef) != SVt_PVIO)
8010 SvREFCNT_dec(SvSTASH(tmpRef));
8013 SvOBJECT_on(tmpRef);
8014 if (SvTYPE(tmpRef) != SVt_PVIO)
8016 SvUPGRADE(tmpRef, SVt_PVMG);
8017 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc_simple(stash));
8022 (void)SvAMAGIC_off(sv);
8024 if(SvSMAGICAL(tmpRef))
8025 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8033 /* Downgrades a PVGV to a PVMG.
8037 S_sv_unglob(pTHX_ SV *sv)
8042 SV * const temp = sv_newmortal();
8044 assert(SvTYPE(sv) == SVt_PVGV);
8046 gv_efullname3(temp, (GV *) sv, "*");
8049 if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash))
8050 mro_method_changed_in(stash);
8054 sv_del_backref((SV*)GvSTASH(sv), sv);
8058 if (GvNAME_HEK(sv)) {
8059 unshare_hek(GvNAME_HEK(sv));
8061 isGV_with_GP_off(sv);
8063 /* need to keep SvANY(sv) in the right arena */
8064 xpvmg = new_XPVMG();
8065 StructCopy(SvANY(sv), xpvmg, XPVMG);
8066 del_XPVGV(SvANY(sv));
8069 SvFLAGS(sv) &= ~SVTYPEMASK;
8070 SvFLAGS(sv) |= SVt_PVMG;
8072 /* Intentionally not calling any local SET magic, as this isn't so much a
8073 set operation as merely an internal storage change. */
8074 sv_setsv_flags(sv, temp, 0);
8078 =for apidoc sv_unref_flags
8080 Unsets the RV status of the SV, and decrements the reference count of
8081 whatever was being referenced by the RV. This can almost be thought of
8082 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8083 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8084 (otherwise the decrementing is conditional on the reference count being
8085 different from one or the reference being a readonly SV).
8092 Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags)
8094 SV* const target = SvRV(ref);
8096 if (SvWEAKREF(ref)) {
8097 sv_del_backref(target, ref);
8099 SvRV_set(ref, NULL);
8102 SvRV_set(ref, NULL);
8104 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
8105 assigned to as BEGIN {$a = \"Foo"} will fail. */
8106 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
8107 SvREFCNT_dec(target);
8108 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8109 sv_2mortal(target); /* Schedule for freeing later */
8113 =for apidoc sv_untaint
8115 Untaint an SV. Use C<SvTAINTED_off> instead.
8120 Perl_sv_untaint(pTHX_ SV *sv)
8122 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8123 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8130 =for apidoc sv_tainted
8132 Test an SV for taintedness. Use C<SvTAINTED> instead.
8137 Perl_sv_tainted(pTHX_ SV *sv)
8139 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8140 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8141 if (mg && (mg->mg_len & 1) )
8148 =for apidoc sv_setpviv
8150 Copies an integer into the given SV, also updating its string value.
8151 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8157 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8159 char buf[TYPE_CHARS(UV)];
8161 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8163 sv_setpvn(sv, ptr, ebuf - ptr);
8167 =for apidoc sv_setpviv_mg
8169 Like C<sv_setpviv>, but also handles 'set' magic.
8175 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8181 #if defined(PERL_IMPLICIT_CONTEXT)
8183 /* pTHX_ magic can't cope with varargs, so this is a no-context
8184 * version of the main function, (which may itself be aliased to us).
8185 * Don't access this version directly.
8189 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8193 va_start(args, pat);
8194 sv_vsetpvf(sv, pat, &args);
8198 /* pTHX_ magic can't cope with varargs, so this is a no-context
8199 * version of the main function, (which may itself be aliased to us).
8200 * Don't access this version directly.
8204 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8208 va_start(args, pat);
8209 sv_vsetpvf_mg(sv, pat, &args);
8215 =for apidoc sv_setpvf
8217 Works like C<sv_catpvf> but copies the text into the SV instead of
8218 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8224 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8227 va_start(args, pat);
8228 sv_vsetpvf(sv, pat, &args);
8233 =for apidoc sv_vsetpvf
8235 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8236 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8238 Usually used via its frontend C<sv_setpvf>.
8244 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8246 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8250 =for apidoc sv_setpvf_mg
8252 Like C<sv_setpvf>, but also handles 'set' magic.
8258 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8261 va_start(args, pat);
8262 sv_vsetpvf_mg(sv, pat, &args);
8267 =for apidoc sv_vsetpvf_mg
8269 Like C<sv_vsetpvf>, but also handles 'set' magic.
8271 Usually used via its frontend C<sv_setpvf_mg>.
8277 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8279 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8283 #if defined(PERL_IMPLICIT_CONTEXT)
8285 /* pTHX_ magic can't cope with varargs, so this is a no-context
8286 * version of the main function, (which may itself be aliased to us).
8287 * Don't access this version directly.
8291 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8295 va_start(args, pat);
8296 sv_vcatpvf(sv, pat, &args);
8300 /* pTHX_ magic can't cope with varargs, so this is a no-context
8301 * version of the main function, (which may itself be aliased to us).
8302 * Don't access this version directly.
8306 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8310 va_start(args, pat);
8311 sv_vcatpvf_mg(sv, pat, &args);
8317 =for apidoc sv_catpvf
8319 Processes its arguments like C<sprintf> and appends the formatted
8320 output to an SV. If the appended data contains "wide" characters
8321 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8322 and characters >255 formatted with %c), the original SV might get
8323 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
8324 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
8325 valid UTF-8; if the original SV was bytes, the pattern should be too.
8330 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8333 va_start(args, pat);
8334 sv_vcatpvf(sv, pat, &args);
8339 =for apidoc sv_vcatpvf
8341 Processes its arguments like C<vsprintf> and appends the formatted output
8342 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
8344 Usually used via its frontend C<sv_catpvf>.
8350 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8352 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8356 =for apidoc sv_catpvf_mg
8358 Like C<sv_catpvf>, but also handles 'set' magic.
8364 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8367 va_start(args, pat);
8368 sv_vcatpvf_mg(sv, pat, &args);
8373 =for apidoc sv_vcatpvf_mg
8375 Like C<sv_vcatpvf>, but also handles 'set' magic.
8377 Usually used via its frontend C<sv_catpvf_mg>.
8383 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8385 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8390 =for apidoc sv_vsetpvfn
8392 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
8395 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
8401 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8403 sv_setpvn(sv, "", 0);
8404 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8408 S_expect_number(pTHX_ char** pattern)
8412 switch (**pattern) {
8413 case '1': case '2': case '3':
8414 case '4': case '5': case '6':
8415 case '7': case '8': case '9':
8416 var = *(*pattern)++ - '0';
8417 while (isDIGIT(**pattern)) {
8418 const I32 tmp = var * 10 + (*(*pattern)++ - '0');
8420 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn"));
8428 S_F0convert(NV nv, char *endbuf, STRLEN *len)
8430 const int neg = nv < 0;
8439 if (uv & 1 && uv == nv)
8440 uv--; /* Round to even */
8442 const unsigned dig = uv % 10;
8455 =for apidoc sv_vcatpvfn
8457 Processes its arguments like C<vsprintf> and appends the formatted output
8458 to an SV. Uses an array of SVs if the C style variable argument list is
8459 missing (NULL). When running with taint checks enabled, indicates via
8460 C<maybe_tainted> if results are untrustworthy (often due to the use of
8463 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
8469 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
8470 vecstr = (U8*)SvPV_const(vecsv,veclen);\
8471 vec_utf8 = DO_UTF8(vecsv);
8473 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
8476 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8484 static const char nullstr[] = "(null)";
8486 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
8487 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
8489 /* Times 4: a decimal digit takes more than 3 binary digits.
8490 * NV_DIG: mantissa takes than many decimal digits.
8491 * Plus 32: Playing safe. */
8492 char ebuf[IV_DIG * 4 + NV_DIG + 32];
8493 /* large enough for "%#.#f" --chip */
8494 /* what about long double NVs? --jhi */
8496 PERL_UNUSED_ARG(maybe_tainted);
8498 /* no matter what, this is a string now */
8499 (void)SvPV_force(sv, origlen);
8501 /* special-case "", "%s", and "%-p" (SVf - see below) */
8504 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
8506 const char * const s = va_arg(*args, char*);
8507 sv_catpv(sv, s ? s : nullstr);
8509 else if (svix < svmax) {
8510 sv_catsv(sv, *svargs);
8514 if (args && patlen == 3 && pat[0] == '%' &&
8515 pat[1] == '-' && pat[2] == 'p') {
8516 argsv = (SV*)va_arg(*args, void*);
8517 sv_catsv(sv, argsv);
8521 #ifndef USE_LONG_DOUBLE
8522 /* special-case "%.<number>[gf]" */
8523 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
8524 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
8525 unsigned digits = 0;
8529 while (*pp >= '0' && *pp <= '9')
8530 digits = 10 * digits + (*pp++ - '0');
8531 if (pp - pat == (int)patlen - 1) {
8539 /* Add check for digits != 0 because it seems that some
8540 gconverts are buggy in this case, and we don't yet have
8541 a Configure test for this. */
8542 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
8543 /* 0, point, slack */
8544 Gconvert(nv, (int)digits, 0, ebuf);
8546 if (*ebuf) /* May return an empty string for digits==0 */
8549 } else if (!digits) {
8552 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
8553 sv_catpvn(sv, p, l);
8559 #endif /* !USE_LONG_DOUBLE */
8561 if (!args && svix < svmax && DO_UTF8(*svargs))
8564 patend = (char*)pat + patlen;
8565 for (p = (char*)pat; p < patend; p = q) {
8568 bool vectorize = FALSE;
8569 bool vectorarg = FALSE;
8570 bool vec_utf8 = FALSE;
8576 bool has_precis = FALSE;
8578 const I32 osvix = svix;
8579 bool is_utf8 = FALSE; /* is this item utf8? */
8580 #ifdef HAS_LDBL_SPRINTF_BUG
8581 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8582 with sfio - Allen <allens@cpan.org> */
8583 bool fix_ldbl_sprintf_bug = FALSE;
8587 U8 utf8buf[UTF8_MAXBYTES+1];
8588 STRLEN esignlen = 0;
8590 const char *eptr = NULL;
8593 const U8 *vecstr = NULL;
8600 /* we need a long double target in case HAS_LONG_DOUBLE but
8603 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
8611 const char *dotstr = ".";
8612 STRLEN dotstrlen = 1;
8613 I32 efix = 0; /* explicit format parameter index */
8614 I32 ewix = 0; /* explicit width index */
8615 I32 epix = 0; /* explicit precision index */
8616 I32 evix = 0; /* explicit vector index */
8617 bool asterisk = FALSE;
8619 /* echo everything up to the next format specification */
8620 for (q = p; q < patend && *q != '%'; ++q) ;
8622 if (has_utf8 && !pat_utf8)
8623 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
8625 sv_catpvn(sv, p, q - p);
8632 We allow format specification elements in this order:
8633 \d+\$ explicit format parameter index
8635 v|\*(\d+\$)?v vector with optional (optionally specified) arg
8636 0 flag (as above): repeated to allow "v02"
8637 \d+|\*(\d+\$)? width using optional (optionally specified) arg
8638 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8640 [%bcdefginopsuxDFOUX] format (mandatory)
8645 As of perl5.9.3, printf format checking is on by default.
8646 Internally, perl uses %p formats to provide an escape to
8647 some extended formatting. This block deals with those
8648 extensions: if it does not match, (char*)q is reset and
8649 the normal format processing code is used.
8651 Currently defined extensions are:
8652 %p include pointer address (standard)
8653 %-p (SVf) include an SV (previously %_)
8654 %-<num>p include an SV with precision <num>
8655 %<num>p reserved for future extensions
8657 Robin Barker 2005-07-14
8659 %1p (VDf) removed. RMB 2007-10-19
8666 n = expect_number(&q);
8673 argsv = (SV*)va_arg(*args, void*);
8674 eptr = SvPV_const(argsv, elen);
8680 if (ckWARN_d(WARN_INTERNAL))
8681 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
8682 "internal %%<num>p might conflict with future printf extensions");
8688 if ( (width = expect_number(&q)) ) {
8703 if (plus == '+' && *q == ' ') /* '+' over ' ' */
8732 if ( (ewix = expect_number(&q)) )
8741 if ((vectorarg = asterisk)) {
8754 width = expect_number(&q);
8760 vecsv = va_arg(*args, SV*);
8762 vecsv = (evix > 0 && evix <= svmax)
8763 ? svargs[evix-1] : &PL_sv_undef;
8765 vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef;
8767 dotstr = SvPV_const(vecsv, dotstrlen);
8768 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
8769 bad with tied or overloaded values that return UTF8. */
8772 else if (has_utf8) {
8773 vecsv = sv_mortalcopy(vecsv);
8774 sv_utf8_upgrade(vecsv);
8775 dotstr = SvPV_const(vecsv, dotstrlen);
8782 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
8783 vecsv = svargs[efix ? efix-1 : svix++];
8784 vecstr = (U8*)SvPV_const(vecsv,veclen);
8785 vec_utf8 = DO_UTF8(vecsv);
8787 /* if this is a version object, we need to convert
8788 * back into v-string notation and then let the
8789 * vectorize happen normally
8791 if (sv_derived_from(vecsv, "version")) {
8792 char *version = savesvpv(vecsv);
8793 if ( hv_exists((HV*)SvRV(vecsv), "alpha", 5 ) ) {
8794 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
8795 "vector argument not supported with alpha versions");
8798 vecsv = sv_newmortal();
8799 scan_vstring(version, version + veclen, vecsv);
8800 vecstr = (U8*)SvPV_const(vecsv, veclen);
8801 vec_utf8 = DO_UTF8(vecsv);
8813 i = va_arg(*args, int);
8815 i = (ewix ? ewix <= svmax : svix < svmax) ?
8816 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8818 width = (i < 0) ? -i : i;
8828 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
8830 /* XXX: todo, support specified precision parameter */
8834 i = va_arg(*args, int);
8836 i = (ewix ? ewix <= svmax : svix < svmax)
8837 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8839 has_precis = !(i < 0);
8844 precis = precis * 10 + (*q++ - '0');
8853 case 'I': /* Ix, I32x, and I64x */
8855 if (q[1] == '6' && q[2] == '4') {
8861 if (q[1] == '3' && q[2] == '2') {
8871 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8882 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8883 if (*(q + 1) == 'l') { /* lld, llf */
8909 if (!vectorize && !args) {
8911 const I32 i = efix-1;
8912 argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef;
8914 argsv = (svix >= 0 && svix < svmax)
8915 ? svargs[svix++] : &PL_sv_undef;
8926 uv = (args) ? va_arg(*args, int) : SvIV(argsv);
8928 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
8930 eptr = (char*)utf8buf;
8931 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
8945 eptr = va_arg(*args, char*);
8947 #ifdef MACOS_TRADITIONAL
8948 /* On MacOS, %#s format is used for Pascal strings */
8953 elen = strlen(eptr);
8955 eptr = (char *)nullstr;
8956 elen = sizeof nullstr - 1;
8960 eptr = SvPV_const(argsv, elen);
8961 if (DO_UTF8(argsv)) {
8962 I32 old_precis = precis;
8963 if (has_precis && precis < elen) {
8965 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
8968 if (width) { /* fudge width (can't fudge elen) */
8969 if (has_precis && precis < elen)
8970 width += precis - old_precis;
8972 width += elen - sv_len_utf8(argsv);
8979 if (has_precis && elen > precis)
8986 if (alt || vectorize)
8988 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9009 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9018 esignbuf[esignlen++] = plus;
9022 case 'h': iv = (short)va_arg(*args, int); break;
9023 case 'l': iv = va_arg(*args, long); break;
9024 case 'V': iv = va_arg(*args, IV); break;
9025 default: iv = va_arg(*args, int); break;
9027 case 'q': iv = va_arg(*args, Quad_t); break;
9032 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
9034 case 'h': iv = (short)tiv; break;
9035 case 'l': iv = (long)tiv; break;
9037 default: iv = tiv; break;
9039 case 'q': iv = (Quad_t)tiv; break;
9043 if ( !vectorize ) /* we already set uv above */
9048 esignbuf[esignlen++] = plus;
9052 esignbuf[esignlen++] = '-';
9096 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9107 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9108 case 'l': uv = va_arg(*args, unsigned long); break;
9109 case 'V': uv = va_arg(*args, UV); break;
9110 default: uv = va_arg(*args, unsigned); break;
9112 case 'q': uv = va_arg(*args, Uquad_t); break;
9117 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
9119 case 'h': uv = (unsigned short)tuv; break;
9120 case 'l': uv = (unsigned long)tuv; break;
9122 default: uv = tuv; break;
9124 case 'q': uv = (Uquad_t)tuv; break;
9131 char *ptr = ebuf + sizeof ebuf;
9132 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
9138 p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
9144 esignbuf[esignlen++] = '0';
9145 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9153 if (alt && *ptr != '0')
9162 esignbuf[esignlen++] = '0';
9163 esignbuf[esignlen++] = c;
9166 default: /* it had better be ten or less */
9170 } while (uv /= base);
9173 elen = (ebuf + sizeof ebuf) - ptr;
9177 zeros = precis - elen;
9178 else if (precis == 0 && elen == 1 && *eptr == '0'
9179 && !(base == 8 && alt)) /* "%#.0o" prints "0" */
9182 /* a precision nullifies the 0 flag. */
9189 /* FLOATING POINT */
9192 c = 'f'; /* maybe %F isn't supported here */
9200 /* This is evil, but floating point is even more evil */
9202 /* for SV-style calling, we can only get NV
9203 for C-style calling, we assume %f is double;
9204 for simplicity we allow any of %Lf, %llf, %qf for long double
9208 #if defined(USE_LONG_DOUBLE)
9212 /* [perl #20339] - we should accept and ignore %lf rather than die */
9216 #if defined(USE_LONG_DOUBLE)
9217 intsize = args ? 0 : 'q';
9221 #if defined(HAS_LONG_DOUBLE)
9230 /* now we need (long double) if intsize == 'q', else (double) */
9232 #if LONG_DOUBLESIZE > DOUBLESIZE
9234 va_arg(*args, long double) :
9235 va_arg(*args, double)
9237 va_arg(*args, double)
9242 /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
9243 else. frexp() has some unspecified behaviour for those three */
9244 if (c != 'e' && c != 'E' && (nv * 0) == 0) {
9246 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9247 will cast our (long double) to (double) */
9248 (void)Perl_frexp(nv, &i);
9249 if (i == PERL_INT_MIN)
9250 Perl_die(aTHX_ "panic: frexp");
9252 need = BIT_DIGITS(i);
9254 need += has_precis ? precis : 6; /* known default */
9259 #ifdef HAS_LDBL_SPRINTF_BUG
9260 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9261 with sfio - Allen <allens@cpan.org> */
9264 # define MY_DBL_MAX DBL_MAX
9265 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9266 # if DOUBLESIZE >= 8
9267 # define MY_DBL_MAX 1.7976931348623157E+308L
9269 # define MY_DBL_MAX 3.40282347E+38L
9273 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9274 # define MY_DBL_MAX_BUG 1L
9276 # define MY_DBL_MAX_BUG MY_DBL_MAX
9280 # define MY_DBL_MIN DBL_MIN
9281 # else /* XXX guessing! -Allen */
9282 # if DOUBLESIZE >= 8
9283 # define MY_DBL_MIN 2.2250738585072014E-308L
9285 # define MY_DBL_MIN 1.17549435E-38L
9289 if ((intsize == 'q') && (c == 'f') &&
9290 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9292 /* it's going to be short enough that
9293 * long double precision is not needed */
9295 if ((nv <= 0L) && (nv >= -0L))
9296 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9298 /* would use Perl_fp_class as a double-check but not
9299 * functional on IRIX - see perl.h comments */
9301 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9302 /* It's within the range that a double can represent */
9303 #if defined(DBL_MAX) && !defined(DBL_MIN)
9304 if ((nv >= ((long double)1/DBL_MAX)) ||
9305 (nv <= (-(long double)1/DBL_MAX)))
9307 fix_ldbl_sprintf_bug = TRUE;
9310 if (fix_ldbl_sprintf_bug == TRUE) {
9320 # undef MY_DBL_MAX_BUG
9323 #endif /* HAS_LDBL_SPRINTF_BUG */
9325 need += 20; /* fudge factor */
9326 if (PL_efloatsize < need) {
9327 Safefree(PL_efloatbuf);
9328 PL_efloatsize = need + 20; /* more fudge */
9329 Newx(PL_efloatbuf, PL_efloatsize, char);
9330 PL_efloatbuf[0] = '\0';
9333 if ( !(width || left || plus || alt) && fill != '0'
9334 && has_precis && intsize != 'q' ) { /* Shortcuts */
9335 /* See earlier comment about buggy Gconvert when digits,
9337 if ( c == 'g' && precis) {
9338 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9339 /* May return an empty string for digits==0 */
9340 if (*PL_efloatbuf) {
9341 elen = strlen(PL_efloatbuf);
9342 goto float_converted;
9344 } else if ( c == 'f' && !precis) {
9345 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9350 char *ptr = ebuf + sizeof ebuf;
9353 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9354 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9355 if (intsize == 'q') {
9356 /* Copy the one or more characters in a long double
9357 * format before the 'base' ([efgEFG]) character to
9358 * the format string. */
9359 static char const prifldbl[] = PERL_PRIfldbl;
9360 char const *p = prifldbl + sizeof(prifldbl) - 3;
9361 while (p >= prifldbl) { *--ptr = *p--; }
9366 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9371 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9383 /* No taint. Otherwise we are in the strange situation
9384 * where printf() taints but print($float) doesn't.
9386 #if defined(HAS_LONG_DOUBLE)
9387 elen = ((intsize == 'q')
9388 ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
9389 : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
9391 elen = my_sprintf(PL_efloatbuf, ptr, nv);
9395 eptr = PL_efloatbuf;
9403 i = SvCUR(sv) - origlen;
9406 case 'h': *(va_arg(*args, short*)) = i; break;
9407 default: *(va_arg(*args, int*)) = i; break;
9408 case 'l': *(va_arg(*args, long*)) = i; break;
9409 case 'V': *(va_arg(*args, IV*)) = i; break;
9411 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
9416 sv_setuv_mg(argsv, (UV)i);
9417 continue; /* not "break" */
9424 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
9425 && ckWARN(WARN_PRINTF))
9427 SV * const msg = sv_newmortal();
9428 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9429 (PL_op->op_type == OP_PRTF) ? "" : "s");
9432 Perl_sv_catpvf(aTHX_ msg,
9433 "\"%%%c\"", c & 0xFF);
9435 Perl_sv_catpvf(aTHX_ msg,
9436 "\"%%\\%03"UVof"\"",
9439 sv_catpvs(msg, "end of string");
9440 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
9443 /* output mangled stuff ... */
9449 /* ... right here, because formatting flags should not apply */
9450 SvGROW(sv, SvCUR(sv) + elen + 1);
9452 Copy(eptr, p, elen, char);
9455 SvCUR_set(sv, p - SvPVX_const(sv));
9457 continue; /* not "break" */
9460 if (is_utf8 != has_utf8) {
9463 sv_utf8_upgrade(sv);
9466 const STRLEN old_elen = elen;
9467 SV * const nsv = sv_2mortal(newSVpvn(eptr, elen));
9468 sv_utf8_upgrade(nsv);
9469 eptr = SvPVX_const(nsv);
9472 if (width) { /* fudge width (can't fudge elen) */
9473 width += elen - old_elen;
9479 have = esignlen + zeros + elen;
9481 Perl_croak_nocontext(PL_memory_wrap);
9483 need = (have > width ? have : width);
9486 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
9487 Perl_croak_nocontext(PL_memory_wrap);
9488 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
9490 if (esignlen && fill == '0') {
9492 for (i = 0; i < (int)esignlen; i++)
9496 memset(p, fill, gap);
9499 if (esignlen && fill != '0') {
9501 for (i = 0; i < (int)esignlen; i++)
9506 for (i = zeros; i; i--)
9510 Copy(eptr, p, elen, char);
9514 memset(p, ' ', gap);
9519 Copy(dotstr, p, dotstrlen, char);
9523 vectorize = FALSE; /* done iterating over vecstr */
9530 SvCUR_set(sv, p - SvPVX_const(sv));
9538 /* =========================================================================
9540 =head1 Cloning an interpreter
9542 All the macros and functions in this section are for the private use of
9543 the main function, perl_clone().
9545 The foo_dup() functions make an exact copy of an existing foo thingy.
9546 During the course of a cloning, a hash table is used to map old addresses
9547 to new addresses. The table is created and manipulated with the
9548 ptr_table_* functions.
9552 ============================================================================*/
9555 #if defined(USE_ITHREADS)
9557 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
9558 #ifndef GpREFCNT_inc
9559 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
9563 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
9564 that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
9565 If this changes, please unmerge ss_dup. */
9566 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
9567 #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t))
9568 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
9569 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9570 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
9571 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9572 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
9573 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9574 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
9575 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
9576 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
9577 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9578 #define SAVEPV(p) ((p) ? savepv(p) : NULL)
9579 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
9581 /* clone a parser */
9584 Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param)
9591 /* look for it in the table first */
9592 parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
9596 /* create anew and remember what it is */
9597 Newxz(parser, 1, yy_parser);
9598 ptr_table_store(PL_ptr_table, proto, parser);
9600 parser->yyerrstatus = 0;
9601 parser->yychar = YYEMPTY; /* Cause a token to be read. */
9603 /* XXX these not yet duped */
9604 parser->old_parser = NULL;
9605 parser->stack = NULL;
9607 parser->stack_size = 0;
9608 /* XXX parser->stack->state = 0; */
9610 /* XXX eventually, just Copy() most of the parser struct ? */
9612 parser->lex_brackets = proto->lex_brackets;
9613 parser->lex_casemods = proto->lex_casemods;
9614 parser->lex_brackstack = savepvn(proto->lex_brackstack,
9615 (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
9616 parser->lex_casestack = savepvn(proto->lex_casestack,
9617 (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
9618 parser->lex_defer = proto->lex_defer;
9619 parser->lex_dojoin = proto->lex_dojoin;
9620 parser->lex_expect = proto->lex_expect;
9621 parser->lex_formbrack = proto->lex_formbrack;
9622 parser->lex_inpat = proto->lex_inpat;
9623 parser->lex_inwhat = proto->lex_inwhat;
9624 parser->lex_op = proto->lex_op;
9625 parser->lex_repl = sv_dup_inc(proto->lex_repl, param);
9626 parser->lex_starts = proto->lex_starts;
9627 parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param);
9628 parser->multi_close = proto->multi_close;
9629 parser->multi_open = proto->multi_open;
9630 parser->multi_start = proto->multi_start;
9631 parser->multi_end = proto->multi_end;
9632 parser->pending_ident = proto->pending_ident;
9633 parser->preambled = proto->preambled;
9634 parser->sublex_info = proto->sublex_info; /* XXX not quite right */
9635 parser->linestr = sv_dup_inc(proto->linestr, param);
9636 parser->expect = proto->expect;
9637 parser->copline = proto->copline;
9638 parser->last_lop_op = proto->last_lop_op;
9639 parser->lex_state = proto->lex_state;
9640 parser->rsfp = fp_dup(proto->rsfp, '<', param);
9641 /* rsfp_filters entries have fake IoDIRP() */
9642 parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
9643 parser->in_my = proto->in_my;
9644 parser->in_my_stash = hv_dup(proto->in_my_stash, param);
9645 parser->error_count = proto->error_count;
9648 parser->linestr = sv_dup_inc(proto->linestr, param);
9651 char * const ols = SvPVX(proto->linestr);
9652 char * const ls = SvPVX(parser->linestr);
9654 parser->bufptr = ls + (proto->bufptr >= ols ?
9655 proto->bufptr - ols : 0);
9656 parser->oldbufptr = ls + (proto->oldbufptr >= ols ?
9657 proto->oldbufptr - ols : 0);
9658 parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
9659 proto->oldoldbufptr - ols : 0);
9660 parser->linestart = ls + (proto->linestart >= ols ?
9661 proto->linestart - ols : 0);
9662 parser->last_uni = ls + (proto->last_uni >= ols ?
9663 proto->last_uni - ols : 0);
9664 parser->last_lop = ls + (proto->last_lop >= ols ?
9665 proto->last_lop - ols : 0);
9667 parser->bufend = ls + SvCUR(parser->linestr);
9670 Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
9674 parser->endwhite = proto->endwhite;
9675 parser->faketokens = proto->faketokens;
9676 parser->lasttoke = proto->lasttoke;
9677 parser->nextwhite = proto->nextwhite;
9678 parser->realtokenstart = proto->realtokenstart;
9679 parser->skipwhite = proto->skipwhite;
9680 parser->thisclose = proto->thisclose;
9681 parser->thismad = proto->thismad;
9682 parser->thisopen = proto->thisopen;
9683 parser->thisstuff = proto->thisstuff;
9684 parser->thistoken = proto->thistoken;
9685 parser->thiswhite = proto->thiswhite;
9687 Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
9688 parser->curforce = proto->curforce;
9690 Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
9691 Copy(proto->nexttype, parser->nexttype, 5, I32);
9692 parser->nexttoke = proto->nexttoke;
9698 /* duplicate a file handle */
9701 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
9705 PERL_UNUSED_ARG(type);
9708 return (PerlIO*)NULL;
9710 /* look for it in the table first */
9711 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
9715 /* create anew and remember what it is */
9716 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
9717 ptr_table_store(PL_ptr_table, fp, ret);
9721 /* duplicate a directory handle */
9724 Perl_dirp_dup(pTHX_ DIR *dp)
9726 PERL_UNUSED_CONTEXT;
9733 /* duplicate a typeglob */
9736 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
9742 /* look for it in the table first */
9743 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
9747 /* create anew and remember what it is */
9749 ptr_table_store(PL_ptr_table, gp, ret);
9752 ret->gp_refcnt = 0; /* must be before any other dups! */
9753 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
9754 ret->gp_io = io_dup_inc(gp->gp_io, param);
9755 ret->gp_form = cv_dup_inc(gp->gp_form, param);
9756 ret->gp_av = av_dup_inc(gp->gp_av, param);
9757 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
9758 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
9759 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
9760 ret->gp_cvgen = gp->gp_cvgen;
9761 ret->gp_line = gp->gp_line;
9762 ret->gp_file_hek = hek_dup(gp->gp_file_hek, param);
9766 /* duplicate a chain of magic */
9769 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
9771 MAGIC *mgprev = (MAGIC*)NULL;
9774 return (MAGIC*)NULL;
9775 /* look for it in the table first */
9776 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
9780 for (; mg; mg = mg->mg_moremagic) {
9782 Newxz(nmg, 1, MAGIC);
9784 mgprev->mg_moremagic = nmg;
9787 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
9788 nmg->mg_private = mg->mg_private;
9789 nmg->mg_type = mg->mg_type;
9790 nmg->mg_flags = mg->mg_flags;
9791 if (mg->mg_type == PERL_MAGIC_qr) {
9792 nmg->mg_obj = (SV*)CALLREGDUPE((REGEXP*)mg->mg_obj, param);
9794 else if(mg->mg_type == PERL_MAGIC_backref) {
9795 /* The backref AV has its reference count deliberately bumped by
9797 nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param));
9800 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
9801 ? sv_dup_inc(mg->mg_obj, param)
9802 : sv_dup(mg->mg_obj, param);
9804 nmg->mg_len = mg->mg_len;
9805 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
9806 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
9807 if (mg->mg_len > 0) {
9808 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
9809 if (mg->mg_type == PERL_MAGIC_overload_table &&
9810 AMT_AMAGIC((AMT*)mg->mg_ptr))
9812 const AMT * const amtp = (AMT*)mg->mg_ptr;
9813 AMT * const namtp = (AMT*)nmg->mg_ptr;
9815 for (i = 1; i < NofAMmeth; i++) {
9816 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
9820 else if (mg->mg_len == HEf_SVKEY)
9821 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
9823 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
9824 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
9831 #endif /* USE_ITHREADS */
9833 /* create a new pointer-mapping table */
9836 Perl_ptr_table_new(pTHX)
9839 PERL_UNUSED_CONTEXT;
9841 Newxz(tbl, 1, PTR_TBL_t);
9844 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
9848 #define PTR_TABLE_HASH(ptr) \
9849 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
9852 we use the PTE_SVSLOT 'reservation' made above, both here (in the
9853 following define) and at call to new_body_inline made below in
9854 Perl_ptr_table_store()
9857 #define del_pte(p) del_body_type(p, PTE_SVSLOT)
9859 /* map an existing pointer using a table */
9861 STATIC PTR_TBL_ENT_t *
9862 S_ptr_table_find(PTR_TBL_t *tbl, const void *sv) {
9863 PTR_TBL_ENT_t *tblent;
9864 const UV hash = PTR_TABLE_HASH(sv);
9866 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
9867 for (; tblent; tblent = tblent->next) {
9868 if (tblent->oldval == sv)
9875 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
9877 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
9878 PERL_UNUSED_CONTEXT;
9879 return tblent ? tblent->newval : NULL;
9882 /* add a new entry to a pointer-mapping table */
9885 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
9887 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
9888 PERL_UNUSED_CONTEXT;
9891 tblent->newval = newsv;
9893 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
9895 new_body_inline(tblent, PTE_SVSLOT);
9897 tblent->oldval = oldsv;
9898 tblent->newval = newsv;
9899 tblent->next = tbl->tbl_ary[entry];
9900 tbl->tbl_ary[entry] = tblent;
9902 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
9903 ptr_table_split(tbl);
9907 /* double the hash bucket size of an existing ptr table */
9910 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
9912 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
9913 const UV oldsize = tbl->tbl_max + 1;
9914 UV newsize = oldsize * 2;
9916 PERL_UNUSED_CONTEXT;
9918 Renew(ary, newsize, PTR_TBL_ENT_t*);
9919 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
9920 tbl->tbl_max = --newsize;
9922 for (i=0; i < oldsize; i++, ary++) {
9923 PTR_TBL_ENT_t **curentp, **entp, *ent;
9926 curentp = ary + oldsize;
9927 for (entp = ary, ent = *ary; ent; ent = *entp) {
9928 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
9930 ent->next = *curentp;
9940 /* remove all the entries from a ptr table */
9943 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
9945 if (tbl && tbl->tbl_items) {
9946 register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary;
9947 UV riter = tbl->tbl_max;
9950 PTR_TBL_ENT_t *entry = array[riter];
9953 PTR_TBL_ENT_t * const oentry = entry;
9954 entry = entry->next;
9963 /* clear and free a ptr table */
9966 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
9971 ptr_table_clear(tbl);
9972 Safefree(tbl->tbl_ary);
9976 #if defined(USE_ITHREADS)
9979 Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param)
9982 SvRV_set(dstr, SvWEAKREF(sstr)
9983 ? sv_dup(SvRV(sstr), param)
9984 : sv_dup_inc(SvRV(sstr), param));
9987 else if (SvPVX_const(sstr)) {
9988 /* Has something there */
9990 /* Normal PV - clone whole allocated space */
9991 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
9992 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9993 /* Not that normal - actually sstr is copy on write.
9994 But we are a true, independant SV, so: */
9995 SvREADONLY_off(dstr);
10000 /* Special case - not normally malloced for some reason */
10001 if (isGV_with_GP(sstr)) {
10002 /* Don't need to do anything here. */
10004 else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
10005 /* A "shared" PV - clone it as "shared" PV */
10007 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
10011 /* Some other special case - random pointer */
10012 SvPV_set(dstr, SvPVX(sstr));
10017 /* Copy the NULL */
10018 if (SvTYPE(dstr) == SVt_RV)
10019 SvRV_set(dstr, NULL);
10021 SvPV_set(dstr, NULL);
10025 /* duplicate an SV of any type (including AV, HV etc) */
10028 Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
10033 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10035 /* look for it in the table first */
10036 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10040 if(param->flags & CLONEf_JOIN_IN) {
10041 /** We are joining here so we don't want do clone
10042 something that is bad **/
10043 if (SvTYPE(sstr) == SVt_PVHV) {
10044 const HEK * const hvname = HvNAME_HEK(sstr);
10046 /** don't clone stashes if they already exist **/
10047 return (SV*)gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0);
10051 /* create anew and remember what it is */
10054 #ifdef DEBUG_LEAKING_SCALARS
10055 dstr->sv_debug_optype = sstr->sv_debug_optype;
10056 dstr->sv_debug_line = sstr->sv_debug_line;
10057 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10058 dstr->sv_debug_cloned = 1;
10059 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10062 ptr_table_store(PL_ptr_table, sstr, dstr);
10065 SvFLAGS(dstr) = SvFLAGS(sstr);
10066 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10067 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10070 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
10071 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10072 (void*)PL_watch_pvx, SvPVX_const(sstr));
10075 /* don't clone objects whose class has asked us not to */
10076 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10081 switch (SvTYPE(sstr)) {
10083 SvANY(dstr) = NULL;
10086 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
10087 SvIV_set(dstr, SvIVX(sstr));
10090 SvANY(dstr) = new_XNV();
10091 SvNV_set(dstr, SvNVX(sstr));
10094 SvANY(dstr) = &(dstr->sv_u.svu_rv);
10095 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10097 /* case SVt_BIND: */
10100 /* These are all the types that need complex bodies allocating. */
10102 const svtype sv_type = SvTYPE(sstr);
10103 const struct body_details *const sv_type_details
10104 = bodies_by_type + sv_type;
10108 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
10112 if (GvUNIQUE((GV*)sstr)) {
10113 NOOP; /* Do sharing here, and fall through */
10125 assert(sv_type_details->body_size);
10126 if (sv_type_details->arena) {
10127 new_body_inline(new_body, sv_type);
10129 = (void*)((char*)new_body - sv_type_details->offset);
10131 new_body = new_NOARENA(sv_type_details);
10135 SvANY(dstr) = new_body;
10138 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
10139 ((char*)SvANY(dstr)) + sv_type_details->offset,
10140 sv_type_details->copy, char);
10142 Copy(((char*)SvANY(sstr)),
10143 ((char*)SvANY(dstr)),
10144 sv_type_details->body_size + sv_type_details->offset, char);
10147 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
10148 && !isGV_with_GP(dstr))
10149 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10151 /* The Copy above means that all the source (unduplicated) pointers
10152 are now in the destination. We can check the flags and the
10153 pointers in either, but it's possible that there's less cache
10154 missing by always going for the destination.
10155 FIXME - instrument and check that assumption */
10156 if (sv_type >= SVt_PVMG) {
10157 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
10158 SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
10159 } else if (SvMAGIC(dstr))
10160 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
10162 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
10165 /* The cast silences a GCC warning about unhandled types. */
10166 switch ((int)sv_type) {
10176 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
10177 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
10178 LvTARG(dstr) = dstr;
10179 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
10180 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
10182 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
10184 if(isGV_with_GP(sstr)) {
10185 if (GvNAME_HEK(dstr))
10186 GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
10187 /* Don't call sv_add_backref here as it's going to be
10188 created as part of the magic cloning of the symbol
10190 /* Danger Will Robinson - GvGP(dstr) isn't initialised
10191 at the point of this comment. */
10192 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
10193 GvGP(dstr) = gp_dup(GvGP(sstr), param);
10194 (void)GpREFCNT_inc(GvGP(dstr));
10196 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10199 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
10200 if (IoOFP(dstr) == IoIFP(sstr))
10201 IoOFP(dstr) = IoIFP(dstr);
10203 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
10204 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
10205 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
10206 /* I have no idea why fake dirp (rsfps)
10207 should be treated differently but otherwise
10208 we end up with leaks -- sky*/
10209 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
10210 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
10211 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
10213 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
10214 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
10215 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
10216 if (IoDIRP(dstr)) {
10217 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
10220 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
10223 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
10224 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
10225 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
10228 if (AvARRAY((AV*)sstr)) {
10229 SV **dst_ary, **src_ary;
10230 SSize_t items = AvFILLp((AV*)sstr) + 1;
10232 src_ary = AvARRAY((AV*)sstr);
10233 Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*);
10234 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10235 AvARRAY((AV*)dstr) = dst_ary;
10236 AvALLOC((AV*)dstr) = dst_ary;
10237 if (AvREAL((AV*)sstr)) {
10238 while (items-- > 0)
10239 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10242 while (items-- > 0)
10243 *dst_ary++ = sv_dup(*src_ary++, param);
10245 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10246 while (items-- > 0) {
10247 *dst_ary++ = &PL_sv_undef;
10251 AvARRAY((AV*)dstr) = NULL;
10252 AvALLOC((AV*)dstr) = (SV**)NULL;
10256 if (HvARRAY((HV*)sstr)) {
10258 const bool sharekeys = !!HvSHAREKEYS(sstr);
10259 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
10260 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
10262 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
10263 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
10265 HvARRAY(dstr) = (HE**)darray;
10266 while (i <= sxhv->xhv_max) {
10267 const HE * const source = HvARRAY(sstr)[i];
10268 HvARRAY(dstr)[i] = source
10269 ? he_dup(source, sharekeys, param) : 0;
10274 const struct xpvhv_aux * const saux = HvAUX(sstr);
10275 struct xpvhv_aux * const daux = HvAUX(dstr);
10276 /* This flag isn't copied. */
10277 /* SvOOK_on(hv) attacks the IV flags. */
10278 SvFLAGS(dstr) |= SVf_OOK;
10280 hvname = saux->xhv_name;
10281 daux->xhv_name = hvname ? hek_dup(hvname, param) : hvname;
10283 daux->xhv_riter = saux->xhv_riter;
10284 daux->xhv_eiter = saux->xhv_eiter
10285 ? he_dup(saux->xhv_eiter,
10286 (bool)!!HvSHAREKEYS(sstr), param) : 0;
10287 daux->xhv_backreferences =
10288 saux->xhv_backreferences
10289 ? (AV*) SvREFCNT_inc(
10290 sv_dup((SV*)saux->xhv_backreferences, param))
10293 daux->xhv_mro_meta = saux->xhv_mro_meta
10294 ? mro_meta_dup(saux->xhv_mro_meta, param)
10297 /* Record stashes for possible cloning in Perl_clone(). */
10299 av_push(param->stashes, dstr);
10303 HvARRAY((HV*)dstr) = NULL;
10306 if (!(param->flags & CLONEf_COPY_STACKS)) {
10310 /* NOTE: not refcounted */
10311 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
10313 if (!CvISXSUB(dstr))
10314 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
10316 if (CvCONST(dstr) && CvISXSUB(dstr)) {
10317 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
10318 SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
10319 sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
10321 /* don't dup if copying back - CvGV isn't refcounted, so the
10322 * duped GV may never be freed. A bit of a hack! DAPM */
10323 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
10324 NULL : gv_dup(CvGV(dstr), param) ;
10325 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10327 CvWEAKOUTSIDE(sstr)
10328 ? cv_dup( CvOUTSIDE(dstr), param)
10329 : cv_dup_inc(CvOUTSIDE(dstr), param);
10330 if (!CvISXSUB(dstr))
10331 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
10337 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10343 /* duplicate a context */
10346 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10348 PERL_CONTEXT *ncxs;
10351 return (PERL_CONTEXT*)NULL;
10353 /* look for it in the table first */
10354 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10358 /* create anew and remember what it is */
10359 Newxz(ncxs, max + 1, PERL_CONTEXT);
10360 ptr_table_store(PL_ptr_table, cxs, ncxs);
10363 PERL_CONTEXT * const cx = &cxs[ix];
10364 PERL_CONTEXT * const ncx = &ncxs[ix];
10365 ncx->cx_type = cx->cx_type;
10366 if (CxTYPE(cx) == CXt_SUBST) {
10367 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10370 ncx->blk_oldsp = cx->blk_oldsp;
10371 ncx->blk_oldcop = cx->blk_oldcop;
10372 ncx->blk_oldmarksp = cx->blk_oldmarksp;
10373 ncx->blk_oldscopesp = cx->blk_oldscopesp;
10374 ncx->blk_oldpm = cx->blk_oldpm;
10375 ncx->blk_gimme = cx->blk_gimme;
10376 switch (CxTYPE(cx)) {
10378 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
10379 ? cv_dup_inc(cx->blk_sub.cv, param)
10380 : cv_dup(cx->blk_sub.cv,param));
10381 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
10382 ? av_dup_inc(cx->blk_sub.argarray, param)
10384 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
10385 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
10386 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10387 ncx->blk_sub.lval = cx->blk_sub.lval;
10388 ncx->blk_sub.retop = cx->blk_sub.retop;
10389 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
10390 cx->blk_sub.oldcomppad);
10393 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
10394 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
10395 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
10396 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
10397 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
10398 ncx->blk_eval.retop = cx->blk_eval.retop;
10401 ncx->blk_loop.label = cx->blk_loop.label;
10402 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
10403 ncx->blk_loop.my_op = cx->blk_loop.my_op;
10404 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
10405 ? cx->blk_loop.iterdata
10406 : gv_dup((GV*)cx->blk_loop.iterdata, param));
10407 ncx->blk_loop.oldcomppad
10408 = (PAD*)ptr_table_fetch(PL_ptr_table,
10409 cx->blk_loop.oldcomppad);
10410 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
10411 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
10412 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
10413 ncx->blk_loop.iterix = cx->blk_loop.iterix;
10414 ncx->blk_loop.itermax = cx->blk_loop.itermax;
10417 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
10418 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
10419 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
10420 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10421 ncx->blk_sub.retop = cx->blk_sub.retop;
10433 /* duplicate a stack info structure */
10436 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10441 return (PERL_SI*)NULL;
10443 /* look for it in the table first */
10444 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10448 /* create anew and remember what it is */
10449 Newxz(nsi, 1, PERL_SI);
10450 ptr_table_store(PL_ptr_table, si, nsi);
10452 nsi->si_stack = av_dup_inc(si->si_stack, param);
10453 nsi->si_cxix = si->si_cxix;
10454 nsi->si_cxmax = si->si_cxmax;
10455 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
10456 nsi->si_type = si->si_type;
10457 nsi->si_prev = si_dup(si->si_prev, param);
10458 nsi->si_next = si_dup(si->si_next, param);
10459 nsi->si_markoff = si->si_markoff;
10464 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
10465 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
10466 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
10467 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
10468 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
10469 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
10470 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
10471 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
10472 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
10473 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
10474 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
10475 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
10476 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
10477 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
10480 #define pv_dup_inc(p) SAVEPV(p)
10481 #define pv_dup(p) SAVEPV(p)
10482 #define svp_dup_inc(p,pp) any_dup(p,pp)
10484 /* map any object to the new equivent - either something in the
10485 * ptr table, or something in the interpreter structure
10489 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
10494 return (void*)NULL;
10496 /* look for it in the table first */
10497 ret = ptr_table_fetch(PL_ptr_table, v);
10501 /* see if it is part of the interpreter structure */
10502 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
10503 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
10511 /* duplicate the save stack */
10514 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
10517 ANY * const ss = proto_perl->Isavestack;
10518 const I32 max = proto_perl->Isavestack_max;
10519 I32 ix = proto_perl->Isavestack_ix;
10532 void (*dptr) (void*);
10533 void (*dxptr) (pTHX_ void*);
10535 Newxz(nss, max, ANY);
10538 const I32 type = POPINT(ss,ix);
10539 TOPINT(nss,ix) = type;
10541 case SAVEt_HELEM: /* hash element */
10542 sv = (SV*)POPPTR(ss,ix);
10543 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10545 case SAVEt_ITEM: /* normal string */
10546 case SAVEt_SV: /* scalar reference */
10547 sv = (SV*)POPPTR(ss,ix);
10548 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10551 case SAVEt_MORTALIZESV:
10552 sv = (SV*)POPPTR(ss,ix);
10553 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10555 case SAVEt_SHARED_PVREF: /* char* in shared space */
10556 c = (char*)POPPTR(ss,ix);
10557 TOPPTR(nss,ix) = savesharedpv(c);
10558 ptr = POPPTR(ss,ix);
10559 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10561 case SAVEt_GENERIC_SVREF: /* generic sv */
10562 case SAVEt_SVREF: /* scalar reference */
10563 sv = (SV*)POPPTR(ss,ix);
10564 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10565 ptr = POPPTR(ss,ix);
10566 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
10568 case SAVEt_HV: /* hash reference */
10569 case SAVEt_AV: /* array reference */
10570 sv = (SV*) POPPTR(ss,ix);
10571 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10573 case SAVEt_COMPPAD:
10575 sv = (SV*) POPPTR(ss,ix);
10576 TOPPTR(nss,ix) = sv_dup(sv, param);
10578 case SAVEt_INT: /* int reference */
10579 ptr = POPPTR(ss,ix);
10580 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10581 intval = (int)POPINT(ss,ix);
10582 TOPINT(nss,ix) = intval;
10584 case SAVEt_LONG: /* long reference */
10585 ptr = POPPTR(ss,ix);
10586 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10588 case SAVEt_CLEARSV:
10589 longval = (long)POPLONG(ss,ix);
10590 TOPLONG(nss,ix) = longval;
10592 case SAVEt_I32: /* I32 reference */
10593 case SAVEt_I16: /* I16 reference */
10594 case SAVEt_I8: /* I8 reference */
10595 case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
10596 ptr = POPPTR(ss,ix);
10597 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10599 TOPINT(nss,ix) = i;
10601 case SAVEt_IV: /* IV reference */
10602 ptr = POPPTR(ss,ix);
10603 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10605 TOPIV(nss,ix) = iv;
10607 case SAVEt_HPTR: /* HV* reference */
10608 case SAVEt_APTR: /* AV* reference */
10609 case SAVEt_SPTR: /* SV* reference */
10610 ptr = POPPTR(ss,ix);
10611 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10612 sv = (SV*)POPPTR(ss,ix);
10613 TOPPTR(nss,ix) = sv_dup(sv, param);
10615 case SAVEt_VPTR: /* random* reference */
10616 ptr = POPPTR(ss,ix);
10617 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10618 ptr = POPPTR(ss,ix);
10619 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10621 case SAVEt_GENERIC_PVREF: /* generic char* */
10622 case SAVEt_PPTR: /* char* reference */
10623 ptr = POPPTR(ss,ix);
10624 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10625 c = (char*)POPPTR(ss,ix);
10626 TOPPTR(nss,ix) = pv_dup(c);
10628 case SAVEt_GP: /* scalar reference */
10629 gp = (GP*)POPPTR(ss,ix);
10630 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
10631 (void)GpREFCNT_inc(gp);
10632 gv = (GV*)POPPTR(ss,ix);
10633 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10636 ptr = POPPTR(ss,ix);
10637 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
10638 /* these are assumed to be refcounted properly */
10640 switch (((OP*)ptr)->op_type) {
10642 case OP_LEAVESUBLV:
10646 case OP_LEAVEWRITE:
10647 TOPPTR(nss,ix) = ptr;
10650 (void) OpREFCNT_inc(o);
10654 TOPPTR(nss,ix) = NULL;
10659 TOPPTR(nss,ix) = NULL;
10662 c = (char*)POPPTR(ss,ix);
10663 TOPPTR(nss,ix) = pv_dup_inc(c);
10666 hv = (HV*)POPPTR(ss,ix);
10667 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10668 c = (char*)POPPTR(ss,ix);
10669 TOPPTR(nss,ix) = pv_dup_inc(c);
10671 case SAVEt_STACK_POS: /* Position on Perl stack */
10673 TOPINT(nss,ix) = i;
10675 case SAVEt_DESTRUCTOR:
10676 ptr = POPPTR(ss,ix);
10677 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10678 dptr = POPDPTR(ss,ix);
10679 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
10680 any_dup(FPTR2DPTR(void *, dptr),
10683 case SAVEt_DESTRUCTOR_X:
10684 ptr = POPPTR(ss,ix);
10685 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10686 dxptr = POPDXPTR(ss,ix);
10687 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
10688 any_dup(FPTR2DPTR(void *, dxptr),
10691 case SAVEt_REGCONTEXT:
10694 TOPINT(nss,ix) = i;
10697 case SAVEt_AELEM: /* array element */
10698 sv = (SV*)POPPTR(ss,ix);
10699 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10701 TOPINT(nss,ix) = i;
10702 av = (AV*)POPPTR(ss,ix);
10703 TOPPTR(nss,ix) = av_dup_inc(av, param);
10706 ptr = POPPTR(ss,ix);
10707 TOPPTR(nss,ix) = ptr;
10711 TOPINT(nss,ix) = i;
10712 ptr = POPPTR(ss,ix);
10715 ((struct refcounted_he *)ptr)->refcounted_he_refcnt++;
10716 HINTS_REFCNT_UNLOCK;
10718 TOPPTR(nss,ix) = ptr;
10719 if (i & HINT_LOCALIZE_HH) {
10720 hv = (HV*)POPPTR(ss,ix);
10721 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10725 longval = (long)POPLONG(ss,ix);
10726 TOPLONG(nss,ix) = longval;
10727 ptr = POPPTR(ss,ix);
10728 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10729 sv = (SV*)POPPTR(ss,ix);
10730 TOPPTR(nss,ix) = sv_dup(sv, param);
10733 ptr = POPPTR(ss,ix);
10734 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10735 longval = (long)POPBOOL(ss,ix);
10736 TOPBOOL(nss,ix) = (bool)longval;
10738 case SAVEt_SET_SVFLAGS:
10740 TOPINT(nss,ix) = i;
10742 TOPINT(nss,ix) = i;
10743 sv = (SV*)POPPTR(ss,ix);
10744 TOPPTR(nss,ix) = sv_dup(sv, param);
10746 case SAVEt_RE_STATE:
10748 const struct re_save_state *const old_state
10749 = (struct re_save_state *)
10750 (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
10751 struct re_save_state *const new_state
10752 = (struct re_save_state *)
10753 (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
10755 Copy(old_state, new_state, 1, struct re_save_state);
10756 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
10758 new_state->re_state_bostr
10759 = pv_dup(old_state->re_state_bostr);
10760 new_state->re_state_reginput
10761 = pv_dup(old_state->re_state_reginput);
10762 new_state->re_state_regeol
10763 = pv_dup(old_state->re_state_regeol);
10764 new_state->re_state_regoffs
10765 = (regexp_paren_pair*)
10766 any_dup(old_state->re_state_regoffs, proto_perl);
10767 new_state->re_state_reglastparen
10768 = (U32*) any_dup(old_state->re_state_reglastparen,
10770 new_state->re_state_reglastcloseparen
10771 = (U32*)any_dup(old_state->re_state_reglastcloseparen,
10773 /* XXX This just has to be broken. The old save_re_context
10774 code did SAVEGENERICPV(PL_reg_start_tmp);
10775 PL_reg_start_tmp is char **.
10776 Look above to what the dup code does for
10777 SAVEt_GENERIC_PVREF
10778 It can never have worked.
10779 So this is merely a faithful copy of the exiting bug: */
10780 new_state->re_state_reg_start_tmp
10781 = (char **) pv_dup((char *)
10782 old_state->re_state_reg_start_tmp);
10783 /* I assume that it only ever "worked" because no-one called
10784 (pseudo)fork while the regexp engine had re-entered itself.
10786 #ifdef PERL_OLD_COPY_ON_WRITE
10787 new_state->re_state_nrs
10788 = sv_dup(old_state->re_state_nrs, param);
10790 new_state->re_state_reg_magic
10791 = (MAGIC*) any_dup(old_state->re_state_reg_magic,
10793 new_state->re_state_reg_oldcurpm
10794 = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
10796 new_state->re_state_reg_curpm
10797 = (PMOP*) any_dup(old_state->re_state_reg_curpm,
10799 new_state->re_state_reg_oldsaved
10800 = pv_dup(old_state->re_state_reg_oldsaved);
10801 new_state->re_state_reg_poscache
10802 = pv_dup(old_state->re_state_reg_poscache);
10803 new_state->re_state_reg_starttry
10804 = pv_dup(old_state->re_state_reg_starttry);
10807 case SAVEt_COMPILE_WARNINGS:
10808 ptr = POPPTR(ss,ix);
10809 TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
10812 ptr = POPPTR(ss,ix);
10813 TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
10817 "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
10825 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
10826 * flag to the result. This is done for each stash before cloning starts,
10827 * so we know which stashes want their objects cloned */
10830 do_mark_cloneable_stash(pTHX_ SV *sv)
10832 const HEK * const hvname = HvNAME_HEK((HV*)sv);
10834 GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
10835 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
10836 if (cloner && GvCV(cloner)) {
10843 XPUSHs(sv_2mortal(newSVhek(hvname)));
10845 call_sv((SV*)GvCV(cloner), G_SCALAR);
10852 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
10860 =for apidoc perl_clone
10862 Create and return a new interpreter by cloning the current one.
10864 perl_clone takes these flags as parameters:
10866 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
10867 without it we only clone the data and zero the stacks,
10868 with it we copy the stacks and the new perl interpreter is
10869 ready to run at the exact same point as the previous one.
10870 The pseudo-fork code uses COPY_STACKS while the
10871 threads->create doesn't.
10873 CLONEf_KEEP_PTR_TABLE
10874 perl_clone keeps a ptr_table with the pointer of the old
10875 variable as a key and the new variable as a value,
10876 this allows it to check if something has been cloned and not
10877 clone it again but rather just use the value and increase the
10878 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
10879 the ptr_table using the function
10880 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
10881 reason to keep it around is if you want to dup some of your own
10882 variable who are outside the graph perl scans, example of this
10883 code is in threads.xs create
10886 This is a win32 thing, it is ignored on unix, it tells perls
10887 win32host code (which is c++) to clone itself, this is needed on
10888 win32 if you want to run two threads at the same time,
10889 if you just want to do some stuff in a separate perl interpreter
10890 and then throw it away and return to the original one,
10891 you don't need to do anything.
10896 /* XXX the above needs expanding by someone who actually understands it ! */
10897 EXTERN_C PerlInterpreter *
10898 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
10901 perl_clone(PerlInterpreter *proto_perl, UV flags)
10904 #ifdef PERL_IMPLICIT_SYS
10906 /* perlhost.h so we need to call into it
10907 to clone the host, CPerlHost should have a c interface, sky */
10909 if (flags & CLONEf_CLONE_HOST) {
10910 return perl_clone_host(proto_perl,flags);
10912 return perl_clone_using(proto_perl, flags,
10914 proto_perl->IMemShared,
10915 proto_perl->IMemParse,
10917 proto_perl->IStdIO,
10921 proto_perl->IProc);
10925 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
10926 struct IPerlMem* ipM, struct IPerlMem* ipMS,
10927 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
10928 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
10929 struct IPerlDir* ipD, struct IPerlSock* ipS,
10930 struct IPerlProc* ipP)
10932 /* XXX many of the string copies here can be optimized if they're
10933 * constants; they need to be allocated as common memory and just
10934 * their pointers copied. */
10937 CLONE_PARAMS clone_params;
10938 CLONE_PARAMS* const param = &clone_params;
10940 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
10941 /* for each stash, determine whether its objects should be cloned */
10942 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10943 PERL_SET_THX(my_perl);
10946 PoisonNew(my_perl, 1, PerlInterpreter);
10952 PL_savestack_ix = 0;
10953 PL_savestack_max = -1;
10954 PL_sig_pending = 0;
10956 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10957 # else /* !DEBUGGING */
10958 Zero(my_perl, 1, PerlInterpreter);
10959 # endif /* DEBUGGING */
10961 /* host pointers */
10963 PL_MemShared = ipMS;
10964 PL_MemParse = ipMP;
10971 #else /* !PERL_IMPLICIT_SYS */
10973 CLONE_PARAMS clone_params;
10974 CLONE_PARAMS* param = &clone_params;
10975 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
10976 /* for each stash, determine whether its objects should be cloned */
10977 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10978 PERL_SET_THX(my_perl);
10981 PoisonNew(my_perl, 1, PerlInterpreter);
10987 PL_savestack_ix = 0;
10988 PL_savestack_max = -1;
10989 PL_sig_pending = 0;
10991 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10992 # else /* !DEBUGGING */
10993 Zero(my_perl, 1, PerlInterpreter);
10994 # endif /* DEBUGGING */
10995 #endif /* PERL_IMPLICIT_SYS */
10996 param->flags = flags;
10997 param->proto_perl = proto_perl;
10999 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
11001 PL_body_arenas = NULL;
11002 Zero(&PL_body_roots, 1, PL_body_roots);
11004 PL_nice_chunk = NULL;
11005 PL_nice_chunk_size = 0;
11007 PL_sv_objcount = 0;
11009 PL_sv_arenaroot = NULL;
11011 PL_debug = proto_perl->Idebug;
11013 PL_hash_seed = proto_perl->Ihash_seed;
11014 PL_rehash_seed = proto_perl->Irehash_seed;
11016 #ifdef USE_REENTRANT_API
11017 /* XXX: things like -Dm will segfault here in perlio, but doing
11018 * PERL_SET_CONTEXT(proto_perl);
11019 * breaks too many other things
11021 Perl_reentrant_init(aTHX);
11024 /* create SV map for pointer relocation */
11025 PL_ptr_table = ptr_table_new();
11027 /* initialize these special pointers as early as possible */
11028 SvANY(&PL_sv_undef) = NULL;
11029 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11030 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11031 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11033 SvANY(&PL_sv_no) = new_XPVNV();
11034 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11035 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11036 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11037 SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
11038 SvCUR_set(&PL_sv_no, 0);
11039 SvLEN_set(&PL_sv_no, 1);
11040 SvIV_set(&PL_sv_no, 0);
11041 SvNV_set(&PL_sv_no, 0);
11042 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11044 SvANY(&PL_sv_yes) = new_XPVNV();
11045 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11046 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11047 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11048 SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
11049 SvCUR_set(&PL_sv_yes, 1);
11050 SvLEN_set(&PL_sv_yes, 2);
11051 SvIV_set(&PL_sv_yes, 1);
11052 SvNV_set(&PL_sv_yes, 1);
11053 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11055 /* create (a non-shared!) shared string table */
11056 PL_strtab = newHV();
11057 HvSHAREKEYS_off(PL_strtab);
11058 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
11059 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11061 PL_compiling = proto_perl->Icompiling;
11063 /* These two PVs will be free'd special way so must set them same way op.c does */
11064 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11065 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11067 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11068 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11070 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11071 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
11072 if (PL_compiling.cop_hints_hash) {
11074 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
11075 HINTS_REFCNT_UNLOCK;
11077 PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
11078 #ifdef PERL_DEBUG_READONLY_OPS
11083 /* pseudo environmental stuff */
11084 PL_origargc = proto_perl->Iorigargc;
11085 PL_origargv = proto_perl->Iorigargv;
11087 param->stashes = newAV(); /* Setup array of objects to call clone on */
11089 /* Set tainting stuff before PerlIO_debug can possibly get called */
11090 PL_tainting = proto_perl->Itainting;
11091 PL_taint_warn = proto_perl->Itaint_warn;
11093 #ifdef PERLIO_LAYERS
11094 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11095 PerlIO_clone(aTHX_ proto_perl, param);
11098 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11099 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11100 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11101 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11102 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11103 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11106 PL_minus_c = proto_perl->Iminus_c;
11107 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11108 PL_localpatches = proto_perl->Ilocalpatches;
11109 PL_splitstr = proto_perl->Isplitstr;
11110 PL_preprocess = proto_perl->Ipreprocess;
11111 PL_minus_n = proto_perl->Iminus_n;
11112 PL_minus_p = proto_perl->Iminus_p;
11113 PL_minus_l = proto_perl->Iminus_l;
11114 PL_minus_a = proto_perl->Iminus_a;
11115 PL_minus_E = proto_perl->Iminus_E;
11116 PL_minus_F = proto_perl->Iminus_F;
11117 PL_doswitches = proto_perl->Idoswitches;
11118 PL_dowarn = proto_perl->Idowarn;
11119 PL_doextract = proto_perl->Idoextract;
11120 PL_sawampersand = proto_perl->Isawampersand;
11121 PL_unsafe = proto_perl->Iunsafe;
11122 PL_inplace = SAVEPV(proto_perl->Iinplace);
11123 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11124 PL_perldb = proto_perl->Iperldb;
11125 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11126 PL_exit_flags = proto_perl->Iexit_flags;
11128 /* magical thingies */
11129 /* XXX time(&PL_basetime) when asked for? */
11130 PL_basetime = proto_perl->Ibasetime;
11131 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11133 PL_maxsysfd = proto_perl->Imaxsysfd;
11134 PL_statusvalue = proto_perl->Istatusvalue;
11136 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11138 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
11140 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11142 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11143 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11144 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11147 /* RE engine related */
11148 Zero(&PL_reg_state, 1, struct re_save_state);
11149 PL_reginterp_cnt = 0;
11150 PL_regmatch_slab = NULL;
11152 /* Clone the regex array */
11153 PL_regex_padav = newAV();
11155 const I32 len = av_len((AV*)proto_perl->Iregex_padav);
11156 SV* const * const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11158 av_push(PL_regex_padav, sv_dup_inc_NN(regexen[0],param));
11159 for(i = 1; i <= len; i++) {
11160 const SV * const regex = regexen[i];
11163 ? sv_dup_inc(regex, param)
11165 newSViv(PTR2IV(CALLREGDUPE(
11166 INT2PTR(REGEXP *, SvIVX(regex)), param))))
11168 if (SvFLAGS(regex) & SVf_BREAK)
11169 SvFLAGS(sv) |= SVf_BREAK; /* unrefcnted PL_curpm */
11170 av_push(PL_regex_padav, sv);
11173 PL_regex_pad = AvARRAY(PL_regex_padav);
11175 /* shortcuts to various I/O objects */
11176 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11177 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11178 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11179 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11180 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11181 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11183 /* shortcuts to regexp stuff */
11184 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11186 /* shortcuts to misc objects */
11187 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11189 /* shortcuts to debugging objects */
11190 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11191 PL_DBline = gv_dup(proto_perl->IDBline, param);
11192 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11193 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11194 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11195 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11196 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11198 /* symbol tables */
11199 PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
11200 PL_curstash = hv_dup(proto_perl->Icurstash, param);
11201 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11202 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11203 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11205 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11206 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11207 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11208 PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
11209 PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
11210 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11211 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11212 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11214 PL_sub_generation = proto_perl->Isub_generation;
11215 PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
11217 /* funky return mechanisms */
11218 PL_forkprocess = proto_perl->Iforkprocess;
11220 /* subprocess state */
11221 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11223 /* internal state */
11224 PL_maxo = proto_perl->Imaxo;
11225 if (proto_perl->Iop_mask)
11226 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11229 /* PL_asserting = proto_perl->Iasserting; */
11231 /* current interpreter roots */
11232 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11234 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11236 PL_main_start = proto_perl->Imain_start;
11237 PL_eval_root = proto_perl->Ieval_root;
11238 PL_eval_start = proto_perl->Ieval_start;
11240 /* runtime control stuff */
11241 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11243 PL_filemode = proto_perl->Ifilemode;
11244 PL_lastfd = proto_perl->Ilastfd;
11245 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11248 PL_gensym = proto_perl->Igensym;
11249 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11250 PL_laststatval = proto_perl->Ilaststatval;
11251 PL_laststype = proto_perl->Ilaststype;
11254 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11256 /* interpreter atexit processing */
11257 PL_exitlistlen = proto_perl->Iexitlistlen;
11258 if (PL_exitlistlen) {
11259 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11260 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11263 PL_exitlist = (PerlExitListEntry*)NULL;
11265 PL_my_cxt_size = proto_perl->Imy_cxt_size;
11266 if (PL_my_cxt_size) {
11267 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
11268 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
11269 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
11270 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
11271 Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
11275 PL_my_cxt_list = (void**)NULL;
11276 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
11277 PL_my_cxt_keys = (const char**)NULL;
11280 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11281 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11282 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11284 PL_profiledata = NULL;
11286 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11288 PAD_CLONE_VARS(proto_perl, param);
11290 #ifdef HAVE_INTERP_INTERN
11291 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11294 /* more statics moved here */
11295 PL_generation = proto_perl->Igeneration;
11296 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11298 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11299 PL_in_clean_all = proto_perl->Iin_clean_all;
11301 PL_uid = proto_perl->Iuid;
11302 PL_euid = proto_perl->Ieuid;
11303 PL_gid = proto_perl->Igid;
11304 PL_egid = proto_perl->Iegid;
11305 PL_nomemok = proto_perl->Inomemok;
11306 PL_an = proto_perl->Ian;
11307 PL_evalseq = proto_perl->Ievalseq;
11308 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11309 PL_origalen = proto_perl->Iorigalen;
11310 #ifdef PERL_USES_PL_PIDSTATUS
11311 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11313 PL_osname = SAVEPV(proto_perl->Iosname);
11314 PL_sighandlerp = proto_perl->Isighandlerp;
11316 PL_runops = proto_perl->Irunops;
11318 PL_parser = parser_dup(proto_perl->Iparser, param);
11320 PL_subline = proto_perl->Isubline;
11321 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
11324 PL_cryptseen = proto_perl->Icryptseen;
11327 PL_hints = proto_perl->Ihints;
11329 PL_amagic_generation = proto_perl->Iamagic_generation;
11331 #ifdef USE_LOCALE_COLLATE
11332 PL_collation_ix = proto_perl->Icollation_ix;
11333 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
11334 PL_collation_standard = proto_perl->Icollation_standard;
11335 PL_collxfrm_base = proto_perl->Icollxfrm_base;
11336 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
11337 #endif /* USE_LOCALE_COLLATE */
11339 #ifdef USE_LOCALE_NUMERIC
11340 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
11341 PL_numeric_standard = proto_perl->Inumeric_standard;
11342 PL_numeric_local = proto_perl->Inumeric_local;
11343 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11344 #endif /* !USE_LOCALE_NUMERIC */
11346 /* utf8 character classes */
11347 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11348 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11349 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11350 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11351 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
11352 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11353 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
11354 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
11355 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
11356 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
11357 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
11358 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
11359 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11360 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
11361 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11362 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11363 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11364 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11365 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11366 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11368 /* Did the locale setup indicate UTF-8? */
11369 PL_utf8locale = proto_perl->Iutf8locale;
11370 /* Unicode features (see perlrun/-C) */
11371 PL_unicode = proto_perl->Iunicode;
11373 /* Pre-5.8 signals control */
11374 PL_signals = proto_perl->Isignals;
11376 /* times() ticks per second */
11377 PL_clocktick = proto_perl->Iclocktick;
11379 /* Recursion stopper for PerlIO_find_layer */
11380 PL_in_load_module = proto_perl->Iin_load_module;
11382 /* sort() routine */
11383 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
11385 /* Not really needed/useful since the reenrant_retint is "volatile",
11386 * but do it for consistency's sake. */
11387 PL_reentrant_retint = proto_perl->Ireentrant_retint;
11389 /* Hooks to shared SVs and locks. */
11390 PL_sharehook = proto_perl->Isharehook;
11391 PL_lockhook = proto_perl->Ilockhook;
11392 PL_unlockhook = proto_perl->Iunlockhook;
11393 PL_threadhook = proto_perl->Ithreadhook;
11394 PL_destroyhook = proto_perl->Idestroyhook;
11396 #ifdef THREADS_HAVE_PIDS
11397 PL_ppid = proto_perl->Ippid;
11401 PL_last_swash_hv = NULL; /* reinits on demand */
11402 PL_last_swash_klen = 0;
11403 PL_last_swash_key[0]= '\0';
11404 PL_last_swash_tmps = (U8*)NULL;
11405 PL_last_swash_slen = 0;
11407 PL_glob_index = proto_perl->Iglob_index;
11408 PL_srand_called = proto_perl->Isrand_called;
11409 PL_bitcount = NULL; /* reinits on demand */
11411 if (proto_perl->Ipsig_pend) {
11412 Newxz(PL_psig_pend, SIG_SIZE, int);
11415 PL_psig_pend = (int*)NULL;
11418 if (proto_perl->Ipsig_ptr) {
11419 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
11420 Newxz(PL_psig_name, SIG_SIZE, SV*);
11421 for (i = 1; i < SIG_SIZE; i++) {
11422 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11423 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11427 PL_psig_ptr = (SV**)NULL;
11428 PL_psig_name = (SV**)NULL;
11431 /* intrpvar.h stuff */
11433 if (flags & CLONEf_COPY_STACKS) {
11434 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11435 PL_tmps_ix = proto_perl->Itmps_ix;
11436 PL_tmps_max = proto_perl->Itmps_max;
11437 PL_tmps_floor = proto_perl->Itmps_floor;
11438 Newxz(PL_tmps_stack, PL_tmps_max, SV*);
11440 while (i <= PL_tmps_ix) {
11441 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Itmps_stack[i], param);
11445 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11446 i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
11447 Newxz(PL_markstack, i, I32);
11448 PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
11449 - proto_perl->Imarkstack);
11450 PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
11451 - proto_perl->Imarkstack);
11452 Copy(proto_perl->Imarkstack, PL_markstack,
11453 PL_markstack_ptr - PL_markstack + 1, I32);
11455 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
11456 * NOTE: unlike the others! */
11457 PL_scopestack_ix = proto_perl->Iscopestack_ix;
11458 PL_scopestack_max = proto_perl->Iscopestack_max;
11459 Newxz(PL_scopestack, PL_scopestack_max, I32);
11460 Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
11462 /* NOTE: si_dup() looks at PL_markstack */
11463 PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
11465 /* PL_curstack = PL_curstackinfo->si_stack; */
11466 PL_curstack = av_dup(proto_perl->Icurstack, param);
11467 PL_mainstack = av_dup(proto_perl->Imainstack, param);
11469 /* next PUSHs() etc. set *(PL_stack_sp+1) */
11470 PL_stack_base = AvARRAY(PL_curstack);
11471 PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp
11472 - proto_perl->Istack_base);
11473 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
11475 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
11476 * NOTE: unlike the others! */
11477 PL_savestack_ix = proto_perl->Isavestack_ix;
11478 PL_savestack_max = proto_perl->Isavestack_max;
11479 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
11480 PL_savestack = ss_dup(proto_perl, param);
11484 ENTER; /* perl_destruct() wants to LEAVE; */
11486 /* although we're not duplicating the tmps stack, we should still
11487 * add entries for any SVs on the tmps stack that got cloned by a
11488 * non-refcount means (eg a temp in @_); otherwise they will be
11491 for (i = 0; i<= proto_perl->Itmps_ix; i++) {
11492 SV * const nsv = (SV*)ptr_table_fetch(PL_ptr_table,
11493 proto_perl->Itmps_stack[i]);
11494 if (nsv && !SvREFCNT(nsv)) {
11496 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv);
11501 PL_start_env = proto_perl->Istart_env; /* XXXXXX */
11502 PL_top_env = &PL_start_env;
11504 PL_op = proto_perl->Iop;
11507 PL_Xpv = (XPV*)NULL;
11508 PL_na = proto_perl->Ina;
11510 PL_statbuf = proto_perl->Istatbuf;
11511 PL_statcache = proto_perl->Istatcache;
11512 PL_statgv = gv_dup(proto_perl->Istatgv, param);
11513 PL_statname = sv_dup_inc(proto_perl->Istatname, param);
11515 PL_timesbuf = proto_perl->Itimesbuf;
11518 PL_tainted = proto_perl->Itainted;
11519 PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
11520 PL_rs = sv_dup_inc(proto_perl->Irs, param);
11521 PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
11522 PL_ofs_sv = sv_dup_inc(proto_perl->Iofs_sv, param);
11523 PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
11524 PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
11525 PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
11526 PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
11527 PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
11529 PL_restartop = proto_perl->Irestartop;
11530 PL_in_eval = proto_perl->Iin_eval;
11531 PL_delaymagic = proto_perl->Idelaymagic;
11532 PL_dirty = proto_perl->Idirty;
11533 PL_localizing = proto_perl->Ilocalizing;
11535 PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
11536 PL_hv_fetch_ent_mh = NULL;
11537 PL_modcount = proto_perl->Imodcount;
11538 PL_lastgotoprobe = NULL;
11539 PL_dumpindent = proto_perl->Idumpindent;
11541 PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
11542 PL_sortstash = hv_dup(proto_perl->Isortstash, param);
11543 PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
11544 PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
11545 PL_efloatbuf = NULL; /* reinits on demand */
11546 PL_efloatsize = 0; /* reinits on demand */
11550 PL_screamfirst = NULL;
11551 PL_screamnext = NULL;
11552 PL_maxscream = -1; /* reinits on demand */
11553 PL_lastscream = NULL;
11556 PL_regdummy = proto_perl->Iregdummy;
11557 PL_colorset = 0; /* reinits PL_colors[] */
11558 /*PL_colors[6] = {0,0,0,0,0,0};*/
11562 /* Pluggable optimizer */
11563 PL_peepp = proto_perl->Ipeepp;
11565 PL_stashcache = newHV();
11567 PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
11568 proto_perl->Iwatchaddr);
11569 PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
11570 if (PL_debug && PL_watchaddr) {
11571 PerlIO_printf(Perl_debug_log,
11572 "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
11573 PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
11574 PTR2UV(PL_watchok));
11577 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
11578 ptr_table_free(PL_ptr_table);
11579 PL_ptr_table = NULL;
11582 /* Call the ->CLONE method, if it exists, for each of the stashes
11583 identified by sv_dup() above.
11585 while(av_len(param->stashes) != -1) {
11586 HV* const stash = (HV*) av_shift(param->stashes);
11587 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
11588 if (cloner && GvCV(cloner)) {
11593 XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
11595 call_sv((SV*)GvCV(cloner), G_DISCARD);
11601 SvREFCNT_dec(param->stashes);
11603 /* orphaned? eg threads->new inside BEGIN or use */
11604 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
11605 SvREFCNT_inc_simple_void(PL_compcv);
11606 SAVEFREESV(PL_compcv);
11612 #endif /* USE_ITHREADS */
11615 =head1 Unicode Support
11617 =for apidoc sv_recode_to_utf8
11619 The encoding is assumed to be an Encode object, on entry the PV
11620 of the sv is assumed to be octets in that encoding, and the sv
11621 will be converted into Unicode (and UTF-8).
11623 If the sv already is UTF-8 (or if it is not POK), or if the encoding
11624 is not a reference, nothing is done to the sv. If the encoding is not
11625 an C<Encode::XS> Encoding object, bad things will happen.
11626 (See F<lib/encoding.pm> and L<Encode>).
11628 The PV of the sv is returned.
11633 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
11636 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
11650 Passing sv_yes is wrong - it needs to be or'ed set of constants
11651 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
11652 remove converted chars from source.
11654 Both will default the value - let them.
11656 XPUSHs(&PL_sv_yes);
11659 call_method("decode", G_SCALAR);
11663 s = SvPV_const(uni, len);
11664 if (s != SvPVX_const(sv)) {
11665 SvGROW(sv, len + 1);
11666 Move(s, SvPVX(sv), len + 1, char);
11667 SvCUR_set(sv, len);
11674 return SvPOKp(sv) ? SvPVX(sv) : NULL;
11678 =for apidoc sv_cat_decode
11680 The encoding is assumed to be an Encode object, the PV of the ssv is
11681 assumed to be octets in that encoding and decoding the input starts
11682 from the position which (PV + *offset) pointed to. The dsv will be
11683 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
11684 when the string tstr appears in decoding output or the input ends on
11685 the PV of the ssv. The value which the offset points will be modified
11686 to the last input position on the ssv.
11688 Returns TRUE if the terminator was found, else returns FALSE.
11693 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
11694 SV *ssv, int *offset, char *tstr, int tlen)
11698 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
11709 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
11710 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
11712 call_method("cat_decode", G_SCALAR);
11714 ret = SvTRUE(TOPs);
11715 *offset = SvIV(offsv);
11721 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
11726 /* ---------------------------------------------------------------------
11728 * support functions for report_uninit()
11731 /* the maxiumum size of array or hash where we will scan looking
11732 * for the undefined element that triggered the warning */
11734 #define FUV_MAX_SEARCH_SIZE 1000
11736 /* Look for an entry in the hash whose value has the same SV as val;
11737 * If so, return a mortal copy of the key. */
11740 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
11743 register HE **array;
11746 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
11747 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
11750 array = HvARRAY(hv);
11752 for (i=HvMAX(hv); i>0; i--) {
11753 register HE *entry;
11754 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
11755 if (HeVAL(entry) != val)
11757 if ( HeVAL(entry) == &PL_sv_undef ||
11758 HeVAL(entry) == &PL_sv_placeholder)
11762 if (HeKLEN(entry) == HEf_SVKEY)
11763 return sv_mortalcopy(HeKEY_sv(entry));
11764 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
11770 /* Look for an entry in the array whose value has the same SV as val;
11771 * If so, return the index, otherwise return -1. */
11774 S_find_array_subscript(pTHX_ AV *av, SV* val)
11777 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
11778 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
11781 if (val != &PL_sv_undef) {
11782 SV ** const svp = AvARRAY(av);
11785 for (i=AvFILLp(av); i>=0; i--)
11792 /* S_varname(): return the name of a variable, optionally with a subscript.
11793 * If gv is non-zero, use the name of that global, along with gvtype (one
11794 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
11795 * targ. Depending on the value of the subscript_type flag, return:
11798 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
11799 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
11800 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
11801 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
11804 S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
11805 SV* keyname, I32 aindex, int subscript_type)
11808 SV * const name = sv_newmortal();
11811 buffer[0] = gvtype;
11814 /* as gv_fullname4(), but add literal '^' for $^FOO names */
11816 gv_fullname4(name, gv, buffer, 0);
11818 if ((unsigned int)SvPVX(name)[1] <= 26) {
11820 buffer[1] = SvPVX(name)[1] + 'A' - 1;
11822 /* Swap the 1 unprintable control character for the 2 byte pretty
11823 version - ie substr($name, 1, 1) = $buffer; */
11824 sv_insert(name, 1, 1, buffer, 2);
11828 CV * const cv = find_runcv(NULL);
11832 if (!cv || !CvPADLIST(cv))
11834 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
11835 sv = *av_fetch(av, targ, FALSE);
11836 sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
11839 if (subscript_type == FUV_SUBSCRIPT_HASH) {
11840 SV * const sv = newSV(0);
11841 *SvPVX(name) = '$';
11842 Perl_sv_catpvf(aTHX_ name, "{%s}",
11843 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
11846 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
11847 *SvPVX(name) = '$';
11848 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
11850 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
11851 Perl_sv_insert(aTHX_ name, 0, 0, STR_WITH_LEN("within "));
11858 =for apidoc find_uninit_var
11860 Find the name of the undefined variable (if any) that caused the operator o
11861 to issue a "Use of uninitialized value" warning.
11862 If match is true, only return a name if it's value matches uninit_sv.
11863 So roughly speaking, if a unary operator (such as OP_COS) generates a
11864 warning, then following the direct child of the op may yield an
11865 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
11866 other hand, with OP_ADD there are two branches to follow, so we only print
11867 the variable name if we get an exact match.
11869 The name is returned as a mortal SV.
11871 Assumes that PL_op is the op that originally triggered the error, and that
11872 PL_comppad/PL_curpad points to the currently executing pad.
11878 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
11886 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
11887 uninit_sv == &PL_sv_placeholder)))
11890 switch (obase->op_type) {
11897 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
11898 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
11901 int subscript_type = FUV_SUBSCRIPT_WITHIN;
11903 if (pad) { /* @lex, %lex */
11904 sv = PAD_SVl(obase->op_targ);
11908 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
11909 /* @global, %global */
11910 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
11913 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
11915 else /* @{expr}, %{expr} */
11916 return find_uninit_var(cUNOPx(obase)->op_first,
11920 /* attempt to find a match within the aggregate */
11922 keysv = find_hash_subscript((HV*)sv, uninit_sv);
11924 subscript_type = FUV_SUBSCRIPT_HASH;
11927 index = find_array_subscript((AV*)sv, uninit_sv);
11929 subscript_type = FUV_SUBSCRIPT_ARRAY;
11932 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
11935 return varname(gv, hash ? '%' : '@', obase->op_targ,
11936 keysv, index, subscript_type);
11940 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
11942 return varname(NULL, '$', obase->op_targ,
11943 NULL, 0, FUV_SUBSCRIPT_NONE);
11946 gv = cGVOPx_gv(obase);
11947 if (!gv || (match && GvSV(gv) != uninit_sv))
11949 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
11952 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
11955 av = (AV*)PAD_SV(obase->op_targ);
11956 if (!av || SvRMAGICAL(av))
11958 svp = av_fetch(av, (I32)obase->op_private, FALSE);
11959 if (!svp || *svp != uninit_sv)
11962 return varname(NULL, '$', obase->op_targ,
11963 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
11966 gv = cGVOPx_gv(obase);
11972 if (!av || SvRMAGICAL(av))
11974 svp = av_fetch(av, (I32)obase->op_private, FALSE);
11975 if (!svp || *svp != uninit_sv)
11978 return varname(gv, '$', 0,
11979 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
11984 o = cUNOPx(obase)->op_first;
11985 if (!o || o->op_type != OP_NULL ||
11986 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
11988 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
11992 if (PL_op == obase)
11993 /* $a[uninit_expr] or $h{uninit_expr} */
11994 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
11997 o = cBINOPx(obase)->op_first;
11998 kid = cBINOPx(obase)->op_last;
12000 /* get the av or hv, and optionally the gv */
12002 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
12003 sv = PAD_SV(o->op_targ);
12005 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
12006 && cUNOPo->op_first->op_type == OP_GV)
12008 gv = cGVOPx_gv(cUNOPo->op_first);
12011 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
12016 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
12017 /* index is constant */
12021 if (obase->op_type == OP_HELEM) {
12022 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
12023 if (!he || HeVAL(he) != uninit_sv)
12027 SV * const * const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
12028 if (!svp || *svp != uninit_sv)
12032 if (obase->op_type == OP_HELEM)
12033 return varname(gv, '%', o->op_targ,
12034 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
12036 return varname(gv, '@', o->op_targ, NULL,
12037 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
12040 /* index is an expression;
12041 * attempt to find a match within the aggregate */
12042 if (obase->op_type == OP_HELEM) {
12043 SV * const keysv = find_hash_subscript((HV*)sv, uninit_sv);
12045 return varname(gv, '%', o->op_targ,
12046 keysv, 0, FUV_SUBSCRIPT_HASH);
12049 const I32 index = find_array_subscript((AV*)sv, uninit_sv);
12051 return varname(gv, '@', o->op_targ,
12052 NULL, index, FUV_SUBSCRIPT_ARRAY);
12057 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
12059 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
12064 /* only examine RHS */
12065 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
12068 o = cUNOPx(obase)->op_first;
12069 if (o->op_type == OP_PUSHMARK)
12072 if (!o->op_sibling) {
12073 /* one-arg version of open is highly magical */
12075 if (o->op_type == OP_GV) { /* open FOO; */
12077 if (match && GvSV(gv) != uninit_sv)
12079 return varname(gv, '$', 0,
12080 NULL, 0, FUV_SUBSCRIPT_NONE);
12082 /* other possibilities not handled are:
12083 * open $x; or open my $x; should return '${*$x}'
12084 * open expr; should return '$'.expr ideally
12090 /* ops where $_ may be an implicit arg */
12094 if ( !(obase->op_flags & OPf_STACKED)) {
12095 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
12096 ? PAD_SVl(obase->op_targ)
12099 sv = sv_newmortal();
12100 sv_setpvn(sv, "$_", 2);
12109 /* skip filehandle as it can't produce 'undef' warning */
12110 o = cUNOPx(obase)->op_first;
12111 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
12112 o = o->op_sibling->op_sibling;
12118 match = 1; /* XS or custom code could trigger random warnings */
12123 /* XXX tmp hack: these two may call an XS sub, and currently
12124 XS subs don't have a SUB entry on the context stack, so CV and
12125 pad determination goes wrong, and BAD things happen. So, just
12126 don't try to determine the value under those circumstances.
12127 Need a better fix at dome point. DAPM 11/2007 */
12131 /* def-ness of rval pos() is independent of the def-ness of its arg */
12132 if ( !(obase->op_flags & OPf_MOD))
12137 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
12138 return sv_2mortal(newSVpvs("${$/}"));
12143 if (!(obase->op_flags & OPf_KIDS))
12145 o = cUNOPx(obase)->op_first;
12151 /* if all except one arg are constant, or have no side-effects,
12152 * or are optimized away, then it's unambiguous */
12154 for (kid=o; kid; kid = kid->op_sibling) {
12156 const OPCODE type = kid->op_type;
12157 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
12158 || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
12159 || (type == OP_PUSHMARK)
12163 if (o2) { /* more than one found */
12170 return find_uninit_var(o2, uninit_sv, match);
12172 /* scan all args */
12174 sv = find_uninit_var(o, uninit_sv, 1);
12186 =for apidoc report_uninit
12188 Print appropriate "Use of uninitialized variable" warning
12194 Perl_report_uninit(pTHX_ SV* uninit_sv)
12198 SV* varname = NULL;
12200 varname = find_uninit_var(PL_op, uninit_sv,0);
12202 sv_insert(varname, 0, 0, " ", 1);
12204 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
12205 varname ? SvPV_nolen_const(varname) : "",
12206 " in ", OP_DESC(PL_op));
12209 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
12215 * c-indentation-style: bsd
12216 * c-basic-offset: 4
12217 * indent-tabs-mode: t
12220 * ex: set ts=8 sts=4 sw=4 noet: