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 *const chunk, const U32 chunk_size)
163 PERL_ARGS_ASSERT_OFFER_NICE_CHUNK;
165 new_chunk = (void *)(chunk);
166 new_chunk_size = (chunk_size);
167 if (new_chunk_size > PL_nice_chunk_size) {
168 Safefree(PL_nice_chunk);
169 PL_nice_chunk = (char *) new_chunk;
170 PL_nice_chunk_size = new_chunk_size;
177 # define MEM_LOG_NEW_SV(sv, file, line, func) \
178 Perl_mem_log_new_sv(sv, file, line, func)
179 # define MEM_LOG_DEL_SV(sv, file, line, func) \
180 Perl_mem_log_del_sv(sv, file, line, func)
182 # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP
183 # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP
186 #ifdef DEBUG_LEAKING_SCALARS
187 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
188 # define DEBUG_SV_SERIAL(sv) \
189 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
190 PTR2UV(sv), (long)(sv)->sv_debug_serial))
192 # define FREE_SV_DEBUG_FILE(sv)
193 # define DEBUG_SV_SERIAL(sv) NOOP
197 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
198 /* Whilst I'd love to do this, it seems that things like to check on
200 # define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
202 # define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
203 PoisonNew(&SvREFCNT(sv), 1, U32)
205 # define SvARENA_CHAIN(sv) SvANY(sv)
206 # define POSION_SV_HEAD(sv)
209 /* Mark an SV head as unused, and add to free list.
211 * If SVf_BREAK is set, skip adding it to the free list, as this SV had
212 * its refcount artificially decremented during global destruction, so
213 * there may be dangling pointers to it. The last thing we want in that
214 * case is for it to be reused. */
216 #define plant_SV(p) \
218 const U32 old_flags = SvFLAGS(p); \
219 MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
220 DEBUG_SV_SERIAL(p); \
221 FREE_SV_DEBUG_FILE(p); \
223 SvFLAGS(p) = SVTYPEMASK; \
224 if (!(old_flags & SVf_BREAK)) { \
225 SvARENA_CHAIN(p) = (void *)PL_sv_root; \
231 #define uproot_SV(p) \
234 PL_sv_root = (SV*)SvARENA_CHAIN(p); \
239 /* make some more SVs by adding another arena */
248 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
249 PL_nice_chunk = NULL;
250 PL_nice_chunk_size = 0;
253 char *chunk; /* must use New here to match call to */
254 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
255 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
261 /* new_SV(): return a new, empty SV head */
263 #ifdef DEBUG_LEAKING_SCALARS
264 /* provide a real function for a debugger to play with */
266 S_new_SV(pTHX_ const char *file, int line, const char *func)
273 sv = S_more_sv(aTHX);
277 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
278 sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
284 sv->sv_debug_inpad = 0;
285 sv->sv_debug_cloned = 0;
286 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
288 sv->sv_debug_serial = PL_sv_serial++;
290 MEM_LOG_NEW_SV(sv, file, line, func);
291 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
292 PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
296 # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
304 (p) = S_more_sv(aTHX); \
308 MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \
313 /* del_SV(): return an empty SV head to the free list */
326 S_del_sv(pTHX_ SV *p)
330 PERL_ARGS_ASSERT_DEL_SV;
335 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
336 const SV * const sv = sva + 1;
337 const SV * const svend = &sva[SvREFCNT(sva)];
338 if (p >= sv && p < svend) {
344 if (ckWARN_d(WARN_INTERNAL))
345 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
346 "Attempt to free non-arena SV: 0x%"UVxf
347 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
354 #else /* ! DEBUGGING */
356 #define del_SV(p) plant_SV(p)
358 #endif /* DEBUGGING */
362 =head1 SV Manipulation Functions
364 =for apidoc sv_add_arena
366 Given a chunk of memory, link it to the head of the list of arenas,
367 and split it into a list of free SVs.
373 Perl_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
376 SV* const sva = (SV*)ptr;
380 PERL_ARGS_ASSERT_SV_ADD_ARENA;
382 /* The first SV in an arena isn't an SV. */
383 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
384 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
385 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
387 PL_sv_arenaroot = sva;
388 PL_sv_root = sva + 1;
390 svend = &sva[SvREFCNT(sva) - 1];
393 SvARENA_CHAIN(sv) = (void *)(SV*)(sv + 1);
397 /* Must always set typemask because it's always checked in on cleanup
398 when the arenas are walked looking for objects. */
399 SvFLAGS(sv) = SVTYPEMASK;
402 SvARENA_CHAIN(sv) = 0;
406 SvFLAGS(sv) = SVTYPEMASK;
409 /* visit(): call the named function for each non-free SV in the arenas
410 * whose flags field matches the flags/mask args. */
413 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
419 PERL_ARGS_ASSERT_VISIT;
421 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
422 register const SV * const svend = &sva[SvREFCNT(sva)];
424 for (sv = sva + 1; sv < svend; ++sv) {
425 if (SvTYPE(sv) != SVTYPEMASK
426 && (sv->sv_flags & mask) == flags
439 /* called by sv_report_used() for each live SV */
442 do_report_used(pTHX_ SV *const sv)
444 if (SvTYPE(sv) != SVTYPEMASK) {
445 PerlIO_printf(Perl_debug_log, "****\n");
452 =for apidoc sv_report_used
454 Dump the contents of all SVs not yet freed. (Debugging aid).
460 Perl_sv_report_used(pTHX)
463 visit(do_report_used, 0, 0);
469 /* called by sv_clean_objs() for each live SV */
472 do_clean_objs(pTHX_ SV *const ref)
477 SV * const target = SvRV(ref);
478 if (SvOBJECT(target)) {
479 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
480 if (SvWEAKREF(ref)) {
481 sv_del_backref(target, ref);
487 SvREFCNT_dec(target);
492 /* XXX Might want to check arrays, etc. */
495 /* called by sv_clean_objs() for each live SV */
497 #ifndef DISABLE_DESTRUCTOR_KLUDGE
499 do_clean_named_objs(pTHX_ SV *const sv)
502 assert(SvTYPE(sv) == SVt_PVGV);
503 assert(isGV_with_GP(sv));
506 #ifdef PERL_DONT_CREATE_GVSV
509 SvOBJECT(GvSV(sv))) ||
510 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
511 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
512 /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */
513 (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) ||
514 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
516 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
517 SvFLAGS(sv) |= SVf_BREAK;
525 =for apidoc sv_clean_objs
527 Attempt to destroy all objects not yet freed
533 Perl_sv_clean_objs(pTHX)
536 PL_in_clean_objs = TRUE;
537 visit(do_clean_objs, SVf_ROK, SVf_ROK);
538 #ifndef DISABLE_DESTRUCTOR_KLUDGE
539 /* some barnacles may yet remain, clinging to typeglobs */
540 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
542 PL_in_clean_objs = FALSE;
545 /* called by sv_clean_all() for each live SV */
548 do_clean_all(pTHX_ SV *const sv)
551 if (sv == (SV*) PL_fdpid || sv == (SV *)PL_strtab) {
552 /* don't clean pid table and strtab */
555 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
556 SvFLAGS(sv) |= SVf_BREAK;
561 =for apidoc sv_clean_all
563 Decrement the refcnt of each remaining SV, possibly triggering a
564 cleanup. This function may have to be called multiple times to free
565 SVs which are in complex self-referential hierarchies.
571 Perl_sv_clean_all(pTHX)
575 PL_in_clean_all = TRUE;
576 cleaned = visit(do_clean_all, 0,0);
577 PL_in_clean_all = FALSE;
582 ARENASETS: a meta-arena implementation which separates arena-info
583 into struct arena_set, which contains an array of struct
584 arena_descs, each holding info for a single arena. By separating
585 the meta-info from the arena, we recover the 1st slot, formerly
586 borrowed for list management. The arena_set is about the size of an
587 arena, avoiding the needless malloc overhead of a naive linked-list.
589 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
590 memory in the last arena-set (1/2 on average). In trade, we get
591 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
592 smaller types). The recovery of the wasted space allows use of
593 small arenas for large, rare body types, by changing array* fields
594 in body_details_by_type[] below.
597 char *arena; /* the raw storage, allocated aligned */
598 size_t size; /* its size ~4k typ */
599 U32 misc; /* type, and in future other things. */
604 /* Get the maximum number of elements in set[] such that struct arena_set
605 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
606 therefore likely to be 1 aligned memory page. */
608 #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
609 - 2 * sizeof(int)) / sizeof (struct arena_desc))
612 struct arena_set* next;
613 unsigned int set_size; /* ie ARENAS_PER_SET */
614 unsigned int curr; /* index of next available arena-desc */
615 struct arena_desc set[ARENAS_PER_SET];
619 =for apidoc sv_free_arenas
621 Deallocate the memory used by all arenas. Note that all the individual SV
622 heads and bodies within the arenas must already have been freed.
627 Perl_sv_free_arenas(pTHX)
634 /* Free arenas here, but be careful about fake ones. (We assume
635 contiguity of the fake ones with the corresponding real ones.) */
637 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
638 svanext = (SV*) SvANY(sva);
639 while (svanext && SvFAKE(svanext))
640 svanext = (SV*) SvANY(svanext);
647 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
650 struct arena_set *current = aroot;
653 assert(aroot->set[i].arena);
654 Safefree(aroot->set[i].arena);
662 i = PERL_ARENA_ROOTS_SIZE;
664 PL_body_roots[i] = 0;
666 Safefree(PL_nice_chunk);
667 PL_nice_chunk = NULL;
668 PL_nice_chunk_size = 0;
674 Here are mid-level routines that manage the allocation of bodies out
675 of the various arenas. There are 5 kinds of arenas:
677 1. SV-head arenas, which are discussed and handled above
678 2. regular body arenas
679 3. arenas for reduced-size bodies
681 5. pte arenas (thread related)
683 Arena types 2 & 3 are chained by body-type off an array of
684 arena-root pointers, which is indexed by svtype. Some of the
685 larger/less used body types are malloced singly, since a large
686 unused block of them is wasteful. Also, several svtypes dont have
687 bodies; the data fits into the sv-head itself. The arena-root
688 pointer thus has a few unused root-pointers (which may be hijacked
689 later for arena types 4,5)
691 3 differs from 2 as an optimization; some body types have several
692 unused fields in the front of the structure (which are kept in-place
693 for consistency). These bodies can be allocated in smaller chunks,
694 because the leading fields arent accessed. Pointers to such bodies
695 are decremented to point at the unused 'ghost' memory, knowing that
696 the pointers are used with offsets to the real memory.
698 HE, HEK arenas are managed separately, with separate code, but may
699 be merge-able later..
701 PTE arenas are not sv-bodies, but they share these mid-level
702 mechanics, so are considered here. The new mid-level mechanics rely
703 on the sv_type of the body being allocated, so we just reserve one
704 of the unused body-slots for PTEs, then use it in those (2) PTE
705 contexts below (line ~10k)
708 /* get_arena(size): this creates custom-sized arenas
709 TBD: export properly for hv.c: S_more_he().
712 Perl_get_arena(pTHX_ const size_t arena_size, const U32 misc)
715 struct arena_desc* adesc;
716 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
719 /* shouldnt need this
720 if (!arena_size) arena_size = PERL_ARENA_SIZE;
723 /* may need new arena-set to hold new arena */
724 if (!aroot || aroot->curr >= aroot->set_size) {
725 struct arena_set *newroot;
726 Newxz(newroot, 1, struct arena_set);
727 newroot->set_size = ARENAS_PER_SET;
728 newroot->next = aroot;
730 PL_body_arenas = (void *) newroot;
731 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
734 /* ok, now have arena-set with at least 1 empty/available arena-desc */
735 curr = aroot->curr++;
736 adesc = &(aroot->set[curr]);
737 assert(!adesc->arena);
739 Newx(adesc->arena, arena_size, char);
740 adesc->size = arena_size;
742 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
743 curr, (void*)adesc->arena, (UV)arena_size));
749 /* return a thing to the free list */
751 #define del_body(thing, root) \
753 void ** const thing_copy = (void **)thing;\
754 *thing_copy = *root; \
755 *root = (void*)thing_copy; \
760 =head1 SV-Body Allocation
762 Allocation of SV-bodies is similar to SV-heads, differing as follows;
763 the allocation mechanism is used for many body types, so is somewhat
764 more complicated, it uses arena-sets, and has no need for still-live
767 At the outermost level, (new|del)_X*V macros return bodies of the
768 appropriate type. These macros call either (new|del)_body_type or
769 (new|del)_body_allocated macro pairs, depending on specifics of the
770 type. Most body types use the former pair, the latter pair is used to
771 allocate body types with "ghost fields".
773 "ghost fields" are fields that are unused in certain types, and
774 consequently dont need to actually exist. They are declared because
775 they're part of a "base type", which allows use of functions as
776 methods. The simplest examples are AVs and HVs, 2 aggregate types
777 which don't use the fields which support SCALAR semantics.
779 For these types, the arenas are carved up into *_allocated size
780 chunks, we thus avoid wasted memory for those unaccessed members.
781 When bodies are allocated, we adjust the pointer back in memory by the
782 size of the bit not allocated, so it's as if we allocated the full
783 structure. (But things will all go boom if you write to the part that
784 is "not there", because you'll be overwriting the last members of the
785 preceding structure in memory.)
787 We calculate the correction using the STRUCT_OFFSET macro. For
788 example, if xpv_allocated is the same structure as XPV then the two
789 OFFSETs sum to zero, and the pointer is unchanged. If the allocated
790 structure is smaller (no initial NV actually allocated) then the net
791 effect is to subtract the size of the NV from the pointer, to return a
792 new pointer as if an initial NV were actually allocated.
794 This is the same trick as was used for NV and IV bodies. Ironically it
795 doesn't need to be used for NV bodies any more, because NV is now at
796 the start of the structure. IV bodies don't need it either, because
797 they are no longer allocated.
799 In turn, the new_body_* allocators call S_new_body(), which invokes
800 new_body_inline macro, which takes a lock, and takes a body off the
801 linked list at PL_body_roots[sv_type], calling S_more_bodies() if
802 necessary to refresh an empty list. Then the lock is released, and
803 the body is returned.
805 S_more_bodies calls get_arena(), and carves it up into an array of N
806 bodies, which it strings into a linked list. It looks up arena-size
807 and body-size from the body_details table described below, thus
808 supporting the multiple body-types.
810 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
811 the (new|del)_X*V macros are mapped directly to malloc/free.
817 For each sv-type, struct body_details bodies_by_type[] carries
818 parameters which control these aspects of SV handling:
820 Arena_size determines whether arenas are used for this body type, and if
821 so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
822 zero, forcing individual mallocs and frees.
824 Body_size determines how big a body is, and therefore how many fit into
825 each arena. Offset carries the body-pointer adjustment needed for
826 *_allocated body types, and is used in *_allocated macros.
828 But its main purpose is to parameterize info needed in
829 Perl_sv_upgrade(). The info here dramatically simplifies the function
830 vs the implementation in 5.8.7, making it table-driven. All fields
831 are used for this, except for arena_size.
833 For the sv-types that have no bodies, arenas are not used, so those
834 PL_body_roots[sv_type] are unused, and can be overloaded. In
835 something of a special case, SVt_NULL is borrowed for HE arenas;
836 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
837 bodies_by_type[SVt_NULL] slot is not used, as the table is not
840 PTEs also use arenas, but are never seen in Perl_sv_upgrade. Nonetheless,
841 they get their own slot in bodies_by_type[PTE_SVSLOT =SVt_IV], so they can
842 just use the same allocation semantics. At first, PTEs were also
843 overloaded to a non-body sv-type, but this yielded hard-to-find malloc
844 bugs, so was simplified by claiming a new slot. This choice has no
845 consequence at this time.
849 struct body_details {
850 U8 body_size; /* Size to allocate */
851 U8 copy; /* Size of structure to copy (may be shorter) */
853 unsigned int type : 4; /* We have space for a sanity check. */
854 unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
855 unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
856 unsigned int arena : 1; /* Allocated from an arena */
857 size_t arena_size; /* Size of arena to allocate */
865 /* With -DPURFIY we allocate everything directly, and don't use arenas.
866 This seems a rather elegant way to simplify some of the code below. */
867 #define HASARENA FALSE
869 #define HASARENA TRUE
871 #define NOARENA FALSE
873 /* Size the arenas to exactly fit a given number of bodies. A count
874 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
875 simplifying the default. If count > 0, the arena is sized to fit
876 only that many bodies, allowing arenas to be used for large, rare
877 bodies (XPVFM, XPVIO) without undue waste. The arena size is
878 limited by PERL_ARENA_SIZE, so we can safely oversize the
881 #define FIT_ARENA0(body_size) \
882 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
883 #define FIT_ARENAn(count,body_size) \
884 ( count * body_size <= PERL_ARENA_SIZE) \
885 ? count * body_size \
886 : FIT_ARENA0 (body_size)
887 #define FIT_ARENA(count,body_size) \
889 ? FIT_ARENAn (count, body_size) \
890 : FIT_ARENA0 (body_size)
892 /* A macro to work out the offset needed to subtract from a pointer to (say)
899 to make its members accessible via a pointer to (say)
909 #define relative_STRUCT_OFFSET(longer, shorter, member) \
910 (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member))
912 /* Calculate the length to copy. Specifically work out the length less any
913 final padding the compiler needed to add. See the comment in sv_upgrade
914 for why copying the padding proved to be a bug. */
916 #define copy_length(type, last_member) \
917 STRUCT_OFFSET(type, last_member) \
918 + sizeof (((type*)SvANY((SV*)0))->last_member)
920 static const struct body_details bodies_by_type[] = {
921 { sizeof(HE), 0, 0, SVt_NULL,
922 FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
924 /* The bind placeholder pretends to be an RV for now.
925 Also it's marked as "can't upgrade" to stop anyone using it before it's
927 { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
929 /* IVs are in the head, so the allocation size is 0.
930 However, the slot is overloaded for PTEs. */
931 { sizeof(struct ptr_tbl_ent), /* This is used for PTEs. */
932 sizeof(IV), /* This is used to copy out the IV body. */
933 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
934 NOARENA /* IVS don't need an arena */,
935 /* But PTEs need to know the size of their arena */
936 FIT_ARENA(0, sizeof(struct ptr_tbl_ent))
939 /* 8 bytes on most ILP32 with IEEE doubles */
940 { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA,
941 FIT_ARENA(0, sizeof(NV)) },
943 /* 8 bytes on most ILP32 with IEEE doubles */
944 { sizeof(xpv_allocated),
945 copy_length(XPV, xpv_len)
946 - relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
947 + relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
948 SVt_PV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpv_allocated)) },
951 { sizeof(xpviv_allocated),
952 copy_length(XPVIV, xiv_u)
953 - relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
954 + relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
955 SVt_PVIV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpviv_allocated)) },
958 { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, SVt_PVNV, FALSE, HADNV,
959 HASARENA, FIT_ARENA(0, sizeof(XPVNV)) },
962 { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
963 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
966 { sizeof(struct regexp_allocated), sizeof(struct regexp_allocated),
967 + relative_STRUCT_OFFSET(struct regexp_allocated, regexp, xpv_cur),
968 SVt_REGEXP, FALSE, NONV, HASARENA,
969 FIT_ARENA(0, sizeof(struct regexp_allocated))
973 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
974 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
977 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
978 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
980 { sizeof(xpvav_allocated),
981 copy_length(XPVAV, xmg_stash)
982 - relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
983 + relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
984 SVt_PVAV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) },
986 { sizeof(xpvhv_allocated),
987 copy_length(XPVHV, xmg_stash)
988 - relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
989 + relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
990 SVt_PVHV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) },
993 { sizeof(xpvcv_allocated), sizeof(xpvcv_allocated),
994 + relative_STRUCT_OFFSET(xpvcv_allocated, XPVCV, xpv_cur),
995 SVt_PVCV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvcv_allocated)) },
997 { sizeof(xpvfm_allocated), sizeof(xpvfm_allocated),
998 + relative_STRUCT_OFFSET(xpvfm_allocated, XPVFM, xpv_cur),
999 SVt_PVFM, TRUE, NONV, NOARENA, FIT_ARENA(20, sizeof(xpvfm_allocated)) },
1001 /* XPVIO is 84 bytes, fits 48x */
1002 { sizeof(xpvio_allocated), sizeof(xpvio_allocated),
1003 + relative_STRUCT_OFFSET(xpvio_allocated, XPVIO, xpv_cur),
1004 SVt_PVIO, TRUE, NONV, HASARENA, FIT_ARENA(24, sizeof(xpvio_allocated)) },
1007 #define new_body_type(sv_type) \
1008 (void *)((char *)S_new_body(aTHX_ sv_type))
1010 #define del_body_type(p, sv_type) \
1011 del_body(p, &PL_body_roots[sv_type])
1014 #define new_body_allocated(sv_type) \
1015 (void *)((char *)S_new_body(aTHX_ sv_type) \
1016 - bodies_by_type[sv_type].offset)
1018 #define del_body_allocated(p, sv_type) \
1019 del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
1022 #define my_safemalloc(s) (void*)safemalloc(s)
1023 #define my_safecalloc(s) (void*)safecalloc(s, 1)
1024 #define my_safefree(p) safefree((char*)p)
1028 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1029 #define del_XNV(p) my_safefree(p)
1031 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1032 #define del_XPVNV(p) my_safefree(p)
1034 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1035 #define del_XPVAV(p) my_safefree(p)
1037 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1038 #define del_XPVHV(p) my_safefree(p)
1040 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1041 #define del_XPVMG(p) my_safefree(p)
1043 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1044 #define del_XPVGV(p) my_safefree(p)
1048 #define new_XNV() new_body_type(SVt_NV)
1049 #define del_XNV(p) del_body_type(p, SVt_NV)
1051 #define new_XPVNV() new_body_type(SVt_PVNV)
1052 #define del_XPVNV(p) del_body_type(p, SVt_PVNV)
1054 #define new_XPVAV() new_body_allocated(SVt_PVAV)
1055 #define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
1057 #define new_XPVHV() new_body_allocated(SVt_PVHV)
1058 #define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
1060 #define new_XPVMG() new_body_type(SVt_PVMG)
1061 #define del_XPVMG(p) del_body_type(p, SVt_PVMG)
1063 #define new_XPVGV() new_body_type(SVt_PVGV)
1064 #define del_XPVGV(p) del_body_type(p, SVt_PVGV)
1068 /* no arena for you! */
1070 #define new_NOARENA(details) \
1071 my_safemalloc((details)->body_size + (details)->offset)
1072 #define new_NOARENAZ(details) \
1073 my_safecalloc((details)->body_size + (details)->offset)
1076 S_more_bodies (pTHX_ const svtype sv_type)
1079 void ** const root = &PL_body_roots[sv_type];
1080 const struct body_details * const bdp = &bodies_by_type[sv_type];
1081 const size_t body_size = bdp->body_size;
1084 const size_t arena_size = Perl_malloc_good_size(bdp->arena_size);
1085 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1086 static bool done_sanity_check;
1088 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1089 * variables like done_sanity_check. */
1090 if (!done_sanity_check) {
1091 unsigned int i = SVt_LAST;
1093 done_sanity_check = TRUE;
1096 assert (bodies_by_type[i].type == i);
1100 assert(bdp->arena_size);
1102 start = (char*) Perl_get_arena(aTHX_ arena_size, sv_type);
1104 end = start + arena_size - 2 * body_size;
1106 /* computed count doesnt reflect the 1st slot reservation */
1107 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1108 DEBUG_m(PerlIO_printf(Perl_debug_log,
1109 "arena %p end %p arena-size %d (from %d) type %d "
1111 (void*)start, (void*)end, (int)arena_size,
1112 (int)bdp->arena_size, sv_type, (int)body_size,
1113 (int)arena_size / (int)body_size));
1115 DEBUG_m(PerlIO_printf(Perl_debug_log,
1116 "arena %p end %p arena-size %d type %d size %d ct %d\n",
1117 (void*)start, (void*)end,
1118 (int)bdp->arena_size, sv_type, (int)body_size,
1119 (int)bdp->arena_size / (int)body_size));
1121 *root = (void *)start;
1123 while (start <= end) {
1124 char * const next = start + body_size;
1125 *(void**) start = (void *)next;
1128 *(void **)start = 0;
1133 /* grab a new thing from the free list, allocating more if necessary.
1134 The inline version is used for speed in hot routines, and the
1135 function using it serves the rest (unless PURIFY).
1137 #define new_body_inline(xpv, sv_type) \
1139 void ** const r3wt = &PL_body_roots[sv_type]; \
1140 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
1141 ? *((void **)(r3wt)) : more_bodies(sv_type)); \
1142 *(r3wt) = *(void**)(xpv); \
1148 S_new_body(pTHX_ const svtype sv_type)
1152 new_body_inline(xpv, sv_type);
1158 static const struct body_details fake_rv =
1159 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1162 =for apidoc sv_upgrade
1164 Upgrade an SV to a more complex form. Generally adds a new body type to the
1165 SV, then copies across as much information as possible from the old body.
1166 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1172 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1177 const svtype old_type = SvTYPE(sv);
1178 const struct body_details *new_type_details;
1179 const struct body_details *old_type_details
1180 = bodies_by_type + old_type;
1181 SV *referant = NULL;
1183 PERL_ARGS_ASSERT_SV_UPGRADE;
1185 if (new_type != SVt_PV && SvIsCOW(sv)) {
1186 sv_force_normal_flags(sv, 0);
1189 if (old_type == new_type)
1192 old_body = SvANY(sv);
1194 /* Copying structures onto other structures that have been neatly zeroed
1195 has a subtle gotcha. Consider XPVMG
1197 +------+------+------+------+------+-------+-------+
1198 | NV | CUR | LEN | IV | MAGIC | STASH |
1199 +------+------+------+------+------+-------+-------+
1200 0 4 8 12 16 20 24 28
1202 where NVs are aligned to 8 bytes, so that sizeof that structure is
1203 actually 32 bytes long, with 4 bytes of padding at the end:
1205 +------+------+------+------+------+-------+-------+------+
1206 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1207 +------+------+------+------+------+-------+-------+------+
1208 0 4 8 12 16 20 24 28 32
1210 so what happens if you allocate memory for this structure:
1212 +------+------+------+------+------+-------+-------+------+------+...
1213 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1214 +------+------+------+------+------+-------+-------+------+------+...
1215 0 4 8 12 16 20 24 28 32 36
1217 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1218 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1219 started out as zero once, but it's quite possible that it isn't. So now,
1220 rather than a nicely zeroed GP, you have it pointing somewhere random.
1223 (In fact, GP ends up pointing at a previous GP structure, because the
1224 principle cause of the padding in XPVMG getting garbage is a copy of
1225 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1226 this happens to be moot because XPVGV has been re-ordered, with GP
1227 no longer after STASH)
1229 So we are careful and work out the size of used parts of all the
1237 referant = SvRV(sv);
1238 old_type_details = &fake_rv;
1239 if (new_type == SVt_NV)
1240 new_type = SVt_PVNV;
1242 if (new_type < SVt_PVIV) {
1243 new_type = (new_type == SVt_NV)
1244 ? SVt_PVNV : SVt_PVIV;
1249 if (new_type < SVt_PVNV) {
1250 new_type = SVt_PVNV;
1254 assert(new_type > SVt_PV);
1255 assert(SVt_IV < SVt_PV);
1256 assert(SVt_NV < SVt_PV);
1263 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1264 there's no way that it can be safely upgraded, because perl.c
1265 expects to Safefree(SvANY(PL_mess_sv)) */
1266 assert(sv != PL_mess_sv);
1267 /* This flag bit is used to mean other things in other scalar types.
1268 Given that it only has meaning inside the pad, it shouldn't be set
1269 on anything that can get upgraded. */
1270 assert(!SvPAD_TYPED(sv));
1273 if (old_type_details->cant_upgrade)
1274 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1275 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1278 if (old_type > new_type)
1279 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1280 (int)old_type, (int)new_type);
1282 new_type_details = bodies_by_type + new_type;
1284 SvFLAGS(sv) &= ~SVTYPEMASK;
1285 SvFLAGS(sv) |= new_type;
1287 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1288 the return statements above will have triggered. */
1289 assert (new_type != SVt_NULL);
1292 assert(old_type == SVt_NULL);
1293 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1297 assert(old_type == SVt_NULL);
1298 SvANY(sv) = new_XNV();
1303 assert(new_type_details->body_size);
1306 assert(new_type_details->arena);
1307 assert(new_type_details->arena_size);
1308 /* This points to the start of the allocated area. */
1309 new_body_inline(new_body, new_type);
1310 Zero(new_body, new_type_details->body_size, char);
1311 new_body = ((char *)new_body) - new_type_details->offset;
1313 /* We always allocated the full length item with PURIFY. To do this
1314 we fake things so that arena is false for all 16 types.. */
1315 new_body = new_NOARENAZ(new_type_details);
1317 SvANY(sv) = new_body;
1318 if (new_type == SVt_PVAV) {
1322 if (old_type_details->body_size) {
1325 /* It will have been zeroed when the new body was allocated.
1326 Lets not write to it, in case it confuses a write-back
1332 #ifndef NODEFAULT_SHAREKEYS
1333 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1335 HvMAX(sv) = 7; /* (start with 8 buckets) */
1336 if (old_type_details->body_size) {
1339 /* It will have been zeroed when the new body was allocated.
1340 Lets not write to it, in case it confuses a write-back
1345 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1346 The target created by newSVrv also is, and it can have magic.
1347 However, it never has SvPVX set.
1349 if (old_type == SVt_IV) {
1351 } else if (old_type >= SVt_PV) {
1352 assert(SvPVX_const(sv) == 0);
1355 if (old_type >= SVt_PVMG) {
1356 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1357 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1359 sv->sv_u.svu_array = NULL; /* or svu_hash */
1365 /* XXX Is this still needed? Was it ever needed? Surely as there is
1366 no route from NV to PVIV, NOK can never be true */
1367 assert(!SvNOKp(sv));
1379 assert(new_type_details->body_size);
1380 /* We always allocated the full length item with PURIFY. To do this
1381 we fake things so that arena is false for all 16 types.. */
1382 if(new_type_details->arena) {
1383 /* This points to the start of the allocated area. */
1384 new_body_inline(new_body, new_type);
1385 Zero(new_body, new_type_details->body_size, char);
1386 new_body = ((char *)new_body) - new_type_details->offset;
1388 new_body = new_NOARENAZ(new_type_details);
1390 SvANY(sv) = new_body;
1392 if (old_type_details->copy) {
1393 /* There is now the potential for an upgrade from something without
1394 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1395 int offset = old_type_details->offset;
1396 int length = old_type_details->copy;
1398 if (new_type_details->offset > old_type_details->offset) {
1399 const int difference
1400 = new_type_details->offset - old_type_details->offset;
1401 offset += difference;
1402 length -= difference;
1404 assert (length >= 0);
1406 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1410 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1411 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1412 * correct 0.0 for us. Otherwise, if the old body didn't have an
1413 * NV slot, but the new one does, then we need to initialise the
1414 * freshly created NV slot with whatever the correct bit pattern is
1416 if (old_type_details->zero_nv && !new_type_details->zero_nv
1417 && !isGV_with_GP(sv))
1421 if (new_type == SVt_PVIO)
1422 IoPAGE_LEN(sv) = 60;
1423 if (old_type < SVt_PV) {
1424 /* referant will be NULL unless the old type was SVt_IV emulating
1426 sv->sv_u.svu_rv = referant;
1430 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1431 (unsigned long)new_type);
1434 if (old_type_details->arena) {
1435 /* If there was an old body, then we need to free it.
1436 Note that there is an assumption that all bodies of types that
1437 can be upgraded came from arenas. Only the more complex non-
1438 upgradable types are allowed to be directly malloc()ed. */
1440 my_safefree(old_body);
1442 del_body((void*)((char*)old_body + old_type_details->offset),
1443 &PL_body_roots[old_type]);
1449 =for apidoc sv_backoff
1451 Remove any string offset. You should normally use the C<SvOOK_off> macro
1458 Perl_sv_backoff(pTHX_ register SV *const sv)
1461 const char * const s = SvPVX_const(sv);
1463 PERL_ARGS_ASSERT_SV_BACKOFF;
1464 PERL_UNUSED_CONTEXT;
1467 assert(SvTYPE(sv) != SVt_PVHV);
1468 assert(SvTYPE(sv) != SVt_PVAV);
1470 SvOOK_offset(sv, delta);
1472 SvLEN_set(sv, SvLEN(sv) + delta);
1473 SvPV_set(sv, SvPVX(sv) - delta);
1474 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1475 SvFLAGS(sv) &= ~SVf_OOK;
1482 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1483 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1484 Use the C<SvGROW> wrapper instead.
1490 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1494 PERL_ARGS_ASSERT_SV_GROW;
1496 if (PL_madskills && newlen >= 0x100000) {
1497 PerlIO_printf(Perl_debug_log,
1498 "Allocation too large: %"UVxf"\n", (UV)newlen);
1500 #ifdef HAS_64K_LIMIT
1501 if (newlen >= 0x10000) {
1502 PerlIO_printf(Perl_debug_log,
1503 "Allocation too large: %"UVxf"\n", (UV)newlen);
1506 #endif /* HAS_64K_LIMIT */
1509 if (SvTYPE(sv) < SVt_PV) {
1510 sv_upgrade(sv, SVt_PV);
1511 s = SvPVX_mutable(sv);
1513 else if (SvOOK(sv)) { /* pv is offset? */
1515 s = SvPVX_mutable(sv);
1516 if (newlen > SvLEN(sv))
1517 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1518 #ifdef HAS_64K_LIMIT
1519 if (newlen >= 0x10000)
1524 s = SvPVX_mutable(sv);
1526 if (newlen > SvLEN(sv)) { /* need more room? */
1527 #ifndef Perl_safesysmalloc_size
1528 newlen = PERL_STRLEN_ROUNDUP(newlen);
1530 if (SvLEN(sv) && s) {
1531 s = (char*)saferealloc(s, newlen);
1534 s = (char*)safemalloc(newlen);
1535 if (SvPVX_const(sv) && SvCUR(sv)) {
1536 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1540 #ifdef Perl_safesysmalloc_size
1541 /* Do this here, do it once, do it right, and then we will never get
1542 called back into sv_grow() unless there really is some growing
1544 SvLEN_set(sv, Perl_safesysmalloc_size(s));
1546 SvLEN_set(sv, newlen);
1553 =for apidoc sv_setiv
1555 Copies an integer into the given SV, upgrading first if necessary.
1556 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1562 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1566 PERL_ARGS_ASSERT_SV_SETIV;
1568 SV_CHECK_THINKFIRST_COW_DROP(sv);
1569 switch (SvTYPE(sv)) {
1572 sv_upgrade(sv, SVt_IV);
1575 sv_upgrade(sv, SVt_PVIV);
1579 if (!isGV_with_GP(sv))
1586 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1590 (void)SvIOK_only(sv); /* validate number */
1596 =for apidoc sv_setiv_mg
1598 Like C<sv_setiv>, but also handles 'set' magic.
1604 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1606 PERL_ARGS_ASSERT_SV_SETIV_MG;
1613 =for apidoc sv_setuv
1615 Copies an unsigned integer into the given SV, upgrading first if necessary.
1616 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1622 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1624 PERL_ARGS_ASSERT_SV_SETUV;
1626 /* With these two if statements:
1627 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1630 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1632 If you wish to remove them, please benchmark to see what the effect is
1634 if (u <= (UV)IV_MAX) {
1635 sv_setiv(sv, (IV)u);
1644 =for apidoc sv_setuv_mg
1646 Like C<sv_setuv>, but also handles 'set' magic.
1652 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1654 PERL_ARGS_ASSERT_SV_SETUV_MG;
1661 =for apidoc sv_setnv
1663 Copies a double into the given SV, upgrading first if necessary.
1664 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1670 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1674 PERL_ARGS_ASSERT_SV_SETNV;
1676 SV_CHECK_THINKFIRST_COW_DROP(sv);
1677 switch (SvTYPE(sv)) {
1680 sv_upgrade(sv, SVt_NV);
1684 sv_upgrade(sv, SVt_PVNV);
1688 if (!isGV_with_GP(sv))
1695 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1700 (void)SvNOK_only(sv); /* validate number */
1705 =for apidoc sv_setnv_mg
1707 Like C<sv_setnv>, but also handles 'set' magic.
1713 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1715 PERL_ARGS_ASSERT_SV_SETNV_MG;
1721 /* Print an "isn't numeric" warning, using a cleaned-up,
1722 * printable version of the offending string
1726 S_not_a_number(pTHX_ SV *const sv)
1733 PERL_ARGS_ASSERT_NOT_A_NUMBER;
1736 dsv = newSVpvs_flags("", SVs_TEMP);
1737 pv = sv_uni_display(dsv, sv, 10, 0);
1740 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1741 /* each *s can expand to 4 chars + "...\0",
1742 i.e. need room for 8 chars */
1744 const char *s = SvPVX_const(sv);
1745 const char * const end = s + SvCUR(sv);
1746 for ( ; s < end && d < limit; s++ ) {
1748 if (ch & 128 && !isPRINT_LC(ch)) {
1757 else if (ch == '\r') {
1761 else if (ch == '\f') {
1765 else if (ch == '\\') {
1769 else if (ch == '\0') {
1773 else if (isPRINT_LC(ch))
1790 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1791 "Argument \"%s\" isn't numeric in %s", pv,
1794 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1795 "Argument \"%s\" isn't numeric", pv);
1799 =for apidoc looks_like_number
1801 Test if the content of an SV looks like a number (or is a number).
1802 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1803 non-numeric warning), even if your atof() doesn't grok them.
1809 Perl_looks_like_number(pTHX_ SV *const sv)
1811 register const char *sbegin;
1814 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1817 sbegin = SvPVX_const(sv);
1820 else if (SvPOKp(sv))
1821 sbegin = SvPV_const(sv, len);
1823 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1824 return grok_number(sbegin, len, NULL);
1828 S_glob_2number(pTHX_ GV * const gv)
1830 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1831 SV *const buffer = sv_newmortal();
1833 PERL_ARGS_ASSERT_GLOB_2NUMBER;
1835 /* FAKE globs can get coerced, so need to turn this off temporarily if it
1838 gv_efullname3(buffer, gv, "*");
1839 SvFLAGS(gv) |= wasfake;
1841 /* We know that all GVs stringify to something that is not-a-number,
1842 so no need to test that. */
1843 if (ckWARN(WARN_NUMERIC))
1844 not_a_number(buffer);
1845 /* We just want something true to return, so that S_sv_2iuv_common
1846 can tail call us and return true. */
1851 S_glob_2pv(pTHX_ GV * const gv, STRLEN * const len)
1853 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1854 SV *const buffer = sv_newmortal();
1856 PERL_ARGS_ASSERT_GLOB_2PV;
1858 /* FAKE globs can get coerced, so need to turn this off temporarily if it
1861 gv_efullname3(buffer, gv, "*");
1862 SvFLAGS(gv) |= wasfake;
1864 assert(SvPOK(buffer));
1866 *len = SvCUR(buffer);
1868 return SvPVX(buffer);
1871 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1872 until proven guilty, assume that things are not that bad... */
1877 As 64 bit platforms often have an NV that doesn't preserve all bits of
1878 an IV (an assumption perl has been based on to date) it becomes necessary
1879 to remove the assumption that the NV always carries enough precision to
1880 recreate the IV whenever needed, and that the NV is the canonical form.
1881 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1882 precision as a side effect of conversion (which would lead to insanity
1883 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1884 1) to distinguish between IV/UV/NV slots that have cached a valid
1885 conversion where precision was lost and IV/UV/NV slots that have a
1886 valid conversion which has lost no precision
1887 2) to ensure that if a numeric conversion to one form is requested that
1888 would lose precision, the precise conversion (or differently
1889 imprecise conversion) is also performed and cached, to prevent
1890 requests for different numeric formats on the same SV causing
1891 lossy conversion chains. (lossless conversion chains are perfectly
1896 SvIOKp is true if the IV slot contains a valid value
1897 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1898 SvNOKp is true if the NV slot contains a valid value
1899 SvNOK is true only if the NV value is accurate
1902 while converting from PV to NV, check to see if converting that NV to an
1903 IV(or UV) would lose accuracy over a direct conversion from PV to
1904 IV(or UV). If it would, cache both conversions, return NV, but mark
1905 SV as IOK NOKp (ie not NOK).
1907 While converting from PV to IV, check to see if converting that IV to an
1908 NV would lose accuracy over a direct conversion from PV to NV. If it
1909 would, cache both conversions, flag similarly.
1911 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1912 correctly because if IV & NV were set NV *always* overruled.
1913 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1914 changes - now IV and NV together means that the two are interchangeable:
1915 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1917 The benefit of this is that operations such as pp_add know that if
1918 SvIOK is true for both left and right operands, then integer addition
1919 can be used instead of floating point (for cases where the result won't
1920 overflow). Before, floating point was always used, which could lead to
1921 loss of precision compared with integer addition.
1923 * making IV and NV equal status should make maths accurate on 64 bit
1925 * may speed up maths somewhat if pp_add and friends start to use
1926 integers when possible instead of fp. (Hopefully the overhead in
1927 looking for SvIOK and checking for overflow will not outweigh the
1928 fp to integer speedup)
1929 * will slow down integer operations (callers of SvIV) on "inaccurate"
1930 values, as the change from SvIOK to SvIOKp will cause a call into
1931 sv_2iv each time rather than a macro access direct to the IV slot
1932 * should speed up number->string conversion on integers as IV is
1933 favoured when IV and NV are equally accurate
1935 ####################################################################
1936 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1937 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1938 On the other hand, SvUOK is true iff UV.
1939 ####################################################################
1941 Your mileage will vary depending your CPU's relative fp to integer
1945 #ifndef NV_PRESERVES_UV
1946 # define IS_NUMBER_UNDERFLOW_IV 1
1947 # define IS_NUMBER_UNDERFLOW_UV 2
1948 # define IS_NUMBER_IV_AND_UV 2
1949 # define IS_NUMBER_OVERFLOW_IV 4
1950 # define IS_NUMBER_OVERFLOW_UV 5
1952 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1954 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1956 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1964 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1966 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));
1967 if (SvNVX(sv) < (NV)IV_MIN) {
1968 (void)SvIOKp_on(sv);
1970 SvIV_set(sv, IV_MIN);
1971 return IS_NUMBER_UNDERFLOW_IV;
1973 if (SvNVX(sv) > (NV)UV_MAX) {
1974 (void)SvIOKp_on(sv);
1977 SvUV_set(sv, UV_MAX);
1978 return IS_NUMBER_OVERFLOW_UV;
1980 (void)SvIOKp_on(sv);
1982 /* Can't use strtol etc to convert this string. (See truth table in
1984 if (SvNVX(sv) <= (UV)IV_MAX) {
1985 SvIV_set(sv, I_V(SvNVX(sv)));
1986 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1987 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1989 /* Integer is imprecise. NOK, IOKp */
1991 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1994 SvUV_set(sv, U_V(SvNVX(sv)));
1995 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1996 if (SvUVX(sv) == UV_MAX) {
1997 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1998 possibly be preserved by NV. Hence, it must be overflow.
2000 return IS_NUMBER_OVERFLOW_UV;
2002 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2004 /* Integer is imprecise. NOK, IOKp */
2006 return IS_NUMBER_OVERFLOW_IV;
2008 #endif /* !NV_PRESERVES_UV*/
2011 S_sv_2iuv_common(pTHX_ SV *const sv)
2015 PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2018 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2019 * without also getting a cached IV/UV from it at the same time
2020 * (ie PV->NV conversion should detect loss of accuracy and cache
2021 * IV or UV at same time to avoid this. */
2022 /* IV-over-UV optimisation - choose to cache IV if possible */
2024 if (SvTYPE(sv) == SVt_NV)
2025 sv_upgrade(sv, SVt_PVNV);
2027 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2028 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2029 certainly cast into the IV range at IV_MAX, whereas the correct
2030 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2032 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2033 if (Perl_isnan(SvNVX(sv))) {
2039 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2040 SvIV_set(sv, I_V(SvNVX(sv)));
2041 if (SvNVX(sv) == (NV) SvIVX(sv)
2042 #ifndef NV_PRESERVES_UV
2043 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2044 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2045 /* Don't flag it as "accurately an integer" if the number
2046 came from a (by definition imprecise) NV operation, and
2047 we're outside the range of NV integer precision */
2051 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2053 /* scalar has trailing garbage, eg "42a" */
2055 DEBUG_c(PerlIO_printf(Perl_debug_log,
2056 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2062 /* IV not precise. No need to convert from PV, as NV
2063 conversion would already have cached IV if it detected
2064 that PV->IV would be better than PV->NV->IV
2065 flags already correct - don't set public IOK. */
2066 DEBUG_c(PerlIO_printf(Perl_debug_log,
2067 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2072 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2073 but the cast (NV)IV_MIN rounds to a the value less (more
2074 negative) than IV_MIN which happens to be equal to SvNVX ??
2075 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2076 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2077 (NV)UVX == NVX are both true, but the values differ. :-(
2078 Hopefully for 2s complement IV_MIN is something like
2079 0x8000000000000000 which will be exact. NWC */
2082 SvUV_set(sv, U_V(SvNVX(sv)));
2084 (SvNVX(sv) == (NV) SvUVX(sv))
2085 #ifndef NV_PRESERVES_UV
2086 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2087 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2088 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2089 /* Don't flag it as "accurately an integer" if the number
2090 came from a (by definition imprecise) NV operation, and
2091 we're outside the range of NV integer precision */
2097 DEBUG_c(PerlIO_printf(Perl_debug_log,
2098 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2104 else if (SvPOKp(sv) && SvLEN(sv)) {
2106 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2107 /* We want to avoid a possible problem when we cache an IV/ a UV which
2108 may be later translated to an NV, and the resulting NV is not
2109 the same as the direct translation of the initial string
2110 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2111 be careful to ensure that the value with the .456 is around if the
2112 NV value is requested in the future).
2114 This means that if we cache such an IV/a UV, we need to cache the
2115 NV as well. Moreover, we trade speed for space, and do not
2116 cache the NV if we are sure it's not needed.
2119 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2120 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2121 == IS_NUMBER_IN_UV) {
2122 /* It's definitely an integer, only upgrade to PVIV */
2123 if (SvTYPE(sv) < SVt_PVIV)
2124 sv_upgrade(sv, SVt_PVIV);
2126 } else if (SvTYPE(sv) < SVt_PVNV)
2127 sv_upgrade(sv, SVt_PVNV);
2129 /* If NVs preserve UVs then we only use the UV value if we know that
2130 we aren't going to call atof() below. If NVs don't preserve UVs
2131 then the value returned may have more precision than atof() will
2132 return, even though value isn't perfectly accurate. */
2133 if ((numtype & (IS_NUMBER_IN_UV
2134 #ifdef NV_PRESERVES_UV
2137 )) == IS_NUMBER_IN_UV) {
2138 /* This won't turn off the public IOK flag if it was set above */
2139 (void)SvIOKp_on(sv);
2141 if (!(numtype & IS_NUMBER_NEG)) {
2143 if (value <= (UV)IV_MAX) {
2144 SvIV_set(sv, (IV)value);
2146 /* it didn't overflow, and it was positive. */
2147 SvUV_set(sv, value);
2151 /* 2s complement assumption */
2152 if (value <= (UV)IV_MIN) {
2153 SvIV_set(sv, -(IV)value);
2155 /* Too negative for an IV. This is a double upgrade, but
2156 I'm assuming it will be rare. */
2157 if (SvTYPE(sv) < SVt_PVNV)
2158 sv_upgrade(sv, SVt_PVNV);
2162 SvNV_set(sv, -(NV)value);
2163 SvIV_set(sv, IV_MIN);
2167 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2168 will be in the previous block to set the IV slot, and the next
2169 block to set the NV slot. So no else here. */
2171 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2172 != IS_NUMBER_IN_UV) {
2173 /* It wasn't an (integer that doesn't overflow the UV). */
2174 SvNV_set(sv, Atof(SvPVX_const(sv)));
2176 if (! numtype && ckWARN(WARN_NUMERIC))
2179 #if defined(USE_LONG_DOUBLE)
2180 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2181 PTR2UV(sv), SvNVX(sv)));
2183 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2184 PTR2UV(sv), SvNVX(sv)));
2187 #ifdef NV_PRESERVES_UV
2188 (void)SvIOKp_on(sv);
2190 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2191 SvIV_set(sv, I_V(SvNVX(sv)));
2192 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2195 NOOP; /* Integer is imprecise. NOK, IOKp */
2197 /* UV will not work better than IV */
2199 if (SvNVX(sv) > (NV)UV_MAX) {
2201 /* Integer is inaccurate. NOK, IOKp, is UV */
2202 SvUV_set(sv, UV_MAX);
2204 SvUV_set(sv, U_V(SvNVX(sv)));
2205 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2206 NV preservse UV so can do correct comparison. */
2207 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2210 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
2215 #else /* NV_PRESERVES_UV */
2216 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2217 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2218 /* The IV/UV slot will have been set from value returned by
2219 grok_number above. The NV slot has just been set using
2222 assert (SvIOKp(sv));
2224 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2225 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2226 /* Small enough to preserve all bits. */
2227 (void)SvIOKp_on(sv);
2229 SvIV_set(sv, I_V(SvNVX(sv)));
2230 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2232 /* Assumption: first non-preserved integer is < IV_MAX,
2233 this NV is in the preserved range, therefore: */
2234 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2236 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);
2240 0 0 already failed to read UV.
2241 0 1 already failed to read UV.
2242 1 0 you won't get here in this case. IV/UV
2243 slot set, public IOK, Atof() unneeded.
2244 1 1 already read UV.
2245 so there's no point in sv_2iuv_non_preserve() attempting
2246 to use atol, strtol, strtoul etc. */
2248 sv_2iuv_non_preserve (sv, numtype);
2250 sv_2iuv_non_preserve (sv);
2254 #endif /* NV_PRESERVES_UV */
2255 /* It might be more code efficient to go through the entire logic above
2256 and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2257 gets complex and potentially buggy, so more programmer efficient
2258 to do it this way, by turning off the public flags: */
2260 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2264 if (isGV_with_GP(sv))
2265 return glob_2number((GV *)sv);
2267 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2268 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2271 if (SvTYPE(sv) < SVt_IV)
2272 /* Typically the caller expects that sv_any is not NULL now. */
2273 sv_upgrade(sv, SVt_IV);
2274 /* Return 0 from the caller. */
2281 =for apidoc sv_2iv_flags
2283 Return the integer value of an SV, doing any necessary string
2284 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2285 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2291 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2296 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2297 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2298 cache IVs just in case. In practice it seems that they never
2299 actually anywhere accessible by user Perl code, let alone get used
2300 in anything other than a string context. */
2301 if (flags & SV_GMAGIC)
2306 return I_V(SvNVX(sv));
2308 if (SvPOKp(sv) && SvLEN(sv)) {
2311 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2313 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2314 == IS_NUMBER_IN_UV) {
2315 /* It's definitely an integer */
2316 if (numtype & IS_NUMBER_NEG) {
2317 if (value < (UV)IV_MIN)
2320 if (value < (UV)IV_MAX)
2325 if (ckWARN(WARN_NUMERIC))
2328 return I_V(Atof(SvPVX_const(sv)));
2333 assert(SvTYPE(sv) >= SVt_PVMG);
2334 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2335 } else if (SvTHINKFIRST(sv)) {
2339 SV * const tmpstr=AMG_CALLun(sv,numer);
2340 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2341 return SvIV(tmpstr);
2344 return PTR2IV(SvRV(sv));
2347 sv_force_normal_flags(sv, 0);
2349 if (SvREADONLY(sv) && !SvOK(sv)) {
2350 if (ckWARN(WARN_UNINITIALIZED))
2356 if (S_sv_2iuv_common(aTHX_ sv))
2359 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2360 PTR2UV(sv),SvIVX(sv)));
2361 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2365 =for apidoc sv_2uv_flags
2367 Return the unsigned integer value of an SV, doing any necessary string
2368 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2369 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2375 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2380 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2381 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2382 cache IVs just in case. */
2383 if (flags & SV_GMAGIC)
2388 return U_V(SvNVX(sv));
2389 if (SvPOKp(sv) && SvLEN(sv)) {
2392 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2394 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2395 == IS_NUMBER_IN_UV) {
2396 /* It's definitely an integer */
2397 if (!(numtype & IS_NUMBER_NEG))
2401 if (ckWARN(WARN_NUMERIC))
2404 return U_V(Atof(SvPVX_const(sv)));
2409 assert(SvTYPE(sv) >= SVt_PVMG);
2410 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
2411 } else if (SvTHINKFIRST(sv)) {
2415 SV *const tmpstr = AMG_CALLun(sv,numer);
2416 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2417 return SvUV(tmpstr);
2420 return PTR2UV(SvRV(sv));
2423 sv_force_normal_flags(sv, 0);
2425 if (SvREADONLY(sv) && !SvOK(sv)) {
2426 if (ckWARN(WARN_UNINITIALIZED))
2432 if (S_sv_2iuv_common(aTHX_ sv))
2436 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2437 PTR2UV(sv),SvUVX(sv)));
2438 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2444 Return the num value of an SV, doing any necessary string or integer
2445 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2452 Perl_sv_2nv(pTHX_ register SV *const sv)
2457 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2458 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2459 cache IVs just in case. */
2463 if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2464 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2465 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2467 return Atof(SvPVX_const(sv));
2471 return (NV)SvUVX(sv);
2473 return (NV)SvIVX(sv);
2478 assert(SvTYPE(sv) >= SVt_PVMG);
2479 /* This falls through to the report_uninit near the end of the
2481 } else if (SvTHINKFIRST(sv)) {
2485 SV *const tmpstr = AMG_CALLun(sv,numer);
2486 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2487 return SvNV(tmpstr);
2490 return PTR2NV(SvRV(sv));
2493 sv_force_normal_flags(sv, 0);
2495 if (SvREADONLY(sv) && !SvOK(sv)) {
2496 if (ckWARN(WARN_UNINITIALIZED))
2501 if (SvTYPE(sv) < SVt_NV) {
2502 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2503 sv_upgrade(sv, SVt_NV);
2504 #ifdef USE_LONG_DOUBLE
2506 STORE_NUMERIC_LOCAL_SET_STANDARD();
2507 PerlIO_printf(Perl_debug_log,
2508 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2509 PTR2UV(sv), SvNVX(sv));
2510 RESTORE_NUMERIC_LOCAL();
2514 STORE_NUMERIC_LOCAL_SET_STANDARD();
2515 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2516 PTR2UV(sv), SvNVX(sv));
2517 RESTORE_NUMERIC_LOCAL();
2521 else if (SvTYPE(sv) < SVt_PVNV)
2522 sv_upgrade(sv, SVt_PVNV);
2527 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2528 #ifdef NV_PRESERVES_UV
2534 /* Only set the public NV OK flag if this NV preserves the IV */
2535 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2537 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2538 : (SvIVX(sv) == I_V(SvNVX(sv))))
2544 else if (SvPOKp(sv) && SvLEN(sv)) {
2546 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2547 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2549 #ifdef NV_PRESERVES_UV
2550 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2551 == IS_NUMBER_IN_UV) {
2552 /* It's definitely an integer */
2553 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2555 SvNV_set(sv, Atof(SvPVX_const(sv)));
2561 SvNV_set(sv, Atof(SvPVX_const(sv)));
2562 /* Only set the public NV OK flag if this NV preserves the value in
2563 the PV at least as well as an IV/UV would.
2564 Not sure how to do this 100% reliably. */
2565 /* if that shift count is out of range then Configure's test is
2566 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2568 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2569 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2570 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2571 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2572 /* Can't use strtol etc to convert this string, so don't try.
2573 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2576 /* value has been set. It may not be precise. */
2577 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2578 /* 2s complement assumption for (UV)IV_MIN */
2579 SvNOK_on(sv); /* Integer is too negative. */
2584 if (numtype & IS_NUMBER_NEG) {
2585 SvIV_set(sv, -(IV)value);
2586 } else if (value <= (UV)IV_MAX) {
2587 SvIV_set(sv, (IV)value);
2589 SvUV_set(sv, value);
2593 if (numtype & IS_NUMBER_NOT_INT) {
2594 /* I believe that even if the original PV had decimals,
2595 they are lost beyond the limit of the FP precision.
2596 However, neither is canonical, so both only get p
2597 flags. NWC, 2000/11/25 */
2598 /* Both already have p flags, so do nothing */
2600 const NV nv = SvNVX(sv);
2601 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2602 if (SvIVX(sv) == I_V(nv)) {
2605 /* It had no "." so it must be integer. */
2609 /* between IV_MAX and NV(UV_MAX).
2610 Could be slightly > UV_MAX */
2612 if (numtype & IS_NUMBER_NOT_INT) {
2613 /* UV and NV both imprecise. */
2615 const UV nv_as_uv = U_V(nv);
2617 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2626 /* It might be more code efficient to go through the entire logic above
2627 and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2628 gets complex and potentially buggy, so more programmer efficient
2629 to do it this way, by turning off the public flags: */
2631 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2632 #endif /* NV_PRESERVES_UV */
2635 if (isGV_with_GP(sv)) {
2636 glob_2number((GV *)sv);
2640 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2642 assert (SvTYPE(sv) >= SVt_NV);
2643 /* Typically the caller expects that sv_any is not NULL now. */
2644 /* XXX Ilya implies that this is a bug in callers that assume this
2645 and ideally should be fixed. */
2648 #if defined(USE_LONG_DOUBLE)
2650 STORE_NUMERIC_LOCAL_SET_STANDARD();
2651 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2652 PTR2UV(sv), SvNVX(sv));
2653 RESTORE_NUMERIC_LOCAL();
2657 STORE_NUMERIC_LOCAL_SET_STANDARD();
2658 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2659 PTR2UV(sv), SvNVX(sv));
2660 RESTORE_NUMERIC_LOCAL();
2669 Return an SV with the numeric value of the source SV, doing any necessary
2670 reference or overload conversion. You must use the C<SvNUM(sv)> macro to
2671 access this function.
2677 Perl_sv_2num(pTHX_ register SV *const sv)
2679 PERL_ARGS_ASSERT_SV_2NUM;
2684 SV * const tmpsv = AMG_CALLun(sv,numer);
2685 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2686 return sv_2num(tmpsv);
2688 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2691 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2692 * UV as a string towards the end of buf, and return pointers to start and
2695 * We assume that buf is at least TYPE_CHARS(UV) long.
2699 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2701 char *ptr = buf + TYPE_CHARS(UV);
2702 char * const ebuf = ptr;
2705 PERL_ARGS_ASSERT_UIV_2BUF;
2717 *--ptr = '0' + (char)(uv % 10);
2726 =for apidoc sv_2pv_flags
2728 Returns a pointer to the string value of an SV, and sets *lp to its length.
2729 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2731 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2732 usually end up here too.
2738 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2748 if (SvGMAGICAL(sv)) {
2749 if (flags & SV_GMAGIC)
2754 if (flags & SV_MUTABLE_RETURN)
2755 return SvPVX_mutable(sv);
2756 if (flags & SV_CONST_RETURN)
2757 return (char *)SvPVX_const(sv);
2760 if (SvIOKp(sv) || SvNOKp(sv)) {
2761 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2766 ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2767 : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2769 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2776 #ifdef FIXNEGATIVEZERO
2777 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2783 SvUPGRADE(sv, SVt_PV);
2786 s = SvGROW_mutable(sv, len + 1);
2789 return (char*)memcpy(s, tbuf, len + 1);
2795 assert(SvTYPE(sv) >= SVt_PVMG);
2796 /* This falls through to the report_uninit near the end of the
2798 } else if (SvTHINKFIRST(sv)) {
2802 SV *const tmpstr = AMG_CALLun(sv,string);
2803 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2805 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2809 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2810 if (flags & SV_CONST_RETURN) {
2811 pv = (char *) SvPVX_const(tmpstr);
2813 pv = (flags & SV_MUTABLE_RETURN)
2814 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2817 *lp = SvCUR(tmpstr);
2819 pv = sv_2pv_flags(tmpstr, lp, flags);
2832 const SV *const referent = (SV*)SvRV(sv);
2836 retval = buffer = savepvn("NULLREF", len);
2837 } else if (SvTYPE(referent) == SVt_REGEXP) {
2838 const REGEXP * const re = (REGEXP *)referent;
2843 /* If the regex is UTF-8 we want the containing scalar to
2844 have an UTF-8 flag too */
2850 if ((seen_evals = RX_SEEN_EVALS(re)))
2851 PL_reginterp_cnt += seen_evals;
2854 *lp = RX_WRAPLEN(re);
2856 return RX_WRAPPED(re);
2858 const char *const typestr = sv_reftype(referent, 0);
2859 const STRLEN typelen = strlen(typestr);
2860 UV addr = PTR2UV(referent);
2861 const char *stashname = NULL;
2862 STRLEN stashnamelen = 0; /* hush, gcc */
2863 const char *buffer_end;
2865 if (SvOBJECT(referent)) {
2866 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2869 stashname = HEK_KEY(name);
2870 stashnamelen = HEK_LEN(name);
2872 if (HEK_UTF8(name)) {
2878 stashname = "__ANON__";
2881 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2882 + 2 * sizeof(UV) + 2 /* )\0 */;
2884 len = typelen + 3 /* (0x */
2885 + 2 * sizeof(UV) + 2 /* )\0 */;
2888 Newx(buffer, len, char);
2889 buffer_end = retval = buffer + len;
2891 /* Working backwards */
2895 *--retval = PL_hexdigit[addr & 15];
2896 } while (addr >>= 4);
2902 memcpy(retval, typestr, typelen);
2906 retval -= stashnamelen;
2907 memcpy(retval, stashname, stashnamelen);
2909 /* retval may not neccesarily have reached the start of the
2911 assert (retval >= buffer);
2913 len = buffer_end - retval - 1; /* -1 for that \0 */
2921 if (SvREADONLY(sv) && !SvOK(sv)) {
2924 if (flags & SV_UNDEF_RETURNS_NULL)
2926 if (ckWARN(WARN_UNINITIALIZED))
2931 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2932 /* I'm assuming that if both IV and NV are equally valid then
2933 converting the IV is going to be more efficient */
2934 const U32 isUIOK = SvIsUV(sv);
2935 char buf[TYPE_CHARS(UV)];
2939 if (SvTYPE(sv) < SVt_PVIV)
2940 sv_upgrade(sv, SVt_PVIV);
2941 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2943 /* inlined from sv_setpvn */
2944 s = SvGROW_mutable(sv, len + 1);
2945 Move(ptr, s, len, char);
2949 else if (SvNOKp(sv)) {
2950 const int olderrno = errno;
2951 if (SvTYPE(sv) < SVt_PVNV)
2952 sv_upgrade(sv, SVt_PVNV);
2953 /* The +20 is pure guesswork. Configure test needed. --jhi */
2954 s = SvGROW_mutable(sv, NV_DIG + 20);
2955 /* some Xenix systems wipe out errno here */
2957 if (SvNVX(sv) == 0.0)
2958 my_strlcpy(s, "0", SvLEN(sv));
2962 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2965 #ifdef FIXNEGATIVEZERO
2966 if (*s == '-' && s[1] == '0' && !s[2]) {
2978 if (isGV_with_GP(sv))
2979 return glob_2pv((GV *)sv, lp);
2983 if (flags & SV_UNDEF_RETURNS_NULL)
2985 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2987 if (SvTYPE(sv) < SVt_PV)
2988 /* Typically the caller expects that sv_any is not NULL now. */
2989 sv_upgrade(sv, SVt_PV);
2993 const STRLEN len = s - SvPVX_const(sv);
2999 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3000 PTR2UV(sv),SvPVX_const(sv)));
3001 if (flags & SV_CONST_RETURN)
3002 return (char *)SvPVX_const(sv);
3003 if (flags & SV_MUTABLE_RETURN)
3004 return SvPVX_mutable(sv);
3009 =for apidoc sv_copypv
3011 Copies a stringified representation of the source SV into the
3012 destination SV. Automatically performs any necessary mg_get and
3013 coercion of numeric values into strings. Guaranteed to preserve
3014 UTF8 flag even from overloaded objects. Similar in nature to
3015 sv_2pv[_flags] but operates directly on an SV instead of just the
3016 string. Mostly uses sv_2pv_flags to do its work, except when that
3017 would lose the UTF-8'ness of the PV.
3023 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
3026 const char * const s = SvPV_const(ssv,len);
3028 PERL_ARGS_ASSERT_SV_COPYPV;
3030 sv_setpvn(dsv,s,len);
3038 =for apidoc sv_2pvbyte
3040 Return a pointer to the byte-encoded representation of the SV, and set *lp
3041 to its length. May cause the SV to be downgraded from UTF-8 as a
3044 Usually accessed via the C<SvPVbyte> macro.
3050 Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
3052 PERL_ARGS_ASSERT_SV_2PVBYTE;
3054 sv_utf8_downgrade(sv,0);
3055 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3059 =for apidoc sv_2pvutf8
3061 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3062 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3064 Usually accessed via the C<SvPVutf8> macro.
3070 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
3072 PERL_ARGS_ASSERT_SV_2PVUTF8;
3074 sv_utf8_upgrade(sv);
3075 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3080 =for apidoc sv_2bool
3082 This function is only called on magical items, and is only used by
3083 sv_true() or its macro equivalent.
3089 Perl_sv_2bool(pTHX_ register SV *const sv)
3093 PERL_ARGS_ASSERT_SV_2BOOL;
3101 SV * const tmpsv = AMG_CALLun(sv,bool_);
3102 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3103 return (bool)SvTRUE(tmpsv);
3105 return SvRV(sv) != 0;
3108 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3110 (*sv->sv_u.svu_pv > '0' ||
3111 Xpvtmp->xpv_cur > 1 ||
3112 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3119 return SvIVX(sv) != 0;
3122 return SvNVX(sv) != 0.0;
3124 if (isGV_with_GP(sv))
3134 =for apidoc sv_utf8_upgrade
3136 Converts the PV of an SV to its UTF-8-encoded form.
3137 Forces the SV to string form if it is not already.
3138 Always sets the SvUTF8 flag to avoid future validity checks even
3139 if all the bytes have hibit clear.
3141 This is not as a general purpose byte encoding to Unicode interface:
3142 use the Encode extension for that.
3144 =for apidoc sv_utf8_upgrade_flags
3146 Converts the PV of an SV to its UTF-8-encoded form.
3147 Forces the SV to string form if it is not already.
3148 Always sets the SvUTF8 flag to avoid future validity checks even
3149 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3150 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3151 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3153 This is not as a general purpose byte encoding to Unicode interface:
3154 use the Encode extension for that.
3160 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *const sv, const I32 flags)
3164 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS;
3166 if (sv == &PL_sv_undef)
3170 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3171 (void) sv_2pv_flags(sv,&len, flags);
3175 (void) SvPV_force(sv,len);
3184 sv_force_normal_flags(sv, 0);
3187 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3188 sv_recode_to_utf8(sv, PL_encoding);
3189 else { /* Assume Latin-1/EBCDIC */
3190 /* This function could be much more efficient if we
3191 * had a FLAG in SVs to signal if there are any hibit
3192 * chars in the PV. Given that there isn't such a flag
3193 * make the loop as fast as possible. */
3194 const U8 * const s = (U8 *) SvPVX_const(sv);
3195 const U8 * const e = (U8 *) SvEND(sv);
3200 /* Check for hi bit */
3201 if (!NATIVE_IS_INVARIANT(ch)) {
3202 STRLEN len = SvCUR(sv);
3203 /* *Currently* bytes_to_utf8() adds a '\0' after every string
3204 it converts. This isn't documented. It's not clear if it's
3205 a bad thing to be doing, and should be changed to do exactly
3206 what the documentation says. If so, this code will have to
3208 As is, we mustn't rely on our incoming SV being well formed
3209 and having a trailing '\0', as certain code in pp_formline
3210 can send us partially built SVs. */
3211 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
3213 SvPV_free(sv); /* No longer using what was there before. */
3214 SvPV_set(sv, (char*)recoded);
3216 SvLEN_set(sv, len + 1); /* No longer know the real size. */
3220 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3227 =for apidoc sv_utf8_downgrade
3229 Attempts to convert the PV of an SV from characters to bytes.
3230 If the PV contains a character beyond byte, this conversion will fail;
3231 in this case, either returns false or, if C<fail_ok> is not
3234 This is not as a general purpose Unicode to byte encoding interface:
3235 use the Encode extension for that.
3241 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3245 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3247 if (SvPOKp(sv) && SvUTF8(sv)) {
3253 sv_force_normal_flags(sv, 0);
3255 s = (U8 *) SvPV(sv, len);
3256 if (!utf8_to_bytes(s, &len)) {
3261 Perl_croak(aTHX_ "Wide character in %s",
3264 Perl_croak(aTHX_ "Wide character");
3275 =for apidoc sv_utf8_encode
3277 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3278 flag off so that it looks like octets again.
3284 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3286 PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3289 sv_force_normal_flags(sv, 0);
3291 if (SvREADONLY(sv)) {
3292 Perl_croak(aTHX_ PL_no_modify);
3294 (void) sv_utf8_upgrade(sv);
3299 =for apidoc sv_utf8_decode
3301 If the PV of the SV is an octet sequence in UTF-8
3302 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3303 so that it looks like a character. If the PV contains only single-byte
3304 characters, the C<SvUTF8> flag stays being off.
3305 Scans PV for validity and returns false if the PV is invalid UTF-8.
3311 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3313 PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3319 /* The octets may have got themselves encoded - get them back as
3322 if (!sv_utf8_downgrade(sv, TRUE))
3325 /* it is actually just a matter of turning the utf8 flag on, but
3326 * we want to make sure everything inside is valid utf8 first.
3328 c = (const U8 *) SvPVX_const(sv);
3329 if (!is_utf8_string(c, SvCUR(sv)+1))
3331 e = (const U8 *) SvEND(sv);
3334 if (!UTF8_IS_INVARIANT(ch)) {
3344 =for apidoc sv_setsv
3346 Copies the contents of the source SV C<ssv> into the destination SV
3347 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3348 function if the source SV needs to be reused. Does not handle 'set' magic.
3349 Loosely speaking, it performs a copy-by-value, obliterating any previous
3350 content of the destination.
3352 You probably want to use one of the assortment of wrappers, such as
3353 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3354 C<SvSetMagicSV_nosteal>.
3356 =for apidoc sv_setsv_flags
3358 Copies the contents of the source SV C<ssv> into the destination SV
3359 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3360 function if the source SV needs to be reused. Does not handle 'set' magic.
3361 Loosely speaking, it performs a copy-by-value, obliterating any previous
3362 content of the destination.
3363 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3364 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3365 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3366 and C<sv_setsv_nomg> are implemented in terms of this function.
3368 You probably want to use one of the assortment of wrappers, such as
3369 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3370 C<SvSetMagicSV_nosteal>.
3372 This is the primary function for copying scalars, and most other
3373 copy-ish functions and macros use this underneath.
3379 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3381 I32 mro_changes = 0; /* 1 = method, 2 = isa */
3383 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3385 if (dtype != SVt_PVGV) {
3386 const char * const name = GvNAME(sstr);
3387 const STRLEN len = GvNAMELEN(sstr);
3389 if (dtype >= SVt_PV) {
3395 SvUPGRADE(dstr, SVt_PVGV);
3396 (void)SvOK_off(dstr);
3397 /* FIXME - why are we doing this, then turning it off and on again
3399 isGV_with_GP_on(dstr);
3401 GvSTASH(dstr) = GvSTASH(sstr);
3403 Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3404 gv_name_set((GV *)dstr, name, len, GV_ADD);
3405 SvFAKE_on(dstr); /* can coerce to non-glob */
3408 #ifdef GV_UNIQUE_CHECK
3409 if (GvUNIQUE((GV*)dstr)) {
3410 Perl_croak(aTHX_ PL_no_modify);
3414 if(GvGP((GV*)sstr)) {
3415 /* If source has method cache entry, clear it */
3417 SvREFCNT_dec(GvCV(sstr));
3421 /* If source has a real method, then a method is
3423 else if(GvCV((GV*)sstr)) {
3428 /* If dest already had a real method, that's a change as well */
3429 if(!mro_changes && GvGP((GV*)dstr) && GvCVu((GV*)dstr)) {
3433 if(strEQ(GvNAME((GV*)dstr),"ISA"))
3437 isGV_with_GP_off(dstr);
3438 (void)SvOK_off(dstr);
3439 isGV_with_GP_on(dstr);
3440 GvINTRO_off(dstr); /* one-shot flag */
3441 GvGP(dstr) = gp_ref(GvGP(sstr));
3442 if (SvTAINTED(sstr))
3444 if (GvIMPORTED(dstr) != GVf_IMPORTED
3445 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3447 GvIMPORTED_on(dstr);
3450 if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
3451 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3456 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3458 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3460 const int intro = GvINTRO(dstr);
3463 const U32 stype = SvTYPE(sref);
3465 PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3467 #ifdef GV_UNIQUE_CHECK
3468 if (GvUNIQUE((GV*)dstr)) {
3469 Perl_croak(aTHX_ PL_no_modify);
3474 GvINTRO_off(dstr); /* one-shot flag */
3475 GvLINE(dstr) = CopLINE(PL_curcop);
3476 GvEGV(dstr) = (GV*)dstr;
3481 location = (SV **) &GvCV(dstr);
3482 import_flag = GVf_IMPORTED_CV;
3485 location = (SV **) &GvHV(dstr);
3486 import_flag = GVf_IMPORTED_HV;
3489 location = (SV **) &GvAV(dstr);
3490 import_flag = GVf_IMPORTED_AV;
3493 location = (SV **) &GvIOp(dstr);
3496 location = (SV **) &GvFORM(dstr);
3498 location = &GvSV(dstr);
3499 import_flag = GVf_IMPORTED_SV;
3502 if (stype == SVt_PVCV) {
3503 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (CV*)sref || GvCVGEN(dstr))) {*/
3504 if (GvCVGEN(dstr)) {
3505 SvREFCNT_dec(GvCV(dstr));
3507 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3510 SAVEGENERICSV(*location);
3514 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3515 CV* const cv = (CV*)*location;
3517 if (!GvCVGEN((GV*)dstr) &&
3518 (CvROOT(cv) || CvXSUB(cv)))
3520 /* Redefining a sub - warning is mandatory if
3521 it was a const and its value changed. */
3522 if (CvCONST(cv) && CvCONST((CV*)sref)
3523 && cv_const_sv(cv) == cv_const_sv((CV*)sref)) {
3525 /* They are 2 constant subroutines generated from
3526 the same constant. This probably means that
3527 they are really the "same" proxy subroutine
3528 instantiated in 2 places. Most likely this is
3529 when a constant is exported twice. Don't warn.
3532 else if (ckWARN(WARN_REDEFINE)
3534 && (!CvCONST((CV*)sref)
3535 || sv_cmp(cv_const_sv(cv),
3536 cv_const_sv((CV*)sref))))) {
3537 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3540 ? "Constant subroutine %s::%s redefined"
3541 : "Subroutine %s::%s redefined"),
3542 HvNAME_get(GvSTASH((GV*)dstr)),
3543 GvENAME((GV*)dstr));
3547 cv_ckproto_len(cv, (GV*)dstr,
3548 SvPOK(sref) ? SvPVX_const(sref) : NULL,
3549 SvPOK(sref) ? SvCUR(sref) : 0);
3551 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3552 GvASSUMECV_on(dstr);
3553 if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3556 if (import_flag && !(GvFLAGS(dstr) & import_flag)
3557 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3558 GvFLAGS(dstr) |= import_flag;
3563 if (SvTAINTED(sstr))
3569 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3572 register U32 sflags;
3574 register svtype stype;
3576 PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3581 if (SvIS_FREED(dstr)) {
3582 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3583 " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3585 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3587 sstr = &PL_sv_undef;
3588 if (SvIS_FREED(sstr)) {
3589 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3590 (void*)sstr, (void*)dstr);
3592 stype = SvTYPE(sstr);
3593 dtype = SvTYPE(dstr);
3595 (void)SvAMAGIC_off(dstr);
3598 /* need to nuke the magic */
3602 /* There's a lot of redundancy below but we're going for speed here */
3607 if (dtype != SVt_PVGV) {
3608 (void)SvOK_off(dstr);
3616 sv_upgrade(dstr, SVt_IV);
3620 sv_upgrade(dstr, SVt_PVIV);
3623 goto end_of_first_switch;
3625 (void)SvIOK_only(dstr);
3626 SvIV_set(dstr, SvIVX(sstr));
3629 /* SvTAINTED can only be true if the SV has taint magic, which in
3630 turn means that the SV type is PVMG (or greater). This is the
3631 case statement for SVt_IV, so this cannot be true (whatever gcov
3633 assert(!SvTAINTED(sstr));
3638 if (dtype < SVt_PV && dtype != SVt_IV)
3639 sv_upgrade(dstr, SVt_IV);
3647 sv_upgrade(dstr, SVt_NV);
3651 sv_upgrade(dstr, SVt_PVNV);
3654 goto end_of_first_switch;
3656 SvNV_set(dstr, SvNVX(sstr));
3657 (void)SvNOK_only(dstr);
3658 /* SvTAINTED can only be true if the SV has taint magic, which in
3659 turn means that the SV type is PVMG (or greater). This is the
3660 case statement for SVt_NV, so this cannot be true (whatever gcov
3662 assert(!SvTAINTED(sstr));
3668 #ifdef PERL_OLD_COPY_ON_WRITE
3669 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3670 if (dtype < SVt_PVIV)
3671 sv_upgrade(dstr, SVt_PVIV);
3679 sv_upgrade(dstr, SVt_PV);
3682 if (dtype < SVt_PVIV)
3683 sv_upgrade(dstr, SVt_PVIV);
3686 if (dtype < SVt_PVNV)
3687 sv_upgrade(dstr, SVt_PVNV);
3691 const char * const type = sv_reftype(sstr,0);
3693 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3695 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3699 /* case SVt_BIND: */
3702 if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
3703 glob_assign_glob(dstr, sstr, dtype);
3706 /* SvVALID means that this PVGV is playing at being an FBM. */
3710 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3712 if (SvTYPE(sstr) != stype) {
3713 stype = SvTYPE(sstr);
3714 if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
3715 glob_assign_glob(dstr, sstr, dtype);
3720 if (stype == SVt_PVLV)
3721 SvUPGRADE(dstr, SVt_PVNV);
3723 SvUPGRADE(dstr, (svtype)stype);
3725 end_of_first_switch:
3727 /* dstr may have been upgraded. */
3728 dtype = SvTYPE(dstr);
3729 sflags = SvFLAGS(sstr);
3731 if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
3732 /* Assigning to a subroutine sets the prototype. */
3735 const char *const ptr = SvPV_const(sstr, len);
3737 SvGROW(dstr, len + 1);
3738 Copy(ptr, SvPVX(dstr), len + 1, char);
3739 SvCUR_set(dstr, len);
3741 SvFLAGS(dstr) |= sflags & SVf_UTF8;
3745 } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
3746 const char * const type = sv_reftype(dstr,0);
3748 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op));
3750 Perl_croak(aTHX_ "Cannot copy to %s", type);
3751 } else if (sflags & SVf_ROK) {
3752 if (isGV_with_GP(dstr) && dtype == SVt_PVGV
3753 && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
3756 if (GvIMPORTED(dstr) != GVf_IMPORTED
3757 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3759 GvIMPORTED_on(dstr);
3764 glob_assign_glob(dstr, sstr, dtype);
3768 if (dtype >= SVt_PV) {
3769 if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3770 glob_assign_ref(dstr, sstr);
3773 if (SvPVX_const(dstr)) {
3779 (void)SvOK_off(dstr);
3780 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3781 SvFLAGS(dstr) |= sflags & SVf_ROK;
3782 assert(!(sflags & SVp_NOK));
3783 assert(!(sflags & SVp_IOK));
3784 assert(!(sflags & SVf_NOK));
3785 assert(!(sflags & SVf_IOK));
3787 else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3788 if (!(sflags & SVf_OK)) {
3789 if (ckWARN(WARN_MISC))
3790 Perl_warner(aTHX_ packWARN(WARN_MISC),
3791 "Undefined value assigned to typeglob");
3794 GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
3795 if (dstr != (SV*)gv) {
3798 GvGP(dstr) = gp_ref(GvGP(gv));
3802 else if (sflags & SVp_POK) {
3806 * Check to see if we can just swipe the string. If so, it's a
3807 * possible small lose on short strings, but a big win on long ones.
3808 * It might even be a win on short strings if SvPVX_const(dstr)
3809 * has to be allocated and SvPVX_const(sstr) has to be freed.
3810 * Likewise if we can set up COW rather than doing an actual copy, we
3811 * drop to the else clause, as the swipe code and the COW setup code
3812 * have much in common.
3815 /* Whichever path we take through the next code, we want this true,
3816 and doing it now facilitates the COW check. */
3817 (void)SvPOK_only(dstr);
3820 /* If we're already COW then this clause is not true, and if COW
3821 is allowed then we drop down to the else and make dest COW
3822 with us. If caller hasn't said that we're allowed to COW
3823 shared hash keys then we don't do the COW setup, even if the
3824 source scalar is a shared hash key scalar. */
3825 (((flags & SV_COW_SHARED_HASH_KEYS)
3826 ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
3827 : 1 /* If making a COW copy is forbidden then the behaviour we
3828 desire is as if the source SV isn't actually already
3829 COW, even if it is. So we act as if the source flags
3830 are not COW, rather than actually testing them. */
3832 #ifndef PERL_OLD_COPY_ON_WRITE
3833 /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
3834 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
3835 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
3836 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
3837 but in turn, it's somewhat dead code, never expected to go
3838 live, but more kept as a placeholder on how to do it better
3839 in a newer implementation. */
3840 /* If we are COW and dstr is a suitable target then we drop down
3841 into the else and make dest a COW of us. */
3842 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
3847 (sflags & SVs_TEMP) && /* slated for free anyway? */
3848 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3849 (!(flags & SV_NOSTEAL)) &&
3850 /* and we're allowed to steal temps */
3851 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3852 SvLEN(sstr) && /* and really is a string */
3853 /* and won't be needed again, potentially */
3854 !(PL_op && PL_op->op_type == OP_AASSIGN))
3855 #ifdef PERL_OLD_COPY_ON_WRITE
3856 && ((flags & SV_COW_SHARED_HASH_KEYS)
3857 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
3858 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
3859 && SvTYPE(sstr) >= SVt_PVIV))
3863 /* Failed the swipe test, and it's not a shared hash key either.
3864 Have to copy the string. */
3865 STRLEN len = SvCUR(sstr);
3866 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3867 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
3868 SvCUR_set(dstr, len);
3869 *SvEND(dstr) = '\0';
3871 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
3873 /* Either it's a shared hash key, or it's suitable for
3874 copy-on-write or we can swipe the string. */
3876 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
3880 #ifdef PERL_OLD_COPY_ON_WRITE
3882 /* I believe I should acquire a global SV mutex if
3883 it's a COW sv (not a shared hash key) to stop
3884 it going un copy-on-write.
3885 If the source SV has gone un copy on write between up there
3886 and down here, then (assert() that) it is of the correct
3887 form to make it copy on write again */
3888 if ((sflags & (SVf_FAKE | SVf_READONLY))
3889 != (SVf_FAKE | SVf_READONLY)) {
3890 SvREADONLY_on(sstr);
3892 /* Make the source SV into a loop of 1.
3893 (about to become 2) */
3894 SV_COW_NEXT_SV_SET(sstr, sstr);
3898 /* Initial code is common. */
3899 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
3904 /* making another shared SV. */
3905 STRLEN cur = SvCUR(sstr);
3906 STRLEN len = SvLEN(sstr);
3907 #ifdef PERL_OLD_COPY_ON_WRITE
3909 assert (SvTYPE(dstr) >= SVt_PVIV);
3910 /* SvIsCOW_normal */
3911 /* splice us in between source and next-after-source. */
3912 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3913 SV_COW_NEXT_SV_SET(sstr, dstr);
3914 SvPV_set(dstr, SvPVX_mutable(sstr));
3918 /* SvIsCOW_shared_hash */
3919 DEBUG_C(PerlIO_printf(Perl_debug_log,
3920 "Copy on write: Sharing hash\n"));
3922 assert (SvTYPE(dstr) >= SVt_PV);
3924 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
3926 SvLEN_set(dstr, len);
3927 SvCUR_set(dstr, cur);
3928 SvREADONLY_on(dstr);
3930 /* Relesase a global SV mutex. */
3933 { /* Passes the swipe test. */
3934 SvPV_set(dstr, SvPVX_mutable(sstr));
3935 SvLEN_set(dstr, SvLEN(sstr));
3936 SvCUR_set(dstr, SvCUR(sstr));
3939 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3940 SvPV_set(sstr, NULL);
3946 if (sflags & SVp_NOK) {
3947 SvNV_set(dstr, SvNVX(sstr));
3949 if (sflags & SVp_IOK) {
3950 SvIV_set(dstr, SvIVX(sstr));
3951 /* Must do this otherwise some other overloaded use of 0x80000000
3952 gets confused. I guess SVpbm_VALID */
3953 if (sflags & SVf_IVisUV)
3956 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
3958 const MAGIC * const smg = SvVSTRING_mg(sstr);
3960 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
3961 smg->mg_ptr, smg->mg_len);
3962 SvRMAGICAL_on(dstr);
3966 else if (sflags & (SVp_IOK|SVp_NOK)) {
3967 (void)SvOK_off(dstr);
3968 SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
3969 if (sflags & SVp_IOK) {
3970 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3971 SvIV_set(dstr, SvIVX(sstr));
3973 if (sflags & SVp_NOK) {
3974 SvNV_set(dstr, SvNVX(sstr));
3978 if (isGV_with_GP(sstr)) {
3979 /* This stringification rule for globs is spread in 3 places.
3980 This feels bad. FIXME. */
3981 const U32 wasfake = sflags & SVf_FAKE;
3983 /* FAKE globs can get coerced, so need to turn this off
3984 temporarily if it is on. */
3986 gv_efullname3(dstr, (GV *)sstr, "*");
3987 SvFLAGS(sstr) |= wasfake;
3990 (void)SvOK_off(dstr);
3992 if (SvTAINTED(sstr))
3997 =for apidoc sv_setsv_mg
3999 Like C<sv_setsv>, but also handles 'set' magic.
4005 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
4007 PERL_ARGS_ASSERT_SV_SETSV_MG;
4009 sv_setsv(dstr,sstr);
4013 #ifdef PERL_OLD_COPY_ON_WRITE
4015 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4017 STRLEN cur = SvCUR(sstr);
4018 STRLEN len = SvLEN(sstr);
4019 register char *new_pv;
4021 PERL_ARGS_ASSERT_SV_SETSV_COW;
4024 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4025 (void*)sstr, (void*)dstr);
4032 if (SvTHINKFIRST(dstr))
4033 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4034 else if (SvPVX_const(dstr))
4035 Safefree(SvPVX_const(dstr));
4039 SvUPGRADE(dstr, SVt_PVIV);
4041 assert (SvPOK(sstr));
4042 assert (SvPOKp(sstr));
4043 assert (!SvIOK(sstr));
4044 assert (!SvIOKp(sstr));
4045 assert (!SvNOK(sstr));
4046 assert (!SvNOKp(sstr));
4048 if (SvIsCOW(sstr)) {
4050 if (SvLEN(sstr) == 0) {
4051 /* source is a COW shared hash key. */
4052 DEBUG_C(PerlIO_printf(Perl_debug_log,
4053 "Fast copy on write: Sharing hash\n"));
4054 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4057 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4059 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4060 SvUPGRADE(sstr, SVt_PVIV);
4061 SvREADONLY_on(sstr);
4063 DEBUG_C(PerlIO_printf(Perl_debug_log,
4064 "Fast copy on write: Converting sstr to COW\n"));
4065 SV_COW_NEXT_SV_SET(dstr, sstr);
4067 SV_COW_NEXT_SV_SET(sstr, dstr);
4068 new_pv = SvPVX_mutable(sstr);
4071 SvPV_set(dstr, new_pv);
4072 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4075 SvLEN_set(dstr, len);
4076 SvCUR_set(dstr, cur);
4085 =for apidoc sv_setpvn
4087 Copies a string into an SV. The C<len> parameter indicates the number of
4088 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4089 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4095 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4098 register char *dptr;
4100 PERL_ARGS_ASSERT_SV_SETPVN;
4102 SV_CHECK_THINKFIRST_COW_DROP(sv);
4108 /* len is STRLEN which is unsigned, need to copy to signed */
4111 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4113 SvUPGRADE(sv, SVt_PV);
4115 dptr = SvGROW(sv, len + 1);
4116 Move(ptr,dptr,len,char);
4119 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4124 =for apidoc sv_setpvn_mg
4126 Like C<sv_setpvn>, but also handles 'set' magic.
4132 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4134 PERL_ARGS_ASSERT_SV_SETPVN_MG;
4136 sv_setpvn(sv,ptr,len);
4141 =for apidoc sv_setpv
4143 Copies a string into an SV. The string must be null-terminated. Does not
4144 handle 'set' magic. See C<sv_setpv_mg>.
4150 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4153 register STRLEN len;
4155 PERL_ARGS_ASSERT_SV_SETPV;
4157 SV_CHECK_THINKFIRST_COW_DROP(sv);
4163 SvUPGRADE(sv, SVt_PV);
4165 SvGROW(sv, len + 1);
4166 Move(ptr,SvPVX(sv),len+1,char);
4168 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4173 =for apidoc sv_setpv_mg
4175 Like C<sv_setpv>, but also handles 'set' magic.
4181 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4183 PERL_ARGS_ASSERT_SV_SETPV_MG;
4190 =for apidoc sv_usepvn_flags
4192 Tells an SV to use C<ptr> to find its string value. Normally the
4193 string is stored inside the SV but sv_usepvn allows the SV to use an
4194 outside string. The C<ptr> should point to memory that was allocated
4195 by C<malloc>. The string length, C<len>, must be supplied. By default
4196 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4197 so that pointer should not be freed or used by the programmer after
4198 giving it to sv_usepvn, and neither should any pointers from "behind"
4199 that pointer (e.g. ptr + 1) be used.
4201 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4202 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4203 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4204 C<len>, and already meets the requirements for storing in C<SvPVX>)
4210 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4215 PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4217 SV_CHECK_THINKFIRST_COW_DROP(sv);
4218 SvUPGRADE(sv, SVt_PV);
4221 if (flags & SV_SMAGIC)
4225 if (SvPVX_const(sv))
4229 if (flags & SV_HAS_TRAILING_NUL)
4230 assert(ptr[len] == '\0');
4233 allocate = (flags & SV_HAS_TRAILING_NUL)
4235 #ifdef Perl_safesysmalloc_size
4238 PERL_STRLEN_ROUNDUP(len + 1);
4240 if (flags & SV_HAS_TRAILING_NUL) {
4241 /* It's long enough - do nothing.
4242 Specfically Perl_newCONSTSUB is relying on this. */
4245 /* Force a move to shake out bugs in callers. */
4246 char *new_ptr = (char*)safemalloc(allocate);
4247 Copy(ptr, new_ptr, len, char);
4248 PoisonFree(ptr,len,char);
4252 ptr = (char*) saferealloc (ptr, allocate);
4255 #ifdef Perl_safesysmalloc_size
4256 SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4258 SvLEN_set(sv, allocate);
4262 if (!(flags & SV_HAS_TRAILING_NUL)) {
4265 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4267 if (flags & SV_SMAGIC)
4271 #ifdef PERL_OLD_COPY_ON_WRITE
4272 /* Need to do this *after* making the SV normal, as we need the buffer
4273 pointer to remain valid until after we've copied it. If we let go too early,
4274 another thread could invalidate it by unsharing last of the same hash key
4275 (which it can do by means other than releasing copy-on-write Svs)
4276 or by changing the other copy-on-write SVs in the loop. */
4278 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4280 PERL_ARGS_ASSERT_SV_RELEASE_COW;
4282 { /* this SV was SvIsCOW_normal(sv) */
4283 /* we need to find the SV pointing to us. */
4284 SV *current = SV_COW_NEXT_SV(after);
4286 if (current == sv) {
4287 /* The SV we point to points back to us (there were only two of us
4289 Hence other SV is no longer copy on write either. */
4291 SvREADONLY_off(after);
4293 /* We need to follow the pointers around the loop. */
4295 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4298 /* don't loop forever if the structure is bust, and we have
4299 a pointer into a closed loop. */
4300 assert (current != after);
4301 assert (SvPVX_const(current) == pvx);
4303 /* Make the SV before us point to the SV after us. */
4304 SV_COW_NEXT_SV_SET(current, after);
4310 =for apidoc sv_force_normal_flags
4312 Undo various types of fakery on an SV: if the PV is a shared string, make
4313 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4314 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4315 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4316 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4317 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4318 set to some other value.) In addition, the C<flags> parameter gets passed to
4319 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4320 with flags set to 0.
4326 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4330 PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4332 #ifdef PERL_OLD_COPY_ON_WRITE
4333 if (SvREADONLY(sv)) {
4334 /* At this point I believe I should acquire a global SV mutex. */
4336 const char * const pvx = SvPVX_const(sv);
4337 const STRLEN len = SvLEN(sv);
4338 const STRLEN cur = SvCUR(sv);
4339 /* next COW sv in the loop. If len is 0 then this is a shared-hash
4340 key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4341 we'll fail an assertion. */
4342 SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4345 PerlIO_printf(Perl_debug_log,
4346 "Copy on write: Force normal %ld\n",
4352 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4355 if (flags & SV_COW_DROP_PV) {
4356 /* OK, so we don't need to copy our buffer. */
4359 SvGROW(sv, cur + 1);
4360 Move(pvx,SvPVX(sv),cur,char);
4365 sv_release_COW(sv, pvx, next);
4367 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4373 else if (IN_PERL_RUNTIME)
4374 Perl_croak(aTHX_ PL_no_modify);
4375 /* At this point I believe that I can drop the global SV mutex. */
4378 if (SvREADONLY(sv)) {
4380 const char * const pvx = SvPVX_const(sv);
4381 const STRLEN len = SvCUR(sv);
4386 SvGROW(sv, len + 1);
4387 Move(pvx,SvPVX(sv),len,char);
4389 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4391 else if (IN_PERL_RUNTIME)
4392 Perl_croak(aTHX_ PL_no_modify);
4396 sv_unref_flags(sv, flags);
4397 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4404 Efficient removal of characters from the beginning of the string buffer.
4405 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4406 the string buffer. The C<ptr> becomes the first character of the adjusted
4407 string. Uses the "OOK hack".
4408 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4409 refer to the same chunk of data.
4415 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4421 const U8 *real_start;
4425 PERL_ARGS_ASSERT_SV_CHOP;
4427 if (!ptr || !SvPOKp(sv))
4429 delta = ptr - SvPVX_const(sv);
4431 /* Nothing to do. */
4434 /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line,
4435 nothing uses the value of ptr any more. */
4436 max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
4437 if (ptr <= SvPVX_const(sv))
4438 Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
4439 ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
4440 SV_CHECK_THINKFIRST(sv);
4441 if (delta > max_delta)
4442 Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p",
4443 SvPVX_const(sv) + delta, ptr, SvPVX_const(sv),
4444 SvPVX_const(sv) + max_delta);
4447 if (!SvLEN(sv)) { /* make copy of shared string */
4448 const char *pvx = SvPVX_const(sv);
4449 const STRLEN len = SvCUR(sv);
4450 SvGROW(sv, len + 1);
4451 Move(pvx,SvPVX(sv),len,char);
4454 SvFLAGS(sv) |= SVf_OOK;
4457 SvOOK_offset(sv, old_delta);
4459 SvLEN_set(sv, SvLEN(sv) - delta);
4460 SvCUR_set(sv, SvCUR(sv) - delta);
4461 SvPV_set(sv, SvPVX(sv) + delta);
4463 p = (U8 *)SvPVX_const(sv);
4468 real_start = p - delta;
4472 if (delta < 0x100) {
4476 p -= sizeof(STRLEN);
4477 Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4481 /* Fill the preceding buffer with sentinals to verify that no-one is
4483 while (p > real_start) {
4491 =for apidoc sv_catpvn
4493 Concatenates the string onto the end of the string which is in the SV. The
4494 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4495 status set, then the bytes appended should be valid UTF-8.
4496 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4498 =for apidoc sv_catpvn_flags
4500 Concatenates the string onto the end of the string which is in the SV. The
4501 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4502 status set, then the bytes appended should be valid UTF-8.
4503 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4504 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4505 in terms of this function.
4511 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4515 const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4517 PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4519 SvGROW(dsv, dlen + slen + 1);
4521 sstr = SvPVX_const(dsv);
4522 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4523 SvCUR_set(dsv, SvCUR(dsv) + slen);
4525 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4527 if (flags & SV_SMAGIC)
4532 =for apidoc sv_catsv
4534 Concatenates the string from SV C<ssv> onto the end of the string in
4535 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4536 not 'set' magic. See C<sv_catsv_mg>.
4538 =for apidoc sv_catsv_flags
4540 Concatenates the string from SV C<ssv> onto the end of the string in
4541 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4542 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4543 and C<sv_catsv_nomg> are implemented in terms of this function.
4548 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4552 PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4556 const char *spv = SvPV_const(ssv, slen);
4558 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4559 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4560 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4561 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4562 dsv->sv_flags doesn't have that bit set.
4563 Andy Dougherty 12 Oct 2001
4565 const I32 sutf8 = DO_UTF8(ssv);
4568 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4570 dutf8 = DO_UTF8(dsv);
4572 if (dutf8 != sutf8) {
4574 /* Not modifying source SV, so taking a temporary copy. */
4575 SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
4577 sv_utf8_upgrade(csv);
4578 spv = SvPV_const(csv, slen);
4581 sv_utf8_upgrade_nomg(dsv);
4583 sv_catpvn_nomg(dsv, spv, slen);
4586 if (flags & SV_SMAGIC)
4591 =for apidoc sv_catpv
4593 Concatenates the string onto the end of the string which is in the SV.
4594 If the SV has the UTF-8 status set, then the bytes appended should be
4595 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4600 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
4603 register STRLEN len;
4607 PERL_ARGS_ASSERT_SV_CATPV;
4611 junk = SvPV_force(sv, tlen);
4613 SvGROW(sv, tlen + len + 1);
4615 ptr = SvPVX_const(sv);
4616 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4617 SvCUR_set(sv, SvCUR(sv) + len);
4618 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4623 =for apidoc sv_catpv_mg
4625 Like C<sv_catpv>, but also handles 'set' magic.
4631 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4633 PERL_ARGS_ASSERT_SV_CATPV_MG;
4642 Creates a new SV. A non-zero C<len> parameter indicates the number of
4643 bytes of preallocated string space the SV should have. An extra byte for a
4644 trailing NUL is also reserved. (SvPOK is not set for the SV even if string
4645 space is allocated.) The reference count for the new SV is set to 1.
4647 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
4648 parameter, I<x>, a debug aid which allowed callers to identify themselves.
4649 This aid has been superseded by a new build option, PERL_MEM_LOG (see
4650 L<perlhack/PERL_MEM_LOG>). The older API is still there for use in XS
4651 modules supporting older perls.
4657 Perl_newSV(pTHX_ const STRLEN len)
4664 sv_upgrade(sv, SVt_PV);
4665 SvGROW(sv, len + 1);
4670 =for apidoc sv_magicext
4672 Adds magic to an SV, upgrading it if necessary. Applies the
4673 supplied vtable and returns a pointer to the magic added.
4675 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4676 In particular, you can add magic to SvREADONLY SVs, and add more than
4677 one instance of the same 'how'.
4679 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4680 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4681 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4682 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4684 (This is now used as a subroutine by C<sv_magic>.)
4689 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
4690 const MGVTBL *const vtable, const char *const name, const I32 namlen)
4695 PERL_ARGS_ASSERT_SV_MAGICEXT;
4697 SvUPGRADE(sv, SVt_PVMG);
4698 Newxz(mg, 1, MAGIC);
4699 mg->mg_moremagic = SvMAGIC(sv);
4700 SvMAGIC_set(sv, mg);
4702 /* Sometimes a magic contains a reference loop, where the sv and
4703 object refer to each other. To prevent a reference loop that
4704 would prevent such objects being freed, we look for such loops
4705 and if we find one we avoid incrementing the object refcount.
4707 Note we cannot do this to avoid self-tie loops as intervening RV must
4708 have its REFCNT incremented to keep it in existence.
4711 if (!obj || obj == sv ||
4712 how == PERL_MAGIC_arylen ||
4713 how == PERL_MAGIC_symtab ||
4714 (SvTYPE(obj) == SVt_PVGV &&
4715 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4716 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4717 GvFORM(obj) == (CV*)sv)))
4722 mg->mg_obj = SvREFCNT_inc_simple(obj);
4723 mg->mg_flags |= MGf_REFCOUNTED;
4726 /* Normal self-ties simply pass a null object, and instead of
4727 using mg_obj directly, use the SvTIED_obj macro to produce a
4728 new RV as needed. For glob "self-ties", we are tieing the PVIO
4729 with an RV obj pointing to the glob containing the PVIO. In
4730 this case, to avoid a reference loop, we need to weaken the
4734 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4735 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4741 mg->mg_len = namlen;
4744 mg->mg_ptr = savepvn(name, namlen);
4745 else if (namlen == HEf_SVKEY)
4746 mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV*)name);
4748 mg->mg_ptr = (char *) name;
4750 mg->mg_virtual = (MGVTBL *) vtable;
4754 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4759 =for apidoc sv_magic
4761 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4762 then adds a new magic item of type C<how> to the head of the magic list.
4764 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4765 handling of the C<name> and C<namlen> arguments.
4767 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4768 to add more than one instance of the same 'how'.
4774 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
4775 const char *const name, const I32 namlen)
4778 const MGVTBL *vtable;
4781 PERL_ARGS_ASSERT_SV_MAGIC;
4783 #ifdef PERL_OLD_COPY_ON_WRITE
4785 sv_force_normal_flags(sv, 0);
4787 if (SvREADONLY(sv)) {
4789 /* its okay to attach magic to shared strings; the subsequent
4790 * upgrade to PVMG will unshare the string */
4791 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4794 && how != PERL_MAGIC_regex_global
4795 && how != PERL_MAGIC_bm
4796 && how != PERL_MAGIC_fm
4797 && how != PERL_MAGIC_sv
4798 && how != PERL_MAGIC_backref
4801 Perl_croak(aTHX_ PL_no_modify);
4804 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4805 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4806 /* sv_magic() refuses to add a magic of the same 'how' as an
4809 if (how == PERL_MAGIC_taint) {
4811 /* Any scalar which already had taint magic on which someone
4812 (erroneously?) did SvIOK_on() or similar will now be
4813 incorrectly sporting public "OK" flags. */
4814 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4822 vtable = &PL_vtbl_sv;
4824 case PERL_MAGIC_overload:
4825 vtable = &PL_vtbl_amagic;
4827 case PERL_MAGIC_overload_elem:
4828 vtable = &PL_vtbl_amagicelem;
4830 case PERL_MAGIC_overload_table:
4831 vtable = &PL_vtbl_ovrld;
4834 vtable = &PL_vtbl_bm;
4836 case PERL_MAGIC_regdata:
4837 vtable = &PL_vtbl_regdata;
4839 case PERL_MAGIC_regdatum:
4840 vtable = &PL_vtbl_regdatum;
4842 case PERL_MAGIC_env:
4843 vtable = &PL_vtbl_env;
4846 vtable = &PL_vtbl_fm;
4848 case PERL_MAGIC_envelem:
4849 vtable = &PL_vtbl_envelem;
4851 case PERL_MAGIC_regex_global:
4852 vtable = &PL_vtbl_mglob;
4854 case PERL_MAGIC_isa:
4855 vtable = &PL_vtbl_isa;
4857 case PERL_MAGIC_isaelem:
4858 vtable = &PL_vtbl_isaelem;
4860 case PERL_MAGIC_nkeys:
4861 vtable = &PL_vtbl_nkeys;
4863 case PERL_MAGIC_dbfile:
4866 case PERL_MAGIC_dbline:
4867 vtable = &PL_vtbl_dbline;
4869 #ifdef USE_LOCALE_COLLATE
4870 case PERL_MAGIC_collxfrm:
4871 vtable = &PL_vtbl_collxfrm;
4873 #endif /* USE_LOCALE_COLLATE */
4874 case PERL_MAGIC_tied:
4875 vtable = &PL_vtbl_pack;
4877 case PERL_MAGIC_tiedelem:
4878 case PERL_MAGIC_tiedscalar:
4879 vtable = &PL_vtbl_packelem;
4882 vtable = &PL_vtbl_regexp;
4884 case PERL_MAGIC_hints:
4885 /* As this vtable is all NULL, we can reuse it. */
4886 case PERL_MAGIC_sig:
4887 vtable = &PL_vtbl_sig;
4889 case PERL_MAGIC_sigelem:
4890 vtable = &PL_vtbl_sigelem;
4892 case PERL_MAGIC_taint:
4893 vtable = &PL_vtbl_taint;
4895 case PERL_MAGIC_uvar:
4896 vtable = &PL_vtbl_uvar;
4898 case PERL_MAGIC_vec:
4899 vtable = &PL_vtbl_vec;
4901 case PERL_MAGIC_arylen_p:
4902 case PERL_MAGIC_rhash:
4903 case PERL_MAGIC_symtab:
4904 case PERL_MAGIC_vstring:
4907 case PERL_MAGIC_utf8:
4908 vtable = &PL_vtbl_utf8;
4910 case PERL_MAGIC_substr:
4911 vtable = &PL_vtbl_substr;
4913 case PERL_MAGIC_defelem:
4914 vtable = &PL_vtbl_defelem;
4916 case PERL_MAGIC_arylen:
4917 vtable = &PL_vtbl_arylen;
4919 case PERL_MAGIC_pos:
4920 vtable = &PL_vtbl_pos;
4922 case PERL_MAGIC_backref:
4923 vtable = &PL_vtbl_backref;
4925 case PERL_MAGIC_hintselem:
4926 vtable = &PL_vtbl_hintselem;
4928 case PERL_MAGIC_ext:
4929 /* Reserved for use by extensions not perl internals. */
4930 /* Useful for attaching extension internal data to perl vars. */
4931 /* Note that multiple extensions may clash if magical scalars */
4932 /* etc holding private data from one are passed to another. */
4936 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4939 /* Rest of work is done else where */
4940 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4943 case PERL_MAGIC_taint:
4946 case PERL_MAGIC_ext:
4947 case PERL_MAGIC_dbfile:
4954 =for apidoc sv_unmagic
4956 Removes all magic of type C<type> from an SV.
4962 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
4967 PERL_ARGS_ASSERT_SV_UNMAGIC;
4969 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4971 mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
4972 for (mg = *mgp; mg; mg = *mgp) {
4973 if (mg->mg_type == type) {
4974 const MGVTBL* const vtbl = mg->mg_virtual;
4975 *mgp = mg->mg_moremagic;
4976 if (vtbl && vtbl->svt_free)
4977 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4978 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4980 Safefree(mg->mg_ptr);
4981 else if (mg->mg_len == HEf_SVKEY)
4982 SvREFCNT_dec((SV*)mg->mg_ptr);
4983 else if (mg->mg_type == PERL_MAGIC_utf8)
4984 Safefree(mg->mg_ptr);
4986 if (mg->mg_flags & MGf_REFCOUNTED)
4987 SvREFCNT_dec(mg->mg_obj);
4991 mgp = &mg->mg_moremagic;
4995 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4996 SvMAGIC_set(sv, NULL);
5003 =for apidoc sv_rvweaken
5005 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5006 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5007 push a back-reference to this RV onto the array of backreferences
5008 associated with that magic. If the RV is magical, set magic will be
5009 called after the RV is cleared.
5015 Perl_sv_rvweaken(pTHX_ SV *const sv)
5019 PERL_ARGS_ASSERT_SV_RVWEAKEN;
5021 if (!SvOK(sv)) /* let undefs pass */
5024 Perl_croak(aTHX_ "Can't weaken a nonreference");
5025 else if (SvWEAKREF(sv)) {
5026 if (ckWARN(WARN_MISC))
5027 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5031 Perl_sv_add_backref(aTHX_ tsv, sv);
5037 /* Give tsv backref magic if it hasn't already got it, then push a
5038 * back-reference to sv onto the array associated with the backref magic.
5041 /* A discussion about the backreferences array and its refcount:
5043 * The AV holding the backreferences is pointed to either as the mg_obj of
5044 * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux
5045 * structure, from the xhv_backreferences field. (A HV without hv_aux will
5046 * have the standard magic instead.) The array is created with a refcount
5047 * of 2. This means that if during global destruction the array gets
5048 * picked on first to have its refcount decremented by the random zapper,
5049 * it won't actually be freed, meaning it's still theere for when its
5050 * parent gets freed.
5051 * When the parent SV is freed, in the case of magic, the magic is freed,
5052 * Perl_magic_killbackrefs is called which decrements one refcount, then
5053 * mg_obj is freed which kills the second count.
5054 * In the vase of a HV being freed, one ref is removed by
5055 * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it
5060 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5065 PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5067 if (SvTYPE(tsv) == SVt_PVHV) {
5068 AV **const avp = Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
5072 /* There is no AV in the offical place - try a fixup. */
5073 MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
5076 /* Aha. They've got it stowed in magic. Bring it back. */
5077 av = (AV*)mg->mg_obj;
5078 /* Stop mg_free decreasing the refernce count. */
5080 /* Stop mg_free even calling the destructor, given that
5081 there's no AV to free up. */
5083 sv_unmagic(tsv, PERL_MAGIC_backref);
5087 SvREFCNT_inc_simple_void(av); /* see discussion above */
5092 const MAGIC *const mg
5093 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5095 av = (AV*)mg->mg_obj;
5099 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5100 /* av now has a refcnt of 2; see discussion above */
5103 if (AvFILLp(av) >= AvMAX(av)) {
5104 av_extend(av, AvFILLp(av)+1);
5106 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5109 /* delete a back-reference to ourselves from the backref magic associated
5110 * with the SV we point to.
5114 S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5121 PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5123 if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
5124 av = *Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
5125 /* We mustn't attempt to "fix up" the hash here by moving the
5126 backreference array back to the hv_aux structure, as that is stored
5127 in the main HvARRAY(), and hfreentries assumes that no-one
5128 reallocates HvARRAY() while it is running. */
5131 const MAGIC *const mg
5132 = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5134 av = (AV *)mg->mg_obj;
5138 Perl_croak(aTHX_ "panic: del_backref");
5140 assert(!SvIS_FREED(av));
5143 /* We shouldn't be in here more than once, but for paranoia reasons lets
5145 for (i = AvFILLp(av); i >= 0; i--) {
5147 const SSize_t fill = AvFILLp(av);
5149 /* We weren't the last entry.
5150 An unordered list has this property that you can take the
5151 last element off the end to fill the hole, and it's still
5152 an unordered list :-)
5157 AvFILLp(av) = fill - 1;
5163 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5165 SV **svp = AvARRAY(av);
5167 PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5168 PERL_UNUSED_ARG(sv);
5170 assert(!svp || !SvIS_FREED(av));
5172 SV *const *const last = svp + AvFILLp(av);
5174 while (svp <= last) {
5176 SV *const referrer = *svp;
5177 if (SvWEAKREF(referrer)) {
5178 /* XXX Should we check that it hasn't changed? */
5179 SvRV_set(referrer, 0);
5181 SvWEAKREF_off(referrer);
5182 SvSETMAGIC(referrer);
5183 } else if (SvTYPE(referrer) == SVt_PVGV ||
5184 SvTYPE(referrer) == SVt_PVLV) {
5185 /* You lookin' at me? */
5186 assert(GvSTASH(referrer));
5187 assert(GvSTASH(referrer) == (HV*)sv);
5188 GvSTASH(referrer) = 0;
5191 "panic: magic_killbackrefs (flags=%"UVxf")",
5192 (UV)SvFLAGS(referrer));
5200 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5205 =for apidoc sv_insert
5207 Inserts a string at the specified offset/length within the SV. Similar to
5208 the Perl substr() function. Handles get magic.
5210 =for apidoc sv_insert_flags
5212 Same as C<sv_insert>, but the extra C<flags> are passed the C<SvPV_force_flags> that applies to C<bigstr>.
5218 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
5223 register char *midend;
5224 register char *bigend;
5228 PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
5231 Perl_croak(aTHX_ "Can't modify non-existent substring");
5232 SvPV_force_flags(bigstr, curlen, flags);
5233 (void)SvPOK_only_UTF8(bigstr);
5234 if (offset + len > curlen) {
5235 SvGROW(bigstr, offset+len+1);
5236 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5237 SvCUR_set(bigstr, offset+len);
5241 i = littlelen - len;
5242 if (i > 0) { /* string might grow */
5243 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5244 mid = big + offset + len;
5245 midend = bigend = big + SvCUR(bigstr);
5248 while (midend > mid) /* shove everything down */
5249 *--bigend = *--midend;
5250 Move(little,big+offset,littlelen,char);
5251 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5256 Move(little,SvPVX(bigstr)+offset,len,char);
5261 big = SvPVX(bigstr);
5264 bigend = big + SvCUR(bigstr);
5266 if (midend > bigend)
5267 Perl_croak(aTHX_ "panic: sv_insert");
5269 if (mid - big > bigend - midend) { /* faster to shorten from end */
5271 Move(little, mid, littlelen,char);
5274 i = bigend - midend;
5276 Move(midend, mid, i,char);
5280 SvCUR_set(bigstr, mid - big);
5282 else if ((i = mid - big)) { /* faster from front */
5283 midend -= littlelen;
5285 Move(big, midend - i, i, char);
5286 sv_chop(bigstr,midend-i);
5288 Move(little, mid, littlelen,char);
5290 else if (littlelen) {
5291 midend -= littlelen;
5292 sv_chop(bigstr,midend);
5293 Move(little,midend,littlelen,char);
5296 sv_chop(bigstr,midend);
5302 =for apidoc sv_replace
5304 Make the first argument a copy of the second, then delete the original.
5305 The target SV physically takes over ownership of the body of the source SV
5306 and inherits its flags; however, the target keeps any magic it owns,
5307 and any magic in the source is discarded.
5308 Note that this is a rather specialist SV copying operation; most of the
5309 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5315 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5318 const U32 refcnt = SvREFCNT(sv);
5320 PERL_ARGS_ASSERT_SV_REPLACE;
5322 SV_CHECK_THINKFIRST_COW_DROP(sv);
5323 if (SvREFCNT(nsv) != 1) {
5324 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
5325 UVuf " != 1)", (UV) SvREFCNT(nsv));
5327 if (SvMAGICAL(sv)) {
5331 sv_upgrade(nsv, SVt_PVMG);
5332 SvMAGIC_set(nsv, SvMAGIC(sv));
5333 SvFLAGS(nsv) |= SvMAGICAL(sv);
5335 SvMAGIC_set(sv, NULL);
5339 assert(!SvREFCNT(sv));
5340 #ifdef DEBUG_LEAKING_SCALARS
5341 sv->sv_flags = nsv->sv_flags;
5342 sv->sv_any = nsv->sv_any;
5343 sv->sv_refcnt = nsv->sv_refcnt;
5344 sv->sv_u = nsv->sv_u;
5346 StructCopy(nsv,sv,SV);
5348 if(SvTYPE(sv) == SVt_IV) {
5350 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5354 #ifdef PERL_OLD_COPY_ON_WRITE
5355 if (SvIsCOW_normal(nsv)) {
5356 /* We need to follow the pointers around the loop to make the
5357 previous SV point to sv, rather than nsv. */
5360 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5363 assert(SvPVX_const(current) == SvPVX_const(nsv));
5365 /* Make the SV before us point to the SV after us. */
5367 PerlIO_printf(Perl_debug_log, "previous is\n");
5369 PerlIO_printf(Perl_debug_log,
5370 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5371 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5373 SV_COW_NEXT_SV_SET(current, sv);
5376 SvREFCNT(sv) = refcnt;
5377 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5383 =for apidoc sv_clear
5385 Clear an SV: call any destructors, free up any memory used by the body,
5386 and free the body itself. The SV's head is I<not> freed, although
5387 its type is set to all 1's so that it won't inadvertently be assumed
5388 to be live during global destruction etc.
5389 This function should only be called when REFCNT is zero. Most of the time
5390 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5397 Perl_sv_clear(pTHX_ register SV *const sv)
5400 const U32 type = SvTYPE(sv);
5401 const struct body_details *const sv_type_details
5402 = bodies_by_type + type;
5405 PERL_ARGS_ASSERT_SV_CLEAR;
5406 assert(SvREFCNT(sv) == 0);
5407 assert(SvTYPE(sv) != SVTYPEMASK);
5409 if (type <= SVt_IV) {
5410 /* See the comment in sv.h about the collusion between this early
5411 return and the overloading of the NULL and IV slots in the size
5414 SV * const target = SvRV(sv);
5416 sv_del_backref(target, sv);
5418 SvREFCNT_dec(target);
5420 SvFLAGS(sv) &= SVf_BREAK;
5421 SvFLAGS(sv) |= SVTYPEMASK;
5426 if (PL_defstash && /* Still have a symbol table? */
5433 stash = SvSTASH(sv);
5434 destructor = StashHANDLER(stash,DESTROY);
5436 SV* const tmpref = newRV(sv);
5437 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5439 PUSHSTACKi(PERLSI_DESTROY);
5444 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5450 if(SvREFCNT(tmpref) < 2) {
5451 /* tmpref is not kept alive! */
5453 SvRV_set(tmpref, NULL);
5456 SvREFCNT_dec(tmpref);
5458 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5462 if (PL_in_clean_objs)
5463 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5465 /* DESTROY gave object new lease on life */
5471 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5472 SvOBJECT_off(sv); /* Curse the object. */
5473 if (type != SVt_PVIO)
5474 --PL_sv_objcount; /* XXX Might want something more general */
5477 if (type >= SVt_PVMG) {
5478 if (type == SVt_PVMG && SvPAD_OUR(sv)) {
5479 SvREFCNT_dec(SvOURSTASH(sv));
5480 } else if (SvMAGIC(sv))
5482 if (type == SVt_PVMG && SvPAD_TYPED(sv))
5483 SvREFCNT_dec(SvSTASH(sv));
5486 /* case SVt_BIND: */
5489 IoIFP(sv) != PerlIO_stdin() &&
5490 IoIFP(sv) != PerlIO_stdout() &&
5491 IoIFP(sv) != PerlIO_stderr())
5493 io_close((IO*)sv, FALSE);
5495 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5496 PerlDir_close(IoDIRP(sv));
5497 IoDIRP(sv) = (DIR*)NULL;
5498 Safefree(IoTOP_NAME(sv));
5499 Safefree(IoFMT_NAME(sv));
5500 Safefree(IoBOTTOM_NAME(sv));
5503 /* FIXME for plugins */
5504 pregfree2((REGEXP*) sv);
5511 if (PL_last_swash_hv == (HV*)sv) {
5512 PL_last_swash_hv = NULL;
5514 Perl_hv_kill_backrefs(aTHX_ (HV*)sv);
5518 if (PL_comppad == (AV*)sv) {
5525 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5526 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5527 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5528 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5530 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5531 SvREFCNT_dec(LvTARG(sv));
5533 if (isGV_with_GP(sv)) {
5534 if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash))
5535 mro_method_changed_in(stash);
5538 unshare_hek(GvNAME_HEK(sv));
5539 /* If we're in a stash, we don't own a reference to it. However it does
5540 have a back reference to us, which needs to be cleared. */
5541 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
5542 sv_del_backref((SV*)stash, sv);
5544 /* FIXME. There are probably more unreferenced pointers to SVs in the
5545 interpreter struct that we should check and tidy in a similar
5547 if ((GV*)sv == PL_last_in_gv)
5548 PL_last_in_gv = NULL;
5554 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5557 SvOOK_offset(sv, offset);
5558 SvPV_set(sv, SvPVX_mutable(sv) - offset);
5559 /* Don't even bother with turning off the OOK flag. */
5562 SV * const target = SvRV(sv);
5564 sv_del_backref(target, sv);
5566 SvREFCNT_dec(target);
5568 #ifdef PERL_OLD_COPY_ON_WRITE
5569 else if (SvPVX_const(sv)) {
5571 /* I believe I need to grab the global SV mutex here and
5572 then recheck the COW status. */
5574 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5578 sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
5580 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5583 /* And drop it here. */
5585 } else if (SvLEN(sv)) {
5586 Safefree(SvPVX_const(sv));
5590 else if (SvPVX_const(sv) && SvLEN(sv))
5591 Safefree(SvPVX_mutable(sv));
5592 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5593 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5602 SvFLAGS(sv) &= SVf_BREAK;
5603 SvFLAGS(sv) |= SVTYPEMASK;
5605 if (sv_type_details->arena) {
5606 del_body(((char *)SvANY(sv) + sv_type_details->offset),
5607 &PL_body_roots[type]);
5609 else if (sv_type_details->body_size) {
5610 my_safefree(SvANY(sv));
5615 =for apidoc sv_newref
5617 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5624 Perl_sv_newref(pTHX_ SV *const sv)
5626 PERL_UNUSED_CONTEXT;
5635 Decrement an SV's reference count, and if it drops to zero, call
5636 C<sv_clear> to invoke destructors and free up any memory used by
5637 the body; finally, deallocate the SV's head itself.
5638 Normally called via a wrapper macro C<SvREFCNT_dec>.
5644 Perl_sv_free(pTHX_ SV *const sv)
5649 if (SvREFCNT(sv) == 0) {
5650 if (SvFLAGS(sv) & SVf_BREAK)
5651 /* this SV's refcnt has been artificially decremented to
5652 * trigger cleanup */
5654 if (PL_in_clean_all) /* All is fair */
5656 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5657 /* make sure SvREFCNT(sv)==0 happens very seldom */
5658 SvREFCNT(sv) = (~(U32)0)/2;
5661 if (ckWARN_d(WARN_INTERNAL)) {
5662 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5663 Perl_dump_sv_child(aTHX_ sv);
5665 #ifdef DEBUG_LEAKING_SCALARS
5668 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5669 if (PL_warnhook == PERL_WARNHOOK_FATAL
5670 || ckDEAD(packWARN(WARN_INTERNAL))) {
5671 /* Don't let Perl_warner cause us to escape our fate: */
5675 /* This may not return: */
5676 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5677 "Attempt to free unreferenced scalar: SV 0x%"UVxf
5678 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5681 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5686 if (--(SvREFCNT(sv)) > 0)
5688 Perl_sv_free2(aTHX_ sv);
5692 Perl_sv_free2(pTHX_ SV *const sv)
5696 PERL_ARGS_ASSERT_SV_FREE2;
5700 if (ckWARN_d(WARN_DEBUGGING))
5701 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5702 "Attempt to free temp prematurely: SV 0x%"UVxf
5703 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5707 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5708 /* make sure SvREFCNT(sv)==0 happens very seldom */
5709 SvREFCNT(sv) = (~(U32)0)/2;
5720 Returns the length of the string in the SV. Handles magic and type
5721 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5727 Perl_sv_len(pTHX_ register SV *const sv)
5735 len = mg_length(sv);
5737 (void)SvPV_const(sv, len);
5742 =for apidoc sv_len_utf8
5744 Returns the number of characters in the string in an SV, counting wide
5745 UTF-8 bytes as a single character. Handles magic and type coercion.
5751 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
5752 * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
5753 * (Note that the mg_len is not the length of the mg_ptr field.
5754 * This allows the cache to store the character length of the string without
5755 * needing to malloc() extra storage to attach to the mg_ptr.)
5760 Perl_sv_len_utf8(pTHX_ register SV *const sv)
5766 return mg_length(sv);
5770 const U8 *s = (U8*)SvPV_const(sv, len);
5774 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
5776 if (mg && mg->mg_len != -1) {
5778 if (PL_utf8cache < 0) {
5779 const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
5781 /* Need to turn the assertions off otherwise we may
5782 recurse infinitely while printing error messages.
5784 SAVEI8(PL_utf8cache);
5786 Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
5787 " real %"UVuf" for %"SVf,
5788 (UV) ulen, (UV) real, SVfARG(sv));
5793 ulen = Perl_utf8_length(aTHX_ s, s + len);
5794 if (!SvREADONLY(sv)) {
5796 mg = sv_magicext(sv, 0, PERL_MAGIC_utf8,
5797 &PL_vtbl_utf8, 0, 0);
5805 return Perl_utf8_length(aTHX_ s, s + len);
5809 /* Walk forwards to find the byte corresponding to the passed in UTF-8
5812 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
5815 const U8 *s = start;
5817 PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
5819 while (s < send && uoffset--)
5822 /* This is the existing behaviour. Possibly it should be a croak, as
5823 it's actually a bounds error */
5829 /* Given the length of the string in both bytes and UTF-8 characters, decide
5830 whether to walk forwards or backwards to find the byte corresponding to
5831 the passed in UTF-8 offset. */
5833 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
5834 const STRLEN uoffset, const STRLEN uend)
5836 STRLEN backw = uend - uoffset;
5838 PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
5840 if (uoffset < 2 * backw) {
5841 /* The assumption is that going forwards is twice the speed of going
5842 forward (that's where the 2 * backw comes from).
5843 (The real figure of course depends on the UTF-8 data.) */
5844 return sv_pos_u2b_forwards(start, send, uoffset);
5849 while (UTF8_IS_CONTINUATION(*send))
5852 return send - start;
5855 /* For the string representation of the given scalar, find the byte
5856 corresponding to the passed in UTF-8 offset. uoffset0 and boffset0
5857 give another position in the string, *before* the sought offset, which
5858 (which is always true, as 0, 0 is a valid pair of positions), which should
5859 help reduce the amount of linear searching.
5860 If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
5861 will be used to reduce the amount of linear searching. The cache will be
5862 created if necessary, and the found value offered to it for update. */
5864 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
5865 const U8 *const send, const STRLEN uoffset,
5866 STRLEN uoffset0, STRLEN boffset0)
5868 STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
5871 PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
5873 assert (uoffset >= uoffset0);
5875 if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
5876 && (*mgp || (*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
5877 if ((*mgp)->mg_ptr) {
5878 STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
5879 if (cache[0] == uoffset) {
5880 /* An exact match. */
5883 if (cache[2] == uoffset) {
5884 /* An exact match. */
5888 if (cache[0] < uoffset) {
5889 /* The cache already knows part of the way. */
5890 if (cache[0] > uoffset0) {
5891 /* The cache knows more than the passed in pair */
5892 uoffset0 = cache[0];
5893 boffset0 = cache[1];
5895 if ((*mgp)->mg_len != -1) {
5896 /* And we know the end too. */
5898 + sv_pos_u2b_midway(start + boffset0, send,
5900 (*mgp)->mg_len - uoffset0);
5903 + sv_pos_u2b_forwards(start + boffset0,
5904 send, uoffset - uoffset0);
5907 else if (cache[2] < uoffset) {
5908 /* We're between the two cache entries. */
5909 if (cache[2] > uoffset0) {
5910 /* and the cache knows more than the passed in pair */
5911 uoffset0 = cache[2];
5912 boffset0 = cache[3];
5916 + sv_pos_u2b_midway(start + boffset0,
5919 cache[0] - uoffset0);
5922 + sv_pos_u2b_midway(start + boffset0,
5925 cache[2] - uoffset0);
5929 else if ((*mgp)->mg_len != -1) {
5930 /* If we can take advantage of a passed in offset, do so. */
5931 /* In fact, offset0 is either 0, or less than offset, so don't
5932 need to worry about the other possibility. */
5934 + sv_pos_u2b_midway(start + boffset0, send,
5936 (*mgp)->mg_len - uoffset0);
5941 if (!found || PL_utf8cache < 0) {
5942 const STRLEN real_boffset
5943 = boffset0 + sv_pos_u2b_forwards(start + boffset0,
5944 send, uoffset - uoffset0);
5946 if (found && PL_utf8cache < 0) {
5947 if (real_boffset != boffset) {
5948 /* Need to turn the assertions off otherwise we may recurse
5949 infinitely while printing error messages. */
5950 SAVEI8(PL_utf8cache);
5952 Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
5953 " real %"UVuf" for %"SVf,
5954 (UV) boffset, (UV) real_boffset, SVfARG(sv));
5957 boffset = real_boffset;
5961 utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
5967 =for apidoc sv_pos_u2b
5969 Converts the value pointed to by offsetp from a count of UTF-8 chars from
5970 the start of the string, to a count of the equivalent number of bytes; if
5971 lenp is non-zero, it does the same to lenp, but this time starting from
5972 the offset, rather than from the start of the string. Handles magic and
5979 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
5980 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5981 * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
5986 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
5991 PERL_ARGS_ASSERT_SV_POS_U2B;
5996 start = (U8*)SvPV_const(sv, len);
5998 STRLEN uoffset = (STRLEN) *offsetp;
5999 const U8 * const send = start + len;
6001 const STRLEN boffset = sv_pos_u2b_cached(sv, &mg, start, send,
6004 *offsetp = (I32) boffset;
6007 /* Convert the relative offset to absolute. */
6008 const STRLEN uoffset2 = uoffset + (STRLEN) *lenp;
6009 const STRLEN boffset2
6010 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
6011 uoffset, boffset) - boffset;
6025 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
6026 byte length pairing. The (byte) length of the total SV is passed in too,
6027 as blen, because for some (more esoteric) SVs, the call to SvPV_const()
6028 may not have updated SvCUR, so we can't rely on reading it directly.
6030 The proffered utf8/byte length pairing isn't used if the cache already has
6031 two pairs, and swapping either for the proffered pair would increase the
6032 RMS of the intervals between known byte offsets.
6034 The cache itself consists of 4 STRLEN values
6035 0: larger UTF-8 offset
6036 1: corresponding byte offset
6037 2: smaller UTF-8 offset
6038 3: corresponding byte offset
6040 Unused cache pairs have the value 0, 0.
6041 Keeping the cache "backwards" means that the invariant of
6042 cache[0] >= cache[2] is maintained even with empty slots, which means that
6043 the code that uses it doesn't need to worry if only 1 entry has actually
6044 been set to non-zero. It also makes the "position beyond the end of the
6045 cache" logic much simpler, as the first slot is always the one to start
6049 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
6050 const STRLEN utf8, const STRLEN blen)
6054 PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
6060 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
6062 (*mgp)->mg_len = -1;
6066 if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
6067 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6068 (*mgp)->mg_ptr = (char *) cache;
6072 if (PL_utf8cache < 0) {
6073 const U8 *start = (const U8 *) SvPVX_const(sv);
6074 const STRLEN realutf8 = utf8_length(start, start + byte);
6076 if (realutf8 != utf8) {
6077 /* Need to turn the assertions off otherwise we may recurse
6078 infinitely while printing error messages. */
6079 SAVEI8(PL_utf8cache);
6081 Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
6082 " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv));
6086 /* Cache is held with the later position first, to simplify the code
6087 that deals with unbounded ends. */
6089 ASSERT_UTF8_CACHE(cache);
6090 if (cache[1] == 0) {
6091 /* Cache is totally empty */
6094 } else if (cache[3] == 0) {
6095 if (byte > cache[1]) {
6096 /* New one is larger, so goes first. */
6097 cache[2] = cache[0];
6098 cache[3] = cache[1];
6106 #define THREEWAY_SQUARE(a,b,c,d) \
6107 ((float)((d) - (c))) * ((float)((d) - (c))) \
6108 + ((float)((c) - (b))) * ((float)((c) - (b))) \
6109 + ((float)((b) - (a))) * ((float)((b) - (a)))
6111 /* Cache has 2 slots in use, and we know three potential pairs.
6112 Keep the two that give the lowest RMS distance. Do the
6113 calcualation in bytes simply because we always know the byte
6114 length. squareroot has the same ordering as the positive value,
6115 so don't bother with the actual square root. */
6116 const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6117 if (byte > cache[1]) {
6118 /* New position is after the existing pair of pairs. */
6119 const float keep_earlier
6120 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6121 const float keep_later
6122 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6124 if (keep_later < keep_earlier) {
6125 if (keep_later < existing) {
6126 cache[2] = cache[0];
6127 cache[3] = cache[1];
6133 if (keep_earlier < existing) {
6139 else if (byte > cache[3]) {
6140 /* New position is between the existing pair of pairs. */
6141 const float keep_earlier
6142 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6143 const float keep_later
6144 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6146 if (keep_later < keep_earlier) {
6147 if (keep_later < existing) {
6153 if (keep_earlier < existing) {
6160 /* New position is before the existing pair of pairs. */
6161 const float keep_earlier
6162 = THREEWAY_SQUARE(0, byte, cache[3], blen);
6163 const float keep_later
6164 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6166 if (keep_later < keep_earlier) {
6167 if (keep_later < existing) {
6173 if (keep_earlier < existing) {
6174 cache[0] = cache[2];
6175 cache[1] = cache[3];
6182 ASSERT_UTF8_CACHE(cache);
6185 /* We already know all of the way, now we may be able to walk back. The same
6186 assumption is made as in S_sv_pos_u2b_midway(), namely that walking
6187 backward is half the speed of walking forward. */
6189 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
6190 const U8 *end, STRLEN endu)
6192 const STRLEN forw = target - s;
6193 STRLEN backw = end - target;
6195 PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
6197 if (forw < 2 * backw) {
6198 return utf8_length(s, target);
6201 while (end > target) {
6203 while (UTF8_IS_CONTINUATION(*end)) {
6212 =for apidoc sv_pos_b2u
6214 Converts the value pointed to by offsetp from a count of bytes from the
6215 start of the string, to a count of the equivalent number of UTF-8 chars.
6216 Handles magic and type coercion.
6222 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6223 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6228 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
6231 const STRLEN byte = *offsetp;
6232 STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
6238 PERL_ARGS_ASSERT_SV_POS_B2U;
6243 s = (const U8*)SvPV_const(sv, blen);
6246 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6250 if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
6251 && (mg = mg_find(sv, PERL_MAGIC_utf8))) {
6253 STRLEN * const cache = (STRLEN *) mg->mg_ptr;
6254 if (cache[1] == byte) {
6255 /* An exact match. */
6256 *offsetp = cache[0];
6259 if (cache[3] == byte) {
6260 /* An exact match. */
6261 *offsetp = cache[2];
6265 if (cache[1] < byte) {
6266 /* We already know part of the way. */
6267 if (mg->mg_len != -1) {
6268 /* Actually, we know the end too. */
6270 + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
6271 s + blen, mg->mg_len - cache[0]);
6273 len = cache[0] + utf8_length(s + cache[1], send);
6276 else if (cache[3] < byte) {
6277 /* We're between the two cached pairs, so we do the calculation
6278 offset by the byte/utf-8 positions for the earlier pair,
6279 then add the utf-8 characters from the string start to
6281 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
6282 s + cache[1], cache[0] - cache[2])
6286 else { /* cache[3] > byte */
6287 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
6291 ASSERT_UTF8_CACHE(cache);
6293 } else if (mg->mg_len != -1) {
6294 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
6298 if (!found || PL_utf8cache < 0) {
6299 const STRLEN real_len = utf8_length(s, send);
6301 if (found && PL_utf8cache < 0) {
6302 if (len != real_len) {
6303 /* Need to turn the assertions off otherwise we may recurse
6304 infinitely while printing error messages. */
6305 SAVEI8(PL_utf8cache);
6307 Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
6308 " real %"UVuf" for %"SVf,
6309 (UV) len, (UV) real_len, SVfARG(sv));
6317 utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
6323 Returns a boolean indicating whether the strings in the two SVs are
6324 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6325 coerce its args to strings if necessary.
6331 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6340 SV* svrecode = NULL;
6347 /* if pv1 and pv2 are the same, second SvPV_const call may
6348 * invalidate pv1, so we may need to make a copy */
6349 if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
6350 pv1 = SvPV_const(sv1, cur1);
6351 sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
6353 pv1 = SvPV_const(sv1, cur1);
6361 pv2 = SvPV_const(sv2, cur2);
6363 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6364 /* Differing utf8ness.
6365 * Do not UTF8size the comparands as a side-effect. */
6368 svrecode = newSVpvn(pv2, cur2);
6369 sv_recode_to_utf8(svrecode, PL_encoding);
6370 pv2 = SvPV_const(svrecode, cur2);
6373 svrecode = newSVpvn(pv1, cur1);
6374 sv_recode_to_utf8(svrecode, PL_encoding);
6375 pv1 = SvPV_const(svrecode, cur1);
6377 /* Now both are in UTF-8. */
6379 SvREFCNT_dec(svrecode);
6384 bool is_utf8 = TRUE;
6387 /* sv1 is the UTF-8 one,
6388 * if is equal it must be downgrade-able */
6389 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6395 /* sv2 is the UTF-8 one,
6396 * if is equal it must be downgrade-able */
6397 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6403 /* Downgrade not possible - cannot be eq */
6411 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6413 SvREFCNT_dec(svrecode);
6423 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6424 string in C<sv1> is less than, equal to, or greater than the string in
6425 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6426 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6432 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
6436 const char *pv1, *pv2;
6439 SV *svrecode = NULL;
6446 pv1 = SvPV_const(sv1, cur1);
6453 pv2 = SvPV_const(sv2, cur2);
6455 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6456 /* Differing utf8ness.
6457 * Do not UTF8size the comparands as a side-effect. */
6460 svrecode = newSVpvn(pv2, cur2);
6461 sv_recode_to_utf8(svrecode, PL_encoding);
6462 pv2 = SvPV_const(svrecode, cur2);
6465 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6470 svrecode = newSVpvn(pv1, cur1);
6471 sv_recode_to_utf8(svrecode, PL_encoding);
6472 pv1 = SvPV_const(svrecode, cur1);
6475 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6481 cmp = cur2 ? -1 : 0;
6485 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6488 cmp = retval < 0 ? -1 : 1;
6489 } else if (cur1 == cur2) {
6492 cmp = cur1 < cur2 ? -1 : 1;
6496 SvREFCNT_dec(svrecode);
6504 =for apidoc sv_cmp_locale
6506 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6507 'use bytes' aware, handles get magic, and will coerce its args to strings
6508 if necessary. See also C<sv_cmp>.
6514 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
6517 #ifdef USE_LOCALE_COLLATE
6523 if (PL_collation_standard)
6527 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6529 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6531 if (!pv1 || !len1) {
6542 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6545 return retval < 0 ? -1 : 1;
6548 * When the result of collation is equality, that doesn't mean
6549 * that there are no differences -- some locales exclude some
6550 * characters from consideration. So to avoid false equalities,
6551 * we use the raw string as a tiebreaker.
6557 #endif /* USE_LOCALE_COLLATE */
6559 return sv_cmp(sv1, sv2);
6563 #ifdef USE_LOCALE_COLLATE
6566 =for apidoc sv_collxfrm
6568 Add Collate Transform magic to an SV if it doesn't already have it.
6570 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6571 scalar data of the variable, but transformed to such a format that a normal
6572 memory comparison can be used to compare the data according to the locale
6579 Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
6584 PERL_ARGS_ASSERT_SV_COLLXFRM;
6586 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6587 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6593 Safefree(mg->mg_ptr);
6594 s = SvPV_const(sv, len);
6595 if ((xf = mem_collxfrm(s, len, &xlen))) {
6597 #ifdef PERL_OLD_COPY_ON_WRITE
6599 sv_force_normal_flags(sv, 0);
6601 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
6615 if (mg && mg->mg_ptr) {
6617 return mg->mg_ptr + sizeof(PL_collation_ix);
6625 #endif /* USE_LOCALE_COLLATE */
6630 Get a line from the filehandle and store it into the SV, optionally
6631 appending to the currently-stored string.
6637 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
6642 register STDCHAR rslast;
6643 register STDCHAR *bp;
6648 PERL_ARGS_ASSERT_SV_GETS;
6650 if (SvTHINKFIRST(sv))
6651 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6652 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6654 However, perlbench says it's slower, because the existing swipe code
6655 is faster than copy on write.
6656 Swings and roundabouts. */
6657 SvUPGRADE(sv, SVt_PV);
6662 if (PerlIO_isutf8(fp)) {
6664 sv_utf8_upgrade_nomg(sv);
6665 sv_pos_u2b(sv,&append,0);
6667 } else if (SvUTF8(sv)) {
6668 SV * const tsv = newSV(0);
6669 sv_gets(tsv, fp, 0);
6670 sv_utf8_upgrade_nomg(tsv);
6671 SvCUR_set(sv,append);
6674 goto return_string_or_null;
6679 if (PerlIO_isutf8(fp))
6682 if (IN_PERL_COMPILETIME) {
6683 /* we always read code in line mode */
6687 else if (RsSNARF(PL_rs)) {
6688 /* If it is a regular disk file use size from stat() as estimate
6689 of amount we are going to read -- may result in mallocing
6690 more memory than we really need if the layers below reduce
6691 the size we read (e.g. CRLF or a gzip layer).
6694 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6695 const Off_t offset = PerlIO_tell(fp);
6696 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6697 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6703 else if (RsRECORD(PL_rs)) {
6711 /* Grab the size of the record we're getting */
6712 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
6713 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6716 /* VMS wants read instead of fread, because fread doesn't respect */
6717 /* RMS record boundaries. This is not necessarily a good thing to be */
6718 /* doing, but we've got no other real choice - except avoid stdio
6719 as implementation - perhaps write a :vms layer ?
6721 fd = PerlIO_fileno(fp);
6722 if (fd == -1) { /* in-memory file from PerlIO::Scalar */
6723 bytesread = PerlIO_read(fp, buffer, recsize);
6726 bytesread = PerlLIO_read(fd, buffer, recsize);
6729 bytesread = PerlIO_read(fp, buffer, recsize);
6733 SvCUR_set(sv, bytesread + append);
6734 buffer[bytesread] = '\0';
6735 goto return_string_or_null;
6737 else if (RsPARA(PL_rs)) {
6743 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6744 if (PerlIO_isutf8(fp)) {
6745 rsptr = SvPVutf8(PL_rs, rslen);
6748 if (SvUTF8(PL_rs)) {
6749 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6750 Perl_croak(aTHX_ "Wide character in $/");
6753 rsptr = SvPV_const(PL_rs, rslen);
6757 rslast = rslen ? rsptr[rslen - 1] : '\0';
6759 if (rspara) { /* have to do this both before and after */
6760 do { /* to make sure file boundaries work right */
6763 i = PerlIO_getc(fp);
6767 PerlIO_ungetc(fp,i);
6773 /* See if we know enough about I/O mechanism to cheat it ! */
6775 /* This used to be #ifdef test - it is made run-time test for ease
6776 of abstracting out stdio interface. One call should be cheap
6777 enough here - and may even be a macro allowing compile
6781 if (PerlIO_fast_gets(fp)) {
6784 * We're going to steal some values from the stdio struct
6785 * and put EVERYTHING in the innermost loop into registers.
6787 register STDCHAR *ptr;
6791 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6792 /* An ungetc()d char is handled separately from the regular
6793 * buffer, so we getc() it back out and stuff it in the buffer.
6795 i = PerlIO_getc(fp);
6796 if (i == EOF) return 0;
6797 *(--((*fp)->_ptr)) = (unsigned char) i;
6801 /* Here is some breathtakingly efficient cheating */
6803 cnt = PerlIO_get_cnt(fp); /* get count into register */
6804 /* make sure we have the room */
6805 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
6806 /* Not room for all of it
6807 if we are looking for a separator and room for some
6809 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
6810 /* just process what we have room for */
6811 shortbuffered = cnt - SvLEN(sv) + append + 1;
6812 cnt -= shortbuffered;
6816 /* remember that cnt can be negative */
6817 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
6822 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
6823 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
6824 DEBUG_P(PerlIO_printf(Perl_debug_log,
6825 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6826 DEBUG_P(PerlIO_printf(Perl_debug_log,
6827 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6828 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6829 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6834 while (cnt > 0) { /* this | eat */
6836 if ((*bp++ = *ptr++) == rslast) /* really | dust */
6837 goto thats_all_folks; /* screams | sed :-) */
6841 Copy(ptr, bp, cnt, char); /* this | eat */
6842 bp += cnt; /* screams | dust */
6843 ptr += cnt; /* louder | sed :-) */
6848 if (shortbuffered) { /* oh well, must extend */
6849 cnt = shortbuffered;
6851 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6853 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6854 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6858 DEBUG_P(PerlIO_printf(Perl_debug_log,
6859 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6860 PTR2UV(ptr),(long)cnt));
6861 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6863 DEBUG_P(PerlIO_printf(Perl_debug_log,
6864 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6865 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6866 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6868 /* This used to call 'filbuf' in stdio form, but as that behaves like
6869 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6870 another abstraction. */
6871 i = PerlIO_getc(fp); /* get more characters */
6873 DEBUG_P(PerlIO_printf(Perl_debug_log,
6874 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6875 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6876 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6878 cnt = PerlIO_get_cnt(fp);
6879 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
6880 DEBUG_P(PerlIO_printf(Perl_debug_log,
6881 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6883 if (i == EOF) /* all done for ever? */
6884 goto thats_really_all_folks;
6886 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6888 SvGROW(sv, bpx + cnt + 2);
6889 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6891 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
6893 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
6894 goto thats_all_folks;
6898 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
6899 memNE((char*)bp - rslen, rsptr, rslen))
6900 goto screamer; /* go back to the fray */
6901 thats_really_all_folks:
6903 cnt += shortbuffered;
6904 DEBUG_P(PerlIO_printf(Perl_debug_log,
6905 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6906 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
6907 DEBUG_P(PerlIO_printf(Perl_debug_log,
6908 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6909 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6910 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6912 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
6913 DEBUG_P(PerlIO_printf(Perl_debug_log,
6914 "Screamer: done, len=%ld, string=|%.*s|\n",
6915 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
6919 /*The big, slow, and stupid way. */
6920 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
6921 STDCHAR *buf = NULL;
6922 Newx(buf, 8192, STDCHAR);
6930 register const STDCHAR * const bpe = buf + sizeof(buf);
6932 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6933 ; /* keep reading */
6937 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6938 /* Accomodate broken VAXC compiler, which applies U8 cast to
6939 * both args of ?: operator, causing EOF to change into 255
6942 i = (U8)buf[cnt - 1];
6948 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
6950 sv_catpvn(sv, (char *) buf, cnt);
6952 sv_setpvn(sv, (char *) buf, cnt);
6954 if (i != EOF && /* joy */
6956 SvCUR(sv) < rslen ||
6957 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6961 * If we're reading from a TTY and we get a short read,
6962 * indicating that the user hit his EOF character, we need
6963 * to notice it now, because if we try to read from the TTY
6964 * again, the EOF condition will disappear.
6966 * The comparison of cnt to sizeof(buf) is an optimization
6967 * that prevents unnecessary calls to feof().
6971 if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
6975 #ifdef USE_HEAP_INSTEAD_OF_STACK
6980 if (rspara) { /* have to do this both before and after */
6981 while (i != EOF) { /* to make sure file boundaries work right */
6982 i = PerlIO_getc(fp);
6984 PerlIO_ungetc(fp,i);
6990 return_string_or_null:
6991 return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
6997 Auto-increment of the value in the SV, doing string to numeric conversion
6998 if necessary. Handles 'get' magic.
7004 Perl_sv_inc(pTHX_ register SV *const sv)
7013 if (SvTHINKFIRST(sv)) {
7015 sv_force_normal_flags(sv, 0);
7016 if (SvREADONLY(sv)) {
7017 if (IN_PERL_RUNTIME)
7018 Perl_croak(aTHX_ PL_no_modify);
7022 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7024 i = PTR2IV(SvRV(sv));
7029 flags = SvFLAGS(sv);
7030 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7031 /* It's (privately or publicly) a float, but not tested as an
7032 integer, so test it to see. */
7034 flags = SvFLAGS(sv);
7036 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7037 /* It's publicly an integer, or privately an integer-not-float */
7038 #ifdef PERL_PRESERVE_IVUV
7042 if (SvUVX(sv) == UV_MAX)
7043 sv_setnv(sv, UV_MAX_P1);
7045 (void)SvIOK_only_UV(sv);
7046 SvUV_set(sv, SvUVX(sv) + 1);
7048 if (SvIVX(sv) == IV_MAX)
7049 sv_setuv(sv, (UV)IV_MAX + 1);
7051 (void)SvIOK_only(sv);
7052 SvIV_set(sv, SvIVX(sv) + 1);
7057 if (flags & SVp_NOK) {
7058 const NV was = SvNVX(sv);
7059 if (NV_OVERFLOWS_INTEGERS_AT &&
7060 was >= NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
7061 Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
7062 "Lost precision when incrementing %" NVff " by 1",
7065 (void)SvNOK_only(sv);
7066 SvNV_set(sv, was + 1.0);
7070 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
7071 if ((flags & SVTYPEMASK) < SVt_PVIV)
7072 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
7073 (void)SvIOK_only(sv);
7078 while (isALPHA(*d)) d++;
7079 while (isDIGIT(*d)) d++;
7081 #ifdef PERL_PRESERVE_IVUV
7082 /* Got to punt this as an integer if needs be, but we don't issue
7083 warnings. Probably ought to make the sv_iv_please() that does
7084 the conversion if possible, and silently. */
7085 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7086 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7087 /* Need to try really hard to see if it's an integer.
7088 9.22337203685478e+18 is an integer.
7089 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7090 so $a="9.22337203685478e+18"; $a+0; $a++
7091 needs to be the same as $a="9.22337203685478e+18"; $a++
7098 /* sv_2iv *should* have made this an NV */
7099 if (flags & SVp_NOK) {
7100 (void)SvNOK_only(sv);
7101 SvNV_set(sv, SvNVX(sv) + 1.0);
7104 /* I don't think we can get here. Maybe I should assert this
7105 And if we do get here I suspect that sv_setnv will croak. NWC
7107 #if defined(USE_LONG_DOUBLE)
7108 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",
7109 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7111 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7112 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7115 #endif /* PERL_PRESERVE_IVUV */
7116 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
7120 while (d >= SvPVX_const(sv)) {
7128 /* MKS: The original code here died if letters weren't consecutive.
7129 * at least it didn't have to worry about non-C locales. The
7130 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7131 * arranged in order (although not consecutively) and that only
7132 * [A-Za-z] are accepted by isALPHA in the C locale.
7134 if (*d != 'z' && *d != 'Z') {
7135 do { ++*d; } while (!isALPHA(*d));
7138 *(d--) -= 'z' - 'a';
7143 *(d--) -= 'z' - 'a' + 1;
7147 /* oh,oh, the number grew */
7148 SvGROW(sv, SvCUR(sv) + 2);
7149 SvCUR_set(sv, SvCUR(sv) + 1);
7150 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7161 Auto-decrement of the value in the SV, doing string to numeric conversion
7162 if necessary. Handles 'get' magic.
7168 Perl_sv_dec(pTHX_ register SV *const sv)
7176 if (SvTHINKFIRST(sv)) {
7178 sv_force_normal_flags(sv, 0);
7179 if (SvREADONLY(sv)) {
7180 if (IN_PERL_RUNTIME)
7181 Perl_croak(aTHX_ PL_no_modify);
7185 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7187 i = PTR2IV(SvRV(sv));
7192 /* Unlike sv_inc we don't have to worry about string-never-numbers
7193 and keeping them magic. But we mustn't warn on punting */
7194 flags = SvFLAGS(sv);
7195 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7196 /* It's publicly an integer, or privately an integer-not-float */
7197 #ifdef PERL_PRESERVE_IVUV
7201 if (SvUVX(sv) == 0) {
7202 (void)SvIOK_only(sv);
7206 (void)SvIOK_only_UV(sv);
7207 SvUV_set(sv, SvUVX(sv) - 1);
7210 if (SvIVX(sv) == IV_MIN) {
7211 sv_setnv(sv, (NV)IV_MIN);
7215 (void)SvIOK_only(sv);
7216 SvIV_set(sv, SvIVX(sv) - 1);
7221 if (flags & SVp_NOK) {
7224 const NV was = SvNVX(sv);
7225 if (NV_OVERFLOWS_INTEGERS_AT &&
7226 was <= -NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
7227 Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
7228 "Lost precision when decrementing %" NVff " by 1",
7231 (void)SvNOK_only(sv);
7232 SvNV_set(sv, was - 1.0);
7236 if (!(flags & SVp_POK)) {
7237 if ((flags & SVTYPEMASK) < SVt_PVIV)
7238 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
7240 (void)SvIOK_only(sv);
7243 #ifdef PERL_PRESERVE_IVUV
7245 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7246 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7247 /* Need to try really hard to see if it's an integer.
7248 9.22337203685478e+18 is an integer.
7249 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7250 so $a="9.22337203685478e+18"; $a+0; $a--
7251 needs to be the same as $a="9.22337203685478e+18"; $a--
7258 /* sv_2iv *should* have made this an NV */
7259 if (flags & SVp_NOK) {
7260 (void)SvNOK_only(sv);
7261 SvNV_set(sv, SvNVX(sv) - 1.0);
7264 /* I don't think we can get here. Maybe I should assert this
7265 And if we do get here I suspect that sv_setnv will croak. NWC
7267 #if defined(USE_LONG_DOUBLE)
7268 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",
7269 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7271 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7272 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7276 #endif /* PERL_PRESERVE_IVUV */
7277 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
7281 =for apidoc sv_mortalcopy
7283 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7284 The new SV is marked as mortal. It will be destroyed "soon", either by an
7285 explicit call to FREETMPS, or by an implicit call at places such as
7286 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7291 /* Make a string that will exist for the duration of the expression
7292 * evaluation. Actually, it may have to last longer than that, but
7293 * hopefully we won't free it until it has been assigned to a
7294 * permanent location. */
7297 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
7303 sv_setsv(sv,oldstr);
7305 PL_tmps_stack[++PL_tmps_ix] = sv;
7311 =for apidoc sv_newmortal
7313 Creates a new null SV which is mortal. The reference count of the SV is
7314 set to 1. It will be destroyed "soon", either by an explicit call to
7315 FREETMPS, or by an implicit call at places such as statement boundaries.
7316 See also C<sv_mortalcopy> and C<sv_2mortal>.
7322 Perl_sv_newmortal(pTHX)
7328 SvFLAGS(sv) = SVs_TEMP;
7330 PL_tmps_stack[++PL_tmps_ix] = sv;
7336 =for apidoc newSVpvn_flags
7338 Creates a new SV and copies a string into it. The reference count for the
7339 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7340 string. You are responsible for ensuring that the source string is at least
7341 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7342 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
7343 If C<SVs_TEMP> is set, then C<sv2mortal()> is called on the result before
7344 returning. If C<SVf_UTF8> is set, then it will be set on the new SV.
7345 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
7347 #define newSVpvn_utf8(s, len, u) \
7348 newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
7354 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
7359 /* All the flags we don't support must be zero.
7360 And we're new code so I'm going to assert this from the start. */
7361 assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
7363 sv_setpvn(sv,s,len);
7364 SvFLAGS(sv) |= (flags & SVf_UTF8);
7365 return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv;
7369 =for apidoc sv_2mortal
7371 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7372 by an explicit call to FREETMPS, or by an implicit call at places such as
7373 statement boundaries. SvTEMP() is turned on which means that the SV's
7374 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7375 and C<sv_mortalcopy>.
7381 Perl_sv_2mortal(pTHX_ register SV *const sv)
7386 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7389 PL_tmps_stack[++PL_tmps_ix] = sv;
7397 Creates a new SV and copies a string into it. The reference count for the
7398 SV is set to 1. If C<len> is zero, Perl will compute the length using
7399 strlen(). For efficiency, consider using C<newSVpvn> instead.
7405 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
7411 sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
7416 =for apidoc newSVpvn
7418 Creates a new SV and copies a string into it. The reference count for the
7419 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7420 string. You are responsible for ensuring that the source string is at least
7421 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7427 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
7433 sv_setpvn(sv,s,len);
7438 =for apidoc newSVhek
7440 Creates a new SV from the hash key structure. It will generate scalars that
7441 point to the shared string table where possible. Returns a new (undefined)
7442 SV if the hek is NULL.
7448 Perl_newSVhek(pTHX_ const HEK *const hek)
7458 if (HEK_LEN(hek) == HEf_SVKEY) {
7459 return newSVsv(*(SV**)HEK_KEY(hek));
7461 const int flags = HEK_FLAGS(hek);
7462 if (flags & HVhek_WASUTF8) {
7464 Andreas would like keys he put in as utf8 to come back as utf8
7466 STRLEN utf8_len = HEK_LEN(hek);
7467 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7468 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
7471 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7473 } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
7474 /* We don't have a pointer to the hv, so we have to replicate the
7475 flag into every HEK. This hv is using custom a hasing
7476 algorithm. Hence we can't return a shared string scalar, as
7477 that would contain the (wrong) hash value, and might get passed
7478 into an hv routine with a regular hash.
7479 Similarly, a hash that isn't using shared hash keys has to have
7480 the flag in every key so that we know not to try to call
7481 share_hek_kek on it. */
7483 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7488 /* This will be overwhelminly the most common case. */
7490 /* Inline most of newSVpvn_share(), because share_hek_hek() is far
7491 more efficient than sharepvn(). */
7495 sv_upgrade(sv, SVt_PV);
7496 SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
7497 SvCUR_set(sv, HEK_LEN(hek));
7510 =for apidoc newSVpvn_share
7512 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7513 table. If the string does not already exist in the table, it is created
7514 first. Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
7515 value is used; otherwise the hash is computed. The string's hash can be later
7516 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
7517 that as the string table is used for shared hash keys these strings will have
7518 SvPVX_const == HeKEY and hash lookup will avoid string compare.
7524 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7528 bool is_utf8 = FALSE;
7529 const char *const orig_src = src;
7532 STRLEN tmplen = -len;
7534 /* See the note in hv.c:hv_fetch() --jhi */
7535 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7539 PERL_HASH(hash, src, len);
7541 /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it
7542 changes here, update it there too. */
7543 sv_upgrade(sv, SVt_PV);
7544 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7552 if (src != orig_src)
7558 #if defined(PERL_IMPLICIT_CONTEXT)
7560 /* pTHX_ magic can't cope with varargs, so this is a no-context
7561 * version of the main function, (which may itself be aliased to us).
7562 * Don't access this version directly.
7566 Perl_newSVpvf_nocontext(const char *const pat, ...)
7572 PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
7574 va_start(args, pat);
7575 sv = vnewSVpvf(pat, &args);
7582 =for apidoc newSVpvf
7584 Creates a new SV and initializes it with the string formatted like
7591 Perl_newSVpvf(pTHX_ const char *const pat, ...)
7596 PERL_ARGS_ASSERT_NEWSVPVF;
7598 va_start(args, pat);
7599 sv = vnewSVpvf(pat, &args);
7604 /* backend for newSVpvf() and newSVpvf_nocontext() */
7607 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
7612 PERL_ARGS_ASSERT_VNEWSVPVF;
7615 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7622 Creates a new SV and copies a floating point value into it.
7623 The reference count for the SV is set to 1.
7629 Perl_newSVnv(pTHX_ const NV n)
7642 Creates a new SV and copies an integer into it. The reference count for the
7649 Perl_newSViv(pTHX_ const IV i)
7662 Creates a new SV and copies an unsigned integer into it.
7663 The reference count for the SV is set to 1.
7669 Perl_newSVuv(pTHX_ const UV u)
7680 =for apidoc newSV_type
7682 Creates a new SV, of the type specified. The reference count for the new SV
7689 Perl_newSV_type(pTHX_ const svtype type)
7694 sv_upgrade(sv, type);
7699 =for apidoc newRV_noinc
7701 Creates an RV wrapper for an SV. The reference count for the original
7702 SV is B<not> incremented.
7708 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
7711 register SV *sv = newSV_type(SVt_IV);
7713 PERL_ARGS_ASSERT_NEWRV_NOINC;
7716 SvRV_set(sv, tmpRef);
7721 /* newRV_inc is the official function name to use now.
7722 * newRV_inc is in fact #defined to newRV in sv.h
7726 Perl_newRV(pTHX_ SV *const sv)
7730 PERL_ARGS_ASSERT_NEWRV;
7732 return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
7738 Creates a new SV which is an exact duplicate of the original SV.
7745 Perl_newSVsv(pTHX_ register SV *const old)
7752 if (SvTYPE(old) == SVTYPEMASK) {
7753 if (ckWARN_d(WARN_INTERNAL))
7754 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7758 /* SV_GMAGIC is the default for sv_setv()
7759 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7760 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7761 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7766 =for apidoc sv_reset
7768 Underlying implementation for the C<reset> Perl function.
7769 Note that the perl-level function is vaguely deprecated.
7775 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
7778 char todo[PERL_UCHAR_MAX+1];
7780 PERL_ARGS_ASSERT_SV_RESET;
7785 if (!*s) { /* reset ?? searches */
7786 MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
7788 const U32 count = mg->mg_len / sizeof(PMOP**);
7789 PMOP **pmp = (PMOP**) mg->mg_ptr;
7790 PMOP *const *const end = pmp + count;
7794 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
7796 (*pmp)->op_pmflags &= ~PMf_USED;
7804 /* reset variables */
7806 if (!HvARRAY(stash))
7809 Zero(todo, 256, char);
7812 I32 i = (unsigned char)*s;
7816 max = (unsigned char)*s++;
7817 for ( ; i <= max; i++) {
7820 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7822 for (entry = HvARRAY(stash)[i];
7824 entry = HeNEXT(entry))
7829 if (!todo[(U8)*HeKEY(entry)])
7831 gv = (GV*)HeVAL(entry);
7834 if (SvTHINKFIRST(sv)) {
7835 if (!SvREADONLY(sv) && SvROK(sv))
7837 /* XXX Is this continue a bug? Why should THINKFIRST
7838 exempt us from resetting arrays and hashes? */
7842 if (SvTYPE(sv) >= SVt_PV) {
7844 if (SvPVX_const(sv) != NULL)
7852 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
7854 Perl_die(aTHX_ "Can't reset %%ENV on this system");
7857 # if defined(USE_ENVIRON_ARRAY)
7860 # endif /* USE_ENVIRON_ARRAY */
7871 Using various gambits, try to get an IO from an SV: the IO slot if its a
7872 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7873 named after the PV if we're a string.
7879 Perl_sv_2io(pTHX_ SV *const sv)
7884 PERL_ARGS_ASSERT_SV_2IO;
7886 switch (SvTYPE(sv)) {
7891 if (isGV_with_GP(sv)) {
7895 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7901 Perl_croak(aTHX_ PL_no_usym, "filehandle");
7903 return sv_2io(SvRV(sv));
7904 gv = gv_fetchsv(sv, 0, SVt_PVIO);
7910 Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
7919 Using various gambits, try to get a CV from an SV; in addition, try if
7920 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7921 The flags in C<lref> are passed to sv_fetchsv.
7927 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
7933 PERL_ARGS_ASSERT_SV_2CV;
7940 switch (SvTYPE(sv)) {
7951 if (isGV_with_GP(sv)) {
7961 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
7963 tryAMAGICunDEREF(to_cv);
7966 if (SvTYPE(sv) == SVt_PVCV) {
7972 else if(isGV_with_GP(sv))
7975 Perl_croak(aTHX_ "Not a subroutine reference");
7977 else if (isGV_with_GP(sv)) {
7982 gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */
7988 /* Some flags to gv_fetchsv mean don't really create the GV */
7989 if (!isGV_with_GP(gv)) {
7995 if (lref && !GvCVu(gv)) {
7999 gv_efullname3(tmpsv, gv, NULL);
8000 /* XXX this is probably not what they think they're getting.
8001 * It has the same effect as "sub name;", i.e. just a forward
8003 newSUB(start_subparse(FALSE, 0),
8004 newSVOP(OP_CONST, 0, tmpsv),
8008 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8009 SVfARG(SvOK(sv) ? sv : &PL_sv_no));
8018 Returns true if the SV has a true value by Perl's rules.
8019 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8020 instead use an in-line version.
8026 Perl_sv_true(pTHX_ register SV *const sv)
8031 register const XPV* const tXpv = (XPV*)SvANY(sv);
8033 (tXpv->xpv_cur > 1 ||
8034 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
8041 return SvIVX(sv) != 0;
8044 return SvNVX(sv) != 0.0;
8046 return sv_2bool(sv);
8052 =for apidoc sv_pvn_force
8054 Get a sensible string out of the SV somehow.
8055 A private implementation of the C<SvPV_force> macro for compilers which
8056 can't cope with complex macro expressions. Always use the macro instead.
8058 =for apidoc sv_pvn_force_flags
8060 Get a sensible string out of the SV somehow.
8061 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8062 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8063 implemented in terms of this function.
8064 You normally want to use the various wrapper macros instead: see
8065 C<SvPV_force> and C<SvPV_force_nomg>
8071 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
8075 PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
8077 if (SvTHINKFIRST(sv) && !SvROK(sv))
8078 sv_force_normal_flags(sv, 0);
8088 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
8089 const char * const ref = sv_reftype(sv,0);
8091 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
8092 ref, OP_NAME(PL_op));
8094 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
8096 if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
8097 || isGV_with_GP(sv))
8098 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8100 s = sv_2pv_flags(sv, &len, flags);
8104 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
8107 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
8108 SvGROW(sv, len + 1);
8109 Move(s,SvPVX(sv),len,char);
8111 SvPVX(sv)[len] = '\0';
8114 SvPOK_on(sv); /* validate pointer */
8116 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8117 PTR2UV(sv),SvPVX_const(sv)));
8120 return SvPVX_mutable(sv);
8124 =for apidoc sv_pvbyten_force
8126 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
8132 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
8134 PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
8136 sv_pvn_force(sv,lp);
8137 sv_utf8_downgrade(sv,0);
8143 =for apidoc sv_pvutf8n_force
8145 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
8151 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
8153 PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
8155 sv_pvn_force(sv,lp);
8156 sv_utf8_upgrade(sv);
8162 =for apidoc sv_reftype
8164 Returns a string describing what the SV is a reference to.
8170 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
8172 PERL_ARGS_ASSERT_SV_REFTYPE;
8174 /* The fact that I don't need to downcast to char * everywhere, only in ?:
8175 inside return suggests a const propagation bug in g++. */
8176 if (ob && SvOBJECT(sv)) {
8177 char * const name = HvNAME_get(SvSTASH(sv));
8178 return name ? name : (char *) "__ANON__";
8181 switch (SvTYPE(sv)) {
8196 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
8197 /* tied lvalues should appear to be
8198 * scalars for backwards compatitbility */
8199 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8200 ? "SCALAR" : "LVALUE");
8201 case SVt_PVAV: return "ARRAY";
8202 case SVt_PVHV: return "HASH";
8203 case SVt_PVCV: return "CODE";
8204 case SVt_PVGV: return (char *) (isGV_with_GP(sv)
8205 ? "GLOB" : "SCALAR");
8206 case SVt_PVFM: return "FORMAT";
8207 case SVt_PVIO: return "IO";
8208 case SVt_BIND: return "BIND";
8209 case SVt_REGEXP: return "REGEXP";
8210 default: return "UNKNOWN";
8216 =for apidoc sv_isobject
8218 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8219 object. If the SV is not an RV, or if the object is not blessed, then this
8226 Perl_sv_isobject(pTHX_ SV *sv)
8242 Returns a boolean indicating whether the SV is blessed into the specified
8243 class. This does not check for subtypes; use C<sv_derived_from> to verify
8244 an inheritance relationship.
8250 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
8254 PERL_ARGS_ASSERT_SV_ISA;
8264 hvname = HvNAME_get(SvSTASH(sv));
8268 return strEQ(hvname, name);
8274 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
8275 it will be upgraded to one. If C<classname> is non-null then the new SV will
8276 be blessed in the specified package. The new SV is returned and its
8277 reference count is 1.
8283 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
8288 PERL_ARGS_ASSERT_NEWSVRV;
8292 SV_CHECK_THINKFIRST_COW_DROP(rv);
8293 (void)SvAMAGIC_off(rv);
8295 if (SvTYPE(rv) >= SVt_PVMG) {
8296 const U32 refcnt = SvREFCNT(rv);
8300 SvREFCNT(rv) = refcnt;
8302 sv_upgrade(rv, SVt_IV);
8303 } else if (SvROK(rv)) {
8304 SvREFCNT_dec(SvRV(rv));
8306 prepare_SV_for_RV(rv);
8314 HV* const stash = gv_stashpv(classname, GV_ADD);
8315 (void)sv_bless(rv, stash);
8321 =for apidoc sv_setref_pv
8323 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
8324 argument will be upgraded to an RV. That RV will be modified to point to
8325 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8326 into the SV. The C<classname> argument indicates the package for the
8327 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8328 will have a reference count of 1, and the RV will be returned.
8330 Do not use with other Perl types such as HV, AV, SV, CV, because those
8331 objects will become corrupted by the pointer copy process.
8333 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8339 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
8343 PERL_ARGS_ASSERT_SV_SETREF_PV;
8346 sv_setsv(rv, &PL_sv_undef);
8350 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8355 =for apidoc sv_setref_iv
8357 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
8358 argument will be upgraded to an RV. That RV will be modified to point to
8359 the new SV. The C<classname> argument indicates the package for the
8360 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8361 will have a reference count of 1, and the RV will be returned.
8367 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
8369 PERL_ARGS_ASSERT_SV_SETREF_IV;
8371 sv_setiv(newSVrv(rv,classname), iv);
8376 =for apidoc sv_setref_uv
8378 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
8379 argument will be upgraded to an RV. That RV will be modified to point to
8380 the new SV. The C<classname> argument indicates the package for the
8381 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8382 will have a reference count of 1, and the RV will be returned.
8388 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
8390 PERL_ARGS_ASSERT_SV_SETREF_UV;
8392 sv_setuv(newSVrv(rv,classname), uv);
8397 =for apidoc sv_setref_nv
8399 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8400 argument will be upgraded to an RV. That RV will be modified to point to
8401 the new SV. The C<classname> argument indicates the package for the
8402 blessing. Set C<classname> to C<NULL> to avoid the blessing. The new SV
8403 will have a reference count of 1, and the RV will be returned.
8409 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
8411 PERL_ARGS_ASSERT_SV_SETREF_NV;
8413 sv_setnv(newSVrv(rv,classname), nv);
8418 =for apidoc sv_setref_pvn
8420 Copies a string into a new SV, optionally blessing the SV. The length of the
8421 string must be specified with C<n>. The C<rv> argument will be upgraded to
8422 an RV. That RV will be modified to point to the new SV. The C<classname>
8423 argument indicates the package for the blessing. Set C<classname> to
8424 C<NULL> to avoid the blessing. The new SV will have a reference count
8425 of 1, and the RV will be returned.
8427 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8433 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
8434 const char *const pv, const STRLEN n)
8436 PERL_ARGS_ASSERT_SV_SETREF_PVN;
8438 sv_setpvn(newSVrv(rv,classname), pv, n);
8443 =for apidoc sv_bless
8445 Blesses an SV into a specified package. The SV must be an RV. The package
8446 must be designated by its stash (see C<gv_stashpv()>). The reference count
8447 of the SV is unaffected.
8453 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
8458 PERL_ARGS_ASSERT_SV_BLESS;
8461 Perl_croak(aTHX_ "Can't bless non-reference value");
8463 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8464 if (SvIsCOW(tmpRef))
8465 sv_force_normal_flags(tmpRef, 0);
8466 if (SvREADONLY(tmpRef))
8467 Perl_croak(aTHX_ PL_no_modify);
8468 if (SvOBJECT(tmpRef)) {
8469 if (SvTYPE(tmpRef) != SVt_PVIO)
8471 SvREFCNT_dec(SvSTASH(tmpRef));
8474 SvOBJECT_on(tmpRef);
8475 if (SvTYPE(tmpRef) != SVt_PVIO)
8477 SvUPGRADE(tmpRef, SVt_PVMG);
8478 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc_simple(stash));
8483 (void)SvAMAGIC_off(sv);
8485 if(SvSMAGICAL(tmpRef))
8486 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8494 /* Downgrades a PVGV to a PVMG.
8498 S_sv_unglob(pTHX_ SV *const sv)
8503 SV * const temp = sv_newmortal();
8505 PERL_ARGS_ASSERT_SV_UNGLOB;
8507 assert(SvTYPE(sv) == SVt_PVGV);
8509 gv_efullname3(temp, (GV *) sv, "*");
8512 if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash))
8513 mro_method_changed_in(stash);
8517 sv_del_backref((SV*)GvSTASH(sv), sv);
8521 if (GvNAME_HEK(sv)) {
8522 unshare_hek(GvNAME_HEK(sv));
8524 isGV_with_GP_off(sv);
8526 /* need to keep SvANY(sv) in the right arena */
8527 xpvmg = new_XPVMG();
8528 StructCopy(SvANY(sv), xpvmg, XPVMG);
8529 del_XPVGV(SvANY(sv));
8532 SvFLAGS(sv) &= ~SVTYPEMASK;
8533 SvFLAGS(sv) |= SVt_PVMG;
8535 /* Intentionally not calling any local SET magic, as this isn't so much a
8536 set operation as merely an internal storage change. */
8537 sv_setsv_flags(sv, temp, 0);
8541 =for apidoc sv_unref_flags
8543 Unsets the RV status of the SV, and decrements the reference count of
8544 whatever was being referenced by the RV. This can almost be thought of
8545 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8546 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8547 (otherwise the decrementing is conditional on the reference count being
8548 different from one or the reference being a readonly SV).
8555 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
8557 SV* const target = SvRV(ref);
8559 PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
8561 if (SvWEAKREF(ref)) {
8562 sv_del_backref(target, ref);
8564 SvRV_set(ref, NULL);
8567 SvRV_set(ref, NULL);
8569 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
8570 assigned to as BEGIN {$a = \"Foo"} will fail. */
8571 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
8572 SvREFCNT_dec(target);
8573 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8574 sv_2mortal(target); /* Schedule for freeing later */
8578 =for apidoc sv_untaint
8580 Untaint an SV. Use C<SvTAINTED_off> instead.
8585 Perl_sv_untaint(pTHX_ SV *const sv)
8587 PERL_ARGS_ASSERT_SV_UNTAINT;
8589 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8590 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8597 =for apidoc sv_tainted
8599 Test an SV for taintedness. Use C<SvTAINTED> instead.
8604 Perl_sv_tainted(pTHX_ SV *const sv)
8606 PERL_ARGS_ASSERT_SV_TAINTED;
8608 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8609 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8610 if (mg && (mg->mg_len & 1) )
8617 =for apidoc sv_setpviv
8619 Copies an integer into the given SV, also updating its string value.
8620 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8626 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
8628 char buf[TYPE_CHARS(UV)];
8630 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8632 PERL_ARGS_ASSERT_SV_SETPVIV;
8634 sv_setpvn(sv, ptr, ebuf - ptr);
8638 =for apidoc sv_setpviv_mg
8640 Like C<sv_setpviv>, but also handles 'set' magic.
8646 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
8648 PERL_ARGS_ASSERT_SV_SETPVIV_MG;
8654 #if defined(PERL_IMPLICIT_CONTEXT)
8656 /* pTHX_ magic can't cope with varargs, so this is a no-context
8657 * version of the main function, (which may itself be aliased to us).
8658 * Don't access this version directly.
8662 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
8667 PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
8669 va_start(args, pat);
8670 sv_vsetpvf(sv, pat, &args);
8674 /* pTHX_ magic can't cope with varargs, so this is a no-context
8675 * version of the main function, (which may itself be aliased to us).
8676 * Don't access this version directly.
8680 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
8685 PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
8687 va_start(args, pat);
8688 sv_vsetpvf_mg(sv, pat, &args);
8694 =for apidoc sv_setpvf
8696 Works like C<sv_catpvf> but copies the text into the SV instead of
8697 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8703 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
8707 PERL_ARGS_ASSERT_SV_SETPVF;
8709 va_start(args, pat);
8710 sv_vsetpvf(sv, pat, &args);
8715 =for apidoc sv_vsetpvf
8717 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8718 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8720 Usually used via its frontend C<sv_setpvf>.
8726 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8728 PERL_ARGS_ASSERT_SV_VSETPVF;
8730 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8734 =for apidoc sv_setpvf_mg
8736 Like C<sv_setpvf>, but also handles 'set' magic.
8742 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
8746 PERL_ARGS_ASSERT_SV_SETPVF_MG;
8748 va_start(args, pat);
8749 sv_vsetpvf_mg(sv, pat, &args);
8754 =for apidoc sv_vsetpvf_mg
8756 Like C<sv_vsetpvf>, but also handles 'set' magic.
8758 Usually used via its frontend C<sv_setpvf_mg>.
8764 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8766 PERL_ARGS_ASSERT_SV_VSETPVF_MG;
8768 sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8772 #if defined(PERL_IMPLICIT_CONTEXT)
8774 /* pTHX_ magic can't cope with varargs, so this is a no-context
8775 * version of the main function, (which may itself be aliased to us).
8776 * Don't access this version directly.
8780 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
8785 PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
8787 va_start(args, pat);
8788 sv_vcatpvf(sv, pat, &args);
8792 /* pTHX_ magic can't cope with varargs, so this is a no-context
8793 * version of the main function, (which may itself be aliased to us).
8794 * Don't access this version directly.
8798 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
8803 PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
8805 va_start(args, pat);
8806 sv_vcatpvf_mg(sv, pat, &args);
8812 =for apidoc sv_catpvf
8814 Processes its arguments like C<sprintf> and appends the formatted
8815 output to an SV. If the appended data contains "wide" characters
8816 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8817 and characters >255 formatted with %c), the original SV might get
8818 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
8819 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
8820 valid UTF-8; if the original SV was bytes, the pattern should be too.
8825 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
8829 PERL_ARGS_ASSERT_SV_CATPVF;
8831 va_start(args, pat);
8832 sv_vcatpvf(sv, pat, &args);
8837 =for apidoc sv_vcatpvf
8839 Processes its arguments like C<vsprintf> and appends the formatted output
8840 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
8842 Usually used via its frontend C<sv_catpvf>.
8848 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8850 PERL_ARGS_ASSERT_SV_VCATPVF;
8852 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8856 =for apidoc sv_catpvf_mg
8858 Like C<sv_catpvf>, but also handles 'set' magic.
8864 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
8868 PERL_ARGS_ASSERT_SV_CATPVF_MG;
8870 va_start(args, pat);
8871 sv_vcatpvf_mg(sv, pat, &args);
8876 =for apidoc sv_vcatpvf_mg
8878 Like C<sv_vcatpvf>, but also handles 'set' magic.
8880 Usually used via its frontend C<sv_catpvf_mg>.
8886 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8888 PERL_ARGS_ASSERT_SV_VCATPVF_MG;
8890 sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8895 =for apidoc sv_vsetpvfn
8897 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
8900 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
8906 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
8907 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
8909 PERL_ARGS_ASSERT_SV_VSETPVFN;
8911 sv_setpvn(sv, "", 0);
8912 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8916 S_expect_number(pTHX_ char **const pattern)
8921 PERL_ARGS_ASSERT_EXPECT_NUMBER;
8923 switch (**pattern) {
8924 case '1': case '2': case '3':
8925 case '4': case '5': case '6':
8926 case '7': case '8': case '9':
8927 var = *(*pattern)++ - '0';
8928 while (isDIGIT(**pattern)) {
8929 const I32 tmp = var * 10 + (*(*pattern)++ - '0');
8931 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn"));
8939 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
8941 const int neg = nv < 0;
8944 PERL_ARGS_ASSERT_F0CONVERT;
8952 if (uv & 1 && uv == nv)
8953 uv--; /* Round to even */
8955 const unsigned dig = uv % 10;
8968 =for apidoc sv_vcatpvfn
8970 Processes its arguments like C<vsprintf> and appends the formatted output
8971 to an SV. Uses an array of SVs if the C style variable argument list is
8972 missing (NULL). When running with taint checks enabled, indicates via
8973 C<maybe_tainted> if results are untrustworthy (often due to the use of
8976 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
8982 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
8983 vecstr = (U8*)SvPV_const(vecsv,veclen);\
8984 vec_utf8 = DO_UTF8(vecsv);
8986 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
8989 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
8990 va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
8998 static const char nullstr[] = "(null)";
9000 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
9001 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
9003 /* Times 4: a decimal digit takes more than 3 binary digits.
9004 * NV_DIG: mantissa takes than many decimal digits.
9005 * Plus 32: Playing safe. */
9006 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9007 /* large enough for "%#.#f" --chip */
9008 /* what about long double NVs? --jhi */
9010 PERL_ARGS_ASSERT_SV_VCATPVFN;
9011 PERL_UNUSED_ARG(maybe_tainted);
9013 /* no matter what, this is a string now */
9014 (void)SvPV_force(sv, origlen);
9016 /* special-case "", "%s", and "%-p" (SVf - see below) */
9019 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9021 const char * const s = va_arg(*args, char*);
9022 sv_catpv(sv, s ? s : nullstr);
9024 else if (svix < svmax) {
9025 sv_catsv(sv, *svargs);
9029 if (args && patlen == 3 && pat[0] == '%' &&
9030 pat[1] == '-' && pat[2] == 'p') {
9031 argsv = (SV*)va_arg(*args, void*);
9032 sv_catsv(sv, argsv);
9036 #ifndef USE_LONG_DOUBLE
9037 /* special-case "%.<number>[gf]" */
9038 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9039 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9040 unsigned digits = 0;
9044 while (*pp >= '0' && *pp <= '9')
9045 digits = 10 * digits + (*pp++ - '0');
9046 if (pp - pat == (int)patlen - 1) {
9054 /* Add check for digits != 0 because it seems that some
9055 gconverts are buggy in this case, and we don't yet have
9056 a Configure test for this. */
9057 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9058 /* 0, point, slack */
9059 Gconvert(nv, (int)digits, 0, ebuf);
9061 if (*ebuf) /* May return an empty string for digits==0 */
9064 } else if (!digits) {
9067 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9068 sv_catpvn(sv, p, l);
9074 #endif /* !USE_LONG_DOUBLE */
9076 if (!args && svix < svmax && DO_UTF8(*svargs))
9079 patend = (char*)pat + patlen;
9080 for (p = (char*)pat; p < patend; p = q) {
9083 bool vectorize = FALSE;
9084 bool vectorarg = FALSE;
9085 bool vec_utf8 = FALSE;
9091 bool has_precis = FALSE;
9093 const I32 osvix = svix;
9094 bool is_utf8 = FALSE; /* is this item utf8? */
9095 #ifdef HAS_LDBL_SPRINTF_BUG
9096 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9097 with sfio - Allen <allens@cpan.org> */
9098 bool fix_ldbl_sprintf_bug = FALSE;
9102 U8 utf8buf[UTF8_MAXBYTES+1];
9103 STRLEN esignlen = 0;
9105 const char *eptr = NULL;
9108 const U8 *vecstr = NULL;
9115 /* we need a long double target in case HAS_LONG_DOUBLE but
9118 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9126 const char *dotstr = ".";
9127 STRLEN dotstrlen = 1;
9128 I32 efix = 0; /* explicit format parameter index */
9129 I32 ewix = 0; /* explicit width index */
9130 I32 epix = 0; /* explicit precision index */
9131 I32 evix = 0; /* explicit vector index */
9132 bool asterisk = FALSE;
9134 /* echo everything up to the next format specification */
9135 for (q = p; q < patend && *q != '%'; ++q) ;
9137 if (has_utf8 && !pat_utf8)
9138 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9140 sv_catpvn(sv, p, q - p);
9147 We allow format specification elements in this order:
9148 \d+\$ explicit format parameter index
9150 v|\*(\d+\$)?v vector with optional (optionally specified) arg
9151 0 flag (as above): repeated to allow "v02"
9152 \d+|\*(\d+\$)? width using optional (optionally specified) arg
9153 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9155 [%bcdefginopsuxDFOUX] format (mandatory)
9160 As of perl5.9.3, printf format checking is on by default.
9161 Internally, perl uses %p formats to provide an escape to
9162 some extended formatting. This block deals with those
9163 extensions: if it does not match, (char*)q is reset and
9164 the normal format processing code is used.
9166 Currently defined extensions are:
9167 %p include pointer address (standard)
9168 %-p (SVf) include an SV (previously %_)
9169 %-<num>p include an SV with precision <num>
9170 %<num>p reserved for future extensions
9172 Robin Barker 2005-07-14
9174 %1p (VDf) removed. RMB 2007-10-19
9181 n = expect_number(&q);
9188 argsv = (SV*)va_arg(*args, void*);
9189 eptr = SvPV_const(argsv, elen);
9195 if (ckWARN_d(WARN_INTERNAL))
9196 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9197 "internal %%<num>p might conflict with future printf extensions");
9203 if ( (width = expect_number(&q)) ) {
9218 if (plus == '+' && *q == ' ') /* '+' over ' ' */
9247 if ( (ewix = expect_number(&q)) )
9256 if ((vectorarg = asterisk)) {
9269 width = expect_number(&q);
9275 vecsv = va_arg(*args, SV*);
9277 vecsv = (evix > 0 && evix <= svmax)
9278 ? svargs[evix-1] : &PL_sv_undef;
9280 vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef;
9282 dotstr = SvPV_const(vecsv, dotstrlen);
9283 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
9284 bad with tied or overloaded values that return UTF8. */
9287 else if (has_utf8) {
9288 vecsv = sv_mortalcopy(vecsv);
9289 sv_utf8_upgrade(vecsv);
9290 dotstr = SvPV_const(vecsv, dotstrlen);
9297 else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
9298 vecsv = svargs[efix ? efix-1 : svix++];
9299 vecstr = (U8*)SvPV_const(vecsv,veclen);
9300 vec_utf8 = DO_UTF8(vecsv);
9302 /* if this is a version object, we need to convert
9303 * back into v-string notation and then let the
9304 * vectorize happen normally
9306 if (sv_derived_from(vecsv, "version")) {
9307 char *version = savesvpv(vecsv);
9308 if ( hv_exists((HV*)SvRV(vecsv), "alpha", 5 ) ) {
9309 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9310 "vector argument not supported with alpha versions");
9313 vecsv = sv_newmortal();
9314 scan_vstring(version, version + veclen, vecsv);
9315 vecstr = (U8*)SvPV_const(vecsv, veclen);
9316 vec_utf8 = DO_UTF8(vecsv);
9328 i = va_arg(*args, int);
9330 i = (ewix ? ewix <= svmax : svix < svmax) ?
9331 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9333 width = (i < 0) ? -i : i;
9343 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
9345 /* XXX: todo, support specified precision parameter */
9349 i = va_arg(*args, int);
9351 i = (ewix ? ewix <= svmax : svix < svmax)
9352 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9354 has_precis = !(i < 0);
9359 precis = precis * 10 + (*q++ - '0');
9368 case 'I': /* Ix, I32x, and I64x */
9370 if (q[1] == '6' && q[2] == '4') {
9376 if (q[1] == '3' && q[2] == '2') {
9386 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9397 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9398 if (*(q + 1) == 'l') { /* lld, llf */
9424 if (!vectorize && !args) {
9426 const I32 i = efix-1;
9427 argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef;
9429 argsv = (svix >= 0 && svix < svmax)
9430 ? svargs[svix++] : &PL_sv_undef;
9441 uv = (args) ? va_arg(*args, int) : SvIV(argsv);
9443 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9445 eptr = (char*)utf8buf;
9446 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9460 eptr = va_arg(*args, char*);
9462 #ifdef MACOS_TRADITIONAL
9463 /* On MacOS, %#s format is used for Pascal strings */
9468 elen = strlen(eptr);
9470 eptr = (char *)nullstr;
9471 elen = sizeof nullstr - 1;
9475 eptr = SvPV_const(argsv, elen);
9476 if (DO_UTF8(argsv)) {
9477 I32 old_precis = precis;
9478 if (has_precis && precis < elen) {
9480 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9483 if (width) { /* fudge width (can't fudge elen) */
9484 if (has_precis && precis < elen)
9485 width += precis - old_precis;
9487 width += elen - sv_len_utf8(argsv);
9494 if (has_precis && elen > precis)
9501 if (alt || vectorize)
9503 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9524 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9533 esignbuf[esignlen++] = plus;
9537 case 'h': iv = (short)va_arg(*args, int); break;
9538 case 'l': iv = va_arg(*args, long); break;
9539 case 'V': iv = va_arg(*args, IV); break;
9540 default: iv = va_arg(*args, int); break;
9542 case 'q': iv = va_arg(*args, Quad_t); break;
9547 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
9549 case 'h': iv = (short)tiv; break;
9550 case 'l': iv = (long)tiv; break;
9552 default: iv = tiv; break;
9554 case 'q': iv = (Quad_t)tiv; break;
9558 if ( !vectorize ) /* we already set uv above */
9563 esignbuf[esignlen++] = plus;
9567 esignbuf[esignlen++] = '-';
9611 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9622 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9623 case 'l': uv = va_arg(*args, unsigned long); break;
9624 case 'V': uv = va_arg(*args, UV); break;
9625 default: uv = va_arg(*args, unsigned); break;
9627 case 'q': uv = va_arg(*args, Uquad_t); break;
9632 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
9634 case 'h': uv = (unsigned short)tuv; break;
9635 case 'l': uv = (unsigned long)tuv; break;
9637 default: uv = tuv; break;
9639 case 'q': uv = (Uquad_t)tuv; break;
9646 char *ptr = ebuf + sizeof ebuf;
9647 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
9653 p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
9659 esignbuf[esignlen++] = '0';
9660 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9668 if (alt && *ptr != '0')
9677 esignbuf[esignlen++] = '0';
9678 esignbuf[esignlen++] = c;
9681 default: /* it had better be ten or less */
9685 } while (uv /= base);
9688 elen = (ebuf + sizeof ebuf) - ptr;
9692 zeros = precis - elen;
9693 else if (precis == 0 && elen == 1 && *eptr == '0'
9694 && !(base == 8 && alt)) /* "%#.0o" prints "0" */
9697 /* a precision nullifies the 0 flag. */
9704 /* FLOATING POINT */
9707 c = 'f'; /* maybe %F isn't supported here */
9715 /* This is evil, but floating point is even more evil */
9717 /* for SV-style calling, we can only get NV
9718 for C-style calling, we assume %f is double;
9719 for simplicity we allow any of %Lf, %llf, %qf for long double
9723 #if defined(USE_LONG_DOUBLE)
9727 /* [perl #20339] - we should accept and ignore %lf rather than die */
9731 #if defined(USE_LONG_DOUBLE)
9732 intsize = args ? 0 : 'q';
9736 #if defined(HAS_LONG_DOUBLE)
9745 /* now we need (long double) if intsize == 'q', else (double) */
9747 #if LONG_DOUBLESIZE > DOUBLESIZE
9749 va_arg(*args, long double) :
9750 va_arg(*args, double)
9752 va_arg(*args, double)
9757 /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
9758 else. frexp() has some unspecified behaviour for those three */
9759 if (c != 'e' && c != 'E' && (nv * 0) == 0) {
9761 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9762 will cast our (long double) to (double) */
9763 (void)Perl_frexp(nv, &i);
9764 if (i == PERL_INT_MIN)
9765 Perl_die(aTHX_ "panic: frexp");
9767 need = BIT_DIGITS(i);
9769 need += has_precis ? precis : 6; /* known default */
9774 #ifdef HAS_LDBL_SPRINTF_BUG
9775 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9776 with sfio - Allen <allens@cpan.org> */
9779 # define MY_DBL_MAX DBL_MAX
9780 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9781 # if DOUBLESIZE >= 8
9782 # define MY_DBL_MAX 1.7976931348623157E+308L
9784 # define MY_DBL_MAX 3.40282347E+38L
9788 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9789 # define MY_DBL_MAX_BUG 1L
9791 # define MY_DBL_MAX_BUG MY_DBL_MAX
9795 # define MY_DBL_MIN DBL_MIN
9796 # else /* XXX guessing! -Allen */
9797 # if DOUBLESIZE >= 8
9798 # define MY_DBL_MIN 2.2250738585072014E-308L
9800 # define MY_DBL_MIN 1.17549435E-38L
9804 if ((intsize == 'q') && (c == 'f') &&
9805 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9807 /* it's going to be short enough that
9808 * long double precision is not needed */
9810 if ((nv <= 0L) && (nv >= -0L))
9811 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9813 /* would use Perl_fp_class as a double-check but not
9814 * functional on IRIX - see perl.h comments */
9816 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9817 /* It's within the range that a double can represent */
9818 #if defined(DBL_MAX) && !defined(DBL_MIN)
9819 if ((nv >= ((long double)1/DBL_MAX)) ||
9820 (nv <= (-(long double)1/DBL_MAX)))
9822 fix_ldbl_sprintf_bug = TRUE;
9825 if (fix_ldbl_sprintf_bug == TRUE) {
9835 # undef MY_DBL_MAX_BUG
9838 #endif /* HAS_LDBL_SPRINTF_BUG */
9840 need += 20; /* fudge factor */
9841 if (PL_efloatsize < need) {
9842 Safefree(PL_efloatbuf);
9843 PL_efloatsize = need + 20; /* more fudge */
9844 Newx(PL_efloatbuf, PL_efloatsize, char);
9845 PL_efloatbuf[0] = '\0';
9848 if ( !(width || left || plus || alt) && fill != '0'
9849 && has_precis && intsize != 'q' ) { /* Shortcuts */
9850 /* See earlier comment about buggy Gconvert when digits,
9852 if ( c == 'g' && precis) {
9853 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9854 /* May return an empty string for digits==0 */
9855 if (*PL_efloatbuf) {
9856 elen = strlen(PL_efloatbuf);
9857 goto float_converted;
9859 } else if ( c == 'f' && !precis) {
9860 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9865 char *ptr = ebuf + sizeof ebuf;
9868 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9869 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9870 if (intsize == 'q') {
9871 /* Copy the one or more characters in a long double
9872 * format before the 'base' ([efgEFG]) character to
9873 * the format string. */
9874 static char const prifldbl[] = PERL_PRIfldbl;
9875 char const *p = prifldbl + sizeof(prifldbl) - 3;
9876 while (p >= prifldbl) { *--ptr = *p--; }
9881 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9886 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9898 /* No taint. Otherwise we are in the strange situation
9899 * where printf() taints but print($float) doesn't.
9901 #if defined(HAS_LONG_DOUBLE)
9902 elen = ((intsize == 'q')
9903 ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
9904 : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
9906 elen = my_sprintf(PL_efloatbuf, ptr, nv);
9910 eptr = PL_efloatbuf;
9918 i = SvCUR(sv) - origlen;
9921 case 'h': *(va_arg(*args, short*)) = i; break;
9922 default: *(va_arg(*args, int*)) = i; break;
9923 case 'l': *(va_arg(*args, long*)) = i; break;
9924 case 'V': *(va_arg(*args, IV*)) = i; break;
9926 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
9931 sv_setuv_mg(argsv, (UV)i);
9932 continue; /* not "break" */
9939 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
9940 && ckWARN(WARN_PRINTF))
9942 SV * const msg = sv_newmortal();
9943 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9944 (PL_op->op_type == OP_PRTF) ? "" : "s");
9947 Perl_sv_catpvf(aTHX_ msg,
9948 "\"%%%c\"", c & 0xFF);
9950 Perl_sv_catpvf(aTHX_ msg,
9951 "\"%%\\%03"UVof"\"",
9954 sv_catpvs(msg, "end of string");
9955 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
9958 /* output mangled stuff ... */
9964 /* ... right here, because formatting flags should not apply */
9965 SvGROW(sv, SvCUR(sv) + elen + 1);
9967 Copy(eptr, p, elen, char);
9970 SvCUR_set(sv, p - SvPVX_const(sv));
9972 continue; /* not "break" */
9975 if (is_utf8 != has_utf8) {
9978 sv_utf8_upgrade(sv);
9981 const STRLEN old_elen = elen;
9982 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
9983 sv_utf8_upgrade(nsv);
9984 eptr = SvPVX_const(nsv);
9987 if (width) { /* fudge width (can't fudge elen) */
9988 width += elen - old_elen;
9994 have = esignlen + zeros + elen;
9996 Perl_croak_nocontext(PL_memory_wrap);
9998 need = (have > width ? have : width);
10001 if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
10002 Perl_croak_nocontext(PL_memory_wrap);
10003 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10005 if (esignlen && fill == '0') {
10007 for (i = 0; i < (int)esignlen; i++)
10008 *p++ = esignbuf[i];
10010 if (gap && !left) {
10011 memset(p, fill, gap);
10014 if (esignlen && fill != '0') {
10016 for (i = 0; i < (int)esignlen; i++)
10017 *p++ = esignbuf[i];
10021 for (i = zeros; i; i--)
10025 Copy(eptr, p, elen, char);
10029 memset(p, ' ', gap);
10034 Copy(dotstr, p, dotstrlen, char);
10038 vectorize = FALSE; /* done iterating over vecstr */
10045 SvCUR_set(sv, p - SvPVX_const(sv));
10053 /* =========================================================================
10055 =head1 Cloning an interpreter
10057 All the macros and functions in this section are for the private use of
10058 the main function, perl_clone().
10060 The foo_dup() functions make an exact copy of an existing foo thingy.
10061 During the course of a cloning, a hash table is used to map old addresses
10062 to new addresses. The table is created and manipulated with the
10063 ptr_table_* functions.
10067 ============================================================================*/
10070 #if defined(USE_ITHREADS)
10072 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
10073 #ifndef GpREFCNT_inc
10074 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10078 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
10079 that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
10080 If this changes, please unmerge ss_dup. */
10081 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10082 #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t))
10083 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
10084 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10085 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
10086 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10087 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
10088 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10089 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
10090 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
10091 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
10092 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10093 #define SAVEPV(p) ((p) ? savepv(p) : NULL)
10094 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
10096 /* clone a parser */
10099 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
10103 PERL_ARGS_ASSERT_PARSER_DUP;
10108 /* look for it in the table first */
10109 parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
10113 /* create anew and remember what it is */
10114 Newxz(parser, 1, yy_parser);
10115 ptr_table_store(PL_ptr_table, proto, parser);
10117 parser->yyerrstatus = 0;
10118 parser->yychar = YYEMPTY; /* Cause a token to be read. */
10120 /* XXX these not yet duped */
10121 parser->old_parser = NULL;
10122 parser->stack = NULL;
10124 parser->stack_size = 0;
10125 /* XXX parser->stack->state = 0; */
10127 /* XXX eventually, just Copy() most of the parser struct ? */
10129 parser->lex_brackets = proto->lex_brackets;
10130 parser->lex_casemods = proto->lex_casemods;
10131 parser->lex_brackstack = savepvn(proto->lex_brackstack,
10132 (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
10133 parser->lex_casestack = savepvn(proto->lex_casestack,
10134 (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
10135 parser->lex_defer = proto->lex_defer;
10136 parser->lex_dojoin = proto->lex_dojoin;
10137 parser->lex_expect = proto->lex_expect;
10138 parser->lex_formbrack = proto->lex_formbrack;
10139 parser->lex_inpat = proto->lex_inpat;
10140 parser->lex_inwhat = proto->lex_inwhat;
10141 parser->lex_op = proto->lex_op;
10142 parser->lex_repl = sv_dup_inc(proto->lex_repl, param);
10143 parser->lex_starts = proto->lex_starts;
10144 parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param);
10145 parser->multi_close = proto->multi_close;
10146 parser->multi_open = proto->multi_open;
10147 parser->multi_start = proto->multi_start;
10148 parser->multi_end = proto->multi_end;
10149 parser->pending_ident = proto->pending_ident;
10150 parser->preambled = proto->preambled;
10151 parser->sublex_info = proto->sublex_info; /* XXX not quite right */
10152 parser->linestr = sv_dup_inc(proto->linestr, param);
10153 parser->expect = proto->expect;
10154 parser->copline = proto->copline;
10155 parser->last_lop_op = proto->last_lop_op;
10156 parser->lex_state = proto->lex_state;
10157 parser->rsfp = fp_dup(proto->rsfp, '<', param);
10158 /* rsfp_filters entries have fake IoDIRP() */
10159 parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
10160 parser->in_my = proto->in_my;
10161 parser->in_my_stash = hv_dup(proto->in_my_stash, param);
10162 parser->error_count = proto->error_count;
10165 parser->linestr = sv_dup_inc(proto->linestr, param);
10168 char * const ols = SvPVX(proto->linestr);
10169 char * const ls = SvPVX(parser->linestr);
10171 parser->bufptr = ls + (proto->bufptr >= ols ?
10172 proto->bufptr - ols : 0);
10173 parser->oldbufptr = ls + (proto->oldbufptr >= ols ?
10174 proto->oldbufptr - ols : 0);
10175 parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
10176 proto->oldoldbufptr - ols : 0);
10177 parser->linestart = ls + (proto->linestart >= ols ?
10178 proto->linestart - ols : 0);
10179 parser->last_uni = ls + (proto->last_uni >= ols ?
10180 proto->last_uni - ols : 0);
10181 parser->last_lop = ls + (proto->last_lop >= ols ?
10182 proto->last_lop - ols : 0);
10184 parser->bufend = ls + SvCUR(parser->linestr);
10187 Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
10191 parser->endwhite = proto->endwhite;
10192 parser->faketokens = proto->faketokens;
10193 parser->lasttoke = proto->lasttoke;
10194 parser->nextwhite = proto->nextwhite;
10195 parser->realtokenstart = proto->realtokenstart;
10196 parser->skipwhite = proto->skipwhite;
10197 parser->thisclose = proto->thisclose;
10198 parser->thismad = proto->thismad;
10199 parser->thisopen = proto->thisopen;
10200 parser->thisstuff = proto->thisstuff;
10201 parser->thistoken = proto->thistoken;
10202 parser->thiswhite = proto->thiswhite;
10204 Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
10205 parser->curforce = proto->curforce;
10207 Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
10208 Copy(proto->nexttype, parser->nexttype, 5, I32);
10209 parser->nexttoke = proto->nexttoke;
10215 /* duplicate a file handle */
10218 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
10222 PERL_ARGS_ASSERT_FP_DUP;
10223 PERL_UNUSED_ARG(type);
10226 return (PerlIO*)NULL;
10228 /* look for it in the table first */
10229 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10233 /* create anew and remember what it is */
10234 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10235 ptr_table_store(PL_ptr_table, fp, ret);
10239 /* duplicate a directory handle */
10242 Perl_dirp_dup(pTHX_ DIR *const dp)
10244 PERL_UNUSED_CONTEXT;
10251 /* duplicate a typeglob */
10254 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
10258 PERL_ARGS_ASSERT_GP_DUP;
10262 /* look for it in the table first */
10263 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10267 /* create anew and remember what it is */
10269 ptr_table_store(PL_ptr_table, gp, ret);
10272 ret->gp_refcnt = 0; /* must be before any other dups! */
10273 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
10274 ret->gp_io = io_dup_inc(gp->gp_io, param);
10275 ret->gp_form = cv_dup_inc(gp->gp_form, param);
10276 ret->gp_av = av_dup_inc(gp->gp_av, param);
10277 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
10278 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10279 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
10280 ret->gp_cvgen = gp->gp_cvgen;
10281 ret->gp_line = gp->gp_line;
10282 ret->gp_file_hek = hek_dup(gp->gp_file_hek, param);
10286 /* duplicate a chain of magic */
10289 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
10291 MAGIC *mgprev = (MAGIC*)NULL;
10294 PERL_ARGS_ASSERT_MG_DUP;
10297 return (MAGIC*)NULL;
10298 /* look for it in the table first */
10299 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
10303 for (; mg; mg = mg->mg_moremagic) {
10305 Newxz(nmg, 1, MAGIC);
10307 mgprev->mg_moremagic = nmg;
10310 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
10311 nmg->mg_private = mg->mg_private;
10312 nmg->mg_type = mg->mg_type;
10313 nmg->mg_flags = mg->mg_flags;
10314 /* FIXME for plugins
10315 if (mg->mg_type == PERL_MAGIC_qr) {
10316 nmg->mg_obj = (SV*)CALLREGDUPE((REGEXP*)mg->mg_obj, param);
10320 if(mg->mg_type == PERL_MAGIC_backref) {
10321 /* The backref AV has its reference count deliberately bumped by
10323 nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param));
10326 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
10327 ? sv_dup_inc(mg->mg_obj, param)
10328 : sv_dup(mg->mg_obj, param);
10330 nmg->mg_len = mg->mg_len;
10331 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
10332 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
10333 if (mg->mg_len > 0) {
10334 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
10335 if (mg->mg_type == PERL_MAGIC_overload_table &&
10336 AMT_AMAGIC((AMT*)mg->mg_ptr))
10338 const AMT * const amtp = (AMT*)mg->mg_ptr;
10339 AMT * const namtp = (AMT*)nmg->mg_ptr;
10341 for (i = 1; i < NofAMmeth; i++) {
10342 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
10346 else if (mg->mg_len == HEf_SVKEY)
10347 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
10349 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
10350 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10357 #endif /* USE_ITHREADS */
10359 /* create a new pointer-mapping table */
10362 Perl_ptr_table_new(pTHX)
10365 PERL_UNUSED_CONTEXT;
10367 Newxz(tbl, 1, PTR_TBL_t);
10368 tbl->tbl_max = 511;
10369 tbl->tbl_items = 0;
10370 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10374 #define PTR_TABLE_HASH(ptr) \
10375 ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
10378 we use the PTE_SVSLOT 'reservation' made above, both here (in the
10379 following define) and at call to new_body_inline made below in
10380 Perl_ptr_table_store()
10383 #define del_pte(p) del_body_type(p, PTE_SVSLOT)
10385 /* map an existing pointer using a table */
10387 STATIC PTR_TBL_ENT_t *
10388 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
10390 PTR_TBL_ENT_t *tblent;
10391 const UV hash = PTR_TABLE_HASH(sv);
10393 PERL_ARGS_ASSERT_PTR_TABLE_FIND;
10395 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10396 for (; tblent; tblent = tblent->next) {
10397 if (tblent->oldval == sv)
10404 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
10406 PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
10408 PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
10409 PERL_UNUSED_CONTEXT;
10411 return tblent ? tblent->newval : NULL;
10414 /* add a new entry to a pointer-mapping table */
10417 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
10419 PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
10421 PERL_ARGS_ASSERT_PTR_TABLE_STORE;
10422 PERL_UNUSED_CONTEXT;
10425 tblent->newval = newsv;
10427 const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
10429 new_body_inline(tblent, PTE_SVSLOT);
10431 tblent->oldval = oldsv;
10432 tblent->newval = newsv;
10433 tblent->next = tbl->tbl_ary[entry];
10434 tbl->tbl_ary[entry] = tblent;
10436 if (tblent->next && tbl->tbl_items > tbl->tbl_max)
10437 ptr_table_split(tbl);
10441 /* double the hash bucket size of an existing ptr table */
10444 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
10446 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10447 const UV oldsize = tbl->tbl_max + 1;
10448 UV newsize = oldsize * 2;
10451 PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
10452 PERL_UNUSED_CONTEXT;
10454 Renew(ary, newsize, PTR_TBL_ENT_t*);
10455 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10456 tbl->tbl_max = --newsize;
10457 tbl->tbl_ary = ary;
10458 for (i=0; i < oldsize; i++, ary++) {
10459 PTR_TBL_ENT_t **curentp, **entp, *ent;
10462 curentp = ary + oldsize;
10463 for (entp = ary, ent = *ary; ent; ent = *entp) {
10464 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10466 ent->next = *curentp;
10476 /* remove all the entries from a ptr table */
10479 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
10481 if (tbl && tbl->tbl_items) {
10482 register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary;
10483 UV riter = tbl->tbl_max;
10486 PTR_TBL_ENT_t *entry = array[riter];
10489 PTR_TBL_ENT_t * const oentry = entry;
10490 entry = entry->next;
10495 tbl->tbl_items = 0;
10499 /* clear and free a ptr table */
10502 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
10507 ptr_table_clear(tbl);
10508 Safefree(tbl->tbl_ary);
10512 #if defined(USE_ITHREADS)
10515 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
10517 PERL_ARGS_ASSERT_RVPV_DUP;
10520 SvRV_set(dstr, SvWEAKREF(sstr)
10521 ? sv_dup(SvRV(sstr), param)
10522 : sv_dup_inc(SvRV(sstr), param));
10525 else if (SvPVX_const(sstr)) {
10526 /* Has something there */
10528 /* Normal PV - clone whole allocated space */
10529 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
10530 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10531 /* Not that normal - actually sstr is copy on write.
10532 But we are a true, independant SV, so: */
10533 SvREADONLY_off(dstr);
10538 /* Special case - not normally malloced for some reason */
10539 if (isGV_with_GP(sstr)) {
10540 /* Don't need to do anything here. */
10542 else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
10543 /* A "shared" PV - clone it as "shared" PV */
10545 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
10549 /* Some other special case - random pointer */
10550 SvPV_set(dstr, SvPVX(sstr));
10555 /* Copy the NULL */
10556 SvPV_set(dstr, NULL);
10560 /* duplicate an SV of any type (including AV, HV etc) */
10563 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
10568 PERL_ARGS_ASSERT_SV_DUP;
10572 if (SvTYPE(sstr) == SVTYPEMASK) {
10573 #ifdef DEBUG_LEAKING_SCALARS_ABORT
10578 /* look for it in the table first */
10579 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10583 if(param->flags & CLONEf_JOIN_IN) {
10584 /** We are joining here so we don't want do clone
10585 something that is bad **/
10586 if (SvTYPE(sstr) == SVt_PVHV) {
10587 const HEK * const hvname = HvNAME_HEK(sstr);
10589 /** don't clone stashes if they already exist **/
10590 return (SV*)gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0);
10594 /* create anew and remember what it is */
10597 #ifdef DEBUG_LEAKING_SCALARS
10598 dstr->sv_debug_optype = sstr->sv_debug_optype;
10599 dstr->sv_debug_line = sstr->sv_debug_line;
10600 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10601 dstr->sv_debug_cloned = 1;
10602 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10605 ptr_table_store(PL_ptr_table, sstr, dstr);
10608 SvFLAGS(dstr) = SvFLAGS(sstr);
10609 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10610 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10613 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
10614 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10615 (void*)PL_watch_pvx, SvPVX_const(sstr));
10618 /* don't clone objects whose class has asked us not to */
10619 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10624 switch (SvTYPE(sstr)) {
10626 SvANY(dstr) = NULL;
10629 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
10631 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10633 SvIV_set(dstr, SvIVX(sstr));
10637 SvANY(dstr) = new_XNV();
10638 SvNV_set(dstr, SvNVX(sstr));
10640 /* case SVt_BIND: */
10643 /* These are all the types that need complex bodies allocating. */
10645 const svtype sv_type = SvTYPE(sstr);
10646 const struct body_details *const sv_type_details
10647 = bodies_by_type + sv_type;
10651 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
10655 if (GvUNIQUE((GV*)sstr)) {
10656 NOOP; /* Do sharing here, and fall through */
10669 assert(sv_type_details->body_size);
10670 if (sv_type_details->arena) {
10671 new_body_inline(new_body, sv_type);
10673 = (void*)((char*)new_body - sv_type_details->offset);
10675 new_body = new_NOARENA(sv_type_details);
10679 SvANY(dstr) = new_body;
10682 Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
10683 ((char*)SvANY(dstr)) + sv_type_details->offset,
10684 sv_type_details->copy, char);
10686 Copy(((char*)SvANY(sstr)),
10687 ((char*)SvANY(dstr)),
10688 sv_type_details->body_size + sv_type_details->offset, char);
10691 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
10692 && !isGV_with_GP(dstr))
10693 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10695 /* The Copy above means that all the source (unduplicated) pointers
10696 are now in the destination. We can check the flags and the
10697 pointers in either, but it's possible that there's less cache
10698 missing by always going for the destination.
10699 FIXME - instrument and check that assumption */
10700 if (sv_type >= SVt_PVMG) {
10701 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
10702 SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
10703 } else if (SvMAGIC(dstr))
10704 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
10706 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
10709 /* The cast silences a GCC warning about unhandled types. */
10710 switch ((int)sv_type) {
10720 /* FIXME for plugins */
10721 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
10724 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
10725 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
10726 LvTARG(dstr) = dstr;
10727 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
10728 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
10730 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
10732 if(isGV_with_GP(sstr)) {
10733 if (GvNAME_HEK(dstr))
10734 GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
10735 /* Don't call sv_add_backref here as it's going to be
10736 created as part of the magic cloning of the symbol
10738 /* Danger Will Robinson - GvGP(dstr) isn't initialised
10739 at the point of this comment. */
10740 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
10741 GvGP(dstr) = gp_dup(GvGP(sstr), param);
10742 (void)GpREFCNT_inc(GvGP(dstr));
10744 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10747 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
10748 if (IoOFP(dstr) == IoIFP(sstr))
10749 IoOFP(dstr) = IoIFP(dstr);
10751 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
10752 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
10753 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
10754 /* I have no idea why fake dirp (rsfps)
10755 should be treated differently but otherwise
10756 we end up with leaks -- sky*/
10757 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
10758 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
10759 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
10761 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
10762 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
10763 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
10764 if (IoDIRP(dstr)) {
10765 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
10768 /* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
10771 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
10772 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
10773 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
10776 if (AvARRAY((AV*)sstr)) {
10777 SV **dst_ary, **src_ary;
10778 SSize_t items = AvFILLp((AV*)sstr) + 1;
10780 src_ary = AvARRAY((AV*)sstr);
10781 Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*);
10782 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10783 AvARRAY((AV*)dstr) = dst_ary;
10784 AvALLOC((AV*)dstr) = dst_ary;
10785 if (AvREAL((AV*)sstr)) {
10786 while (items-- > 0)
10787 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10790 while (items-- > 0)
10791 *dst_ary++ = sv_dup(*src_ary++, param);
10793 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10794 while (items-- > 0) {
10795 *dst_ary++ = &PL_sv_undef;
10799 AvARRAY((AV*)dstr) = NULL;
10800 AvALLOC((AV*)dstr) = (SV**)NULL;
10804 if (HvARRAY((HV*)sstr)) {
10806 const bool sharekeys = !!HvSHAREKEYS(sstr);
10807 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
10808 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
10810 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
10811 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
10813 HvARRAY(dstr) = (HE**)darray;
10814 while (i <= sxhv->xhv_max) {
10815 const HE * const source = HvARRAY(sstr)[i];
10816 HvARRAY(dstr)[i] = source
10817 ? he_dup(source, sharekeys, param) : 0;
10822 const struct xpvhv_aux * const saux = HvAUX(sstr);
10823 struct xpvhv_aux * const daux = HvAUX(dstr);
10824 /* This flag isn't copied. */
10825 /* SvOOK_on(hv) attacks the IV flags. */
10826 SvFLAGS(dstr) |= SVf_OOK;
10828 hvname = saux->xhv_name;
10829 daux->xhv_name = hvname ? hek_dup(hvname, param) : hvname;
10831 daux->xhv_riter = saux->xhv_riter;
10832 daux->xhv_eiter = saux->xhv_eiter
10833 ? he_dup(saux->xhv_eiter,
10834 (bool)!!HvSHAREKEYS(sstr), param) : 0;
10835 /* backref array needs refcnt=2; see sv_add_backref */
10836 daux->xhv_backreferences =
10837 saux->xhv_backreferences
10838 ? (AV*) SvREFCNT_inc(
10839 sv_dup_inc((SV*)saux->xhv_backreferences, param))
10842 daux->xhv_mro_meta = saux->xhv_mro_meta
10843 ? mro_meta_dup(saux->xhv_mro_meta, param)
10846 /* Record stashes for possible cloning in Perl_clone(). */
10848 av_push(param->stashes, dstr);
10852 HvARRAY((HV*)dstr) = NULL;
10855 if (!(param->flags & CLONEf_COPY_STACKS)) {
10859 /* NOTE: not refcounted */
10860 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
10862 if (!CvISXSUB(dstr))
10863 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
10865 if (CvCONST(dstr) && CvISXSUB(dstr)) {
10866 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
10867 SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
10868 sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
10870 /* don't dup if copying back - CvGV isn't refcounted, so the
10871 * duped GV may never be freed. A bit of a hack! DAPM */
10872 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
10873 NULL : gv_dup(CvGV(dstr), param) ;
10874 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10876 CvWEAKOUTSIDE(sstr)
10877 ? cv_dup( CvOUTSIDE(dstr), param)
10878 : cv_dup_inc(CvOUTSIDE(dstr), param);
10879 if (!CvISXSUB(dstr))
10880 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
10886 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10892 /* duplicate a context */
10895 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10897 PERL_CONTEXT *ncxs;
10899 PERL_ARGS_ASSERT_CX_DUP;
10902 return (PERL_CONTEXT*)NULL;
10904 /* look for it in the table first */
10905 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10909 /* create anew and remember what it is */
10910 Newx(ncxs, max + 1, PERL_CONTEXT);
10911 ptr_table_store(PL_ptr_table, cxs, ncxs);
10912 Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
10915 PERL_CONTEXT * const ncx = &ncxs[ix];
10916 if (CxTYPE(ncx) == CXt_SUBST) {
10917 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10920 switch (CxTYPE(ncx)) {
10922 ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
10923 ? cv_dup_inc(ncx->blk_sub.cv, param)
10924 : cv_dup(ncx->blk_sub.cv,param));
10925 ncx->blk_sub.argarray = (CxHASARGS(ncx)
10926 ? av_dup_inc(ncx->blk_sub.argarray,
10929 ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,
10931 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
10932 ncx->blk_sub.oldcomppad);
10935 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
10937 ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
10939 case CXt_LOOP_LAZYSV:
10940 ncx->blk_loop.state_u.lazysv.end
10941 = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
10942 /* We are taking advantage of av_dup_inc and sv_dup_inc
10943 actually being the same function, and order equivalance of
10945 We can assert the later [but only at run time :-(] */
10946 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
10947 (void *) &ncx->blk_loop.state_u.lazysv.cur);
10949 ncx->blk_loop.state_u.ary.ary
10950 = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
10951 case CXt_LOOP_LAZYIV:
10952 case CXt_LOOP_PLAIN:
10953 if (CxPADLOOP(ncx)) {
10954 ncx->blk_loop.oldcomppad
10955 = (PAD*)ptr_table_fetch(PL_ptr_table,
10956 ncx->blk_loop.oldcomppad);
10958 ncx->blk_loop.oldcomppad
10959 = (PAD*)gv_dup((GV*)ncx->blk_loop.oldcomppad, param);
10963 ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param);
10964 ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param);
10965 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
10978 /* duplicate a stack info structure */
10981 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10985 PERL_ARGS_ASSERT_SI_DUP;
10988 return (PERL_SI*)NULL;
10990 /* look for it in the table first */
10991 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10995 /* create anew and remember what it is */
10996 Newxz(nsi, 1, PERL_SI);
10997 ptr_table_store(PL_ptr_table, si, nsi);
10999 nsi->si_stack = av_dup_inc(si->si_stack, param);
11000 nsi->si_cxix = si->si_cxix;
11001 nsi->si_cxmax = si->si_cxmax;
11002 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11003 nsi->si_type = si->si_type;
11004 nsi->si_prev = si_dup(si->si_prev, param);
11005 nsi->si_next = si_dup(si->si_next, param);
11006 nsi->si_markoff = si->si_markoff;
11011 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
11012 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
11013 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
11014 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
11015 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
11016 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
11017 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
11018 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
11019 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
11020 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
11021 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
11022 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
11023 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11024 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11027 #define pv_dup_inc(p) SAVEPV(p)
11028 #define pv_dup(p) SAVEPV(p)
11029 #define svp_dup_inc(p,pp) any_dup(p,pp)
11031 /* map any object to the new equivent - either something in the
11032 * ptr table, or something in the interpreter structure
11036 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
11040 PERL_ARGS_ASSERT_ANY_DUP;
11043 return (void*)NULL;
11045 /* look for it in the table first */
11046 ret = ptr_table_fetch(PL_ptr_table, v);
11050 /* see if it is part of the interpreter structure */
11051 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11052 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11060 /* duplicate the save stack */
11063 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11066 ANY * const ss = proto_perl->Isavestack;
11067 const I32 max = proto_perl->Isavestack_max;
11068 I32 ix = proto_perl->Isavestack_ix;
11081 void (*dptr) (void*);
11082 void (*dxptr) (pTHX_ void*);
11084 PERL_ARGS_ASSERT_SS_DUP;
11086 Newxz(nss, max, ANY);
11089 const I32 type = POPINT(ss,ix);
11090 TOPINT(nss,ix) = type;
11092 case SAVEt_HELEM: /* hash element */
11093 sv = (SV*)POPPTR(ss,ix);
11094 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11096 case SAVEt_ITEM: /* normal string */
11097 case SAVEt_SV: /* scalar reference */
11098 sv = (SV*)POPPTR(ss,ix);
11099 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11102 case SAVEt_MORTALIZESV:
11103 sv = (SV*)POPPTR(ss,ix);
11104 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11106 case SAVEt_SHARED_PVREF: /* char* in shared space */
11107 c = (char*)POPPTR(ss,ix);
11108 TOPPTR(nss,ix) = savesharedpv(c);
11109 ptr = POPPTR(ss,ix);
11110 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11112 case SAVEt_GENERIC_SVREF: /* generic sv */
11113 case SAVEt_SVREF: /* scalar reference */
11114 sv = (SV*)POPPTR(ss,ix);
11115 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11116 ptr = POPPTR(ss,ix);
11117 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11119 case SAVEt_HV: /* hash reference */
11120 case SAVEt_AV: /* array reference */
11121 sv = (SV*) POPPTR(ss,ix);
11122 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11124 case SAVEt_COMPPAD:
11126 sv = (SV*) POPPTR(ss,ix);
11127 TOPPTR(nss,ix) = sv_dup(sv, param);
11129 case SAVEt_INT: /* int reference */
11130 ptr = POPPTR(ss,ix);
11131 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11132 intval = (int)POPINT(ss,ix);
11133 TOPINT(nss,ix) = intval;
11135 case SAVEt_LONG: /* long reference */
11136 ptr = POPPTR(ss,ix);
11137 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11139 case SAVEt_CLEARSV:
11140 longval = (long)POPLONG(ss,ix);
11141 TOPLONG(nss,ix) = longval;
11143 case SAVEt_I32: /* I32 reference */
11144 case SAVEt_I16: /* I16 reference */
11145 case SAVEt_I8: /* I8 reference */
11146 case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
11147 ptr = POPPTR(ss,ix);
11148 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11150 TOPINT(nss,ix) = i;
11152 case SAVEt_IV: /* IV reference */
11153 ptr = POPPTR(ss,ix);
11154 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11156 TOPIV(nss,ix) = iv;
11158 case SAVEt_HPTR: /* HV* reference */
11159 case SAVEt_APTR: /* AV* reference */
11160 case SAVEt_SPTR: /* SV* reference */
11161 ptr = POPPTR(ss,ix);
11162 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11163 sv = (SV*)POPPTR(ss,ix);
11164 TOPPTR(nss,ix) = sv_dup(sv, param);
11166 case SAVEt_VPTR: /* random* reference */
11167 ptr = POPPTR(ss,ix);
11168 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11169 ptr = POPPTR(ss,ix);
11170 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11172 case SAVEt_GENERIC_PVREF: /* generic char* */
11173 case SAVEt_PPTR: /* char* reference */
11174 ptr = POPPTR(ss,ix);
11175 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11176 c = (char*)POPPTR(ss,ix);
11177 TOPPTR(nss,ix) = pv_dup(c);
11179 case SAVEt_GP: /* scalar reference */
11180 gp = (GP*)POPPTR(ss,ix);
11181 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11182 (void)GpREFCNT_inc(gp);
11183 gv = (GV*)POPPTR(ss,ix);
11184 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11187 ptr = POPPTR(ss,ix);
11188 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11189 /* these are assumed to be refcounted properly */
11191 switch (((OP*)ptr)->op_type) {
11193 case OP_LEAVESUBLV:
11197 case OP_LEAVEWRITE:
11198 TOPPTR(nss,ix) = ptr;
11201 (void) OpREFCNT_inc(o);
11205 TOPPTR(nss,ix) = NULL;
11210 TOPPTR(nss,ix) = NULL;
11213 c = (char*)POPPTR(ss,ix);
11214 TOPPTR(nss,ix) = pv_dup_inc(c);
11217 hv = (HV*)POPPTR(ss,ix);
11218 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11219 c = (char*)POPPTR(ss,ix);
11220 TOPPTR(nss,ix) = pv_dup_inc(c);
11222 case SAVEt_STACK_POS: /* Position on Perl stack */
11224 TOPINT(nss,ix) = i;
11226 case SAVEt_DESTRUCTOR:
11227 ptr = POPPTR(ss,ix);
11228 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11229 dptr = POPDPTR(ss,ix);
11230 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
11231 any_dup(FPTR2DPTR(void *, dptr),
11234 case SAVEt_DESTRUCTOR_X:
11235 ptr = POPPTR(ss,ix);
11236 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11237 dxptr = POPDXPTR(ss,ix);
11238 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
11239 any_dup(FPTR2DPTR(void *, dxptr),
11242 case SAVEt_REGCONTEXT:
11245 TOPINT(nss,ix) = i;
11248 case SAVEt_AELEM: /* array element */
11249 sv = (SV*)POPPTR(ss,ix);
11250 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11252 TOPINT(nss,ix) = i;
11253 av = (AV*)POPPTR(ss,ix);
11254 TOPPTR(nss,ix) = av_dup_inc(av, param);
11257 ptr = POPPTR(ss,ix);
11258 TOPPTR(nss,ix) = ptr;
11262 TOPINT(nss,ix) = i;
11263 ptr = POPPTR(ss,ix);
11266 ((struct refcounted_he *)ptr)->refcounted_he_refcnt++;
11267 HINTS_REFCNT_UNLOCK;
11269 TOPPTR(nss,ix) = ptr;
11270 if (i & HINT_LOCALIZE_HH) {
11271 hv = (HV*)POPPTR(ss,ix);
11272 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11275 case SAVEt_PADSV_AND_MORTALIZE:
11276 longval = (long)POPLONG(ss,ix);
11277 TOPLONG(nss,ix) = longval;
11278 ptr = POPPTR(ss,ix);
11279 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11280 sv = (SV*)POPPTR(ss,ix);
11281 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11284 ptr = POPPTR(ss,ix);
11285 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11286 longval = (long)POPBOOL(ss,ix);
11287 TOPBOOL(nss,ix) = (bool)longval;
11289 case SAVEt_SET_SVFLAGS:
11291 TOPINT(nss,ix) = i;
11293 TOPINT(nss,ix) = i;
11294 sv = (SV*)POPPTR(ss,ix);
11295 TOPPTR(nss,ix) = sv_dup(sv, param);
11297 case SAVEt_RE_STATE:
11299 const struct re_save_state *const old_state
11300 = (struct re_save_state *)
11301 (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11302 struct re_save_state *const new_state
11303 = (struct re_save_state *)
11304 (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11306 Copy(old_state, new_state, 1, struct re_save_state);
11307 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
11309 new_state->re_state_bostr
11310 = pv_dup(old_state->re_state_bostr);
11311 new_state->re_state_reginput
11312 = pv_dup(old_state->re_state_reginput);
11313 new_state->re_state_regeol
11314 = pv_dup(old_state->re_state_regeol);
11315 new_state->re_state_regoffs
11316 = (regexp_paren_pair*)
11317 any_dup(old_state->re_state_regoffs, proto_perl);
11318 new_state->re_state_reglastparen
11319 = (U32*) any_dup(old_state->re_state_reglastparen,
11321 new_state->re_state_reglastcloseparen
11322 = (U32*)any_dup(old_state->re_state_reglastcloseparen,
11324 /* XXX This just has to be broken. The old save_re_context
11325 code did SAVEGENERICPV(PL_reg_start_tmp);
11326 PL_reg_start_tmp is char **.
11327 Look above to what the dup code does for
11328 SAVEt_GENERIC_PVREF
11329 It can never have worked.
11330 So this is merely a faithful copy of the exiting bug: */
11331 new_state->re_state_reg_start_tmp
11332 = (char **) pv_dup((char *)
11333 old_state->re_state_reg_start_tmp);
11334 /* I assume that it only ever "worked" because no-one called
11335 (pseudo)fork while the regexp engine had re-entered itself.
11337 #ifdef PERL_OLD_COPY_ON_WRITE
11338 new_state->re_state_nrs
11339 = sv_dup(old_state->re_state_nrs, param);
11341 new_state->re_state_reg_magic
11342 = (MAGIC*) any_dup(old_state->re_state_reg_magic,
11344 new_state->re_state_reg_oldcurpm
11345 = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
11347 new_state->re_state_reg_curpm
11348 = (PMOP*) any_dup(old_state->re_state_reg_curpm,
11350 new_state->re_state_reg_oldsaved
11351 = pv_dup(old_state->re_state_reg_oldsaved);
11352 new_state->re_state_reg_poscache
11353 = pv_dup(old_state->re_state_reg_poscache);
11354 new_state->re_state_reg_starttry
11355 = pv_dup(old_state->re_state_reg_starttry);
11358 case SAVEt_COMPILE_WARNINGS:
11359 ptr = POPPTR(ss,ix);
11360 TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
11363 ptr = POPPTR(ss,ix);
11364 TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
11368 "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
11376 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11377 * flag to the result. This is done for each stash before cloning starts,
11378 * so we know which stashes want their objects cloned */
11381 do_mark_cloneable_stash(pTHX_ SV *const sv)
11383 const HEK * const hvname = HvNAME_HEK((HV*)sv);
11385 GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
11386 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11387 if (cloner && GvCV(cloner)) {
11394 mXPUSHs(newSVhek(hvname));
11396 call_sv((SV*)GvCV(cloner), G_SCALAR);
11403 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11411 =for apidoc perl_clone
11413 Create and return a new interpreter by cloning the current one.
11415 perl_clone takes these flags as parameters:
11417 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11418 without it we only clone the data and zero the stacks,
11419 with it we copy the stacks and the new perl interpreter is
11420 ready to run at the exact same point as the previous one.
11421 The pseudo-fork code uses COPY_STACKS while the
11422 threads->create doesn't.
11424 CLONEf_KEEP_PTR_TABLE
11425 perl_clone keeps a ptr_table with the pointer of the old
11426 variable as a key and the new variable as a value,
11427 this allows it to check if something has been cloned and not
11428 clone it again but rather just use the value and increase the
11429 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11430 the ptr_table using the function
11431 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11432 reason to keep it around is if you want to dup some of your own
11433 variable who are outside the graph perl scans, example of this
11434 code is in threads.xs create
11437 This is a win32 thing, it is ignored on unix, it tells perls
11438 win32host code (which is c++) to clone itself, this is needed on
11439 win32 if you want to run two threads at the same time,
11440 if you just want to do some stuff in a separate perl interpreter
11441 and then throw it away and return to the original one,
11442 you don't need to do anything.
11447 /* XXX the above needs expanding by someone who actually understands it ! */
11448 EXTERN_C PerlInterpreter *
11449 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11452 perl_clone(PerlInterpreter *proto_perl, UV flags)
11455 #ifdef PERL_IMPLICIT_SYS
11457 PERL_ARGS_ASSERT_PERL_CLONE;
11459 /* perlhost.h so we need to call into it
11460 to clone the host, CPerlHost should have a c interface, sky */
11462 if (flags & CLONEf_CLONE_HOST) {
11463 return perl_clone_host(proto_perl,flags);
11465 return perl_clone_using(proto_perl, flags,
11467 proto_perl->IMemShared,
11468 proto_perl->IMemParse,
11470 proto_perl->IStdIO,
11474 proto_perl->IProc);
11478 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11479 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11480 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11481 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11482 struct IPerlDir* ipD, struct IPerlSock* ipS,
11483 struct IPerlProc* ipP)
11485 /* XXX many of the string copies here can be optimized if they're
11486 * constants; they need to be allocated as common memory and just
11487 * their pointers copied. */
11490 CLONE_PARAMS clone_params;
11491 CLONE_PARAMS* const param = &clone_params;
11493 PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11495 PERL_ARGS_ASSERT_PERL_CLONE_USING;
11497 /* for each stash, determine whether its objects should be cloned */
11498 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11499 PERL_SET_THX(my_perl);
11502 PoisonNew(my_perl, 1, PerlInterpreter);
11508 PL_savestack_ix = 0;
11509 PL_savestack_max = -1;
11510 PL_sig_pending = 0;
11512 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11513 # else /* !DEBUGGING */
11514 Zero(my_perl, 1, PerlInterpreter);
11515 # endif /* DEBUGGING */
11517 /* host pointers */
11519 PL_MemShared = ipMS;
11520 PL_MemParse = ipMP;
11527 #else /* !PERL_IMPLICIT_SYS */
11529 CLONE_PARAMS clone_params;
11530 CLONE_PARAMS* param = &clone_params;
11531 PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11533 PERL_ARGS_ASSERT_PERL_CLONE;
11535 /* for each stash, determine whether its objects should be cloned */
11536 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11537 PERL_SET_THX(my_perl);
11540 PoisonNew(my_perl, 1, PerlInterpreter);
11546 PL_savestack_ix = 0;
11547 PL_savestack_max = -1;
11548 PL_sig_pending = 0;
11550 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11551 # else /* !DEBUGGING */
11552 Zero(my_perl, 1, PerlInterpreter);
11553 # endif /* DEBUGGING */
11554 #endif /* PERL_IMPLICIT_SYS */
11555 param->flags = flags;
11556 param->proto_perl = proto_perl;
11558 INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
11560 PL_body_arenas = NULL;
11561 Zero(&PL_body_roots, 1, PL_body_roots);
11563 PL_nice_chunk = NULL;
11564 PL_nice_chunk_size = 0;
11566 PL_sv_objcount = 0;
11568 PL_sv_arenaroot = NULL;
11570 PL_debug = proto_perl->Idebug;
11572 PL_hash_seed = proto_perl->Ihash_seed;
11573 PL_rehash_seed = proto_perl->Irehash_seed;
11575 #ifdef USE_REENTRANT_API
11576 /* XXX: things like -Dm will segfault here in perlio, but doing
11577 * PERL_SET_CONTEXT(proto_perl);
11578 * breaks too many other things
11580 Perl_reentrant_init(aTHX);
11583 /* create SV map for pointer relocation */
11584 PL_ptr_table = ptr_table_new();
11586 /* initialize these special pointers as early as possible */
11587 SvANY(&PL_sv_undef) = NULL;
11588 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11589 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11590 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11592 SvANY(&PL_sv_no) = new_XPVNV();
11593 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11594 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11595 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11596 SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
11597 SvCUR_set(&PL_sv_no, 0);
11598 SvLEN_set(&PL_sv_no, 1);
11599 SvIV_set(&PL_sv_no, 0);
11600 SvNV_set(&PL_sv_no, 0);
11601 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11603 SvANY(&PL_sv_yes) = new_XPVNV();
11604 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11605 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11606 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11607 SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
11608 SvCUR_set(&PL_sv_yes, 1);
11609 SvLEN_set(&PL_sv_yes, 2);
11610 SvIV_set(&PL_sv_yes, 1);
11611 SvNV_set(&PL_sv_yes, 1);
11612 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11614 /* create (a non-shared!) shared string table */
11615 PL_strtab = newHV();
11616 HvSHAREKEYS_off(PL_strtab);
11617 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
11618 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11620 PL_compiling = proto_perl->Icompiling;
11622 /* These two PVs will be free'd special way so must set them same way op.c does */
11623 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11624 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11626 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11627 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11629 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11630 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
11631 if (PL_compiling.cop_hints_hash) {
11633 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
11634 HINTS_REFCNT_UNLOCK;
11636 PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
11637 #ifdef PERL_DEBUG_READONLY_OPS
11642 /* pseudo environmental stuff */
11643 PL_origargc = proto_perl->Iorigargc;
11644 PL_origargv = proto_perl->Iorigargv;
11646 param->stashes = newAV(); /* Setup array of objects to call clone on */
11648 /* Set tainting stuff before PerlIO_debug can possibly get called */
11649 PL_tainting = proto_perl->Itainting;
11650 PL_taint_warn = proto_perl->Itaint_warn;
11652 #ifdef PERLIO_LAYERS
11653 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11654 PerlIO_clone(aTHX_ proto_perl, param);
11657 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11658 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11659 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11660 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11661 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11662 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11665 PL_minus_c = proto_perl->Iminus_c;
11666 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11667 PL_localpatches = proto_perl->Ilocalpatches;
11668 PL_splitstr = proto_perl->Isplitstr;
11669 PL_minus_n = proto_perl->Iminus_n;
11670 PL_minus_p = proto_perl->Iminus_p;
11671 PL_minus_l = proto_perl->Iminus_l;
11672 PL_minus_a = proto_perl->Iminus_a;
11673 PL_minus_E = proto_perl->Iminus_E;
11674 PL_minus_F = proto_perl->Iminus_F;
11675 PL_doswitches = proto_perl->Idoswitches;
11676 PL_dowarn = proto_perl->Idowarn;
11677 PL_doextract = proto_perl->Idoextract;
11678 PL_sawampersand = proto_perl->Isawampersand;
11679 PL_unsafe = proto_perl->Iunsafe;
11680 PL_inplace = SAVEPV(proto_perl->Iinplace);
11681 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11682 PL_perldb = proto_perl->Iperldb;
11683 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11684 PL_exit_flags = proto_perl->Iexit_flags;
11686 /* magical thingies */
11687 /* XXX time(&PL_basetime) when asked for? */
11688 PL_basetime = proto_perl->Ibasetime;
11689 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11691 PL_maxsysfd = proto_perl->Imaxsysfd;
11692 PL_statusvalue = proto_perl->Istatusvalue;
11694 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11696 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
11698 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11700 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11701 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11702 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11705 /* RE engine related */
11706 Zero(&PL_reg_state, 1, struct re_save_state);
11707 PL_reginterp_cnt = 0;
11708 PL_regmatch_slab = NULL;
11710 /* Clone the regex array */
11711 /* ORANGE FIXME for plugins, probably in the SV dup code.
11712 newSViv(PTR2IV(CALLREGDUPE(
11713 INT2PTR(REGEXP *, SvIVX(regex)), param))))
11715 PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
11716 PL_regex_pad = AvARRAY(PL_regex_padav);
11718 /* shortcuts to various I/O objects */
11719 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11720 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11721 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11722 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11723 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11724 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11726 /* shortcuts to regexp stuff */
11727 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11729 /* shortcuts to misc objects */
11730 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11732 /* shortcuts to debugging objects */
11733 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11734 PL_DBline = gv_dup(proto_perl->IDBline, param);
11735 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11736 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11737 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11738 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11739 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11741 /* symbol tables */
11742 PL_defstash = hv_dup_inc(proto_perl->Idefstash, param);
11743 PL_curstash = hv_dup(proto_perl->Icurstash, param);
11744 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11745 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11746 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11748 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11749 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11750 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11751 PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
11752 PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
11753 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11754 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11755 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11757 PL_sub_generation = proto_perl->Isub_generation;
11758 PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
11760 /* funky return mechanisms */
11761 PL_forkprocess = proto_perl->Iforkprocess;
11763 /* subprocess state */
11764 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11766 /* internal state */
11767 PL_maxo = proto_perl->Imaxo;
11768 if (proto_perl->Iop_mask)
11769 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11772 /* PL_asserting = proto_perl->Iasserting; */
11774 /* current interpreter roots */
11775 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11777 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11779 PL_main_start = proto_perl->Imain_start;
11780 PL_eval_root = proto_perl->Ieval_root;
11781 PL_eval_start = proto_perl->Ieval_start;
11783 /* runtime control stuff */
11784 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11786 PL_filemode = proto_perl->Ifilemode;
11787 PL_lastfd = proto_perl->Ilastfd;
11788 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11791 PL_gensym = proto_perl->Igensym;
11792 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11793 PL_laststatval = proto_perl->Ilaststatval;
11794 PL_laststype = proto_perl->Ilaststype;
11797 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11799 /* interpreter atexit processing */
11800 PL_exitlistlen = proto_perl->Iexitlistlen;
11801 if (PL_exitlistlen) {
11802 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11803 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11806 PL_exitlist = (PerlExitListEntry*)NULL;
11808 PL_my_cxt_size = proto_perl->Imy_cxt_size;
11809 if (PL_my_cxt_size) {
11810 Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
11811 Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
11812 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
11813 Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
11814 Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
11818 PL_my_cxt_list = (void**)NULL;
11819 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
11820 PL_my_cxt_keys = (const char**)NULL;
11823 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11824 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11825 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11827 PL_profiledata = NULL;
11829 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11831 PAD_CLONE_VARS(proto_perl, param);
11833 #ifdef HAVE_INTERP_INTERN
11834 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11837 /* more statics moved here */
11838 PL_generation = proto_perl->Igeneration;
11839 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11841 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11842 PL_in_clean_all = proto_perl->Iin_clean_all;
11844 PL_uid = proto_perl->Iuid;
11845 PL_euid = proto_perl->Ieuid;
11846 PL_gid = proto_perl->Igid;
11847 PL_egid = proto_perl->Iegid;
11848 PL_nomemok = proto_perl->Inomemok;
11849 PL_an = proto_perl->Ian;
11850 PL_evalseq = proto_perl->Ievalseq;
11851 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11852 PL_origalen = proto_perl->Iorigalen;
11853 #ifdef PERL_USES_PL_PIDSTATUS
11854 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11856 PL_osname = SAVEPV(proto_perl->Iosname);
11857 PL_sighandlerp = proto_perl->Isighandlerp;
11859 PL_runops = proto_perl->Irunops;
11861 PL_parser = parser_dup(proto_perl->Iparser, param);
11863 PL_subline = proto_perl->Isubline;
11864 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
11867 PL_cryptseen = proto_perl->Icryptseen;
11870 PL_hints = proto_perl->Ihints;
11872 PL_amagic_generation = proto_perl->Iamagic_generation;
11874 #ifdef USE_LOCALE_COLLATE
11875 PL_collation_ix = proto_perl->Icollation_ix;
11876 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
11877 PL_collation_standard = proto_perl->Icollation_standard;
11878 PL_collxfrm_base = proto_perl->Icollxfrm_base;
11879 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
11880 #endif /* USE_LOCALE_COLLATE */
11882 #ifdef USE_LOCALE_NUMERIC
11883 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
11884 PL_numeric_standard = proto_perl->Inumeric_standard;
11885 PL_numeric_local = proto_perl->Inumeric_local;
11886 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11887 #endif /* !USE_LOCALE_NUMERIC */
11889 /* utf8 character classes */
11890 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11891 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11892 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11893 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11894 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
11895 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11896 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
11897 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
11898 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
11899 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
11900 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
11901 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
11902 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11903 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
11904 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11905 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11906 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11907 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11908 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11909 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11911 /* Did the locale setup indicate UTF-8? */
11912 PL_utf8locale = proto_perl->Iutf8locale;
11913 /* Unicode features (see perlrun/-C) */
11914 PL_unicode = proto_perl->Iunicode;
11916 /* Pre-5.8 signals control */
11917 PL_signals = proto_perl->Isignals;
11919 /* times() ticks per second */
11920 PL_clocktick = proto_perl->Iclocktick;
11922 /* Recursion stopper for PerlIO_find_layer */
11923 PL_in_load_module = proto_perl->Iin_load_module;
11925 /* sort() routine */
11926 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
11928 /* Not really needed/useful since the reenrant_retint is "volatile",
11929 * but do it for consistency's sake. */
11930 PL_reentrant_retint = proto_perl->Ireentrant_retint;
11932 /* Hooks to shared SVs and locks. */
11933 PL_sharehook = proto_perl->Isharehook;
11934 PL_lockhook = proto_perl->Ilockhook;
11935 PL_unlockhook = proto_perl->Iunlockhook;
11936 PL_threadhook = proto_perl->Ithreadhook;
11937 PL_destroyhook = proto_perl->Idestroyhook;
11939 #ifdef THREADS_HAVE_PIDS
11940 PL_ppid = proto_perl->Ippid;
11944 PL_last_swash_hv = NULL; /* reinits on demand */
11945 PL_last_swash_klen = 0;
11946 PL_last_swash_key[0]= '\0';
11947 PL_last_swash_tmps = (U8*)NULL;
11948 PL_last_swash_slen = 0;
11950 PL_glob_index = proto_perl->Iglob_index;
11951 PL_srand_called = proto_perl->Isrand_called;
11952 PL_bitcount = NULL; /* reinits on demand */
11954 if (proto_perl->Ipsig_pend) {
11955 Newxz(PL_psig_pend, SIG_SIZE, int);
11958 PL_psig_pend = (int*)NULL;
11961 if (proto_perl->Ipsig_ptr) {
11962 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
11963 Newxz(PL_psig_name, SIG_SIZE, SV*);
11964 for (i = 1; i < SIG_SIZE; i++) {
11965 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11966 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11970 PL_psig_ptr = (SV**)NULL;
11971 PL_psig_name = (SV**)NULL;
11974 /* intrpvar.h stuff */
11976 if (flags & CLONEf_COPY_STACKS) {
11977 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11978 PL_tmps_ix = proto_perl->Itmps_ix;
11979 PL_tmps_max = proto_perl->Itmps_max;
11980 PL_tmps_floor = proto_perl->Itmps_floor;
11981 Newxz(PL_tmps_stack, PL_tmps_max, SV*);
11983 while (i <= PL_tmps_ix) {
11984 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Itmps_stack[i], param);
11988 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11989 i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
11990 Newxz(PL_markstack, i, I32);
11991 PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
11992 - proto_perl->Imarkstack);
11993 PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
11994 - proto_perl->Imarkstack);
11995 Copy(proto_perl->Imarkstack, PL_markstack,
11996 PL_markstack_ptr - PL_markstack + 1, I32);
11998 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
11999 * NOTE: unlike the others! */
12000 PL_scopestack_ix = proto_perl->Iscopestack_ix;
12001 PL_scopestack_max = proto_perl->Iscopestack_max;
12002 Newxz(PL_scopestack, PL_scopestack_max, I32);
12003 Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
12005 /* NOTE: si_dup() looks at PL_markstack */
12006 PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);
12008 /* PL_curstack = PL_curstackinfo->si_stack; */
12009 PL_curstack = av_dup(proto_perl->Icurstack, param);
12010 PL_mainstack = av_dup(proto_perl->Imainstack, param);
12012 /* next PUSHs() etc. set *(PL_stack_sp+1) */
12013 PL_stack_base = AvARRAY(PL_curstack);
12014 PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp
12015 - proto_perl->Istack_base);
12016 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
12018 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12019 * NOTE: unlike the others! */
12020 PL_savestack_ix = proto_perl->Isavestack_ix;
12021 PL_savestack_max = proto_perl->Isavestack_max;
12022 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
12023 PL_savestack = ss_dup(proto_perl, param);
12027 ENTER; /* perl_destruct() wants to LEAVE; */
12029 /* although we're not duplicating the tmps stack, we should still
12030 * add entries for any SVs on the tmps stack that got cloned by a
12031 * non-refcount means (eg a temp in @_); otherwise they will be
12034 for (i = 0; i<= proto_perl->Itmps_ix; i++) {
12035 SV * const nsv = (SV*)ptr_table_fetch(PL_ptr_table,
12036 proto_perl->Itmps_stack[i]);
12037 if (nsv && !SvREFCNT(nsv)) {
12039 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv);
12044 PL_start_env = proto_perl->Istart_env; /* XXXXXX */
12045 PL_top_env = &PL_start_env;
12047 PL_op = proto_perl->Iop;
12050 PL_Xpv = (XPV*)NULL;
12051 my_perl->Ina = proto_perl->Ina;
12053 PL_statbuf = proto_perl->Istatbuf;
12054 PL_statcache = proto_perl->Istatcache;
12055 PL_statgv = gv_dup(proto_perl->Istatgv, param);
12056 PL_statname = sv_dup_inc(proto_perl->Istatname, param);
12058 PL_timesbuf = proto_perl->Itimesbuf;
12061 PL_tainted = proto_perl->Itainted;
12062 PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */
12063 PL_rs = sv_dup_inc(proto_perl->Irs, param);
12064 PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param);
12065 PL_ofs_sv = sv_dup_inc(proto_perl->Iofs_sv, param);
12066 PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param);
12067 PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */
12068 PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param);
12069 PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param);
12070 PL_formtarget = sv_dup(proto_perl->Iformtarget, param);
12072 PL_restartop = proto_perl->Irestartop;
12073 PL_in_eval = proto_perl->Iin_eval;
12074 PL_delaymagic = proto_perl->Idelaymagic;
12075 PL_dirty = proto_perl->Idirty;
12076 PL_localizing = proto_perl->Ilocalizing;
12078 PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
12079 PL_hv_fetch_ent_mh = NULL;
12080 PL_modcount = proto_perl->Imodcount;
12081 PL_lastgotoprobe = NULL;
12082 PL_dumpindent = proto_perl->Idumpindent;
12084 PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
12085 PL_sortstash = hv_dup(proto_perl->Isortstash, param);
12086 PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
12087 PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
12088 PL_efloatbuf = NULL; /* reinits on demand */
12089 PL_efloatsize = 0; /* reinits on demand */
12093 PL_screamfirst = NULL;
12094 PL_screamnext = NULL;
12095 PL_maxscream = -1; /* reinits on demand */
12096 PL_lastscream = NULL;
12099 PL_regdummy = proto_perl->Iregdummy;
12100 PL_colorset = 0; /* reinits PL_colors[] */
12101 /*PL_colors[6] = {0,0,0,0,0,0};*/
12105 /* Pluggable optimizer */
12106 PL_peepp = proto_perl->Ipeepp;
12108 PL_stashcache = newHV();
12110 PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table,
12111 proto_perl->Iwatchaddr);
12112 PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
12113 if (PL_debug && PL_watchaddr) {
12114 PerlIO_printf(Perl_debug_log,
12115 "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
12116 PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
12117 PTR2UV(PL_watchok));
12120 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12121 ptr_table_free(PL_ptr_table);
12122 PL_ptr_table = NULL;
12125 /* Call the ->CLONE method, if it exists, for each of the stashes
12126 identified by sv_dup() above.
12128 while(av_len(param->stashes) != -1) {
12129 HV* const stash = (HV*) av_shift(param->stashes);
12130 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12131 if (cloner && GvCV(cloner)) {
12136 mXPUSHs(newSVhek(HvNAME_HEK(stash)));
12138 call_sv((SV*)GvCV(cloner), G_DISCARD);
12144 SvREFCNT_dec(param->stashes);
12146 /* orphaned? eg threads->new inside BEGIN or use */
12147 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
12148 SvREFCNT_inc_simple_void(PL_compcv);
12149 SAVEFREESV(PL_compcv);
12155 #endif /* USE_ITHREADS */
12158 =head1 Unicode Support
12160 =for apidoc sv_recode_to_utf8
12162 The encoding is assumed to be an Encode object, on entry the PV
12163 of the sv is assumed to be octets in that encoding, and the sv
12164 will be converted into Unicode (and UTF-8).
12166 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12167 is not a reference, nothing is done to the sv. If the encoding is not
12168 an C<Encode::XS> Encoding object, bad things will happen.
12169 (See F<lib/encoding.pm> and L<Encode>).
12171 The PV of the sv is returned.
12176 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12180 PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
12182 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12196 Passing sv_yes is wrong - it needs to be or'ed set of constants
12197 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12198 remove converted chars from source.
12200 Both will default the value - let them.
12202 XPUSHs(&PL_sv_yes);
12205 call_method("decode", G_SCALAR);
12209 s = SvPV_const(uni, len);
12210 if (s != SvPVX_const(sv)) {
12211 SvGROW(sv, len + 1);
12212 Move(s, SvPVX(sv), len + 1, char);
12213 SvCUR_set(sv, len);
12220 return SvPOKp(sv) ? SvPVX(sv) : NULL;
12224 =for apidoc sv_cat_decode
12226 The encoding is assumed to be an Encode object, the PV of the ssv is
12227 assumed to be octets in that encoding and decoding the input starts
12228 from the position which (PV + *offset) pointed to. The dsv will be
12229 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
12230 when the string tstr appears in decoding output or the input ends on
12231 the PV of the ssv. The value which the offset points will be modified
12232 to the last input position on the ssv.
12234 Returns TRUE if the terminator was found, else returns FALSE.
12239 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12240 SV *ssv, int *offset, char *tstr, int tlen)
12245 PERL_ARGS_ASSERT_SV_CAT_DECODE;
12247 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12258 offsv = newSViv(*offset);
12260 mXPUSHp(tstr, tlen);
12262 call_method("cat_decode", G_SCALAR);
12264 ret = SvTRUE(TOPs);
12265 *offset = SvIV(offsv);
12271 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12276 /* ---------------------------------------------------------------------
12278 * support functions for report_uninit()
12281 /* the maxiumum size of array or hash where we will scan looking
12282 * for the undefined element that triggered the warning */
12284 #define FUV_MAX_SEARCH_SIZE 1000
12286 /* Look for an entry in the hash whose value has the same SV as val;
12287 * If so, return a mortal copy of the key. */
12290 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
12293 register HE **array;
12296 PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
12298 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
12299 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
12302 array = HvARRAY(hv);
12304 for (i=HvMAX(hv); i>0; i--) {
12305 register HE *entry;
12306 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
12307 if (HeVAL(entry) != val)
12309 if ( HeVAL(entry) == &PL_sv_undef ||
12310 HeVAL(entry) == &PL_sv_placeholder)
12314 if (HeKLEN(entry) == HEf_SVKEY)
12315 return sv_mortalcopy(HeKEY_sv(entry));
12316 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
12322 /* Look for an entry in the array whose value has the same SV as val;
12323 * If so, return the index, otherwise return -1. */
12326 S_find_array_subscript(pTHX_ AV *av, SV* val)
12330 PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
12332 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
12333 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
12336 if (val != &PL_sv_undef) {
12337 SV ** const svp = AvARRAY(av);
12340 for (i=AvFILLp(av); i>=0; i--)
12347 /* S_varname(): return the name of a variable, optionally with a subscript.
12348 * If gv is non-zero, use the name of that global, along with gvtype (one
12349 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
12350 * targ. Depending on the value of the subscript_type flag, return:
12353 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
12354 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
12355 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
12356 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
12359 S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
12360 SV* keyname, I32 aindex, int subscript_type)
12363 SV * const name = sv_newmortal();
12366 buffer[0] = gvtype;
12369 /* as gv_fullname4(), but add literal '^' for $^FOO names */
12371 gv_fullname4(name, gv, buffer, 0);
12373 if ((unsigned int)SvPVX(name)[1] <= 26) {
12375 buffer[1] = SvPVX(name)[1] + 'A' - 1;
12377 /* Swap the 1 unprintable control character for the 2 byte pretty
12378 version - ie substr($name, 1, 1) = $buffer; */
12379 sv_insert(name, 1, 1, buffer, 2);
12383 CV * const cv = find_runcv(NULL);
12387 if (!cv || !CvPADLIST(cv))
12389 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
12390 sv = *av_fetch(av, targ, FALSE);
12391 sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
12394 if (subscript_type == FUV_SUBSCRIPT_HASH) {
12395 SV * const sv = newSV(0);
12396 *SvPVX(name) = '$';
12397 Perl_sv_catpvf(aTHX_ name, "{%s}",
12398 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
12401 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
12402 *SvPVX(name) = '$';
12403 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
12405 else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
12406 /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
12407 Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
12415 =for apidoc find_uninit_var
12417 Find the name of the undefined variable (if any) that caused the operator o
12418 to issue a "Use of uninitialized value" warning.
12419 If match is true, only return a name if it's value matches uninit_sv.
12420 So roughly speaking, if a unary operator (such as OP_COS) generates a
12421 warning, then following the direct child of the op may yield an
12422 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
12423 other hand, with OP_ADD there are two branches to follow, so we only print
12424 the variable name if we get an exact match.
12426 The name is returned as a mortal SV.
12428 Assumes that PL_op is the op that originally triggered the error, and that
12429 PL_comppad/PL_curpad points to the currently executing pad.
12435 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
12443 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
12444 uninit_sv == &PL_sv_placeholder)))
12447 switch (obase->op_type) {
12454 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
12455 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
12458 int subscript_type = FUV_SUBSCRIPT_WITHIN;
12460 if (pad) { /* @lex, %lex */
12461 sv = PAD_SVl(obase->op_targ);
12465 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
12466 /* @global, %global */
12467 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
12470 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
12472 else /* @{expr}, %{expr} */
12473 return find_uninit_var(cUNOPx(obase)->op_first,
12477 /* attempt to find a match within the aggregate */
12479 keysv = find_hash_subscript((HV*)sv, uninit_sv);
12481 subscript_type = FUV_SUBSCRIPT_HASH;
12484 index = find_array_subscript((AV*)sv, uninit_sv);
12486 subscript_type = FUV_SUBSCRIPT_ARRAY;
12489 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
12492 return varname(gv, hash ? '%' : '@', obase->op_targ,
12493 keysv, index, subscript_type);
12497 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
12499 return varname(NULL, '$', obase->op_targ,
12500 NULL, 0, FUV_SUBSCRIPT_NONE);
12503 gv = cGVOPx_gv(obase);
12504 if (!gv || (match && GvSV(gv) != uninit_sv))
12506 return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
12509 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
12512 av = (AV*)PAD_SV(obase->op_targ);
12513 if (!av || SvRMAGICAL(av))
12515 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12516 if (!svp || *svp != uninit_sv)
12519 return varname(NULL, '$', obase->op_targ,
12520 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12523 gv = cGVOPx_gv(obase);
12529 if (!av || SvRMAGICAL(av))
12531 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12532 if (!svp || *svp != uninit_sv)
12535 return varname(gv, '$', 0,
12536 NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12541 o = cUNOPx(obase)->op_first;
12542 if (!o || o->op_type != OP_NULL ||
12543 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
12545 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
12549 if (PL_op == obase)
12550 /* $a[uninit_expr] or $h{uninit_expr} */
12551 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
12554 o = cBINOPx(obase)->op_first;
12555 kid = cBINOPx(obase)->op_last;
12557 /* get the av or hv, and optionally the gv */
12559 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
12560 sv = PAD_SV(o->op_targ);
12562 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
12563 && cUNOPo->op_first->op_type == OP_GV)
12565 gv = cGVOPx_gv(cUNOPo->op_first);
12568 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
12573 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
12574 /* index is constant */
12578 if (obase->op_type == OP_HELEM) {
12579 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
12580 if (!he || HeVAL(he) != uninit_sv)
12584 SV * const * const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
12585 if (!svp || *svp != uninit_sv)
12589 if (obase->op_type == OP_HELEM)
12590 return varname(gv, '%', o->op_targ,
12591 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
12593 return varname(gv, '@', o->op_targ, NULL,
12594 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
12597 /* index is an expression;
12598 * attempt to find a match within the aggregate */
12599 if (obase->op_type == OP_HELEM) {
12600 SV * const keysv = find_hash_subscript((HV*)sv, uninit_sv);
12602 return varname(gv, '%', o->op_targ,
12603 keysv, 0, FUV_SUBSCRIPT_HASH);
12606 const I32 index = find_array_subscript((AV*)sv, uninit_sv);
12608 return varname(gv, '@', o->op_targ,
12609 NULL, index, FUV_SUBSCRIPT_ARRAY);
12614 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
12616 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
12621 /* only examine RHS */
12622 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
12625 o = cUNOPx(obase)->op_first;
12626 if (o->op_type == OP_PUSHMARK)
12629 if (!o->op_sibling) {
12630 /* one-arg version of open is highly magical */
12632 if (o->op_type == OP_GV) { /* open FOO; */
12634 if (match && GvSV(gv) != uninit_sv)
12636 return varname(gv, '$', 0,
12637 NULL, 0, FUV_SUBSCRIPT_NONE);
12639 /* other possibilities not handled are:
12640 * open $x; or open my $x; should return '${*$x}'
12641 * open expr; should return '$'.expr ideally
12647 /* ops where $_ may be an implicit arg */
12651 if ( !(obase->op_flags & OPf_STACKED)) {
12652 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
12653 ? PAD_SVl(obase->op_targ)
12656 sv = sv_newmortal();
12657 sv_setpvn(sv, "$_", 2);
12666 match = 1; /* print etc can return undef on defined args */
12667 /* skip filehandle as it can't produce 'undef' warning */
12668 o = cUNOPx(obase)->op_first;
12669 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
12670 o = o->op_sibling->op_sibling;
12674 case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
12676 case OP_CUSTOM: /* XS or custom code could trigger random warnings */
12678 /* the following ops are capable of returning PL_sv_undef even for
12679 * defined arg(s) */
12698 case OP_GETPEERNAME:
12746 case OP_SMARTMATCH:
12755 /* XXX tmp hack: these two may call an XS sub, and currently
12756 XS subs don't have a SUB entry on the context stack, so CV and
12757 pad determination goes wrong, and BAD things happen. So, just
12758 don't try to determine the value under those circumstances.
12759 Need a better fix at dome point. DAPM 11/2007 */
12764 /* def-ness of rval pos() is independent of the def-ness of its arg */
12765 if ( !(obase->op_flags & OPf_MOD))
12770 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
12771 return newSVpvs_flags("${$/}", SVs_TEMP);
12776 if (!(obase->op_flags & OPf_KIDS))
12778 o = cUNOPx(obase)->op_first;
12784 /* if all except one arg are constant, or have no side-effects,
12785 * or are optimized away, then it's unambiguous */
12787 for (kid=o; kid; kid = kid->op_sibling) {
12789 const OPCODE type = kid->op_type;
12790 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
12791 || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
12792 || (type == OP_PUSHMARK)
12796 if (o2) { /* more than one found */
12803 return find_uninit_var(o2, uninit_sv, match);
12805 /* scan all args */
12807 sv = find_uninit_var(o, uninit_sv, 1);
12819 =for apidoc report_uninit
12821 Print appropriate "Use of uninitialized variable" warning
12827 Perl_report_uninit(pTHX_ SV* uninit_sv)
12831 SV* varname = NULL;
12833 varname = find_uninit_var(PL_op, uninit_sv,0);
12835 sv_insert(varname, 0, 0, " ", 1);
12837 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
12838 varname ? SvPV_nolen_const(varname) : "",
12839 " in ", OP_DESC(PL_op));
12842 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
12848 * c-indentation-style: bsd
12849 * c-basic-offset: 4
12850 * indent-tabs-mode: t
12853 * ex: set ts=8 sts=4 sw=4 noet: