3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
9 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
12 * This file contains the code that creates, manipulates and destroys
13 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
14 * structure of an SV, so their creation and destruction is handled
15 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
16 * level functions (eg. substr, split, join) for each of the types are
28 /* Missing proto on LynxOS */
29 char *gconvert(double, int, int, char *);
32 #ifdef PERL_UTF8_CACHE_ASSERT
33 /* The cache element 0 is the Unicode offset;
34 * the cache element 1 is the byte offset of the element 0;
35 * the cache element 2 is the Unicode length of the substring;
36 * the cache element 3 is the byte length of the substring;
37 * The checking of the substring side would be good
38 * but substr() has enough code paths to make my head spin;
39 * if adding more checks watch out for the following tests:
40 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
41 * lib/utf8.t lib/Unicode/Collate/t/index.t
44 #define ASSERT_UTF8_CACHE(cache) \
45 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
47 #define ASSERT_UTF8_CACHE(cache) NOOP
50 #ifdef PERL_OLD_COPY_ON_WRITE
51 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
52 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
53 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
57 /* ============================================================================
59 =head1 Allocation and deallocation of SVs.
61 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
62 av, hv...) contains type and reference count information, as well as a
63 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
64 specific to each type.
66 In all but the most memory-paranoid configuations (ex: PURIFY), this
67 allocation is done using arenas, which by default are approximately 4K
68 chunks of memory parcelled up into N heads or bodies (of same size).
69 Sv-bodies are allocated by their sv-type, guaranteeing size
70 consistency needed to allocate safely from arrays.
72 The first slot in each arena is reserved, and is used to hold a link
73 to the next arena. In the case of heads, the unused first slot also
74 contains some flags and a note of the number of slots. Snaked through
75 each arena chain is a linked list of free items; when this becomes
76 empty, an extra arena is allocated and divided up into N items which
77 are threaded into the free list.
79 The following global variables are associated with arenas:
81 PL_sv_arenaroot pointer to list of SV arenas
82 PL_sv_root pointer to list of free SV structures
84 PL_body_arenaroots[] array of pointers to list of arenas, 1 per svtype
85 PL_body_roots[] array of pointers to list of free bodies of svtype
86 arrays are indexed by the svtype needed
88 Note that some of the larger and more rarely used body types (eg
89 xpvio) are not allocated using arenas, but are instead just
90 malloc()/free()ed as required.
92 In addition, a few SV heads are not allocated from an arena, but are
93 instead directly created as static or auto variables, eg PL_sv_undef.
94 The size of arenas can be changed from the default by setting
95 PERL_ARENA_SIZE appropriately at compile time.
97 The SV arena serves the secondary purpose of allowing still-live SVs
98 to be located and destroyed during final cleanup.
100 At the lowest level, the macros new_SV() and del_SV() grab and free
101 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
102 to return the SV to the free list with error checking.) new_SV() calls
103 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
104 SVs in the free list have their SvTYPE field set to all ones.
106 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
107 that allocate and return individual body types. Normally these are mapped
108 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
109 instead mapped directly to malloc()/free() if PURIFY is defined. The
110 new/del functions remove from, or add to, the appropriate PL_foo_root
111 list, and call more_xiv() etc to add a new arena if the list is empty.
113 At the time of very final cleanup, sv_free_arenas() is called from
114 perl_destruct() to physically free all the arenas allocated since the
115 start of the interpreter. Note that this also clears PL_he_arenaroot,
116 which is otherwise dealt with in hv.c.
118 Manipulation of any of the PL_*root pointers is protected by enclosing
119 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
120 if threads are enabled.
122 The function visit() scans the SV arenas list, and calls a specified
123 function for each SV it finds which is still live - ie which has an SvTYPE
124 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
125 following functions (specified as [function that calls visit()] / [function
126 called by visit() for each SV]):
128 sv_report_used() / do_report_used()
129 dump all remaining SVs (debugging aid)
131 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
132 Attempt to free all objects pointed to by RVs,
133 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
134 try to do the same for all objects indirectly
135 referenced by typeglobs too. Called once from
136 perl_destruct(), prior to calling sv_clean_all()
139 sv_clean_all() / do_clean_all()
140 SvREFCNT_dec(sv) each remaining SV, possibly
141 triggering an sv_free(). It also sets the
142 SVf_BREAK flag on the SV to indicate that the
143 refcnt has been artificially lowered, and thus
144 stopping sv_free() from giving spurious warnings
145 about SVs which unexpectedly have a refcnt
146 of zero. called repeatedly from perl_destruct()
147 until there are no SVs left.
149 =head2 Arena allocator API Summary
151 Private API to rest of sv.c
155 new_XIV(), del_XIV(),
156 new_XNV(), del_XNV(),
161 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
166 ============================================================================ */
171 * "A time to plant, and a time to uproot what was planted..."
175 * nice_chunk and nice_chunk size need to be set
176 * and queried under the protection of sv_mutex
179 Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
184 new_chunk = (void *)(chunk);
185 new_chunk_size = (chunk_size);
186 if (new_chunk_size > PL_nice_chunk_size) {
187 Safefree(PL_nice_chunk);
188 PL_nice_chunk = (char *) new_chunk;
189 PL_nice_chunk_size = new_chunk_size;
196 #ifdef DEBUG_LEAKING_SCALARS
197 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
199 # define FREE_SV_DEBUG_FILE(sv)
203 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
204 /* Whilst I'd love to do this, it seems that things like to check on
206 # define POSION_SV_HEAD(sv) Poison(sv, 1, struct STRUCT_SV)
208 # define POSION_SV_HEAD(sv) Poison(&SvANY(sv), 1, void *), \
209 Poison(&SvREFCNT(sv), 1, U32)
211 # define SvARENA_CHAIN(sv) SvANY(sv)
212 # define POSION_SV_HEAD(sv)
215 #define plant_SV(p) \
217 FREE_SV_DEBUG_FILE(p); \
219 SvARENA_CHAIN(p) = (void *)PL_sv_root; \
220 SvFLAGS(p) = SVTYPEMASK; \
225 /* sv_mutex must be held while calling uproot_SV() */
226 #define uproot_SV(p) \
229 PL_sv_root = (SV*)SvARENA_CHAIN(p); \
234 /* make some more SVs by adding another arena */
236 /* sv_mutex must be held while calling more_sv() */
243 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
244 PL_nice_chunk = Nullch;
245 PL_nice_chunk_size = 0;
248 char *chunk; /* must use New here to match call to */
249 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
250 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
256 /* new_SV(): return a new, empty SV head */
258 #ifdef DEBUG_LEAKING_SCALARS
259 /* provide a real function for a debugger to play with */
269 sv = S_more_sv(aTHX);
274 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
275 sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
276 (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
277 sv->sv_debug_inpad = 0;
278 sv->sv_debug_cloned = 0;
279 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
283 # define new_SV(p) (p)=S_new_SV(aTHX)
292 (p) = S_more_sv(aTHX); \
301 /* del_SV(): return an empty SV head to the free list */
316 S_del_sv(pTHX_ SV *p)
321 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
322 const SV * const sv = sva + 1;
323 const SV * const svend = &sva[SvREFCNT(sva)];
324 if (p >= sv && p < svend) {
330 if (ckWARN_d(WARN_INTERNAL))
331 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
332 "Attempt to free non-arena SV: 0x%"UVxf
333 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
340 #else /* ! DEBUGGING */
342 #define del_SV(p) plant_SV(p)
344 #endif /* DEBUGGING */
348 =head1 SV Manipulation Functions
350 =for apidoc sv_add_arena
352 Given a chunk of memory, link it to the head of the list of arenas,
353 and split it into a list of free SVs.
359 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
365 /* The first SV in an arena isn't an SV. */
366 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
367 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
368 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
370 PL_sv_arenaroot = sva;
371 PL_sv_root = sva + 1;
373 svend = &sva[SvREFCNT(sva) - 1];
376 SvARENA_CHAIN(sv) = (void *)(SV*)(sv + 1);
380 /* Must always set typemask because it's awlays checked in on cleanup
381 when the arenas are walked looking for objects. */
382 SvFLAGS(sv) = SVTYPEMASK;
385 SvARENA_CHAIN(sv) = 0;
389 SvFLAGS(sv) = SVTYPEMASK;
392 /* visit(): call the named function for each non-free SV in the arenas
393 * whose flags field matches the flags/mask args. */
396 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
401 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
402 register const SV * const svend = &sva[SvREFCNT(sva)];
404 for (sv = sva + 1; sv < svend; ++sv) {
405 if (SvTYPE(sv) != SVTYPEMASK
406 && (sv->sv_flags & mask) == flags
419 /* called by sv_report_used() for each live SV */
422 do_report_used(pTHX_ SV *sv)
424 if (SvTYPE(sv) != SVTYPEMASK) {
425 PerlIO_printf(Perl_debug_log, "****\n");
432 =for apidoc sv_report_used
434 Dump the contents of all SVs not yet freed. (Debugging aid).
440 Perl_sv_report_used(pTHX)
443 visit(do_report_used, 0, 0);
447 /* called by sv_clean_objs() for each live SV */
450 do_clean_objs(pTHX_ SV *ref)
453 SV * const target = SvRV(ref);
454 if (SvOBJECT(target)) {
455 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
456 if (SvWEAKREF(ref)) {
457 sv_del_backref(target, ref);
463 SvREFCNT_dec(target);
468 /* XXX Might want to check arrays, etc. */
471 /* called by sv_clean_objs() for each live SV */
473 #ifndef DISABLE_DESTRUCTOR_KLUDGE
475 do_clean_named_objs(pTHX_ SV *sv)
477 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
479 #ifdef PERL_DONT_CREATE_GVSV
482 SvOBJECT(GvSV(sv))) ||
483 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
484 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
485 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
486 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
488 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
489 SvFLAGS(sv) |= SVf_BREAK;
497 =for apidoc sv_clean_objs
499 Attempt to destroy all objects not yet freed
505 Perl_sv_clean_objs(pTHX)
507 PL_in_clean_objs = TRUE;
508 visit(do_clean_objs, SVf_ROK, SVf_ROK);
509 #ifndef DISABLE_DESTRUCTOR_KLUDGE
510 /* some barnacles may yet remain, clinging to typeglobs */
511 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
513 PL_in_clean_objs = FALSE;
516 /* called by sv_clean_all() for each live SV */
519 do_clean_all(pTHX_ SV *sv)
521 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
522 SvFLAGS(sv) |= SVf_BREAK;
523 if (PL_comppad == (AV*)sv) {
525 PL_curpad = Null(SV**);
531 =for apidoc sv_clean_all
533 Decrement the refcnt of each remaining SV, possibly triggering a
534 cleanup. This function may have to be called multiple times to free
535 SVs which are in complex self-referential hierarchies.
541 Perl_sv_clean_all(pTHX)
544 PL_in_clean_all = TRUE;
545 cleaned = visit(do_clean_all, 0,0);
546 PL_in_clean_all = FALSE;
551 S_free_arena(pTHX_ void **root) {
553 void ** const next = *(void **)root;
560 =for apidoc sv_free_arenas
562 Deallocate the memory used by all arenas. Note that all the individual SV
563 heads and bodies within the arenas must already have been freed.
567 #define free_arena(name) \
569 S_free_arena(aTHX_ (void**) PL_ ## name ## _arenaroot); \
570 PL_ ## name ## _arenaroot = 0; \
571 PL_ ## name ## _root = 0; \
575 Perl_sv_free_arenas(pTHX)
581 /* Free arenas here, but be careful about fake ones. (We assume
582 contiguity of the fake ones with the corresponding real ones.) */
584 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
585 svanext = (SV*) SvANY(sva);
586 while (svanext && SvFAKE(svanext))
587 svanext = (SV*) SvANY(svanext);
593 for (i=0; i<SVt_LAST; i++) {
594 S_free_arena(aTHX_ (void**) PL_body_arenaroots[i]);
595 PL_body_arenaroots[i] = 0;
596 PL_body_roots[i] = 0;
601 Safefree(PL_nice_chunk);
602 PL_nice_chunk = Nullch;
603 PL_nice_chunk_size = 0;
608 /* ---------------------------------------------------------------------
610 * support functions for report_uninit()
613 /* the maxiumum size of array or hash where we will scan looking
614 * for the undefined element that triggered the warning */
616 #define FUV_MAX_SEARCH_SIZE 1000
618 /* Look for an entry in the hash whose value has the same SV as val;
619 * If so, return a mortal copy of the key. */
622 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
628 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
629 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
634 for (i=HvMAX(hv); i>0; i--) {
636 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
637 if (HeVAL(entry) != val)
639 if ( HeVAL(entry) == &PL_sv_undef ||
640 HeVAL(entry) == &PL_sv_placeholder)
644 if (HeKLEN(entry) == HEf_SVKEY)
645 return sv_mortalcopy(HeKEY_sv(entry));
646 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
652 /* Look for an entry in the array whose value has the same SV as val;
653 * If so, return the index, otherwise return -1. */
656 S_find_array_subscript(pTHX_ AV *av, SV* val)
660 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
661 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
665 for (i=AvFILLp(av); i>=0; i--) {
666 if (svp[i] == val && svp[i] != &PL_sv_undef)
672 /* S_varname(): return the name of a variable, optionally with a subscript.
673 * If gv is non-zero, use the name of that global, along with gvtype (one
674 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
675 * targ. Depending on the value of the subscript_type flag, return:
678 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
679 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
680 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
681 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
684 S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
685 SV* keyname, I32 aindex, int subscript_type)
688 SV * const name = sv_newmortal();
694 /* as gv_fullname4(), but add literal '^' for $^FOO names */
696 gv_fullname4(name, gv, buffer, 0);
698 if ((unsigned int)SvPVX(name)[1] <= 26) {
700 buffer[1] = SvPVX(name)[1] + 'A' - 1;
702 /* Swap the 1 unprintable control character for the 2 byte pretty
703 version - ie substr($name, 1, 1) = $buffer; */
704 sv_insert(name, 1, 1, buffer, 2);
709 CV * const cv = find_runcv(&unused);
713 if (!cv || !CvPADLIST(cv))
715 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
716 sv = *av_fetch(av, targ, FALSE);
717 /* SvLEN in a pad name is not to be trusted */
718 sv_setpv(name, SvPV_nolen_const(sv));
721 if (subscript_type == FUV_SUBSCRIPT_HASH) {
722 SV * const sv = NEWSV(0,0);
724 Perl_sv_catpvf(aTHX_ name, "{%s}",
725 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
728 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
730 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
732 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
733 sv_insert(name, 0, 0, "within ", 7);
740 =for apidoc find_uninit_var
742 Find the name of the undefined variable (if any) that caused the operator o
743 to issue a "Use of uninitialized value" warning.
744 If match is true, only return a name if it's value matches uninit_sv.
745 So roughly speaking, if a unary operator (such as OP_COS) generates a
746 warning, then following the direct child of the op may yield an
747 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
748 other hand, with OP_ADD there are two branches to follow, so we only print
749 the variable name if we get an exact match.
751 The name is returned as a mortal SV.
753 Assumes that PL_op is the op that originally triggered the error, and that
754 PL_comppad/PL_curpad points to the currently executing pad.
760 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
768 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
769 uninit_sv == &PL_sv_placeholder)))
772 switch (obase->op_type) {
779 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
780 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
783 int subscript_type = FUV_SUBSCRIPT_WITHIN;
785 if (pad) { /* @lex, %lex */
786 sv = PAD_SVl(obase->op_targ);
790 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
791 /* @global, %global */
792 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
795 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
797 else /* @{expr}, %{expr} */
798 return find_uninit_var(cUNOPx(obase)->op_first,
802 /* attempt to find a match within the aggregate */
804 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
806 subscript_type = FUV_SUBSCRIPT_HASH;
809 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
811 subscript_type = FUV_SUBSCRIPT_ARRAY;
814 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
817 return varname(gv, hash ? '%' : '@', obase->op_targ,
818 keysv, index, subscript_type);
822 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
824 return varname(Nullgv, '$', obase->op_targ,
825 Nullsv, 0, FUV_SUBSCRIPT_NONE);
828 gv = cGVOPx_gv(obase);
829 if (!gv || (match && GvSV(gv) != uninit_sv))
831 return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
834 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
837 av = (AV*)PAD_SV(obase->op_targ);
838 if (!av || SvRMAGICAL(av))
840 svp = av_fetch(av, (I32)obase->op_private, FALSE);
841 if (!svp || *svp != uninit_sv)
844 return varname(Nullgv, '$', obase->op_targ,
845 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
848 gv = cGVOPx_gv(obase);
854 if (!av || SvRMAGICAL(av))
856 svp = av_fetch(av, (I32)obase->op_private, FALSE);
857 if (!svp || *svp != uninit_sv)
860 return varname(gv, '$', 0,
861 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
866 o = cUNOPx(obase)->op_first;
867 if (!o || o->op_type != OP_NULL ||
868 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
870 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
875 /* $a[uninit_expr] or $h{uninit_expr} */
876 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
879 o = cBINOPx(obase)->op_first;
880 kid = cBINOPx(obase)->op_last;
882 /* get the av or hv, and optionally the gv */
884 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
885 sv = PAD_SV(o->op_targ);
887 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
888 && cUNOPo->op_first->op_type == OP_GV)
890 gv = cGVOPx_gv(cUNOPo->op_first);
893 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
898 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
899 /* index is constant */
903 if (obase->op_type == OP_HELEM) {
904 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
905 if (!he || HeVAL(he) != uninit_sv)
909 SV ** const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
910 if (!svp || *svp != uninit_sv)
914 if (obase->op_type == OP_HELEM)
915 return varname(gv, '%', o->op_targ,
916 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
918 return varname(gv, '@', o->op_targ, Nullsv,
919 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
923 /* index is an expression;
924 * attempt to find a match within the aggregate */
925 if (obase->op_type == OP_HELEM) {
926 SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
928 return varname(gv, '%', o->op_targ,
929 keysv, 0, FUV_SUBSCRIPT_HASH);
932 const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
934 return varname(gv, '@', o->op_targ,
935 Nullsv, index, FUV_SUBSCRIPT_ARRAY);
940 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
942 o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
948 /* only examine RHS */
949 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
952 o = cUNOPx(obase)->op_first;
953 if (o->op_type == OP_PUSHMARK)
956 if (!o->op_sibling) {
957 /* one-arg version of open is highly magical */
959 if (o->op_type == OP_GV) { /* open FOO; */
961 if (match && GvSV(gv) != uninit_sv)
963 return varname(gv, '$', 0,
964 Nullsv, 0, FUV_SUBSCRIPT_NONE);
966 /* other possibilities not handled are:
967 * open $x; or open my $x; should return '${*$x}'
968 * open expr; should return '$'.expr ideally
974 /* ops where $_ may be an implicit arg */
978 if ( !(obase->op_flags & OPf_STACKED)) {
979 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
980 ? PAD_SVl(obase->op_targ)
984 sv_setpvn(sv, "$_", 2);
992 /* skip filehandle as it can't produce 'undef' warning */
993 o = cUNOPx(obase)->op_first;
994 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
995 o = o->op_sibling->op_sibling;
1002 match = 1; /* XS or custom code could trigger random warnings */
1007 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
1008 return sv_2mortal(newSVpvn("${$/}", 5));
1013 if (!(obase->op_flags & OPf_KIDS))
1015 o = cUNOPx(obase)->op_first;
1021 /* if all except one arg are constant, or have no side-effects,
1022 * or are optimized away, then it's unambiguous */
1024 for (kid=o; kid; kid = kid->op_sibling) {
1026 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
1027 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
1028 || (kid->op_type == OP_PUSHMARK)
1032 if (o2) { /* more than one found */
1039 return find_uninit_var(o2, uninit_sv, match);
1043 sv = find_uninit_var(o, uninit_sv, 1);
1055 =for apidoc report_uninit
1057 Print appropriate "Use of uninitialized variable" warning
1063 Perl_report_uninit(pTHX_ SV* uninit_sv)
1066 SV* varname = Nullsv;
1068 varname = find_uninit_var(PL_op, uninit_sv,0);
1070 sv_insert(varname, 0, 0, " ", 1);
1072 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1073 varname ? SvPV_nolen_const(varname) : "",
1074 " in ", OP_DESC(PL_op));
1077 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1082 Here are mid-level routines that manage the allocation of bodies out
1083 of the various arenas. There are 5 kinds of arenas:
1085 1. SV-head arenas, which are discussed and handled above
1086 2. regular body arenas
1087 3. arenas for reduced-size bodies
1088 4. Hash-Entry arenas
1089 5. pte arenas (thread related)
1091 Arena types 2 & 3 are chained by body-type off an array of
1092 arena-root pointers, which is indexed by svtype. Some of the
1093 larger/less used body types are malloced singly, since a large
1094 unused block of them is wasteful. Also, several svtypes dont have
1095 bodies; the data fits into the sv-head itself. The arena-root
1096 pointer thus has a few unused root-pointers (which may be hijacked
1097 later for arena types 4,5)
1099 3 differs from 2 as an optimization; some body types have several
1100 unused fields in the front of the structure (which are kept in-place
1101 for consistency). These bodies can be allocated in smaller chunks,
1102 because the leading fields arent accessed. Pointers to such bodies
1103 are decremented to point at the unused 'ghost' memory, knowing that
1104 the pointers are used with offsets to the real memory.
1106 HE, HEK arenas are managed separately, with separate code, but may
1107 be merge-able later..
1109 PTE arenas are not sv-bodies, but they share these mid-level
1110 mechanics, so are considered here. The new mid-level mechanics rely
1111 on the sv_type of the body being allocated, so we just reserve one
1112 of the unused body-slots for PTEs, then use it in those (2) PTE
1113 contexts below (line ~10k)
1117 S_more_bodies (pTHX_ size_t size, svtype sv_type)
1119 void **arena_root = &PL_body_arenaroots[sv_type];
1120 void **root = &PL_body_roots[sv_type];
1123 const size_t count = PERL_ARENA_SIZE / size;
1125 Newx(start, count*size, char);
1126 *((void **) start) = *arena_root;
1127 *arena_root = (void *)start;
1129 end = start + (count-1) * size;
1131 /* The initial slot is used to link the arenas together, so it isn't to be
1132 linked into the list of ready-to-use bodies. */
1136 *root = (void *)start;
1138 while (start < end) {
1139 char * const next = start + size;
1140 *(void**) start = (void *)next;
1143 *(void **)start = 0;
1148 /* grab a new thing from the free list, allocating more if necessary */
1150 /* 1st, the inline version */
1152 #define new_body_inline(xpv, size, sv_type) \
1154 void **r3wt = &PL_body_roots[sv_type]; \
1156 xpv = *((void **)(r3wt)) \
1157 ? *((void **)(r3wt)) : S_more_bodies(aTHX_ size, sv_type); \
1158 *(r3wt) = *(void**)(xpv); \
1162 /* now use the inline version in the proper function */
1166 /* This isn't being used with -DPURIFY, so don't declare it. Otherwise
1167 compilers issue warnings. */
1170 S_new_body(pTHX_ size_t size, svtype sv_type)
1173 new_body_inline(xpv, size, sv_type);
1179 /* return a thing to the free list */
1181 #define del_body(thing, root) \
1183 void **thing_copy = (void **)thing; \
1185 *thing_copy = *root; \
1186 *root = (void*)thing_copy; \
1191 Revisiting type 3 arenas, there are 4 body-types which have some
1192 members that are never accessed. They are XPV, XPVIV, XPVAV,
1193 XPVHV, which have corresponding types: xpv_allocated,
1194 xpviv_allocated, xpvav_allocated, xpvhv_allocated,
1196 For these types, the arenas are carved up into *_allocated size
1197 chunks, we thus avoid wasted memory for those unaccessed members.
1198 When bodies are allocated, we adjust the pointer back in memory by
1199 the size of the bit not allocated, so it's as if we allocated the
1200 full structure. (But things will all go boom if you write to the
1201 part that is "not there", because you'll be overwriting the last
1202 members of the preceding structure in memory.)
1204 We calculate the correction using the STRUCT_OFFSET macro. For example, if
1205 xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
1206 and the pointer is unchanged. If the allocated structure is smaller (no
1207 initial NV actually allocated) then the net effect is to subtract the size
1208 of the NV from the pointer, to return a new pointer as if an initial NV were
1211 This is the same trick as was used for NV and IV bodies. Ironically it
1212 doesn't need to be used for NV bodies any more, because NV is now at the
1213 start of the structure. IV bodies don't need it either, because they are
1214 no longer allocated. */
1216 /* The following 2 arrays hide the above details in a pair of
1217 lookup-tables, allowing us to be body-type agnostic.
1219 size maps svtype to its body's allocated size.
1220 offset maps svtype to the body-pointer adjustment needed
1222 NB: elements in latter are 0 or <0, and are added during
1223 allocation, and subtracted during deallocation. It may be clearer
1224 to invert the values, and call it shrinkage_by_svtype.
1227 struct body_details {
1228 size_t size; /* Size to allocate */
1229 size_t copy; /* Size of structure to copy (may be shorter) */
1231 bool cant_upgrade; /* Can upgrade this type */
1232 bool zero_nv; /* zero the NV when upgrading from this */
1233 bool arena; /* Allocated from an arena */
1239 #define HASARENA TRUE
1240 #define NOARENA FALSE
1242 static const struct body_details bodies_by_type[] = {
1243 {0, 0, 0, FALSE, NONV, NOARENA},
1244 /* IVs are in the head, so the allocation size is 0 */
1245 {0, sizeof(IV), -STRUCT_OFFSET(XPVIV, xiv_iv), FALSE, NONV, NOARENA},
1246 /* 8 bytes on most ILP32 with IEEE doubles */
1247 {sizeof(NV), sizeof(NV), 0, FALSE, HADNV, HASARENA},
1248 /* RVs are in the head now */
1249 /* However, this slot is overloaded and used by the pte */
1250 {0, 0, 0, FALSE, NONV, NOARENA},
1251 /* 8 bytes on most ILP32 with IEEE doubles */
1252 {sizeof(xpv_allocated),
1253 STRUCT_OFFSET(XPV, xpv_len) + sizeof (((XPV*)SvANY((SV*)0))->xpv_len)
1254 + STRUCT_OFFSET(xpv_allocated, xpv_cur) - STRUCT_OFFSET(XPV, xpv_cur),
1255 + STRUCT_OFFSET(xpv_allocated, xpv_cur) - STRUCT_OFFSET(XPV, xpv_cur)
1256 , FALSE, NONV, HASARENA},
1258 {sizeof(xpviv_allocated),
1259 STRUCT_OFFSET(XPVIV, xiv_u) + sizeof (((XPVIV*)SvANY((SV*)0))->xiv_u)
1260 + STRUCT_OFFSET(xpviv_allocated, xpv_cur) - STRUCT_OFFSET(XPVIV, xpv_cur),
1261 + STRUCT_OFFSET(xpviv_allocated, xpv_cur) - STRUCT_OFFSET(XPVIV, xpv_cur)
1262 , FALSE, NONV, HASARENA},
1265 STRUCT_OFFSET(XPVNV, xiv_u) + sizeof (((XPVNV*)SvANY((SV*)0))->xiv_u),
1266 0, FALSE, HADNV, HASARENA},
1269 STRUCT_OFFSET(XPVMG, xmg_stash) + sizeof (((XPVMG*)SvANY((SV*)0))->xmg_stash),
1270 0, FALSE, HADNV, HASARENA},
1272 {sizeof(XPVBM), sizeof(XPVBM), 0, TRUE, HADNV, HASARENA},
1274 {sizeof(XPVGV), sizeof(XPVGV), 0, TRUE, HADNV, HASARENA},
1276 {sizeof(XPVLV), sizeof(XPVLV), 0, TRUE, HADNV, HASARENA},
1278 {sizeof(xpvav_allocated),
1279 STRUCT_OFFSET(XPVAV, xmg_stash)
1280 + sizeof (((XPVAV*)SvANY((SV *)0))->xmg_stash)
1281 + STRUCT_OFFSET(xpvav_allocated, xav_fill)
1282 - STRUCT_OFFSET(XPVAV, xav_fill),
1283 STRUCT_OFFSET(xpvav_allocated, xav_fill)
1284 - STRUCT_OFFSET(XPVAV, xav_fill), TRUE, HADNV, HASARENA},
1286 {sizeof(xpvhv_allocated),
1287 STRUCT_OFFSET(XPVHV, xmg_stash)
1288 + sizeof (((XPVHV*)SvANY((SV *)0))->xmg_stash)
1289 + STRUCT_OFFSET(xpvhv_allocated, xhv_fill)
1290 - STRUCT_OFFSET(XPVHV, xhv_fill),
1291 STRUCT_OFFSET(xpvhv_allocated, xhv_fill)
1292 - STRUCT_OFFSET(XPVHV, xhv_fill), TRUE, HADNV, HASARENA},
1294 {sizeof(XPVCV), sizeof(XPVCV), 0, TRUE, HADNV, HASARENA},
1296 {sizeof(XPVFM), sizeof(XPVFM), 0, TRUE, HADNV, NOARENA},
1298 {sizeof(XPVIO), sizeof(XPVIO), 0, TRUE, HADNV, NOARENA}
1301 #define new_body_type(sv_type) \
1302 (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
1303 + bodies_by_type[sv_type].offset)
1305 #define del_body_type(p, sv_type) \
1306 del_body(p, &PL_body_roots[sv_type])
1309 #define new_body_allocated(sv_type) \
1310 (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
1311 + bodies_by_type[sv_type].offset)
1313 #define del_body_allocated(p, sv_type) \
1314 del_body(p - bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
1317 #define my_safemalloc(s) (void*)safemalloc(s)
1318 #define my_safecalloc(s) (void*)safecalloc(s, 1)
1319 #define my_safefree(p) safefree((char*)p)
1323 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1324 #define del_XNV(p) my_safefree(p)
1326 #define new_XPV() my_safemalloc(sizeof(XPV))
1327 #define del_XPV(p) my_safefree(p)
1329 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1330 #define del_XPVIV(p) my_safefree(p)
1332 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1333 #define del_XPVNV(p) my_safefree(p)
1335 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1336 #define del_XPVCV(p) my_safefree(p)
1338 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1339 #define del_XPVAV(p) my_safefree(p)
1341 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1342 #define del_XPVHV(p) my_safefree(p)
1344 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1345 #define del_XPVMG(p) my_safefree(p)
1347 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1348 #define del_XPVGV(p) my_safefree(p)
1350 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1351 #define del_XPVLV(p) my_safefree(p)
1353 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1354 #define del_XPVBM(p) my_safefree(p)
1358 #define new_XNV() new_body_type(SVt_NV)
1359 #define del_XNV(p) del_body_type(p, SVt_NV)
1361 #define new_XPV() new_body_allocated(SVt_PV)
1362 #define del_XPV(p) del_body_allocated(p, SVt_PV)
1364 #define new_XPVIV() new_body_allocated(SVt_PVIV)
1365 #define del_XPVIV(p) del_body_allocated(p, SVt_PVIV)
1367 #define new_XPVNV() new_body_type(SVt_PVNV)
1368 #define del_XPVNV(p) del_body_type(p, SVt_PVNV)
1370 #define new_XPVCV() new_body_type(SVt_PVCV)
1371 #define del_XPVCV(p) del_body_type(p, SVt_PVCV)
1373 #define new_XPVAV() new_body_allocated(SVt_PVAV)
1374 #define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
1376 #define new_XPVHV() new_body_allocated(SVt_PVHV)
1377 #define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
1379 #define new_XPVMG() new_body_type(SVt_PVMG)
1380 #define del_XPVMG(p) del_body_type(p, SVt_PVMG)
1382 #define new_XPVGV() new_body_type(SVt_PVGV)
1383 #define del_XPVGV(p) del_body_type(p, SVt_PVGV)
1385 #define new_XPVLV() new_body_type(SVt_PVLV)
1386 #define del_XPVLV(p) del_body_type(p, SVt_PVLV)
1388 #define new_XPVBM() new_body_type(SVt_PVBM)
1389 #define del_XPVBM(p) del_body_type(p, SVt_PVBM)
1393 /* no arena for you! */
1395 #define new_NOARENA(details) \
1396 my_safecalloc((details)->size - (details)->offset)
1398 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1399 #define del_XPVFM(p) my_safefree(p)
1401 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1402 #define del_XPVIO(p) my_safefree(p)
1407 =for apidoc sv_upgrade
1409 Upgrade an SV to a more complex form. Generally adds a new body type to the
1410 SV, then copies across as much information as possible from the old body.
1411 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1417 Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
1421 const U32 old_type = SvTYPE(sv);
1422 const struct body_details *const old_type_details
1423 = bodies_by_type + old_type;
1424 const struct body_details *new_type_details = bodies_by_type + new_type;
1426 if (new_type != SVt_PV && SvIsCOW(sv)) {
1427 sv_force_normal_flags(sv, 0);
1430 if (old_type == new_type)
1433 if (old_type > new_type)
1434 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1435 (int)old_type, (int)new_type);
1438 old_body = SvANY(sv);
1440 /* Copying structures onto other structures that have been neatly zeroed
1441 has a subtle gotcha. Consider XPVMG
1443 +------+------+------+------+------+-------+-------+
1444 | NV | CUR | LEN | IV | MAGIC | STASH |
1445 +------+------+------+------+------+-------+-------+
1446 0 4 8 12 16 20 24 28
1448 where NVs are aligned to 8 bytes, so that sizeof that structure is
1449 actually 32 bytes long, with 4 bytes of padding at the end:
1451 +------+------+------+------+------+-------+-------+------+
1452 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1453 +------+------+------+------+------+-------+-------+------+
1454 0 4 8 12 16 20 24 28 32
1456 so what happens if you allocate memory for this structure:
1458 +------+------+------+------+------+-------+-------+------+------+...
1459 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1460 +------+------+------+------+------+-------+-------+------+------+...
1461 0 4 8 12 16 20 24 28 32 36
1463 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1464 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1465 started out as zero once, but it's quite possible that it isn't. So now,
1466 rather than a nicely zeroed GP, you have it pointing somewhere random.
1469 (In fact, GP ends up pointing at a previous GP structure, because the
1470 principle cause of the padding in XPVMG getting garbage is a copy of
1471 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob)
1473 So we are careful and work out the size of used parts of all the
1480 if (new_type < SVt_PVIV) {
1481 new_type = (new_type == SVt_NV)
1482 ? SVt_PVNV : SVt_PVIV;
1483 new_type_details = bodies_by_type + new_type;
1487 if (new_type < SVt_PVNV) {
1488 new_type = SVt_PVNV;
1489 new_type_details = bodies_by_type + new_type;
1495 assert(new_type > SVt_PV);
1496 assert(SVt_IV < SVt_PV);
1497 assert(SVt_NV < SVt_PV);
1504 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1505 there's no way that it can be safely upgraded, because perl.c
1506 expects to Safefree(SvANY(PL_mess_sv)) */
1507 assert(sv != PL_mess_sv);
1508 /* This flag bit is used to mean other things in other scalar types.
1509 Given that it only has meaning inside the pad, it shouldn't be set
1510 on anything that can get upgraded. */
1511 assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
1514 if (old_type_details->cant_upgrade)
1515 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1518 SvFLAGS(sv) &= ~SVTYPEMASK;
1519 SvFLAGS(sv) |= new_type;
1523 Perl_croak(aTHX_ "Can't upgrade to undef");
1525 assert(old_type == SVt_NULL);
1526 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1530 assert(old_type == SVt_NULL);
1531 SvANY(sv) = new_XNV();
1535 assert(old_type == SVt_NULL);
1536 SvANY(sv) = &sv->sv_u.svu_rv;
1540 SvANY(sv) = new_XPVHV();
1543 HvTOTALKEYS(sv) = 0;
1548 SvANY(sv) = new_XPVAV();
1555 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1556 The target created by newSVrv also is, and it can have magic.
1557 However, it never has SvPVX set.
1559 if (old_type >= SVt_RV) {
1560 assert(SvPVX_const(sv) == 0);
1563 /* Could put this in the else clause below, as PVMG must have SvPVX
1564 0 already (the assertion above) */
1565 SvPV_set(sv, (char*)0);
1567 if (old_type >= SVt_PVMG) {
1568 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic);
1569 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1578 /* XXX Is this still needed? Was it ever needed? Surely as there is
1579 no route from NV to PVIV, NOK can never be true */
1580 assert(!SvNOKp(sv));
1592 assert(new_type_details->size);
1594 if(new_type_details->arena) {
1595 /* This points to the start of the allocated area. */
1596 new_body_inline(new_body, new_type_details->size, new_type);
1597 Zero(new_body, new_type_details->size, char);
1598 new_body = ((char *)new_body) + new_type_details->offset;
1600 new_body = new_NOARENA(new_type_details);
1603 /* We always allocated the full length item with PURIFY */
1604 new_body = new_NOARENA(new_type_details);
1606 SvANY(sv) = new_body;
1608 if (old_type_details->copy) {
1609 Copy((char *)old_body - old_type_details->offset,
1610 (char *)new_body - old_type_details->offset,
1611 old_type_details->copy, char);
1614 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1615 /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct
1617 if (old_type_details->zero_nv)
1621 if (new_type == SVt_PVIO)
1622 IoPAGE_LEN(sv) = 60;
1623 if (old_type < SVt_RV)
1627 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", new_type);
1630 if (old_type_details->size) {
1631 /* If the old body had an allocated size, then we need to free it. */
1633 my_safefree(old_body);
1635 del_body((void*)((char*)old_body - old_type_details->offset),
1636 &PL_body_roots[old_type]);
1642 =for apidoc sv_backoff
1644 Remove any string offset. You should normally use the C<SvOOK_off> macro
1651 Perl_sv_backoff(pTHX_ register SV *sv)
1654 assert(SvTYPE(sv) != SVt_PVHV);
1655 assert(SvTYPE(sv) != SVt_PVAV);
1657 const char * const s = SvPVX_const(sv);
1658 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1659 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1661 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1663 SvFLAGS(sv) &= ~SVf_OOK;
1670 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1671 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1672 Use the C<SvGROW> wrapper instead.
1678 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1682 #ifdef HAS_64K_LIMIT
1683 if (newlen >= 0x10000) {
1684 PerlIO_printf(Perl_debug_log,
1685 "Allocation too large: %"UVxf"\n", (UV)newlen);
1688 #endif /* HAS_64K_LIMIT */
1691 if (SvTYPE(sv) < SVt_PV) {
1692 sv_upgrade(sv, SVt_PV);
1693 s = SvPVX_mutable(sv);
1695 else if (SvOOK(sv)) { /* pv is offset? */
1697 s = SvPVX_mutable(sv);
1698 if (newlen > SvLEN(sv))
1699 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1700 #ifdef HAS_64K_LIMIT
1701 if (newlen >= 0x10000)
1706 s = SvPVX_mutable(sv);
1708 if (newlen > SvLEN(sv)) { /* need more room? */
1709 newlen = PERL_STRLEN_ROUNDUP(newlen);
1710 if (SvLEN(sv) && s) {
1712 const STRLEN l = malloced_size((void*)SvPVX_const(sv));
1718 s = saferealloc(s, newlen);
1721 s = safemalloc(newlen);
1722 if (SvPVX_const(sv) && SvCUR(sv)) {
1723 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1727 SvLEN_set(sv, newlen);
1733 =for apidoc sv_setiv
1735 Copies an integer into the given SV, upgrading first if necessary.
1736 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1742 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1744 SV_CHECK_THINKFIRST_COW_DROP(sv);
1745 switch (SvTYPE(sv)) {
1747 sv_upgrade(sv, SVt_IV);
1750 sv_upgrade(sv, SVt_PVNV);
1754 sv_upgrade(sv, SVt_PVIV);
1763 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1766 (void)SvIOK_only(sv); /* validate number */
1772 =for apidoc sv_setiv_mg
1774 Like C<sv_setiv>, but also handles 'set' magic.
1780 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1787 =for apidoc sv_setuv
1789 Copies an unsigned integer into the given SV, upgrading first if necessary.
1790 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1796 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1798 /* With these two if statements:
1799 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1802 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1804 If you wish to remove them, please benchmark to see what the effect is
1806 if (u <= (UV)IV_MAX) {
1807 sv_setiv(sv, (IV)u);
1816 =for apidoc sv_setuv_mg
1818 Like C<sv_setuv>, but also handles 'set' magic.
1824 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1833 =for apidoc sv_setnv
1835 Copies a double into the given SV, upgrading first if necessary.
1836 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1842 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1844 SV_CHECK_THINKFIRST_COW_DROP(sv);
1845 switch (SvTYPE(sv)) {
1848 sv_upgrade(sv, SVt_NV);
1853 sv_upgrade(sv, SVt_PVNV);
1862 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1866 (void)SvNOK_only(sv); /* validate number */
1871 =for apidoc sv_setnv_mg
1873 Like C<sv_setnv>, but also handles 'set' magic.
1879 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1885 /* Print an "isn't numeric" warning, using a cleaned-up,
1886 * printable version of the offending string
1890 S_not_a_number(pTHX_ SV *sv)
1897 dsv = sv_2mortal(newSVpvn("", 0));
1898 pv = sv_uni_display(dsv, sv, 10, 0);
1901 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1902 /* each *s can expand to 4 chars + "...\0",
1903 i.e. need room for 8 chars */
1905 const char *s, *end;
1906 for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit;
1909 if (ch & 128 && !isPRINT_LC(ch)) {
1918 else if (ch == '\r') {
1922 else if (ch == '\f') {
1926 else if (ch == '\\') {
1930 else if (ch == '\0') {
1934 else if (isPRINT_LC(ch))
1951 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1952 "Argument \"%s\" isn't numeric in %s", pv,
1955 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1956 "Argument \"%s\" isn't numeric", pv);
1960 =for apidoc looks_like_number
1962 Test if the content of an SV looks like a number (or is a number).
1963 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1964 non-numeric warning), even if your atof() doesn't grok them.
1970 Perl_looks_like_number(pTHX_ SV *sv)
1972 register const char *sbegin;
1976 sbegin = SvPVX_const(sv);
1979 else if (SvPOKp(sv))
1980 sbegin = SvPV_const(sv, len);
1982 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1983 return grok_number(sbegin, len, NULL);
1986 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1987 until proven guilty, assume that things are not that bad... */
1992 As 64 bit platforms often have an NV that doesn't preserve all bits of
1993 an IV (an assumption perl has been based on to date) it becomes necessary
1994 to remove the assumption that the NV always carries enough precision to
1995 recreate the IV whenever needed, and that the NV is the canonical form.
1996 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1997 precision as a side effect of conversion (which would lead to insanity
1998 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1999 1) to distinguish between IV/UV/NV slots that have cached a valid
2000 conversion where precision was lost and IV/UV/NV slots that have a
2001 valid conversion which has lost no precision
2002 2) to ensure that if a numeric conversion to one form is requested that
2003 would lose precision, the precise conversion (or differently
2004 imprecise conversion) is also performed and cached, to prevent
2005 requests for different numeric formats on the same SV causing
2006 lossy conversion chains. (lossless conversion chains are perfectly
2011 SvIOKp is true if the IV slot contains a valid value
2012 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
2013 SvNOKp is true if the NV slot contains a valid value
2014 SvNOK is true only if the NV value is accurate
2017 while converting from PV to NV, check to see if converting that NV to an
2018 IV(or UV) would lose accuracy over a direct conversion from PV to
2019 IV(or UV). If it would, cache both conversions, return NV, but mark
2020 SV as IOK NOKp (ie not NOK).
2022 While converting from PV to IV, check to see if converting that IV to an
2023 NV would lose accuracy over a direct conversion from PV to NV. If it
2024 would, cache both conversions, flag similarly.
2026 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2027 correctly because if IV & NV were set NV *always* overruled.
2028 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2029 changes - now IV and NV together means that the two are interchangeable:
2030 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
2032 The benefit of this is that operations such as pp_add know that if
2033 SvIOK is true for both left and right operands, then integer addition
2034 can be used instead of floating point (for cases where the result won't
2035 overflow). Before, floating point was always used, which could lead to
2036 loss of precision compared with integer addition.
2038 * making IV and NV equal status should make maths accurate on 64 bit
2040 * may speed up maths somewhat if pp_add and friends start to use
2041 integers when possible instead of fp. (Hopefully the overhead in
2042 looking for SvIOK and checking for overflow will not outweigh the
2043 fp to integer speedup)
2044 * will slow down integer operations (callers of SvIV) on "inaccurate"
2045 values, as the change from SvIOK to SvIOKp will cause a call into
2046 sv_2iv each time rather than a macro access direct to the IV slot
2047 * should speed up number->string conversion on integers as IV is
2048 favoured when IV and NV are equally accurate
2050 ####################################################################
2051 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2052 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2053 On the other hand, SvUOK is true iff UV.
2054 ####################################################################
2056 Your mileage will vary depending your CPU's relative fp to integer
2060 #ifndef NV_PRESERVES_UV
2061 # define IS_NUMBER_UNDERFLOW_IV 1
2062 # define IS_NUMBER_UNDERFLOW_UV 2
2063 # define IS_NUMBER_IV_AND_UV 2
2064 # define IS_NUMBER_OVERFLOW_IV 4
2065 # define IS_NUMBER_OVERFLOW_UV 5
2067 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2069 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2071 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2073 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));
2074 if (SvNVX(sv) < (NV)IV_MIN) {
2075 (void)SvIOKp_on(sv);
2077 SvIV_set(sv, IV_MIN);
2078 return IS_NUMBER_UNDERFLOW_IV;
2080 if (SvNVX(sv) > (NV)UV_MAX) {
2081 (void)SvIOKp_on(sv);
2084 SvUV_set(sv, UV_MAX);
2085 return IS_NUMBER_OVERFLOW_UV;
2087 (void)SvIOKp_on(sv);
2089 /* Can't use strtol etc to convert this string. (See truth table in
2091 if (SvNVX(sv) <= (UV)IV_MAX) {
2092 SvIV_set(sv, I_V(SvNVX(sv)));
2093 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2094 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2096 /* Integer is imprecise. NOK, IOKp */
2098 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2101 SvUV_set(sv, U_V(SvNVX(sv)));
2102 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2103 if (SvUVX(sv) == UV_MAX) {
2104 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2105 possibly be preserved by NV. Hence, it must be overflow.
2107 return IS_NUMBER_OVERFLOW_UV;
2109 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2111 /* Integer is imprecise. NOK, IOKp */
2113 return IS_NUMBER_OVERFLOW_IV;
2115 #endif /* !NV_PRESERVES_UV*/
2118 =for apidoc sv_2iv_flags
2120 Return the integer value of an SV, doing any necessary string
2121 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2122 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2128 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2132 if (SvGMAGICAL(sv)) {
2133 if (flags & SV_GMAGIC)
2138 return I_V(SvNVX(sv));
2140 if (SvPOKp(sv) && SvLEN(sv))
2143 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2144 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2150 if (SvTHINKFIRST(sv)) {
2153 SV * const tmpstr=AMG_CALLun(sv,numer);
2154 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2155 return SvIV(tmpstr);
2158 return PTR2IV(SvRV(sv));
2161 sv_force_normal_flags(sv, 0);
2163 if (SvREADONLY(sv) && !SvOK(sv)) {
2164 if (ckWARN(WARN_UNINITIALIZED))
2171 return (IV)(SvUVX(sv));
2178 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2179 * without also getting a cached IV/UV from it at the same time
2180 * (ie PV->NV conversion should detect loss of accuracy and cache
2181 * IV or UV at same time to avoid this. NWC */
2183 if (SvTYPE(sv) == SVt_NV)
2184 sv_upgrade(sv, SVt_PVNV);
2186 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2187 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2188 certainly cast into the IV range at IV_MAX, whereas the correct
2189 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2191 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2192 SvIV_set(sv, I_V(SvNVX(sv)));
2193 if (SvNVX(sv) == (NV) SvIVX(sv)
2194 #ifndef NV_PRESERVES_UV
2195 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2196 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2197 /* Don't flag it as "accurately an integer" if the number
2198 came from a (by definition imprecise) NV operation, and
2199 we're outside the range of NV integer precision */
2202 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2203 DEBUG_c(PerlIO_printf(Perl_debug_log,
2204 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2210 /* IV not precise. No need to convert from PV, as NV
2211 conversion would already have cached IV if it detected
2212 that PV->IV would be better than PV->NV->IV
2213 flags already correct - don't set public IOK. */
2214 DEBUG_c(PerlIO_printf(Perl_debug_log,
2215 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2220 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2221 but the cast (NV)IV_MIN rounds to a the value less (more
2222 negative) than IV_MIN which happens to be equal to SvNVX ??
2223 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2224 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2225 (NV)UVX == NVX are both true, but the values differ. :-(
2226 Hopefully for 2s complement IV_MIN is something like
2227 0x8000000000000000 which will be exact. NWC */
2230 SvUV_set(sv, U_V(SvNVX(sv)));
2232 (SvNVX(sv) == (NV) SvUVX(sv))
2233 #ifndef NV_PRESERVES_UV
2234 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2235 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2236 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2237 /* Don't flag it as "accurately an integer" if the number
2238 came from a (by definition imprecise) NV operation, and
2239 we're outside the range of NV integer precision */
2245 DEBUG_c(PerlIO_printf(Perl_debug_log,
2246 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2250 return (IV)SvUVX(sv);
2253 else if (SvPOKp(sv) && SvLEN(sv)) {
2255 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2256 /* We want to avoid a possible problem when we cache an IV which
2257 may be later translated to an NV, and the resulting NV is not
2258 the same as the direct translation of the initial string
2259 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2260 be careful to ensure that the value with the .456 is around if the
2261 NV value is requested in the future).
2263 This means that if we cache such an IV, we need to cache the
2264 NV as well. Moreover, we trade speed for space, and do not
2265 cache the NV if we are sure it's not needed.
2268 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2269 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2270 == IS_NUMBER_IN_UV) {
2271 /* It's definitely an integer, only upgrade to PVIV */
2272 if (SvTYPE(sv) < SVt_PVIV)
2273 sv_upgrade(sv, SVt_PVIV);
2275 } else if (SvTYPE(sv) < SVt_PVNV)
2276 sv_upgrade(sv, SVt_PVNV);
2278 /* If NV preserves UV then we only use the UV value if we know that
2279 we aren't going to call atof() below. If NVs don't preserve UVs
2280 then the value returned may have more precision than atof() will
2281 return, even though value isn't perfectly accurate. */
2282 if ((numtype & (IS_NUMBER_IN_UV
2283 #ifdef NV_PRESERVES_UV
2286 )) == IS_NUMBER_IN_UV) {
2287 /* This won't turn off the public IOK flag if it was set above */
2288 (void)SvIOKp_on(sv);
2290 if (!(numtype & IS_NUMBER_NEG)) {
2292 if (value <= (UV)IV_MAX) {
2293 SvIV_set(sv, (IV)value);
2295 SvUV_set(sv, value);
2299 /* 2s complement assumption */
2300 if (value <= (UV)IV_MIN) {
2301 SvIV_set(sv, -(IV)value);
2303 /* Too negative for an IV. This is a double upgrade, but
2304 I'm assuming it will be rare. */
2305 if (SvTYPE(sv) < SVt_PVNV)
2306 sv_upgrade(sv, SVt_PVNV);
2310 SvNV_set(sv, -(NV)value);
2311 SvIV_set(sv, IV_MIN);
2315 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2316 will be in the previous block to set the IV slot, and the next
2317 block to set the NV slot. So no else here. */
2319 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2320 != IS_NUMBER_IN_UV) {
2321 /* It wasn't an (integer that doesn't overflow the UV). */
2322 SvNV_set(sv, Atof(SvPVX_const(sv)));
2324 if (! numtype && ckWARN(WARN_NUMERIC))
2327 #if defined(USE_LONG_DOUBLE)
2328 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2329 PTR2UV(sv), SvNVX(sv)));
2331 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2332 PTR2UV(sv), SvNVX(sv)));
2336 #ifdef NV_PRESERVES_UV
2337 (void)SvIOKp_on(sv);
2339 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2340 SvIV_set(sv, I_V(SvNVX(sv)));
2341 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2344 /* Integer is imprecise. NOK, IOKp */
2346 /* UV will not work better than IV */
2348 if (SvNVX(sv) > (NV)UV_MAX) {
2350 /* Integer is inaccurate. NOK, IOKp, is UV */
2351 SvUV_set(sv, UV_MAX);
2354 SvUV_set(sv, U_V(SvNVX(sv)));
2355 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2356 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2360 /* Integer is imprecise. NOK, IOKp, is UV */
2366 #else /* NV_PRESERVES_UV */
2367 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2368 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2369 /* The IV slot will have been set from value returned by
2370 grok_number above. The NV slot has just been set using
2373 assert (SvIOKp(sv));
2375 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2376 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2377 /* Small enough to preserve all bits. */
2378 (void)SvIOKp_on(sv);
2380 SvIV_set(sv, I_V(SvNVX(sv)));
2381 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2383 /* Assumption: first non-preserved integer is < IV_MAX,
2384 this NV is in the preserved range, therefore: */
2385 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2387 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);
2391 0 0 already failed to read UV.
2392 0 1 already failed to read UV.
2393 1 0 you won't get here in this case. IV/UV
2394 slot set, public IOK, Atof() unneeded.
2395 1 1 already read UV.
2396 so there's no point in sv_2iuv_non_preserve() attempting
2397 to use atol, strtol, strtoul etc. */
2398 if (sv_2iuv_non_preserve (sv, numtype)
2399 >= IS_NUMBER_OVERFLOW_IV)
2403 #endif /* NV_PRESERVES_UV */
2406 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2408 if (SvTYPE(sv) < SVt_IV)
2409 /* Typically the caller expects that sv_any is not NULL now. */
2410 sv_upgrade(sv, SVt_IV);
2413 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2414 PTR2UV(sv),SvIVX(sv)));
2415 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2419 =for apidoc sv_2uv_flags
2421 Return the unsigned integer value of an SV, doing any necessary string
2422 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2423 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2429 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2433 if (SvGMAGICAL(sv)) {
2434 if (flags & SV_GMAGIC)
2439 return U_V(SvNVX(sv));
2440 if (SvPOKp(sv) && SvLEN(sv))
2443 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2444 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2450 if (SvTHINKFIRST(sv)) {
2453 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2454 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2455 return SvUV(tmpstr);
2456 return PTR2UV(SvRV(sv));
2459 sv_force_normal_flags(sv, 0);
2461 if (SvREADONLY(sv) && !SvOK(sv)) {
2462 if (ckWARN(WARN_UNINITIALIZED))
2472 return (UV)SvIVX(sv);
2476 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2477 * without also getting a cached IV/UV from it at the same time
2478 * (ie PV->NV conversion should detect loss of accuracy and cache
2479 * IV or UV at same time to avoid this. */
2480 /* IV-over-UV optimisation - choose to cache IV if possible */
2482 if (SvTYPE(sv) == SVt_NV)
2483 sv_upgrade(sv, SVt_PVNV);
2485 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2486 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2487 SvIV_set(sv, I_V(SvNVX(sv)));
2488 if (SvNVX(sv) == (NV) SvIVX(sv)
2489 #ifndef NV_PRESERVES_UV
2490 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2491 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2492 /* Don't flag it as "accurately an integer" if the number
2493 came from a (by definition imprecise) NV operation, and
2494 we're outside the range of NV integer precision */
2497 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2498 DEBUG_c(PerlIO_printf(Perl_debug_log,
2499 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2505 /* IV not precise. No need to convert from PV, as NV
2506 conversion would already have cached IV if it detected
2507 that PV->IV would be better than PV->NV->IV
2508 flags already correct - don't set public IOK. */
2509 DEBUG_c(PerlIO_printf(Perl_debug_log,
2510 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2515 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2516 but the cast (NV)IV_MIN rounds to a the value less (more
2517 negative) than IV_MIN which happens to be equal to SvNVX ??
2518 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2519 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2520 (NV)UVX == NVX are both true, but the values differ. :-(
2521 Hopefully for 2s complement IV_MIN is something like
2522 0x8000000000000000 which will be exact. NWC */
2525 SvUV_set(sv, U_V(SvNVX(sv)));
2527 (SvNVX(sv) == (NV) SvUVX(sv))
2528 #ifndef NV_PRESERVES_UV
2529 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2530 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2531 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2532 /* Don't flag it as "accurately an integer" if the number
2533 came from a (by definition imprecise) NV operation, and
2534 we're outside the range of NV integer precision */
2539 DEBUG_c(PerlIO_printf(Perl_debug_log,
2540 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2546 else if (SvPOKp(sv) && SvLEN(sv)) {
2548 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2550 /* We want to avoid a possible problem when we cache a UV which
2551 may be later translated to an NV, and the resulting NV is not
2552 the translation of the initial data.
2554 This means that if we cache such a UV, we need to cache the
2555 NV as well. Moreover, we trade speed for space, and do not
2556 cache the NV if not needed.
2559 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2560 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2561 == IS_NUMBER_IN_UV) {
2562 /* It's definitely an integer, only upgrade to PVIV */
2563 if (SvTYPE(sv) < SVt_PVIV)
2564 sv_upgrade(sv, SVt_PVIV);
2566 } else if (SvTYPE(sv) < SVt_PVNV)
2567 sv_upgrade(sv, SVt_PVNV);
2569 /* If NV preserves UV then we only use the UV value if we know that
2570 we aren't going to call atof() below. If NVs don't preserve UVs
2571 then the value returned may have more precision than atof() will
2572 return, even though it isn't accurate. */
2573 if ((numtype & (IS_NUMBER_IN_UV
2574 #ifdef NV_PRESERVES_UV
2577 )) == IS_NUMBER_IN_UV) {
2578 /* This won't turn off the public IOK flag if it was set above */
2579 (void)SvIOKp_on(sv);
2581 if (!(numtype & IS_NUMBER_NEG)) {
2583 if (value <= (UV)IV_MAX) {
2584 SvIV_set(sv, (IV)value);
2586 /* it didn't overflow, and it was positive. */
2587 SvUV_set(sv, value);
2591 /* 2s complement assumption */
2592 if (value <= (UV)IV_MIN) {
2593 SvIV_set(sv, -(IV)value);
2595 /* Too negative for an IV. This is a double upgrade, but
2596 I'm assuming it will be rare. */
2597 if (SvTYPE(sv) < SVt_PVNV)
2598 sv_upgrade(sv, SVt_PVNV);
2602 SvNV_set(sv, -(NV)value);
2603 SvIV_set(sv, IV_MIN);
2608 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2609 != IS_NUMBER_IN_UV) {
2610 /* It wasn't an integer, or it overflowed the UV. */
2611 SvNV_set(sv, Atof(SvPVX_const(sv)));
2613 if (! numtype && ckWARN(WARN_NUMERIC))
2616 #if defined(USE_LONG_DOUBLE)
2617 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2618 PTR2UV(sv), SvNVX(sv)));
2620 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2621 PTR2UV(sv), SvNVX(sv)));
2624 #ifdef NV_PRESERVES_UV
2625 (void)SvIOKp_on(sv);
2627 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2628 SvIV_set(sv, I_V(SvNVX(sv)));
2629 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2632 /* Integer is imprecise. NOK, IOKp */
2634 /* UV will not work better than IV */
2636 if (SvNVX(sv) > (NV)UV_MAX) {
2638 /* Integer is inaccurate. NOK, IOKp, is UV */
2639 SvUV_set(sv, UV_MAX);
2642 SvUV_set(sv, U_V(SvNVX(sv)));
2643 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2644 NV preservse UV so can do correct comparison. */
2645 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2649 /* Integer is imprecise. NOK, IOKp, is UV */
2654 #else /* NV_PRESERVES_UV */
2655 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2656 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2657 /* The UV slot will have been set from value returned by
2658 grok_number above. The NV slot has just been set using
2661 assert (SvIOKp(sv));
2663 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2664 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2665 /* Small enough to preserve all bits. */
2666 (void)SvIOKp_on(sv);
2668 SvIV_set(sv, I_V(SvNVX(sv)));
2669 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2671 /* Assumption: first non-preserved integer is < IV_MAX,
2672 this NV is in the preserved range, therefore: */
2673 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2675 Perl_croak(aTHX_ "sv_2uv 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);
2678 sv_2iuv_non_preserve (sv, numtype);
2680 #endif /* NV_PRESERVES_UV */
2684 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2685 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2688 if (SvTYPE(sv) < SVt_IV)
2689 /* Typically the caller expects that sv_any is not NULL now. */
2690 sv_upgrade(sv, SVt_IV);
2694 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2695 PTR2UV(sv),SvUVX(sv)));
2696 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2702 Return the num value of an SV, doing any necessary string or integer
2703 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2710 Perl_sv_2nv(pTHX_ register SV *sv)
2714 if (SvGMAGICAL(sv)) {
2718 if (SvPOKp(sv) && SvLEN(sv)) {
2719 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2720 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2722 return Atof(SvPVX_const(sv));
2726 return (NV)SvUVX(sv);
2728 return (NV)SvIVX(sv);
2731 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2732 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2738 if (SvTHINKFIRST(sv)) {
2741 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2742 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2743 return SvNV(tmpstr);
2744 return PTR2NV(SvRV(sv));
2747 sv_force_normal_flags(sv, 0);
2749 if (SvREADONLY(sv) && !SvOK(sv)) {
2750 if (ckWARN(WARN_UNINITIALIZED))
2755 if (SvTYPE(sv) < SVt_NV) {
2756 if (SvTYPE(sv) == SVt_IV)
2757 sv_upgrade(sv, SVt_PVNV);
2759 sv_upgrade(sv, SVt_NV);
2760 #ifdef USE_LONG_DOUBLE
2762 STORE_NUMERIC_LOCAL_SET_STANDARD();
2763 PerlIO_printf(Perl_debug_log,
2764 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2765 PTR2UV(sv), SvNVX(sv));
2766 RESTORE_NUMERIC_LOCAL();
2770 STORE_NUMERIC_LOCAL_SET_STANDARD();
2771 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2772 PTR2UV(sv), SvNVX(sv));
2773 RESTORE_NUMERIC_LOCAL();
2777 else if (SvTYPE(sv) < SVt_PVNV)
2778 sv_upgrade(sv, SVt_PVNV);
2783 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2784 #ifdef NV_PRESERVES_UV
2787 /* Only set the public NV OK flag if this NV preserves the IV */
2788 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2789 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2790 : (SvIVX(sv) == I_V(SvNVX(sv))))
2796 else if (SvPOKp(sv) && SvLEN(sv)) {
2798 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2799 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2801 #ifdef NV_PRESERVES_UV
2802 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2803 == IS_NUMBER_IN_UV) {
2804 /* It's definitely an integer */
2805 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2807 SvNV_set(sv, Atof(SvPVX_const(sv)));
2810 SvNV_set(sv, Atof(SvPVX_const(sv)));
2811 /* Only set the public NV OK flag if this NV preserves the value in
2812 the PV at least as well as an IV/UV would.
2813 Not sure how to do this 100% reliably. */
2814 /* if that shift count is out of range then Configure's test is
2815 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2817 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2818 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2819 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2820 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2821 /* Can't use strtol etc to convert this string, so don't try.
2822 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2825 /* value has been set. It may not be precise. */
2826 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2827 /* 2s complement assumption for (UV)IV_MIN */
2828 SvNOK_on(sv); /* Integer is too negative. */
2833 if (numtype & IS_NUMBER_NEG) {
2834 SvIV_set(sv, -(IV)value);
2835 } else if (value <= (UV)IV_MAX) {
2836 SvIV_set(sv, (IV)value);
2838 SvUV_set(sv, value);
2842 if (numtype & IS_NUMBER_NOT_INT) {
2843 /* I believe that even if the original PV had decimals,
2844 they are lost beyond the limit of the FP precision.
2845 However, neither is canonical, so both only get p
2846 flags. NWC, 2000/11/25 */
2847 /* Both already have p flags, so do nothing */
2849 const NV nv = SvNVX(sv);
2850 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2851 if (SvIVX(sv) == I_V(nv)) {
2856 /* It had no "." so it must be integer. */
2859 /* between IV_MAX and NV(UV_MAX).
2860 Could be slightly > UV_MAX */
2862 if (numtype & IS_NUMBER_NOT_INT) {
2863 /* UV and NV both imprecise. */
2865 const UV nv_as_uv = U_V(nv);
2867 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2878 #endif /* NV_PRESERVES_UV */
2881 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2883 if (SvTYPE(sv) < SVt_NV)
2884 /* Typically the caller expects that sv_any is not NULL now. */
2885 /* XXX Ilya implies that this is a bug in callers that assume this
2886 and ideally should be fixed. */
2887 sv_upgrade(sv, SVt_NV);
2890 #if defined(USE_LONG_DOUBLE)
2892 STORE_NUMERIC_LOCAL_SET_STANDARD();
2893 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2894 PTR2UV(sv), SvNVX(sv));
2895 RESTORE_NUMERIC_LOCAL();
2899 STORE_NUMERIC_LOCAL_SET_STANDARD();
2900 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2901 PTR2UV(sv), SvNVX(sv));
2902 RESTORE_NUMERIC_LOCAL();
2908 /* asIV(): extract an integer from the string value of an SV.
2909 * Caller must validate PVX */
2912 S_asIV(pTHX_ SV *sv)
2915 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2917 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2918 == IS_NUMBER_IN_UV) {
2919 /* It's definitely an integer */
2920 if (numtype & IS_NUMBER_NEG) {
2921 if (value < (UV)IV_MIN)
2924 if (value < (UV)IV_MAX)
2929 if (ckWARN(WARN_NUMERIC))
2932 return I_V(Atof(SvPVX_const(sv)));
2935 /* asUV(): extract an unsigned integer from the string value of an SV
2936 * Caller must validate PVX */
2939 S_asUV(pTHX_ SV *sv)
2942 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2944 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2945 == IS_NUMBER_IN_UV) {
2946 /* It's definitely an integer */
2947 if (!(numtype & IS_NUMBER_NEG))
2951 if (ckWARN(WARN_NUMERIC))
2954 return U_V(Atof(SvPVX_const(sv)));
2957 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2958 * UV as a string towards the end of buf, and return pointers to start and
2961 * We assume that buf is at least TYPE_CHARS(UV) long.
2965 S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2967 char *ptr = buf + TYPE_CHARS(UV);
2968 char * const ebuf = ptr;
2981 *--ptr = '0' + (char)(uv % 10);
2990 =for apidoc sv_2pv_flags
2992 Returns a pointer to the string value of an SV, and sets *lp to its length.
2993 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2995 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2996 usually end up here too.
3002 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3007 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3008 char *tmpbuf = tbuf;
3009 STRLEN len = 0; /* Hush gcc. len is always initialised before use. */
3016 if (SvGMAGICAL(sv)) {
3017 if (flags & SV_GMAGIC)
3022 if (flags & SV_MUTABLE_RETURN)
3023 return SvPVX_mutable(sv);
3024 if (flags & SV_CONST_RETURN)
3025 return (char *)SvPVX_const(sv);
3029 len = SvIsUV(sv) ? my_sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv))
3030 : my_sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3032 goto tokensave_has_len;
3035 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3040 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3041 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3049 if (SvTHINKFIRST(sv)) {
3052 register const char *typestr;
3053 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3054 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3056 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
3059 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
3060 if (flags & SV_CONST_RETURN) {
3061 pv = (char *) SvPVX_const(tmpstr);
3063 pv = (flags & SV_MUTABLE_RETURN)
3064 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
3067 *lp = SvCUR(tmpstr);
3069 pv = sv_2pv_flags(tmpstr, lp, flags);
3080 typestr = "NULLREF";
3084 switch (SvTYPE(sv)) {
3086 if ( ((SvFLAGS(sv) &
3087 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3088 == (SVs_OBJECT|SVs_SMG))
3089 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3090 const regexp *re = (regexp *)mg->mg_obj;
3093 const char *fptr = "msix";
3098 char need_newline = 0;
3099 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3101 while((ch = *fptr++)) {
3103 reflags[left++] = ch;
3106 reflags[right--] = ch;
3111 reflags[left] = '-';
3115 mg->mg_len = re->prelen + 4 + left;
3117 * If /x was used, we have to worry about a regex
3118 * ending with a comment later being embedded
3119 * within another regex. If so, we don't want this
3120 * regex's "commentization" to leak out to the
3121 * right part of the enclosing regex, we must cap
3122 * it with a newline.
3124 * So, if /x was used, we scan backwards from the
3125 * end of the regex. If we find a '#' before we
3126 * find a newline, we need to add a newline
3127 * ourself. If we find a '\n' first (or if we
3128 * don't find '#' or '\n'), we don't need to add
3129 * anything. -jfriedl
3131 if (PMf_EXTENDED & re->reganch)
3133 const char *endptr = re->precomp + re->prelen;
3134 while (endptr >= re->precomp)
3136 const char c = *(endptr--);
3138 break; /* don't need another */
3140 /* we end while in a comment, so we
3142 mg->mg_len++; /* save space for it */
3143 need_newline = 1; /* note to add it */
3149 Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
3150 Copy("(?", mg->mg_ptr, 2, char);
3151 Copy(reflags, mg->mg_ptr+2, left, char);
3152 Copy(":", mg->mg_ptr+left+2, 1, char);
3153 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3155 mg->mg_ptr[mg->mg_len - 2] = '\n';
3156 mg->mg_ptr[mg->mg_len - 1] = ')';
3157 mg->mg_ptr[mg->mg_len] = 0;
3159 PL_reginterp_cnt += re->program[0].next_off;
3161 if (re->reganch & ROPT_UTF8)
3177 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3178 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3179 /* tied lvalues should appear to be
3180 * scalars for backwards compatitbility */
3181 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3182 ? "SCALAR" : "LVALUE"; break;
3183 case SVt_PVAV: typestr = "ARRAY"; break;
3184 case SVt_PVHV: typestr = "HASH"; break;
3185 case SVt_PVCV: typestr = "CODE"; break;
3186 case SVt_PVGV: typestr = "GLOB"; break;
3187 case SVt_PVFM: typestr = "FORMAT"; break;
3188 case SVt_PVIO: typestr = "IO"; break;
3189 default: typestr = "UNKNOWN"; break;
3193 const char * const name = HvNAME_get(SvSTASH(sv));
3194 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3195 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3198 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3202 *lp = strlen(typestr);
3203 return (char *)typestr;
3205 if (SvREADONLY(sv) && !SvOK(sv)) {
3206 if (ckWARN(WARN_UNINITIALIZED))
3213 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3214 /* I'm assuming that if both IV and NV are equally valid then
3215 converting the IV is going to be more efficient */
3216 const U32 isIOK = SvIOK(sv);
3217 const U32 isUIOK = SvIsUV(sv);
3218 char buf[TYPE_CHARS(UV)];
3221 if (SvTYPE(sv) < SVt_PVIV)
3222 sv_upgrade(sv, SVt_PVIV);
3224 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3226 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3227 /* inlined from sv_setpvn */
3228 SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
3229 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
3230 SvCUR_set(sv, ebuf - ptr);
3240 else if (SvNOKp(sv)) {
3241 if (SvTYPE(sv) < SVt_PVNV)
3242 sv_upgrade(sv, SVt_PVNV);
3243 /* The +20 is pure guesswork. Configure test needed. --jhi */
3244 s = SvGROW_mutable(sv, NV_DIG + 20);
3245 olderrno = errno; /* some Xenix systems wipe out errno here */
3247 if (SvNVX(sv) == 0.0)
3248 (void)strcpy(s,"0");
3252 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3255 #ifdef FIXNEGATIVEZERO
3256 if (*s == '-' && s[1] == '0' && !s[2])
3266 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
3270 if (SvTYPE(sv) < SVt_PV)
3271 /* Typically the caller expects that sv_any is not NULL now. */
3272 sv_upgrade(sv, SVt_PV);
3276 const STRLEN len = s - SvPVX_const(sv);
3282 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3283 PTR2UV(sv),SvPVX_const(sv)));
3284 if (flags & SV_CONST_RETURN)
3285 return (char *)SvPVX_const(sv);
3286 if (flags & SV_MUTABLE_RETURN)
3287 return SvPVX_mutable(sv);
3291 len = strlen(tmpbuf);
3294 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3295 /* Sneaky stuff here */
3299 tsv = newSVpvn(tmpbuf, len);
3308 #ifdef FIXNEGATIVEZERO
3309 if (len == 2 && tmpbuf[0] == '-' && tmpbuf[1] == '0') {
3315 SvUPGRADE(sv, SVt_PV);
3318 s = SvGROW_mutable(sv, len + 1);
3321 return memcpy(s, tmpbuf, len + 1);
3326 =for apidoc sv_copypv
3328 Copies a stringified representation of the source SV into the
3329 destination SV. Automatically performs any necessary mg_get and
3330 coercion of numeric values into strings. Guaranteed to preserve
3331 UTF-8 flag even from overloaded objects. Similar in nature to
3332 sv_2pv[_flags] but operates directly on an SV instead of just the
3333 string. Mostly uses sv_2pv_flags to do its work, except when that
3334 would lose the UTF-8'ness of the PV.
3340 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3343 const char * const s = SvPV_const(ssv,len);
3344 sv_setpvn(dsv,s,len);
3352 =for apidoc sv_2pvbyte
3354 Return a pointer to the byte-encoded representation of the SV, and set *lp
3355 to its length. May cause the SV to be downgraded from UTF-8 as a
3358 Usually accessed via the C<SvPVbyte> macro.
3364 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3366 sv_utf8_downgrade(sv,0);
3367 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3371 =for apidoc sv_2pvutf8
3373 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3374 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3376 Usually accessed via the C<SvPVutf8> macro.
3382 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3384 sv_utf8_upgrade(sv);
3385 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3390 =for apidoc sv_2bool
3392 This function is only called on magical items, and is only used by
3393 sv_true() or its macro equivalent.
3399 Perl_sv_2bool(pTHX_ register SV *sv)
3407 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3408 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3409 return (bool)SvTRUE(tmpsv);
3410 return SvRV(sv) != 0;
3413 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3415 (*sv->sv_u.svu_pv > '0' ||
3416 Xpvtmp->xpv_cur > 1 ||
3417 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3424 return SvIVX(sv) != 0;
3427 return SvNVX(sv) != 0.0;
3435 =for apidoc sv_utf8_upgrade
3437 Converts the PV of an SV to its UTF-8-encoded form.
3438 Forces the SV to string form if it is not already.
3439 Always sets the SvUTF8 flag to avoid future validity checks even
3440 if all the bytes have hibit clear.
3442 This is not as a general purpose byte encoding to Unicode interface:
3443 use the Encode extension for that.
3445 =for apidoc sv_utf8_upgrade_flags
3447 Converts the PV of an SV to its UTF-8-encoded form.
3448 Forces the SV to string form if it is not already.
3449 Always sets the SvUTF8 flag to avoid future validity checks even
3450 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3451 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3452 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3454 This is not as a general purpose byte encoding to Unicode interface:
3455 use the Encode extension for that.
3461 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3463 if (sv == &PL_sv_undef)
3467 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3468 (void) sv_2pv_flags(sv,&len, flags);
3472 (void) SvPV_force(sv,len);
3481 sv_force_normal_flags(sv, 0);
3484 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3485 sv_recode_to_utf8(sv, PL_encoding);
3486 else { /* Assume Latin-1/EBCDIC */
3487 /* This function could be much more efficient if we
3488 * had a FLAG in SVs to signal if there are any hibit
3489 * chars in the PV. Given that there isn't such a flag
3490 * make the loop as fast as possible. */
3491 const U8 *s = (U8 *) SvPVX_const(sv);
3492 const U8 * const e = (U8 *) SvEND(sv);
3498 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3502 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3503 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
3505 SvPV_free(sv); /* No longer using what was there before. */
3507 SvPV_set(sv, (char*)recoded);
3508 SvCUR_set(sv, len - 1);
3509 SvLEN_set(sv, len); /* No longer know the real size. */
3511 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3518 =for apidoc sv_utf8_downgrade
3520 Attempts to convert the PV of an SV from characters to bytes.
3521 If the PV contains a character beyond byte, this conversion will fail;
3522 in this case, either returns false or, if C<fail_ok> is not
3525 This is not as a general purpose Unicode to byte encoding interface:
3526 use the Encode extension for that.
3532 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3534 if (SvPOKp(sv) && SvUTF8(sv)) {
3540 sv_force_normal_flags(sv, 0);
3542 s = (U8 *) SvPV(sv, len);
3543 if (!utf8_to_bytes(s, &len)) {
3548 Perl_croak(aTHX_ "Wide character in %s",
3551 Perl_croak(aTHX_ "Wide character");
3562 =for apidoc sv_utf8_encode
3564 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3565 flag off so that it looks like octets again.
3571 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3573 (void) sv_utf8_upgrade(sv);
3575 sv_force_normal_flags(sv, 0);
3577 if (SvREADONLY(sv)) {
3578 Perl_croak(aTHX_ PL_no_modify);
3584 =for apidoc sv_utf8_decode
3586 If the PV of the SV is an octet sequence in UTF-8
3587 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3588 so that it looks like a character. If the PV contains only single-byte
3589 characters, the C<SvUTF8> flag stays being off.
3590 Scans PV for validity and returns false if the PV is invalid UTF-8.
3596 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3602 /* The octets may have got themselves encoded - get them back as
3605 if (!sv_utf8_downgrade(sv, TRUE))
3608 /* it is actually just a matter of turning the utf8 flag on, but
3609 * we want to make sure everything inside is valid utf8 first.
3611 c = (const U8 *) SvPVX_const(sv);
3612 if (!is_utf8_string(c, SvCUR(sv)+1))
3614 e = (const U8 *) SvEND(sv);
3617 if (!UTF8_IS_INVARIANT(ch)) {
3627 =for apidoc sv_setsv
3629 Copies the contents of the source SV C<ssv> into the destination SV
3630 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3631 function if the source SV needs to be reused. Does not handle 'set' magic.
3632 Loosely speaking, it performs a copy-by-value, obliterating any previous
3633 content of the destination.
3635 You probably want to use one of the assortment of wrappers, such as
3636 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3637 C<SvSetMagicSV_nosteal>.
3639 =for apidoc sv_setsv_flags
3641 Copies the contents of the source SV C<ssv> into the destination SV
3642 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3643 function if the source SV needs to be reused. Does not handle 'set' magic.
3644 Loosely speaking, it performs a copy-by-value, obliterating any previous
3645 content of the destination.
3646 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3647 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3648 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3649 and C<sv_setsv_nomg> are implemented in terms of this function.
3651 You probably want to use one of the assortment of wrappers, such as
3652 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3653 C<SvSetMagicSV_nosteal>.
3655 This is the primary function for copying scalars, and most other
3656 copy-ish functions and macros use this underneath.
3662 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3664 register U32 sflags;
3670 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3672 sstr = &PL_sv_undef;
3673 stype = SvTYPE(sstr);
3674 dtype = SvTYPE(dstr);
3679 /* need to nuke the magic */
3681 SvRMAGICAL_off(dstr);
3684 /* There's a lot of redundancy below but we're going for speed here */
3689 if (dtype != SVt_PVGV) {
3690 (void)SvOK_off(dstr);
3698 sv_upgrade(dstr, SVt_IV);
3701 sv_upgrade(dstr, SVt_PVNV);
3705 sv_upgrade(dstr, SVt_PVIV);
3708 (void)SvIOK_only(dstr);
3709 SvIV_set(dstr, SvIVX(sstr));
3712 if (SvTAINTED(sstr))
3723 sv_upgrade(dstr, SVt_NV);
3728 sv_upgrade(dstr, SVt_PVNV);
3731 SvNV_set(dstr, SvNVX(sstr));
3732 (void)SvNOK_only(dstr);
3733 if (SvTAINTED(sstr))
3741 sv_upgrade(dstr, SVt_RV);
3742 else if (dtype == SVt_PVGV &&
3743 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3746 if (GvIMPORTED(dstr) != GVf_IMPORTED
3747 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3749 GvIMPORTED_on(dstr);
3758 #ifdef PERL_OLD_COPY_ON_WRITE
3759 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3760 if (dtype < SVt_PVIV)
3761 sv_upgrade(dstr, SVt_PVIV);
3768 sv_upgrade(dstr, SVt_PV);
3771 if (dtype < SVt_PVIV)
3772 sv_upgrade(dstr, SVt_PVIV);
3775 if (dtype < SVt_PVNV)
3776 sv_upgrade(dstr, SVt_PVNV);
3783 const char * const type = sv_reftype(sstr,0);
3785 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3787 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3792 if (dtype <= SVt_PVGV) {
3794 if (dtype != SVt_PVGV) {
3795 const char * const name = GvNAME(sstr);
3796 const STRLEN len = GvNAMELEN(sstr);
3797 /* don't upgrade SVt_PVLV: it can hold a glob */
3798 if (dtype != SVt_PVLV)
3799 sv_upgrade(dstr, SVt_PVGV);
3800 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3801 GvSTASH(dstr) = GvSTASH(sstr);
3803 Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3804 GvNAME(dstr) = savepvn(name, len);
3805 GvNAMELEN(dstr) = len;
3806 SvFAKE_on(dstr); /* can coerce to non-glob */
3809 #ifdef GV_UNIQUE_CHECK
3810 if (GvUNIQUE((GV*)dstr)) {
3811 Perl_croak(aTHX_ PL_no_modify);
3815 (void)SvOK_off(dstr);
3816 GvINTRO_off(dstr); /* one-shot flag */
3818 GvGP(dstr) = gp_ref(GvGP(sstr));
3819 if (SvTAINTED(sstr))
3821 if (GvIMPORTED(dstr) != GVf_IMPORTED
3822 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3824 GvIMPORTED_on(dstr);
3832 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3834 if ((int)SvTYPE(sstr) != stype) {
3835 stype = SvTYPE(sstr);
3836 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3840 if (stype == SVt_PVLV)
3841 SvUPGRADE(dstr, SVt_PVNV);
3843 SvUPGRADE(dstr, (U32)stype);
3846 sflags = SvFLAGS(sstr);
3848 if (sflags & SVf_ROK) {
3849 if (dtype >= SVt_PV) {
3850 if (dtype == SVt_PVGV) {
3851 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3853 const int intro = GvINTRO(dstr);
3855 #ifdef GV_UNIQUE_CHECK
3856 if (GvUNIQUE((GV*)dstr)) {
3857 Perl_croak(aTHX_ PL_no_modify);
3862 GvINTRO_off(dstr); /* one-shot flag */
3863 GvLINE(dstr) = CopLINE(PL_curcop);
3864 GvEGV(dstr) = (GV*)dstr;
3867 switch (SvTYPE(sref)) {
3870 SAVEGENERICSV(GvAV(dstr));
3872 dref = (SV*)GvAV(dstr);
3873 GvAV(dstr) = (AV*)sref;
3874 if (!GvIMPORTED_AV(dstr)
3875 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3877 GvIMPORTED_AV_on(dstr);
3882 SAVEGENERICSV(GvHV(dstr));
3884 dref = (SV*)GvHV(dstr);
3885 GvHV(dstr) = (HV*)sref;
3886 if (!GvIMPORTED_HV(dstr)
3887 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3889 GvIMPORTED_HV_on(dstr);
3894 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3895 SvREFCNT_dec(GvCV(dstr));
3896 GvCV(dstr) = Nullcv;
3897 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3898 PL_sub_generation++;
3900 SAVEGENERICSV(GvCV(dstr));
3903 dref = (SV*)GvCV(dstr);
3904 if (GvCV(dstr) != (CV*)sref) {
3905 CV* const cv = GvCV(dstr);
3907 if (!GvCVGEN((GV*)dstr) &&
3908 (CvROOT(cv) || CvXSUB(cv)))
3910 /* Redefining a sub - warning is mandatory if
3911 it was a const and its value changed. */
3912 if (ckWARN(WARN_REDEFINE)
3914 && (!CvCONST((CV*)sref)
3915 || sv_cmp(cv_const_sv(cv),
3916 cv_const_sv((CV*)sref)))))
3918 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3920 ? "Constant subroutine %s::%s redefined"
3921 : "Subroutine %s::%s redefined",
3922 HvNAME_get(GvSTASH((GV*)dstr)),
3923 GvENAME((GV*)dstr));
3927 cv_ckproto(cv, (GV*)dstr,
3929 ? SvPVX_const(sref) : Nullch);
3931 GvCV(dstr) = (CV*)sref;
3932 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3933 GvASSUMECV_on(dstr);
3934 PL_sub_generation++;
3936 if (!GvIMPORTED_CV(dstr)
3937 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3939 GvIMPORTED_CV_on(dstr);
3944 SAVEGENERICSV(GvIOp(dstr));
3946 dref = (SV*)GvIOp(dstr);
3947 GvIOp(dstr) = (IO*)sref;
3951 SAVEGENERICSV(GvFORM(dstr));
3953 dref = (SV*)GvFORM(dstr);
3954 GvFORM(dstr) = (CV*)sref;
3958 SAVEGENERICSV(GvSV(dstr));
3960 dref = (SV*)GvSV(dstr);
3962 if (!GvIMPORTED_SV(dstr)
3963 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3965 GvIMPORTED_SV_on(dstr);
3971 if (SvTAINTED(sstr))
3975 if (SvPVX_const(dstr)) {
3981 (void)SvOK_off(dstr);
3982 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3984 if (sflags & SVp_NOK) {
3986 /* Only set the public OK flag if the source has public OK. */
3987 if (sflags & SVf_NOK)
3988 SvFLAGS(dstr) |= SVf_NOK;
3989 SvNV_set(dstr, SvNVX(sstr));
3991 if (sflags & SVp_IOK) {
3992 (void)SvIOKp_on(dstr);
3993 if (sflags & SVf_IOK)
3994 SvFLAGS(dstr) |= SVf_IOK;
3995 if (sflags & SVf_IVisUV)
3997 SvIV_set(dstr, SvIVX(sstr));
3999 if (SvAMAGIC(sstr)) {
4003 else if (sflags & SVp_POK) {
4007 * Check to see if we can just swipe the string. If so, it's a
4008 * possible small lose on short strings, but a big win on long ones.
4009 * It might even be a win on short strings if SvPVX_const(dstr)
4010 * has to be allocated and SvPVX_const(sstr) has to be freed.
4013 /* Whichever path we take through the next code, we want this true,
4014 and doing it now facilitates the COW check. */
4015 (void)SvPOK_only(dstr);
4018 /* We're not already COW */
4019 ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4020 #ifndef PERL_OLD_COPY_ON_WRITE
4021 /* or we are, but dstr isn't a suitable target. */
4022 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4027 (sflags & SVs_TEMP) && /* slated for free anyway? */
4028 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4029 (!(flags & SV_NOSTEAL)) &&
4030 /* and we're allowed to steal temps */
4031 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4032 SvLEN(sstr) && /* and really is a string */
4033 /* and won't be needed again, potentially */
4034 !(PL_op && PL_op->op_type == OP_AASSIGN))
4035 #ifdef PERL_OLD_COPY_ON_WRITE
4036 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4037 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4038 && SvTYPE(sstr) >= SVt_PVIV)
4041 /* Failed the swipe test, and it's not a shared hash key either.
4042 Have to copy the string. */
4043 STRLEN len = SvCUR(sstr);
4044 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4045 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4046 SvCUR_set(dstr, len);
4047 *SvEND(dstr) = '\0';
4049 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4051 /* Either it's a shared hash key, or it's suitable for
4052 copy-on-write or we can swipe the string. */
4054 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4058 #ifdef PERL_OLD_COPY_ON_WRITE
4060 /* I believe I should acquire a global SV mutex if
4061 it's a COW sv (not a shared hash key) to stop
4062 it going un copy-on-write.
4063 If the source SV has gone un copy on write between up there
4064 and down here, then (assert() that) it is of the correct
4065 form to make it copy on write again */
4066 if ((sflags & (SVf_FAKE | SVf_READONLY))
4067 != (SVf_FAKE | SVf_READONLY)) {
4068 SvREADONLY_on(sstr);
4070 /* Make the source SV into a loop of 1.
4071 (about to become 2) */
4072 SV_COW_NEXT_SV_SET(sstr, sstr);
4076 /* Initial code is common. */
4077 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4082 /* making another shared SV. */
4083 STRLEN cur = SvCUR(sstr);
4084 STRLEN len = SvLEN(sstr);
4085 #ifdef PERL_OLD_COPY_ON_WRITE
4087 assert (SvTYPE(dstr) >= SVt_PVIV);
4088 /* SvIsCOW_normal */
4089 /* splice us in between source and next-after-source. */
4090 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4091 SV_COW_NEXT_SV_SET(sstr, dstr);
4092 SvPV_set(dstr, SvPVX_mutable(sstr));
4096 /* SvIsCOW_shared_hash */
4097 DEBUG_C(PerlIO_printf(Perl_debug_log,
4098 "Copy on write: Sharing hash\n"));
4100 assert (SvTYPE(dstr) >= SVt_PV);
4102 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4104 SvLEN_set(dstr, len);
4105 SvCUR_set(dstr, cur);
4106 SvREADONLY_on(dstr);
4108 /* Relesase a global SV mutex. */
4111 { /* Passes the swipe test. */
4112 SvPV_set(dstr, SvPVX_mutable(sstr));
4113 SvLEN_set(dstr, SvLEN(sstr));
4114 SvCUR_set(dstr, SvCUR(sstr));
4117 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4118 SvPV_set(sstr, Nullch);
4124 if (sflags & SVf_UTF8)
4126 if (sflags & SVp_NOK) {
4128 if (sflags & SVf_NOK)
4129 SvFLAGS(dstr) |= SVf_NOK;
4130 SvNV_set(dstr, SvNVX(sstr));
4132 if (sflags & SVp_IOK) {
4133 (void)SvIOKp_on(dstr);
4134 if (sflags & SVf_IOK)
4135 SvFLAGS(dstr) |= SVf_IOK;
4136 if (sflags & SVf_IVisUV)
4138 SvIV_set(dstr, SvIVX(sstr));
4141 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4142 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4143 smg->mg_ptr, smg->mg_len);
4144 SvRMAGICAL_on(dstr);
4147 else if (sflags & SVp_IOK) {
4148 if (sflags & SVf_IOK)
4149 (void)SvIOK_only(dstr);
4151 (void)SvOK_off(dstr);
4152 (void)SvIOKp_on(dstr);
4154 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4155 if (sflags & SVf_IVisUV)
4157 SvIV_set(dstr, SvIVX(sstr));
4158 if (sflags & SVp_NOK) {
4159 if (sflags & SVf_NOK)
4160 (void)SvNOK_on(dstr);
4162 (void)SvNOKp_on(dstr);
4163 SvNV_set(dstr, SvNVX(sstr));
4166 else if (sflags & SVp_NOK) {
4167 if (sflags & SVf_NOK)
4168 (void)SvNOK_only(dstr);
4170 (void)SvOK_off(dstr);
4173 SvNV_set(dstr, SvNVX(sstr));
4176 if (dtype == SVt_PVGV) {
4177 if (ckWARN(WARN_MISC))
4178 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4181 (void)SvOK_off(dstr);
4183 if (SvTAINTED(sstr))
4188 =for apidoc sv_setsv_mg
4190 Like C<sv_setsv>, but also handles 'set' magic.
4196 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4198 sv_setsv(dstr,sstr);
4202 #ifdef PERL_OLD_COPY_ON_WRITE
4204 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4206 STRLEN cur = SvCUR(sstr);
4207 STRLEN len = SvLEN(sstr);
4208 register char *new_pv;
4211 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4219 if (SvTHINKFIRST(dstr))
4220 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4221 else if (SvPVX_const(dstr))
4222 Safefree(SvPVX_const(dstr));
4226 SvUPGRADE(dstr, SVt_PVIV);
4228 assert (SvPOK(sstr));
4229 assert (SvPOKp(sstr));
4230 assert (!SvIOK(sstr));
4231 assert (!SvIOKp(sstr));
4232 assert (!SvNOK(sstr));
4233 assert (!SvNOKp(sstr));
4235 if (SvIsCOW(sstr)) {
4237 if (SvLEN(sstr) == 0) {
4238 /* source is a COW shared hash key. */
4239 DEBUG_C(PerlIO_printf(Perl_debug_log,
4240 "Fast copy on write: Sharing hash\n"));
4241 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4244 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4246 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4247 SvUPGRADE(sstr, SVt_PVIV);
4248 SvREADONLY_on(sstr);
4250 DEBUG_C(PerlIO_printf(Perl_debug_log,
4251 "Fast copy on write: Converting sstr to COW\n"));
4252 SV_COW_NEXT_SV_SET(dstr, sstr);
4254 SV_COW_NEXT_SV_SET(sstr, dstr);
4255 new_pv = SvPVX_mutable(sstr);
4258 SvPV_set(dstr, new_pv);
4259 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4262 SvLEN_set(dstr, len);
4263 SvCUR_set(dstr, cur);
4272 =for apidoc sv_setpvn
4274 Copies a string into an SV. The C<len> parameter indicates the number of
4275 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4276 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4282 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4284 register char *dptr;
4286 SV_CHECK_THINKFIRST_COW_DROP(sv);
4292 /* len is STRLEN which is unsigned, need to copy to signed */
4295 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4297 SvUPGRADE(sv, SVt_PV);
4299 dptr = SvGROW(sv, len + 1);
4300 Move(ptr,dptr,len,char);
4303 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4308 =for apidoc sv_setpvn_mg
4310 Like C<sv_setpvn>, but also handles 'set' magic.
4316 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4318 sv_setpvn(sv,ptr,len);
4323 =for apidoc sv_setpv
4325 Copies a string into an SV. The string must be null-terminated. Does not
4326 handle 'set' magic. See C<sv_setpv_mg>.
4332 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4334 register STRLEN len;
4336 SV_CHECK_THINKFIRST_COW_DROP(sv);
4342 SvUPGRADE(sv, SVt_PV);
4344 SvGROW(sv, len + 1);
4345 Move(ptr,SvPVX(sv),len+1,char);
4347 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4352 =for apidoc sv_setpv_mg
4354 Like C<sv_setpv>, but also handles 'set' magic.
4360 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4367 =for apidoc sv_usepvn
4369 Tells an SV to use C<ptr> to find its string value. Normally the string is
4370 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4371 The C<ptr> should point to memory that was allocated by C<malloc>. The
4372 string length, C<len>, must be supplied. This function will realloc the
4373 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4374 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4375 See C<sv_usepvn_mg>.
4381 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4384 SV_CHECK_THINKFIRST_COW_DROP(sv);
4385 SvUPGRADE(sv, SVt_PV);
4390 if (SvPVX_const(sv))
4393 allocate = PERL_STRLEN_ROUNDUP(len + 1);
4394 ptr = saferealloc (ptr, allocate);
4397 SvLEN_set(sv, allocate);
4399 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4404 =for apidoc sv_usepvn_mg
4406 Like C<sv_usepvn>, but also handles 'set' magic.
4412 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4414 sv_usepvn(sv,ptr,len);
4418 #ifdef PERL_OLD_COPY_ON_WRITE
4419 /* Need to do this *after* making the SV normal, as we need the buffer
4420 pointer to remain valid until after we've copied it. If we let go too early,
4421 another thread could invalidate it by unsharing last of the same hash key
4422 (which it can do by means other than releasing copy-on-write Svs)
4423 or by changing the other copy-on-write SVs in the loop. */
4425 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
4427 if (len) { /* this SV was SvIsCOW_normal(sv) */
4428 /* we need to find the SV pointing to us. */
4429 SV * const current = SV_COW_NEXT_SV(after);
4431 if (current == sv) {
4432 /* The SV we point to points back to us (there were only two of us
4434 Hence other SV is no longer copy on write either. */
4436 SvREADONLY_off(after);
4438 /* We need to follow the pointers around the loop. */
4440 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4443 /* don't loop forever if the structure is bust, and we have
4444 a pointer into a closed loop. */
4445 assert (current != after);
4446 assert (SvPVX_const(current) == pvx);
4448 /* Make the SV before us point to the SV after us. */
4449 SV_COW_NEXT_SV_SET(current, after);
4452 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4457 Perl_sv_release_IVX(pTHX_ register SV *sv)
4460 sv_force_normal_flags(sv, 0);
4466 =for apidoc sv_force_normal_flags
4468 Undo various types of fakery on an SV: if the PV is a shared string, make
4469 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4470 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4471 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4472 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4473 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4474 set to some other value.) In addition, the C<flags> parameter gets passed to
4475 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4476 with flags set to 0.
4482 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4484 #ifdef PERL_OLD_COPY_ON_WRITE
4485 if (SvREADONLY(sv)) {
4486 /* At this point I believe I should acquire a global SV mutex. */
4488 const char * const pvx = SvPVX_const(sv);
4489 const STRLEN len = SvLEN(sv);
4490 const STRLEN cur = SvCUR(sv);
4491 SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
4493 PerlIO_printf(Perl_debug_log,
4494 "Copy on write: Force normal %ld\n",
4500 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4501 SvPV_set(sv, (char*)0);
4503 if (flags & SV_COW_DROP_PV) {
4504 /* OK, so we don't need to copy our buffer. */
4507 SvGROW(sv, cur + 1);
4508 Move(pvx,SvPVX(sv),cur,char);
4512 sv_release_COW(sv, pvx, len, next);
4517 else if (IN_PERL_RUNTIME)
4518 Perl_croak(aTHX_ PL_no_modify);
4519 /* At this point I believe that I can drop the global SV mutex. */
4522 if (SvREADONLY(sv)) {
4524 const char * const pvx = SvPVX_const(sv);
4525 const STRLEN len = SvCUR(sv);
4528 SvPV_set(sv, Nullch);
4530 SvGROW(sv, len + 1);
4531 Move(pvx,SvPVX(sv),len,char);
4533 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4535 else if (IN_PERL_RUNTIME)
4536 Perl_croak(aTHX_ PL_no_modify);
4540 sv_unref_flags(sv, flags);
4541 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4548 Efficient removal of characters from the beginning of the string buffer.
4549 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4550 the string buffer. The C<ptr> becomes the first character of the adjusted
4551 string. Uses the "OOK hack".
4552 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4553 refer to the same chunk of data.
4559 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
4561 register STRLEN delta;
4562 if (!ptr || !SvPOKp(sv))
4564 delta = ptr - SvPVX_const(sv);
4565 SV_CHECK_THINKFIRST(sv);
4566 if (SvTYPE(sv) < SVt_PVIV)
4567 sv_upgrade(sv,SVt_PVIV);
4570 if (!SvLEN(sv)) { /* make copy of shared string */
4571 const char *pvx = SvPVX_const(sv);
4572 const STRLEN len = SvCUR(sv);
4573 SvGROW(sv, len + 1);
4574 Move(pvx,SvPVX(sv),len,char);
4578 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
4579 and we do that anyway inside the SvNIOK_off
4581 SvFLAGS(sv) |= SVf_OOK;
4584 SvLEN_set(sv, SvLEN(sv) - delta);
4585 SvCUR_set(sv, SvCUR(sv) - delta);
4586 SvPV_set(sv, SvPVX(sv) + delta);
4587 SvIV_set(sv, SvIVX(sv) + delta);
4591 =for apidoc sv_catpvn
4593 Concatenates the string onto the end of the string which is in the SV. The
4594 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4595 status set, then the bytes appended should be valid UTF-8.
4596 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4598 =for apidoc sv_catpvn_flags
4600 Concatenates the string onto the end of the string which is in the SV. The
4601 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4602 status set, then the bytes appended should be valid UTF-8.
4603 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4604 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4605 in terms of this function.
4611 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4614 const char *dstr = SvPV_force_flags(dsv, dlen, flags);
4616 SvGROW(dsv, dlen + slen + 1);
4618 sstr = SvPVX_const(dsv);
4619 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4620 SvCUR_set(dsv, SvCUR(dsv) + slen);
4622 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4624 if (flags & SV_SMAGIC)
4629 =for apidoc sv_catsv
4631 Concatenates the string from SV C<ssv> onto the end of the string in
4632 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4633 not 'set' magic. See C<sv_catsv_mg>.
4635 =for apidoc sv_catsv_flags
4637 Concatenates the string from SV C<ssv> onto the end of the string in
4638 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4639 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4640 and C<sv_catsv_nomg> are implemented in terms of this function.
4645 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4650 if ((spv = SvPV_const(ssv, slen))) {
4651 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4652 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4653 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4654 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4655 dsv->sv_flags doesn't have that bit set.
4656 Andy Dougherty 12 Oct 2001
4658 const I32 sutf8 = DO_UTF8(ssv);
4661 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4663 dutf8 = DO_UTF8(dsv);
4665 if (dutf8 != sutf8) {
4667 /* Not modifying source SV, so taking a temporary copy. */
4668 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4670 sv_utf8_upgrade(csv);
4671 spv = SvPV_const(csv, slen);
4674 sv_utf8_upgrade_nomg(dsv);
4676 sv_catpvn_nomg(dsv, spv, slen);
4679 if (flags & SV_SMAGIC)
4684 =for apidoc sv_catpv
4686 Concatenates the string onto the end of the string which is in the SV.
4687 If the SV has the UTF-8 status set, then the bytes appended should be
4688 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4693 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4695 register STRLEN len;
4701 junk = SvPV_force(sv, tlen);
4703 SvGROW(sv, tlen + len + 1);
4705 ptr = SvPVX_const(sv);
4706 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4707 SvCUR_set(sv, SvCUR(sv) + len);
4708 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4713 =for apidoc sv_catpv_mg
4715 Like C<sv_catpv>, but also handles 'set' magic.
4721 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4730 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4731 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4738 Perl_newSV(pTHX_ STRLEN len)
4744 sv_upgrade(sv, SVt_PV);
4745 SvGROW(sv, len + 1);
4750 =for apidoc sv_magicext
4752 Adds magic to an SV, upgrading it if necessary. Applies the
4753 supplied vtable and returns a pointer to the magic added.
4755 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4756 In particular, you can add magic to SvREADONLY SVs, and add more than
4757 one instance of the same 'how'.
4759 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4760 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4761 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4762 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4764 (This is now used as a subroutine by C<sv_magic>.)
4769 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
4770 const char* name, I32 namlen)
4774 if (SvTYPE(sv) < SVt_PVMG) {
4775 SvUPGRADE(sv, SVt_PVMG);
4777 Newxz(mg, 1, MAGIC);
4778 mg->mg_moremagic = SvMAGIC(sv);
4779 SvMAGIC_set(sv, mg);
4781 /* Sometimes a magic contains a reference loop, where the sv and
4782 object refer to each other. To prevent a reference loop that
4783 would prevent such objects being freed, we look for such loops
4784 and if we find one we avoid incrementing the object refcount.
4786 Note we cannot do this to avoid self-tie loops as intervening RV must
4787 have its REFCNT incremented to keep it in existence.
4790 if (!obj || obj == sv ||
4791 how == PERL_MAGIC_arylen ||
4792 how == PERL_MAGIC_qr ||
4793 how == PERL_MAGIC_symtab ||
4794 (SvTYPE(obj) == SVt_PVGV &&
4795 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4796 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4797 GvFORM(obj) == (CV*)sv)))
4802 mg->mg_obj = SvREFCNT_inc(obj);
4803 mg->mg_flags |= MGf_REFCOUNTED;
4806 /* Normal self-ties simply pass a null object, and instead of
4807 using mg_obj directly, use the SvTIED_obj macro to produce a
4808 new RV as needed. For glob "self-ties", we are tieing the PVIO
4809 with an RV obj pointing to the glob containing the PVIO. In
4810 this case, to avoid a reference loop, we need to weaken the
4814 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4815 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4821 mg->mg_len = namlen;
4824 mg->mg_ptr = savepvn(name, namlen);
4825 else if (namlen == HEf_SVKEY)
4826 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4828 mg->mg_ptr = (char *) name;
4830 mg->mg_virtual = vtable;
4834 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4839 =for apidoc sv_magic
4841 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4842 then adds a new magic item of type C<how> to the head of the magic list.
4844 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4845 handling of the C<name> and C<namlen> arguments.
4847 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4848 to add more than one instance of the same 'how'.
4854 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4856 const MGVTBL *vtable;
4859 #ifdef PERL_OLD_COPY_ON_WRITE
4861 sv_force_normal_flags(sv, 0);
4863 if (SvREADONLY(sv)) {
4865 /* its okay to attach magic to shared strings; the subsequent
4866 * upgrade to PVMG will unshare the string */
4867 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4870 && how != PERL_MAGIC_regex_global
4871 && how != PERL_MAGIC_bm
4872 && how != PERL_MAGIC_fm
4873 && how != PERL_MAGIC_sv
4874 && how != PERL_MAGIC_backref
4877 Perl_croak(aTHX_ PL_no_modify);
4880 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4881 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4882 /* sv_magic() refuses to add a magic of the same 'how' as an
4885 if (how == PERL_MAGIC_taint)
4893 vtable = &PL_vtbl_sv;
4895 case PERL_MAGIC_overload:
4896 vtable = &PL_vtbl_amagic;
4898 case PERL_MAGIC_overload_elem:
4899 vtable = &PL_vtbl_amagicelem;
4901 case PERL_MAGIC_overload_table:
4902 vtable = &PL_vtbl_ovrld;
4905 vtable = &PL_vtbl_bm;
4907 case PERL_MAGIC_regdata:
4908 vtable = &PL_vtbl_regdata;
4910 case PERL_MAGIC_regdatum:
4911 vtable = &PL_vtbl_regdatum;
4913 case PERL_MAGIC_env:
4914 vtable = &PL_vtbl_env;
4917 vtable = &PL_vtbl_fm;
4919 case PERL_MAGIC_envelem:
4920 vtable = &PL_vtbl_envelem;
4922 case PERL_MAGIC_regex_global:
4923 vtable = &PL_vtbl_mglob;
4925 case PERL_MAGIC_isa:
4926 vtable = &PL_vtbl_isa;
4928 case PERL_MAGIC_isaelem:
4929 vtable = &PL_vtbl_isaelem;
4931 case PERL_MAGIC_nkeys:
4932 vtable = &PL_vtbl_nkeys;
4934 case PERL_MAGIC_dbfile:
4937 case PERL_MAGIC_dbline:
4938 vtable = &PL_vtbl_dbline;
4940 #ifdef USE_LOCALE_COLLATE
4941 case PERL_MAGIC_collxfrm:
4942 vtable = &PL_vtbl_collxfrm;
4944 #endif /* USE_LOCALE_COLLATE */
4945 case PERL_MAGIC_tied:
4946 vtable = &PL_vtbl_pack;
4948 case PERL_MAGIC_tiedelem:
4949 case PERL_MAGIC_tiedscalar:
4950 vtable = &PL_vtbl_packelem;
4953 vtable = &PL_vtbl_regexp;
4955 case PERL_MAGIC_sig:
4956 vtable = &PL_vtbl_sig;
4958 case PERL_MAGIC_sigelem:
4959 vtable = &PL_vtbl_sigelem;
4961 case PERL_MAGIC_taint:
4962 vtable = &PL_vtbl_taint;
4964 case PERL_MAGIC_uvar:
4965 vtable = &PL_vtbl_uvar;
4967 case PERL_MAGIC_vec:
4968 vtable = &PL_vtbl_vec;
4970 case PERL_MAGIC_arylen_p:
4971 case PERL_MAGIC_rhash:
4972 case PERL_MAGIC_symtab:
4973 case PERL_MAGIC_vstring:
4976 case PERL_MAGIC_utf8:
4977 vtable = &PL_vtbl_utf8;
4979 case PERL_MAGIC_substr:
4980 vtable = &PL_vtbl_substr;
4982 case PERL_MAGIC_defelem:
4983 vtable = &PL_vtbl_defelem;
4985 case PERL_MAGIC_glob:
4986 vtable = &PL_vtbl_glob;
4988 case PERL_MAGIC_arylen:
4989 vtable = &PL_vtbl_arylen;
4991 case PERL_MAGIC_pos:
4992 vtable = &PL_vtbl_pos;
4994 case PERL_MAGIC_backref:
4995 vtable = &PL_vtbl_backref;
4997 case PERL_MAGIC_ext:
4998 /* Reserved for use by extensions not perl internals. */
4999 /* Useful for attaching extension internal data to perl vars. */
5000 /* Note that multiple extensions may clash if magical scalars */
5001 /* etc holding private data from one are passed to another. */
5005 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5008 /* Rest of work is done else where */
5009 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5012 case PERL_MAGIC_taint:
5015 case PERL_MAGIC_ext:
5016 case PERL_MAGIC_dbfile:
5023 =for apidoc sv_unmagic
5025 Removes all magic of type C<type> from an SV.
5031 Perl_sv_unmagic(pTHX_ SV *sv, int type)
5035 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5038 for (mg = *mgp; mg; mg = *mgp) {
5039 if (mg->mg_type == type) {
5040 const MGVTBL* const vtbl = mg->mg_virtual;
5041 *mgp = mg->mg_moremagic;
5042 if (vtbl && vtbl->svt_free)
5043 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5044 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5046 Safefree(mg->mg_ptr);
5047 else if (mg->mg_len == HEf_SVKEY)
5048 SvREFCNT_dec((SV*)mg->mg_ptr);
5049 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
5050 Safefree(mg->mg_ptr);
5052 if (mg->mg_flags & MGf_REFCOUNTED)
5053 SvREFCNT_dec(mg->mg_obj);
5057 mgp = &mg->mg_moremagic;
5061 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5068 =for apidoc sv_rvweaken
5070 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5071 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5072 push a back-reference to this RV onto the array of backreferences
5073 associated with that magic.
5079 Perl_sv_rvweaken(pTHX_ SV *sv)
5082 if (!SvOK(sv)) /* let undefs pass */
5085 Perl_croak(aTHX_ "Can't weaken a nonreference");
5086 else if (SvWEAKREF(sv)) {
5087 if (ckWARN(WARN_MISC))
5088 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5092 Perl_sv_add_backref(aTHX_ tsv, sv);
5098 /* Give tsv backref magic if it hasn't already got it, then push a
5099 * back-reference to sv onto the array associated with the backref magic.
5103 Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
5107 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
5108 av = (AV*)mg->mg_obj;
5111 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5112 /* av now has a refcnt of 2, which avoids it getting freed
5113 * before us during global cleanup. The extra ref is removed
5114 * by magic_killbackrefs() when tsv is being freed */
5116 if (AvFILLp(av) >= AvMAX(av)) {
5117 av_extend(av, AvFILLp(av)+1);
5119 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5122 /* delete a back-reference to ourselves from the backref magic associated
5123 * with the SV we point to.
5127 S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
5133 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) {
5134 if (PL_in_clean_all)
5137 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
5138 Perl_croak(aTHX_ "panic: del_backref");
5139 av = (AV *)mg->mg_obj;
5141 /* We shouldn't be in here more than once, but for paranoia reasons lets
5143 for (i = AvFILLp(av); i >= 0; i--) {
5145 const SSize_t fill = AvFILLp(av);
5147 /* We weren't the last entry.
5148 An unordered list has this property that you can take the
5149 last element off the end to fill the hole, and it's still
5150 an unordered list :-)
5155 AvFILLp(av) = fill - 1;
5161 =for apidoc sv_insert
5163 Inserts a string at the specified offset/length within the SV. Similar to
5164 the Perl substr() function.
5170 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
5174 register char *midend;
5175 register char *bigend;
5181 Perl_croak(aTHX_ "Can't modify non-existent substring");
5182 SvPV_force(bigstr, curlen);
5183 (void)SvPOK_only_UTF8(bigstr);
5184 if (offset + len > curlen) {
5185 SvGROW(bigstr, offset+len+1);
5186 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5187 SvCUR_set(bigstr, offset+len);
5191 i = littlelen - len;
5192 if (i > 0) { /* string might grow */
5193 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5194 mid = big + offset + len;
5195 midend = bigend = big + SvCUR(bigstr);
5198 while (midend > mid) /* shove everything down */
5199 *--bigend = *--midend;
5200 Move(little,big+offset,littlelen,char);
5201 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5206 Move(little,SvPVX(bigstr)+offset,len,char);
5211 big = SvPVX(bigstr);
5214 bigend = big + SvCUR(bigstr);
5216 if (midend > bigend)
5217 Perl_croak(aTHX_ "panic: sv_insert");
5219 if (mid - big > bigend - midend) { /* faster to shorten from end */
5221 Move(little, mid, littlelen,char);
5224 i = bigend - midend;
5226 Move(midend, mid, i,char);
5230 SvCUR_set(bigstr, mid - big);
5232 else if ((i = mid - big)) { /* faster from front */
5233 midend -= littlelen;
5235 sv_chop(bigstr,midend-i);
5240 Move(little, mid, littlelen,char);
5242 else if (littlelen) {
5243 midend -= littlelen;
5244 sv_chop(bigstr,midend);
5245 Move(little,midend,littlelen,char);
5248 sv_chop(bigstr,midend);
5254 =for apidoc sv_replace
5256 Make the first argument a copy of the second, then delete the original.
5257 The target SV physically takes over ownership of the body of the source SV
5258 and inherits its flags; however, the target keeps any magic it owns,
5259 and any magic in the source is discarded.
5260 Note that this is a rather specialist SV copying operation; most of the
5261 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5267 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5269 const U32 refcnt = SvREFCNT(sv);
5270 SV_CHECK_THINKFIRST_COW_DROP(sv);
5271 if (SvREFCNT(nsv) != 1) {
5272 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
5273 UVuf " != 1)", (UV) SvREFCNT(nsv));
5275 if (SvMAGICAL(sv)) {
5279 sv_upgrade(nsv, SVt_PVMG);
5280 SvMAGIC_set(nsv, SvMAGIC(sv));
5281 SvFLAGS(nsv) |= SvMAGICAL(sv);
5283 SvMAGIC_set(sv, NULL);
5287 assert(!SvREFCNT(sv));
5288 #ifdef DEBUG_LEAKING_SCALARS
5289 sv->sv_flags = nsv->sv_flags;
5290 sv->sv_any = nsv->sv_any;
5291 sv->sv_refcnt = nsv->sv_refcnt;
5292 sv->sv_u = nsv->sv_u;
5294 StructCopy(nsv,sv,SV);
5296 /* Currently could join these into one piece of pointer arithmetic, but
5297 it would be unclear. */
5298 if(SvTYPE(sv) == SVt_IV)
5300 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5301 else if (SvTYPE(sv) == SVt_RV) {
5302 SvANY(sv) = &sv->sv_u.svu_rv;
5306 #ifdef PERL_OLD_COPY_ON_WRITE
5307 if (SvIsCOW_normal(nsv)) {
5308 /* We need to follow the pointers around the loop to make the
5309 previous SV point to sv, rather than nsv. */
5312 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5315 assert(SvPVX_const(current) == SvPVX_const(nsv));
5317 /* Make the SV before us point to the SV after us. */
5319 PerlIO_printf(Perl_debug_log, "previous is\n");
5321 PerlIO_printf(Perl_debug_log,
5322 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5323 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5325 SV_COW_NEXT_SV_SET(current, sv);
5328 SvREFCNT(sv) = refcnt;
5329 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5335 =for apidoc sv_clear
5337 Clear an SV: call any destructors, free up any memory used by the body,
5338 and free the body itself. The SV's head is I<not> freed, although
5339 its type is set to all 1's so that it won't inadvertently be assumed
5340 to be live during global destruction etc.
5341 This function should only be called when REFCNT is zero. Most of the time
5342 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5349 Perl_sv_clear(pTHX_ register SV *sv)
5352 void** old_body_arena;
5353 size_t old_body_offset;
5354 const U32 type = SvTYPE(sv);
5357 assert(SvREFCNT(sv) == 0);
5363 old_body_offset = 0;
5366 if (PL_defstash) { /* Still have a symbol table? */
5371 stash = SvSTASH(sv);
5372 destructor = StashHANDLER(stash,DESTROY);
5374 SV* const tmpref = newRV(sv);
5375 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5377 PUSHSTACKi(PERLSI_DESTROY);
5382 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5388 if(SvREFCNT(tmpref) < 2) {
5389 /* tmpref is not kept alive! */
5391 SvRV_set(tmpref, NULL);
5394 SvREFCNT_dec(tmpref);
5396 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5400 if (PL_in_clean_objs)
5401 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5403 /* DESTROY gave object new lease on life */
5409 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5410 SvOBJECT_off(sv); /* Curse the object. */
5411 if (type != SVt_PVIO)
5412 --PL_sv_objcount; /* XXX Might want something more general */
5415 if (type >= SVt_PVMG) {
5418 if (type == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
5419 SvREFCNT_dec(SvSTASH(sv));
5424 IoIFP(sv) != PerlIO_stdin() &&
5425 IoIFP(sv) != PerlIO_stdout() &&
5426 IoIFP(sv) != PerlIO_stderr())
5428 io_close((IO*)sv, FALSE);
5430 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5431 PerlDir_close(IoDIRP(sv));
5432 IoDIRP(sv) = (DIR*)NULL;
5433 Safefree(IoTOP_NAME(sv));
5434 Safefree(IoFMT_NAME(sv));
5435 Safefree(IoBOTTOM_NAME(sv));
5436 /* PVIOs aren't from arenas */
5439 old_body_arena = &PL_body_roots[SVt_PVBM];
5442 old_body_arena = &PL_body_roots[SVt_PVCV];
5444 /* PVFMs aren't from arenas */
5449 old_body_arena = &PL_body_roots[SVt_PVHV];
5450 old_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill);
5454 old_body_arena = &PL_body_roots[SVt_PVAV];
5455 old_body_offset = STRUCT_OFFSET(XPVAV, xav_fill);
5458 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5459 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5460 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5461 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5463 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5464 SvREFCNT_dec(LvTARG(sv));
5465 old_body_arena = &PL_body_roots[SVt_PVLV];
5469 Safefree(GvNAME(sv));
5470 /* If we're in a stash, we don't own a reference to it. However it does
5471 have a back reference to us, which needs to be cleared. */
5473 sv_del_backref((SV*)GvSTASH(sv), sv);
5474 old_body_arena = &PL_body_roots[SVt_PVGV];
5477 old_body_arena = &PL_body_roots[SVt_PVMG];
5480 old_body_arena = &PL_body_roots[SVt_PVNV];
5483 old_body_arena = &PL_body_roots[SVt_PVIV];
5484 old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur);
5486 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5488 SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
5489 /* Don't even bother with turning off the OOK flag. */
5493 old_body_arena = &PL_body_roots[SVt_PV];
5494 old_body_offset = STRUCT_OFFSET(XPV, xpv_cur);
5498 SV *target = SvRV(sv);
5500 sv_del_backref(target, sv);
5502 SvREFCNT_dec(target);
5504 #ifdef PERL_OLD_COPY_ON_WRITE
5505 else if (SvPVX_const(sv)) {
5507 /* I believe I need to grab the global SV mutex here and
5508 then recheck the COW status. */
5510 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5513 sv_release_COW(sv, SvPVX_const(sv), SvLEN(sv),
5514 SV_COW_NEXT_SV(sv));
5515 /* And drop it here. */
5517 } else if (SvLEN(sv)) {
5518 Safefree(SvPVX_const(sv));
5522 else if (SvPVX_const(sv) && SvLEN(sv))
5523 Safefree(SvPVX_mutable(sv));
5524 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5525 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5531 old_body_arena = PL_body_roots[SVt_NV];
5535 SvFLAGS(sv) &= SVf_BREAK;
5536 SvFLAGS(sv) |= SVTYPEMASK;
5539 if (old_body_arena) {
5540 del_body(((char *)SvANY(sv) + old_body_offset), old_body_arena);
5544 if (type > SVt_RV) {
5545 my_safefree(SvANY(sv));
5550 =for apidoc sv_newref
5552 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5559 Perl_sv_newref(pTHX_ SV *sv)
5569 Decrement an SV's reference count, and if it drops to zero, call
5570 C<sv_clear> to invoke destructors and free up any memory used by
5571 the body; finally, deallocate the SV's head itself.
5572 Normally called via a wrapper macro C<SvREFCNT_dec>.
5578 Perl_sv_free(pTHX_ SV *sv)
5583 if (SvREFCNT(sv) == 0) {
5584 if (SvFLAGS(sv) & SVf_BREAK)
5585 /* this SV's refcnt has been artificially decremented to
5586 * trigger cleanup */
5588 if (PL_in_clean_all) /* All is fair */
5590 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5591 /* make sure SvREFCNT(sv)==0 happens very seldom */
5592 SvREFCNT(sv) = (~(U32)0)/2;
5595 if (ckWARN_d(WARN_INTERNAL)) {
5596 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5597 "Attempt to free unreferenced scalar: SV 0x%"UVxf
5598 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5599 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5600 Perl_dump_sv_child(aTHX_ sv);
5605 if (--(SvREFCNT(sv)) > 0)
5607 Perl_sv_free2(aTHX_ sv);
5611 Perl_sv_free2(pTHX_ SV *sv)
5616 if (ckWARN_d(WARN_DEBUGGING))
5617 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5618 "Attempt to free temp prematurely: SV 0x%"UVxf
5619 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5623 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5624 /* make sure SvREFCNT(sv)==0 happens very seldom */
5625 SvREFCNT(sv) = (~(U32)0)/2;
5636 Returns the length of the string in the SV. Handles magic and type
5637 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5643 Perl_sv_len(pTHX_ register SV *sv)
5651 len = mg_length(sv);
5653 (void)SvPV_const(sv, len);
5658 =for apidoc sv_len_utf8
5660 Returns the number of characters in the string in an SV, counting wide
5661 UTF-8 bytes as a single character. Handles magic and type coercion.
5667 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
5668 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
5669 * (Note that the mg_len is not the length of the mg_ptr field.)
5674 Perl_sv_len_utf8(pTHX_ register SV *sv)
5680 return mg_length(sv);
5684 const U8 *s = (U8*)SvPV_const(sv, len);
5685 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
5687 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
5689 #ifdef PERL_UTF8_CACHE_ASSERT
5690 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
5694 ulen = Perl_utf8_length(aTHX_ s, s + len);
5695 if (!mg && !SvREADONLY(sv)) {
5696 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5697 mg = mg_find(sv, PERL_MAGIC_utf8);
5707 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
5708 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5709 * between UTF-8 and byte offsets. There are two (substr offset and substr
5710 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
5711 * and byte offset) cache positions.
5713 * The mg_len field is used by sv_len_utf8(), see its comments.
5714 * Note that the mg_len is not the length of the mg_ptr field.
5718 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i,
5719 I32 offsetp, const U8 *s, const U8 *start)
5723 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5725 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
5729 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5731 Newxz(*cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5732 (*mgp)->mg_ptr = (char *) *cachep;
5736 (*cachep)[i] = offsetp;
5737 (*cachep)[i+1] = s - start;
5745 * S_utf8_mg_pos() is used to query and update mg_ptr field of
5746 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5747 * between UTF-8 and byte offsets. See also the comments of
5748 * S_utf8_mg_pos_init().
5752 S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, const U8 **sp, const U8 *start, const U8 *send)
5756 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5758 *mgp = mg_find(sv, PERL_MAGIC_utf8);
5759 if (*mgp && (*mgp)->mg_ptr) {
5760 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5761 ASSERT_UTF8_CACHE(*cachep);
5762 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
5764 else { /* We will skip to the right spot. */
5769 /* The assumption is that going backward is half
5770 * the speed of going forward (that's where the
5771 * 2 * backw in the below comes from). (The real
5772 * figure of course depends on the UTF-8 data.) */
5774 if ((*cachep)[i] > (STRLEN)uoff) {
5776 backw = (*cachep)[i] - (STRLEN)uoff;
5778 if (forw < 2 * backw)
5781 p = start + (*cachep)[i+1];
5783 /* Try this only for the substr offset (i == 0),
5784 * not for the substr length (i == 2). */
5785 else if (i == 0) { /* (*cachep)[i] < uoff */
5786 const STRLEN ulen = sv_len_utf8(sv);
5788 if ((STRLEN)uoff < ulen) {
5789 forw = (STRLEN)uoff - (*cachep)[i];
5790 backw = ulen - (STRLEN)uoff;
5792 if (forw < 2 * backw)
5793 p = start + (*cachep)[i+1];
5798 /* If the string is not long enough for uoff,
5799 * we could extend it, but not at this low a level. */
5803 if (forw < 2 * backw) {
5810 while (UTF8_IS_CONTINUATION(*p))
5815 /* Update the cache. */
5816 (*cachep)[i] = (STRLEN)uoff;
5817 (*cachep)[i+1] = p - start;
5819 /* Drop the stale "length" cache */
5828 if (found) { /* Setup the return values. */
5829 *offsetp = (*cachep)[i+1];
5830 *sp = start + *offsetp;
5833 *offsetp = send - start;
5835 else if (*sp < start) {
5841 #ifdef PERL_UTF8_CACHE_ASSERT
5846 while (n-- && s < send)
5850 assert(*offsetp == s - start);
5851 assert((*cachep)[0] == (STRLEN)uoff);
5852 assert((*cachep)[1] == *offsetp);
5854 ASSERT_UTF8_CACHE(*cachep);
5863 =for apidoc sv_pos_u2b
5865 Converts the value pointed to by offsetp from a count of UTF-8 chars from
5866 the start of the string, to a count of the equivalent number of bytes; if
5867 lenp is non-zero, it does the same to lenp, but this time starting from
5868 the offset, rather than from the start of the string. Handles magic and
5875 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
5876 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5877 * byte offsets. See also the comments of S_utf8_mg_pos().
5882 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5890 start = (U8*)SvPV_const(sv, len);
5894 const U8 *s = start;
5895 I32 uoffset = *offsetp;
5896 const U8 * const send = s + len;
5900 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
5902 if (!found && uoffset > 0) {
5903 while (s < send && uoffset--)
5907 if (utf8_mg_pos_init(sv, &mg, &cache, 0, *offsetp, s, start))
5909 *offsetp = s - start;
5914 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) {
5918 if (!found && *lenp > 0) {
5921 while (s < send && ulen--)
5925 utf8_mg_pos_init(sv, &mg, &cache, 2, *lenp, s, start);
5929 ASSERT_UTF8_CACHE(cache);
5941 =for apidoc sv_pos_b2u
5943 Converts the value pointed to by offsetp from a count of bytes from the
5944 start of the string, to a count of the equivalent number of UTF-8 chars.
5945 Handles magic and type coercion.
5951 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
5952 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5953 * byte offsets. See also the comments of S_utf8_mg_pos().
5958 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
5966 s = (const U8*)SvPV_const(sv, len);
5967 if ((I32)len < *offsetp)
5968 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5970 const U8* send = s + *offsetp;
5972 STRLEN *cache = NULL;
5976 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5977 mg = mg_find(sv, PERL_MAGIC_utf8);
5978 if (mg && mg->mg_ptr) {
5979 cache = (STRLEN *) mg->mg_ptr;
5980 if (cache[1] == (STRLEN)*offsetp) {
5981 /* An exact match. */
5982 *offsetp = cache[0];
5986 else if (cache[1] < (STRLEN)*offsetp) {
5987 /* We already know part of the way. */
5990 /* Let the below loop do the rest. */
5992 else { /* cache[1] > *offsetp */
5993 /* We already know all of the way, now we may
5994 * be able to walk back. The same assumption
5995 * is made as in S_utf8_mg_pos(), namely that
5996 * walking backward is twice slower than
5997 * walking forward. */
5998 const STRLEN forw = *offsetp;
5999 STRLEN backw = cache[1] - *offsetp;
6001 if (!(forw < 2 * backw)) {
6002 const U8 *p = s + cache[1];
6009 while (UTF8_IS_CONTINUATION(*p)) {
6017 *offsetp = cache[0];
6019 /* Drop the stale "length" cache */
6027 ASSERT_UTF8_CACHE(cache);
6033 /* Call utf8n_to_uvchr() to validate the sequence
6034 * (unless a simple non-UTF character) */
6035 if (!UTF8_IS_INVARIANT(*s))
6036 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
6045 if (!SvREADONLY(sv)) {
6047 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6048 mg = mg_find(sv, PERL_MAGIC_utf8);
6053 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6054 mg->mg_ptr = (char *) cache;
6059 cache[1] = *offsetp;
6060 /* Drop the stale "length" cache */
6073 Returns a boolean indicating whether the strings in the two SVs are
6074 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6075 coerce its args to strings if necessary.
6081 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6089 SV* svrecode = Nullsv;
6096 pv1 = SvPV_const(sv1, cur1);
6103 pv2 = SvPV_const(sv2, cur2);
6105 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6106 /* Differing utf8ness.
6107 * Do not UTF8size the comparands as a side-effect. */
6110 svrecode = newSVpvn(pv2, cur2);
6111 sv_recode_to_utf8(svrecode, PL_encoding);
6112 pv2 = SvPV_const(svrecode, cur2);
6115 svrecode = newSVpvn(pv1, cur1);
6116 sv_recode_to_utf8(svrecode, PL_encoding);
6117 pv1 = SvPV_const(svrecode, cur1);
6119 /* Now both are in UTF-8. */
6121 SvREFCNT_dec(svrecode);
6126 bool is_utf8 = TRUE;
6129 /* sv1 is the UTF-8 one,
6130 * if is equal it must be downgrade-able */
6131 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6137 /* sv2 is the UTF-8 one,
6138 * if is equal it must be downgrade-able */
6139 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6145 /* Downgrade not possible - cannot be eq */
6153 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6156 SvREFCNT_dec(svrecode);
6167 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6168 string in C<sv1> is less than, equal to, or greater than the string in
6169 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6170 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6176 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6179 const char *pv1, *pv2;
6182 SV *svrecode = Nullsv;
6189 pv1 = SvPV_const(sv1, cur1);
6196 pv2 = SvPV_const(sv2, cur2);
6198 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6199 /* Differing utf8ness.
6200 * Do not UTF8size the comparands as a side-effect. */
6203 svrecode = newSVpvn(pv2, cur2);
6204 sv_recode_to_utf8(svrecode, PL_encoding);
6205 pv2 = SvPV_const(svrecode, cur2);
6208 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6213 svrecode = newSVpvn(pv1, cur1);
6214 sv_recode_to_utf8(svrecode, PL_encoding);
6215 pv1 = SvPV_const(svrecode, cur1);
6218 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6224 cmp = cur2 ? -1 : 0;
6228 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6231 cmp = retval < 0 ? -1 : 1;
6232 } else if (cur1 == cur2) {
6235 cmp = cur1 < cur2 ? -1 : 1;
6240 SvREFCNT_dec(svrecode);
6249 =for apidoc sv_cmp_locale
6251 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6252 'use bytes' aware, handles get magic, and will coerce its args to strings
6253 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6259 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6261 #ifdef USE_LOCALE_COLLATE
6267 if (PL_collation_standard)
6271 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6273 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6275 if (!pv1 || !len1) {
6286 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6289 return retval < 0 ? -1 : 1;
6292 * When the result of collation is equality, that doesn't mean
6293 * that there are no differences -- some locales exclude some
6294 * characters from consideration. So to avoid false equalities,
6295 * we use the raw string as a tiebreaker.
6301 #endif /* USE_LOCALE_COLLATE */
6303 return sv_cmp(sv1, sv2);
6307 #ifdef USE_LOCALE_COLLATE
6310 =for apidoc sv_collxfrm
6312 Add Collate Transform magic to an SV if it doesn't already have it.
6314 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6315 scalar data of the variable, but transformed to such a format that a normal
6316 memory comparison can be used to compare the data according to the locale
6323 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6327 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6328 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6334 Safefree(mg->mg_ptr);
6335 s = SvPV_const(sv, len);
6336 if ((xf = mem_collxfrm(s, len, &xlen))) {
6337 if (SvREADONLY(sv)) {
6340 return xf + sizeof(PL_collation_ix);
6343 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6344 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6357 if (mg && mg->mg_ptr) {
6359 return mg->mg_ptr + sizeof(PL_collation_ix);
6367 #endif /* USE_LOCALE_COLLATE */
6372 Get a line from the filehandle and store it into the SV, optionally
6373 appending to the currently-stored string.
6379 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6383 register STDCHAR rslast;
6384 register STDCHAR *bp;
6390 if (SvTHINKFIRST(sv))
6391 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6392 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6394 However, perlbench says it's slower, because the existing swipe code
6395 is faster than copy on write.
6396 Swings and roundabouts. */
6397 SvUPGRADE(sv, SVt_PV);
6402 if (PerlIO_isutf8(fp)) {
6404 sv_utf8_upgrade_nomg(sv);
6405 sv_pos_u2b(sv,&append,0);
6407 } else if (SvUTF8(sv)) {
6408 SV * const tsv = NEWSV(0,0);
6409 sv_gets(tsv, fp, 0);
6410 sv_utf8_upgrade_nomg(tsv);
6411 SvCUR_set(sv,append);
6414 goto return_string_or_null;
6419 if (PerlIO_isutf8(fp))
6422 if (IN_PERL_COMPILETIME) {
6423 /* we always read code in line mode */
6427 else if (RsSNARF(PL_rs)) {
6428 /* If it is a regular disk file use size from stat() as estimate
6429 of amount we are going to read - may result in malloc-ing
6430 more memory than we realy need if layers bellow reduce
6431 size we read (e.g. CRLF or a gzip layer)
6434 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6435 const Off_t offset = PerlIO_tell(fp);
6436 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6437 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6443 else if (RsRECORD(PL_rs)) {
6447 /* Grab the size of the record we're getting */
6448 recsize = SvIV(SvRV(PL_rs));
6449 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6452 /* VMS wants read instead of fread, because fread doesn't respect */
6453 /* RMS record boundaries. This is not necessarily a good thing to be */
6454 /* doing, but we've got no other real choice - except avoid stdio
6455 as implementation - perhaps write a :vms layer ?
6457 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6459 bytesread = PerlIO_read(fp, buffer, recsize);
6463 SvCUR_set(sv, bytesread += append);
6464 buffer[bytesread] = '\0';
6465 goto return_string_or_null;
6467 else if (RsPARA(PL_rs)) {
6473 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6474 if (PerlIO_isutf8(fp)) {
6475 rsptr = SvPVutf8(PL_rs, rslen);
6478 if (SvUTF8(PL_rs)) {
6479 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6480 Perl_croak(aTHX_ "Wide character in $/");
6483 rsptr = SvPV_const(PL_rs, rslen);
6487 rslast = rslen ? rsptr[rslen - 1] : '\0';
6489 if (rspara) { /* have to do this both before and after */
6490 do { /* to make sure file boundaries work right */
6493 i = PerlIO_getc(fp);
6497 PerlIO_ungetc(fp,i);
6503 /* See if we know enough about I/O mechanism to cheat it ! */
6505 /* This used to be #ifdef test - it is made run-time test for ease
6506 of abstracting out stdio interface. One call should be cheap
6507 enough here - and may even be a macro allowing compile
6511 if (PerlIO_fast_gets(fp)) {
6514 * We're going to steal some values from the stdio struct
6515 * and put EVERYTHING in the innermost loop into registers.
6517 register STDCHAR *ptr;
6521 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6522 /* An ungetc()d char is handled separately from the regular
6523 * buffer, so we getc() it back out and stuff it in the buffer.
6525 i = PerlIO_getc(fp);
6526 if (i == EOF) return 0;
6527 *(--((*fp)->_ptr)) = (unsigned char) i;
6531 /* Here is some breathtakingly efficient cheating */
6533 cnt = PerlIO_get_cnt(fp); /* get count into register */
6534 /* make sure we have the room */
6535 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
6536 /* Not room for all of it
6537 if we are looking for a separator and room for some
6539 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
6540 /* just process what we have room for */
6541 shortbuffered = cnt - SvLEN(sv) + append + 1;
6542 cnt -= shortbuffered;
6546 /* remember that cnt can be negative */
6547 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
6552 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
6553 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
6554 DEBUG_P(PerlIO_printf(Perl_debug_log,
6555 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6556 DEBUG_P(PerlIO_printf(Perl_debug_log,
6557 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6558 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6559 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6564 while (cnt > 0) { /* this | eat */
6566 if ((*bp++ = *ptr++) == rslast) /* really | dust */
6567 goto thats_all_folks; /* screams | sed :-) */
6571 Copy(ptr, bp, cnt, char); /* this | eat */
6572 bp += cnt; /* screams | dust */
6573 ptr += cnt; /* louder | sed :-) */
6578 if (shortbuffered) { /* oh well, must extend */
6579 cnt = shortbuffered;
6581 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6583 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6584 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6588 DEBUG_P(PerlIO_printf(Perl_debug_log,
6589 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6590 PTR2UV(ptr),(long)cnt));
6591 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6593 DEBUG_P(PerlIO_printf(Perl_debug_log,
6594 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6595 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6596 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6598 /* This used to call 'filbuf' in stdio form, but as that behaves like
6599 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6600 another abstraction. */
6601 i = PerlIO_getc(fp); /* get more characters */
6603 DEBUG_P(PerlIO_printf(Perl_debug_log,
6604 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6605 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6606 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6608 cnt = PerlIO_get_cnt(fp);
6609 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
6610 DEBUG_P(PerlIO_printf(Perl_debug_log,
6611 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6613 if (i == EOF) /* all done for ever? */
6614 goto thats_really_all_folks;
6616 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6618 SvGROW(sv, bpx + cnt + 2);
6619 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6621 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
6623 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
6624 goto thats_all_folks;
6628 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
6629 memNE((char*)bp - rslen, rsptr, rslen))
6630 goto screamer; /* go back to the fray */
6631 thats_really_all_folks:
6633 cnt += shortbuffered;
6634 DEBUG_P(PerlIO_printf(Perl_debug_log,
6635 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6636 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
6637 DEBUG_P(PerlIO_printf(Perl_debug_log,
6638 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6639 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6640 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6642 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
6643 DEBUG_P(PerlIO_printf(Perl_debug_log,
6644 "Screamer: done, len=%ld, string=|%.*s|\n",
6645 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
6649 /*The big, slow, and stupid way. */
6650 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
6652 Newx(buf, 8192, STDCHAR);
6660 register const STDCHAR *bpe = buf + sizeof(buf);
6662 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6663 ; /* keep reading */
6667 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6668 /* Accomodate broken VAXC compiler, which applies U8 cast to
6669 * both args of ?: operator, causing EOF to change into 255
6672 i = (U8)buf[cnt - 1];
6678 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
6680 sv_catpvn(sv, (char *) buf, cnt);
6682 sv_setpvn(sv, (char *) buf, cnt);
6684 if (i != EOF && /* joy */
6686 SvCUR(sv) < rslen ||
6687 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6691 * If we're reading from a TTY and we get a short read,
6692 * indicating that the user hit his EOF character, we need
6693 * to notice it now, because if we try to read from the TTY
6694 * again, the EOF condition will disappear.
6696 * The comparison of cnt to sizeof(buf) is an optimization
6697 * that prevents unnecessary calls to feof().
6701 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
6705 #ifdef USE_HEAP_INSTEAD_OF_STACK
6710 if (rspara) { /* have to do this both before and after */
6711 while (i != EOF) { /* to make sure file boundaries work right */
6712 i = PerlIO_getc(fp);
6714 PerlIO_ungetc(fp,i);
6720 return_string_or_null:
6721 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
6727 Auto-increment of the value in the SV, doing string to numeric conversion
6728 if necessary. Handles 'get' magic.
6734 Perl_sv_inc(pTHX_ register SV *sv)
6742 if (SvTHINKFIRST(sv)) {
6744 sv_force_normal_flags(sv, 0);
6745 if (SvREADONLY(sv)) {
6746 if (IN_PERL_RUNTIME)
6747 Perl_croak(aTHX_ PL_no_modify);
6751 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6753 i = PTR2IV(SvRV(sv));
6758 flags = SvFLAGS(sv);
6759 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6760 /* It's (privately or publicly) a float, but not tested as an
6761 integer, so test it to see. */
6763 flags = SvFLAGS(sv);
6765 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6766 /* It's publicly an integer, or privately an integer-not-float */
6767 #ifdef PERL_PRESERVE_IVUV
6771 if (SvUVX(sv) == UV_MAX)
6772 sv_setnv(sv, UV_MAX_P1);
6774 (void)SvIOK_only_UV(sv);
6775 SvUV_set(sv, SvUVX(sv) + 1);
6777 if (SvIVX(sv) == IV_MAX)
6778 sv_setuv(sv, (UV)IV_MAX + 1);
6780 (void)SvIOK_only(sv);
6781 SvIV_set(sv, SvIVX(sv) + 1);
6786 if (flags & SVp_NOK) {
6787 (void)SvNOK_only(sv);
6788 SvNV_set(sv, SvNVX(sv) + 1.0);
6792 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
6793 if ((flags & SVTYPEMASK) < SVt_PVIV)
6794 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
6795 (void)SvIOK_only(sv);
6800 while (isALPHA(*d)) d++;
6801 while (isDIGIT(*d)) d++;
6803 #ifdef PERL_PRESERVE_IVUV
6804 /* Got to punt this as an integer if needs be, but we don't issue
6805 warnings. Probably ought to make the sv_iv_please() that does
6806 the conversion if possible, and silently. */
6807 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6808 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6809 /* Need to try really hard to see if it's an integer.
6810 9.22337203685478e+18 is an integer.
6811 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6812 so $a="9.22337203685478e+18"; $a+0; $a++
6813 needs to be the same as $a="9.22337203685478e+18"; $a++
6820 /* sv_2iv *should* have made this an NV */
6821 if (flags & SVp_NOK) {
6822 (void)SvNOK_only(sv);
6823 SvNV_set(sv, SvNVX(sv) + 1.0);
6826 /* I don't think we can get here. Maybe I should assert this
6827 And if we do get here I suspect that sv_setnv will croak. NWC
6829 #if defined(USE_LONG_DOUBLE)
6830 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",
6831 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6833 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6834 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6837 #endif /* PERL_PRESERVE_IVUV */
6838 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
6842 while (d >= SvPVX_const(sv)) {
6850 /* MKS: The original code here died if letters weren't consecutive.
6851 * at least it didn't have to worry about non-C locales. The
6852 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6853 * arranged in order (although not consecutively) and that only
6854 * [A-Za-z] are accepted by isALPHA in the C locale.
6856 if (*d != 'z' && *d != 'Z') {
6857 do { ++*d; } while (!isALPHA(*d));
6860 *(d--) -= 'z' - 'a';
6865 *(d--) -= 'z' - 'a' + 1;
6869 /* oh,oh, the number grew */
6870 SvGROW(sv, SvCUR(sv) + 2);
6871 SvCUR_set(sv, SvCUR(sv) + 1);
6872 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
6883 Auto-decrement of the value in the SV, doing string to numeric conversion
6884 if necessary. Handles 'get' magic.
6890 Perl_sv_dec(pTHX_ register SV *sv)
6897 if (SvTHINKFIRST(sv)) {
6899 sv_force_normal_flags(sv, 0);
6900 if (SvREADONLY(sv)) {
6901 if (IN_PERL_RUNTIME)
6902 Perl_croak(aTHX_ PL_no_modify);
6906 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6908 i = PTR2IV(SvRV(sv));
6913 /* Unlike sv_inc we don't have to worry about string-never-numbers
6914 and keeping them magic. But we mustn't warn on punting */
6915 flags = SvFLAGS(sv);
6916 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6917 /* It's publicly an integer, or privately an integer-not-float */
6918 #ifdef PERL_PRESERVE_IVUV
6922 if (SvUVX(sv) == 0) {
6923 (void)SvIOK_only(sv);
6927 (void)SvIOK_only_UV(sv);
6928 SvUV_set(sv, SvUVX(sv) - 1);
6931 if (SvIVX(sv) == IV_MIN)
6932 sv_setnv(sv, (NV)IV_MIN - 1.0);
6934 (void)SvIOK_only(sv);
6935 SvIV_set(sv, SvIVX(sv) - 1);
6940 if (flags & SVp_NOK) {
6941 SvNV_set(sv, SvNVX(sv) - 1.0);
6942 (void)SvNOK_only(sv);
6945 if (!(flags & SVp_POK)) {
6946 if ((flags & SVTYPEMASK) < SVt_PVIV)
6947 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
6949 (void)SvIOK_only(sv);
6952 #ifdef PERL_PRESERVE_IVUV
6954 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6955 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6956 /* Need to try really hard to see if it's an integer.
6957 9.22337203685478e+18 is an integer.
6958 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6959 so $a="9.22337203685478e+18"; $a+0; $a--
6960 needs to be the same as $a="9.22337203685478e+18"; $a--
6967 /* sv_2iv *should* have made this an NV */
6968 if (flags & SVp_NOK) {
6969 (void)SvNOK_only(sv);
6970 SvNV_set(sv, SvNVX(sv) - 1.0);
6973 /* I don't think we can get here. Maybe I should assert this
6974 And if we do get here I suspect that sv_setnv will croak. NWC
6976 #if defined(USE_LONG_DOUBLE)
6977 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",
6978 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6980 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6981 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6985 #endif /* PERL_PRESERVE_IVUV */
6986 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
6990 =for apidoc sv_mortalcopy
6992 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6993 The new SV is marked as mortal. It will be destroyed "soon", either by an
6994 explicit call to FREETMPS, or by an implicit call at places such as
6995 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7000 /* Make a string that will exist for the duration of the expression
7001 * evaluation. Actually, it may have to last longer than that, but
7002 * hopefully we won't free it until it has been assigned to a
7003 * permanent location. */
7006 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
7011 sv_setsv(sv,oldstr);
7013 PL_tmps_stack[++PL_tmps_ix] = sv;
7019 =for apidoc sv_newmortal
7021 Creates a new null SV which is mortal. The reference count of the SV is
7022 set to 1. It will be destroyed "soon", either by an explicit call to
7023 FREETMPS, or by an implicit call at places such as statement boundaries.
7024 See also C<sv_mortalcopy> and C<sv_2mortal>.
7030 Perl_sv_newmortal(pTHX)
7035 SvFLAGS(sv) = SVs_TEMP;
7037 PL_tmps_stack[++PL_tmps_ix] = sv;
7042 =for apidoc sv_2mortal
7044 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7045 by an explicit call to FREETMPS, or by an implicit call at places such as
7046 statement boundaries. SvTEMP() is turned on which means that the SV's
7047 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7048 and C<sv_mortalcopy>.
7054 Perl_sv_2mortal(pTHX_ register SV *sv)
7059 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7062 PL_tmps_stack[++PL_tmps_ix] = sv;
7070 Creates a new SV and copies a string into it. The reference count for the
7071 SV is set to 1. If C<len> is zero, Perl will compute the length using
7072 strlen(). For efficiency, consider using C<newSVpvn> instead.
7078 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
7083 sv_setpvn(sv,s,len ? len : strlen(s));
7088 =for apidoc newSVpvn
7090 Creates a new SV and copies a string into it. The reference count for the
7091 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7092 string. You are responsible for ensuring that the source string is at least
7093 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7099 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7104 sv_setpvn(sv,s,len);
7110 =for apidoc newSVhek
7112 Creates a new SV from the hash key structure. It will generate scalars that
7113 point to the shared string table where possible. Returns a new (undefined)
7114 SV if the hek is NULL.
7120 Perl_newSVhek(pTHX_ const HEK *hek)
7129 if (HEK_LEN(hek) == HEf_SVKEY) {
7130 return newSVsv(*(SV**)HEK_KEY(hek));
7132 const int flags = HEK_FLAGS(hek);
7133 if (flags & HVhek_WASUTF8) {
7135 Andreas would like keys he put in as utf8 to come back as utf8
7137 STRLEN utf8_len = HEK_LEN(hek);
7138 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7139 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
7142 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7144 } else if (flags & HVhek_REHASH) {
7145 /* We don't have a pointer to the hv, so we have to replicate the
7146 flag into every HEK. This hv is using custom a hasing
7147 algorithm. Hence we can't return a shared string scalar, as
7148 that would contain the (wrong) hash value, and might get passed
7149 into an hv routine with a regular hash */
7151 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7156 /* This will be overwhelminly the most common case. */
7157 return newSVpvn_share(HEK_KEY(hek),
7158 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
7164 =for apidoc newSVpvn_share
7166 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7167 table. If the string does not already exist in the table, it is created
7168 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
7169 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
7170 otherwise the hash is computed. The idea here is that as the string table
7171 is used for shared hash keys these strings will have SvPVX_const == HeKEY and
7172 hash lookup will avoid string compare.
7178 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7181 bool is_utf8 = FALSE;
7183 STRLEN tmplen = -len;
7185 /* See the note in hv.c:hv_fetch() --jhi */
7186 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7190 PERL_HASH(hash, src, len);
7192 sv_upgrade(sv, SVt_PV);
7193 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7205 #if defined(PERL_IMPLICIT_CONTEXT)
7207 /* pTHX_ magic can't cope with varargs, so this is a no-context
7208 * version of the main function, (which may itself be aliased to us).
7209 * Don't access this version directly.
7213 Perl_newSVpvf_nocontext(const char* pat, ...)
7218 va_start(args, pat);
7219 sv = vnewSVpvf(pat, &args);
7226 =for apidoc newSVpvf
7228 Creates a new SV and initializes it with the string formatted like
7235 Perl_newSVpvf(pTHX_ const char* pat, ...)
7239 va_start(args, pat);
7240 sv = vnewSVpvf(pat, &args);
7245 /* backend for newSVpvf() and newSVpvf_nocontext() */
7248 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7252 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7259 Creates a new SV and copies a floating point value into it.
7260 The reference count for the SV is set to 1.
7266 Perl_newSVnv(pTHX_ NV n)
7278 Creates a new SV and copies an integer into it. The reference count for the
7285 Perl_newSViv(pTHX_ IV i)
7297 Creates a new SV and copies an unsigned integer into it.
7298 The reference count for the SV is set to 1.
7304 Perl_newSVuv(pTHX_ UV u)
7314 =for apidoc newRV_noinc
7316 Creates an RV wrapper for an SV. The reference count for the original
7317 SV is B<not> incremented.
7323 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7328 sv_upgrade(sv, SVt_RV);
7330 SvRV_set(sv, tmpRef);
7335 /* newRV_inc is the official function name to use now.
7336 * newRV_inc is in fact #defined to newRV in sv.h
7340 Perl_newRV(pTHX_ SV *tmpRef)
7342 return newRV_noinc(SvREFCNT_inc(tmpRef));
7348 Creates a new SV which is an exact duplicate of the original SV.
7355 Perl_newSVsv(pTHX_ register SV *old)
7361 if (SvTYPE(old) == SVTYPEMASK) {
7362 if (ckWARN_d(WARN_INTERNAL))
7363 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7367 /* SV_GMAGIC is the default for sv_setv()
7368 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7369 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7370 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7375 =for apidoc sv_reset
7377 Underlying implementation for the C<reset> Perl function.
7378 Note that the perl-level function is vaguely deprecated.
7384 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
7387 char todo[PERL_UCHAR_MAX+1];
7392 if (!*s) { /* reset ?? searches */
7393 MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
7395 PMOP *pm = (PMOP *) mg->mg_obj;
7397 pm->op_pmdynflags &= ~PMdf_USED;
7404 /* reset variables */
7406 if (!HvARRAY(stash))
7409 Zero(todo, 256, char);
7412 I32 i = (unsigned char)*s;
7416 max = (unsigned char)*s++;
7417 for ( ; i <= max; i++) {
7420 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7422 for (entry = HvARRAY(stash)[i];
7424 entry = HeNEXT(entry))
7429 if (!todo[(U8)*HeKEY(entry)])
7431 gv = (GV*)HeVAL(entry);
7434 if (SvTHINKFIRST(sv)) {
7435 if (!SvREADONLY(sv) && SvROK(sv))
7437 /* XXX Is this continue a bug? Why should THINKFIRST
7438 exempt us from resetting arrays and hashes? */
7442 if (SvTYPE(sv) >= SVt_PV) {
7444 if (SvPVX_const(sv) != Nullch)
7452 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
7454 Perl_die(aTHX_ "Can't reset %%ENV on this system");
7457 # if defined(USE_ENVIRON_ARRAY)
7460 # endif /* USE_ENVIRON_ARRAY */
7471 Using various gambits, try to get an IO from an SV: the IO slot if its a
7472 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7473 named after the PV if we're a string.
7479 Perl_sv_2io(pTHX_ SV *sv)
7484 switch (SvTYPE(sv)) {
7492 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7496 Perl_croak(aTHX_ PL_no_usym, "filehandle");
7498 return sv_2io(SvRV(sv));
7499 gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
7505 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
7514 Using various gambits, try to get a CV from an SV; in addition, try if
7515 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7521 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7528 return *gvp = Nullgv, Nullcv;
7529 switch (SvTYPE(sv)) {
7547 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
7548 tryAMAGICunDEREF(to_cv);
7551 if (SvTYPE(sv) == SVt_PVCV) {
7560 Perl_croak(aTHX_ "Not a subroutine reference");
7565 gv = gv_fetchsv(sv, lref, SVt_PVCV);
7571 if (lref && !GvCVu(gv)) {
7574 tmpsv = NEWSV(704,0);
7575 gv_efullname3(tmpsv, gv, Nullch);
7576 /* XXX this is probably not what they think they're getting.
7577 * It has the same effect as "sub name;", i.e. just a forward
7579 newSUB(start_subparse(FALSE, 0),
7580 newSVOP(OP_CONST, 0, tmpsv),
7585 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
7595 Returns true if the SV has a true value by Perl's rules.
7596 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
7597 instead use an in-line version.
7603 Perl_sv_true(pTHX_ register SV *sv)
7608 register const XPV* const tXpv = (XPV*)SvANY(sv);
7610 (tXpv->xpv_cur > 1 ||
7611 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
7618 return SvIVX(sv) != 0;
7621 return SvNVX(sv) != 0.0;
7623 return sv_2bool(sv);
7629 =for apidoc sv_pvn_force
7631 Get a sensible string out of the SV somehow.
7632 A private implementation of the C<SvPV_force> macro for compilers which
7633 can't cope with complex macro expressions. Always use the macro instead.
7635 =for apidoc sv_pvn_force_flags
7637 Get a sensible string out of the SV somehow.
7638 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
7639 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
7640 implemented in terms of this function.
7641 You normally want to use the various wrapper macros instead: see
7642 C<SvPV_force> and C<SvPV_force_nomg>
7648 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
7651 if (SvTHINKFIRST(sv) && !SvROK(sv))
7652 sv_force_normal_flags(sv, 0);
7662 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
7663 const char * const ref = sv_reftype(sv,0);
7665 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
7666 ref, OP_NAME(PL_op));
7668 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
7670 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
7671 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
7673 s = sv_2pv_flags(sv, &len, flags);
7677 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
7680 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
7681 SvGROW(sv, len + 1);
7682 Move(s,SvPVX(sv),len,char);
7687 SvPOK_on(sv); /* validate pointer */
7689 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
7690 PTR2UV(sv),SvPVX_const(sv)));
7693 return SvPVX_mutable(sv);
7697 =for apidoc sv_pvbyten_force
7699 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
7705 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
7707 sv_pvn_force(sv,lp);
7708 sv_utf8_downgrade(sv,0);
7714 =for apidoc sv_pvutf8n_force
7716 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
7722 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
7724 sv_pvn_force(sv,lp);
7725 sv_utf8_upgrade(sv);
7731 =for apidoc sv_reftype
7733 Returns a string describing what the SV is a reference to.
7739 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
7741 /* The fact that I don't need to downcast to char * everywhere, only in ?:
7742 inside return suggests a const propagation bug in g++. */
7743 if (ob && SvOBJECT(sv)) {
7744 char * const name = HvNAME_get(SvSTASH(sv));
7745 return name ? name : (char *) "__ANON__";
7748 switch (SvTYPE(sv)) {
7765 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
7766 /* tied lvalues should appear to be
7767 * scalars for backwards compatitbility */
7768 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
7769 ? "SCALAR" : "LVALUE");
7770 case SVt_PVAV: return "ARRAY";
7771 case SVt_PVHV: return "HASH";
7772 case SVt_PVCV: return "CODE";
7773 case SVt_PVGV: return "GLOB";
7774 case SVt_PVFM: return "FORMAT";
7775 case SVt_PVIO: return "IO";
7776 default: return "UNKNOWN";
7782 =for apidoc sv_isobject
7784 Returns a boolean indicating whether the SV is an RV pointing to a blessed
7785 object. If the SV is not an RV, or if the object is not blessed, then this
7792 Perl_sv_isobject(pTHX_ SV *sv)
7808 Returns a boolean indicating whether the SV is blessed into the specified
7809 class. This does not check for subtypes; use C<sv_derived_from> to verify
7810 an inheritance relationship.
7816 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7827 hvname = HvNAME_get(SvSTASH(sv));
7831 return strEQ(hvname, name);
7837 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
7838 it will be upgraded to one. If C<classname> is non-null then the new SV will
7839 be blessed in the specified package. The new SV is returned and its
7840 reference count is 1.
7846 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7852 SV_CHECK_THINKFIRST_COW_DROP(rv);
7855 if (SvTYPE(rv) >= SVt_PVMG) {
7856 const U32 refcnt = SvREFCNT(rv);
7860 SvREFCNT(rv) = refcnt;
7863 if (SvTYPE(rv) < SVt_RV)
7864 sv_upgrade(rv, SVt_RV);
7865 else if (SvTYPE(rv) > SVt_RV) {
7876 HV* const stash = gv_stashpv(classname, TRUE);
7877 (void)sv_bless(rv, stash);
7883 =for apidoc sv_setref_pv
7885 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7886 argument will be upgraded to an RV. That RV will be modified to point to
7887 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7888 into the SV. The C<classname> argument indicates the package for the
7889 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7890 will have a reference count of 1, and the RV will be returned.
7892 Do not use with other Perl types such as HV, AV, SV, CV, because those
7893 objects will become corrupted by the pointer copy process.
7895 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7901 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7904 sv_setsv(rv, &PL_sv_undef);
7908 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7913 =for apidoc sv_setref_iv
7915 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7916 argument will be upgraded to an RV. That RV will be modified to point to
7917 the new SV. The C<classname> argument indicates the package for the
7918 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7919 will have a reference count of 1, and the RV will be returned.
7925 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7927 sv_setiv(newSVrv(rv,classname), iv);
7932 =for apidoc sv_setref_uv
7934 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7935 argument will be upgraded to an RV. That RV will be modified to point to
7936 the new SV. The C<classname> argument indicates the package for the
7937 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7938 will have a reference count of 1, and the RV will be returned.
7944 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7946 sv_setuv(newSVrv(rv,classname), uv);
7951 =for apidoc sv_setref_nv
7953 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7954 argument will be upgraded to an RV. That RV will be modified to point to
7955 the new SV. The C<classname> argument indicates the package for the
7956 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7957 will have a reference count of 1, and the RV will be returned.
7963 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7965 sv_setnv(newSVrv(rv,classname), nv);
7970 =for apidoc sv_setref_pvn
7972 Copies a string into a new SV, optionally blessing the SV. The length of the
7973 string must be specified with C<n>. The C<rv> argument will be upgraded to
7974 an RV. That RV will be modified to point to the new SV. The C<classname>
7975 argument indicates the package for the blessing. Set C<classname> to
7976 C<Nullch> to avoid the blessing. The new SV will have a reference count
7977 of 1, and the RV will be returned.
7979 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7985 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n)
7987 sv_setpvn(newSVrv(rv,classname), pv, n);
7992 =for apidoc sv_bless
7994 Blesses an SV into a specified package. The SV must be an RV. The package
7995 must be designated by its stash (see C<gv_stashpv()>). The reference count
7996 of the SV is unaffected.
8002 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8006 Perl_croak(aTHX_ "Can't bless non-reference value");
8008 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8009 if (SvREADONLY(tmpRef))
8010 Perl_croak(aTHX_ PL_no_modify);
8011 if (SvOBJECT(tmpRef)) {
8012 if (SvTYPE(tmpRef) != SVt_PVIO)
8014 SvREFCNT_dec(SvSTASH(tmpRef));
8017 SvOBJECT_on(tmpRef);
8018 if (SvTYPE(tmpRef) != SVt_PVIO)
8020 SvUPGRADE(tmpRef, SVt_PVMG);
8021 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
8028 if(SvSMAGICAL(tmpRef))
8029 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8037 /* Downgrades a PVGV to a PVMG.
8041 S_sv_unglob(pTHX_ SV *sv)
8045 assert(SvTYPE(sv) == SVt_PVGV);
8050 sv_del_backref((SV*)GvSTASH(sv), sv);
8051 GvSTASH(sv) = Nullhv;
8053 sv_unmagic(sv, PERL_MAGIC_glob);
8054 Safefree(GvNAME(sv));
8057 /* need to keep SvANY(sv) in the right arena */
8058 xpvmg = new_XPVMG();
8059 StructCopy(SvANY(sv), xpvmg, XPVMG);
8060 del_XPVGV(SvANY(sv));
8063 SvFLAGS(sv) &= ~SVTYPEMASK;
8064 SvFLAGS(sv) |= SVt_PVMG;
8068 =for apidoc sv_unref_flags
8070 Unsets the RV status of the SV, and decrements the reference count of
8071 whatever was being referenced by the RV. This can almost be thought of
8072 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8073 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8074 (otherwise the decrementing is conditional on the reference count being
8075 different from one or the reference being a readonly SV).
8082 Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags)
8084 SV* const target = SvRV(ref);
8086 if (SvWEAKREF(ref)) {
8087 sv_del_backref(target, ref);
8089 SvRV_set(ref, NULL);
8092 SvRV_set(ref, NULL);
8094 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
8095 assigned to as BEGIN {$a = \"Foo"} will fail. */
8096 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
8097 SvREFCNT_dec(target);
8098 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8099 sv_2mortal(target); /* Schedule for freeing later */
8103 =for apidoc sv_untaint
8105 Untaint an SV. Use C<SvTAINTED_off> instead.
8110 Perl_sv_untaint(pTHX_ SV *sv)
8112 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8113 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8120 =for apidoc sv_tainted
8122 Test an SV for taintedness. Use C<SvTAINTED> instead.
8127 Perl_sv_tainted(pTHX_ SV *sv)
8129 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8130 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8131 if (mg && (mg->mg_len & 1) )
8138 =for apidoc sv_setpviv
8140 Copies an integer into the given SV, also updating its string value.
8141 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8147 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8149 char buf[TYPE_CHARS(UV)];
8151 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8153 sv_setpvn(sv, ptr, ebuf - ptr);
8157 =for apidoc sv_setpviv_mg
8159 Like C<sv_setpviv>, but also handles 'set' magic.
8165 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8171 #if defined(PERL_IMPLICIT_CONTEXT)
8173 /* pTHX_ magic can't cope with varargs, so this is a no-context
8174 * version of the main function, (which may itself be aliased to us).
8175 * Don't access this version directly.
8179 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8183 va_start(args, pat);
8184 sv_vsetpvf(sv, pat, &args);
8188 /* pTHX_ magic can't cope with varargs, so this is a no-context
8189 * version of the main function, (which may itself be aliased to us).
8190 * Don't access this version directly.
8194 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8198 va_start(args, pat);
8199 sv_vsetpvf_mg(sv, pat, &args);
8205 =for apidoc sv_setpvf
8207 Works like C<sv_catpvf> but copies the text into the SV instead of
8208 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8214 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8217 va_start(args, pat);
8218 sv_vsetpvf(sv, pat, &args);
8223 =for apidoc sv_vsetpvf
8225 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8226 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8228 Usually used via its frontend C<sv_setpvf>.
8234 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8236 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8240 =for apidoc sv_setpvf_mg
8242 Like C<sv_setpvf>, but also handles 'set' magic.
8248 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8251 va_start(args, pat);
8252 sv_vsetpvf_mg(sv, pat, &args);
8257 =for apidoc sv_vsetpvf_mg
8259 Like C<sv_vsetpvf>, but also handles 'set' magic.
8261 Usually used via its frontend C<sv_setpvf_mg>.
8267 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8269 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8273 #if defined(PERL_IMPLICIT_CONTEXT)
8275 /* pTHX_ magic can't cope with varargs, so this is a no-context
8276 * version of the main function, (which may itself be aliased to us).
8277 * Don't access this version directly.
8281 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8285 va_start(args, pat);
8286 sv_vcatpvf(sv, pat, &args);
8290 /* pTHX_ magic can't cope with varargs, so this is a no-context
8291 * version of the main function, (which may itself be aliased to us).
8292 * Don't access this version directly.
8296 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8300 va_start(args, pat);
8301 sv_vcatpvf_mg(sv, pat, &args);
8307 =for apidoc sv_catpvf
8309 Processes its arguments like C<sprintf> and appends the formatted
8310 output to an SV. If the appended data contains "wide" characters
8311 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8312 and characters >255 formatted with %c), the original SV might get
8313 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
8314 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
8315 valid UTF-8; if the original SV was bytes, the pattern should be too.
8320 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8323 va_start(args, pat);
8324 sv_vcatpvf(sv, pat, &args);
8329 =for apidoc sv_vcatpvf
8331 Processes its arguments like C<vsprintf> and appends the formatted output
8332 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
8334 Usually used via its frontend C<sv_catpvf>.
8340 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8342 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8346 =for apidoc sv_catpvf_mg
8348 Like C<sv_catpvf>, but also handles 'set' magic.
8354 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8357 va_start(args, pat);
8358 sv_vcatpvf_mg(sv, pat, &args);
8363 =for apidoc sv_vcatpvf_mg
8365 Like C<sv_vcatpvf>, but also handles 'set' magic.
8367 Usually used via its frontend C<sv_catpvf_mg>.
8373 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8375 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8380 =for apidoc sv_vsetpvfn
8382 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
8385 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
8391 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8393 sv_setpvn(sv, "", 0);
8394 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8397 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
8400 S_expect_number(pTHX_ char** pattern)
8403 switch (**pattern) {
8404 case '1': case '2': case '3':
8405 case '4': case '5': case '6':
8406 case '7': case '8': case '9':
8407 while (isDIGIT(**pattern))
8408 var = var * 10 + (*(*pattern)++ - '0');
8412 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
8415 F0convert(NV nv, char *endbuf, STRLEN *len)
8417 const int neg = nv < 0;
8426 if (uv & 1 && uv == nv)
8427 uv--; /* Round to even */
8429 const unsigned dig = uv % 10;
8442 =for apidoc sv_vcatpvfn
8444 Processes its arguments like C<vsprintf> and appends the formatted output
8445 to an SV. Uses an array of SVs if the C style variable argument list is
8446 missing (NULL). When running with taint checks enabled, indicates via
8447 C<maybe_tainted> if results are untrustworthy (often due to the use of
8450 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
8456 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
8457 vecstr = (U8*)SvPV_const(vecsv,veclen);\
8458 vec_utf8 = DO_UTF8(vecsv);
8460 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
8463 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8470 static const char nullstr[] = "(null)";
8472 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
8473 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
8475 /* Times 4: a decimal digit takes more than 3 binary digits.
8476 * NV_DIG: mantissa takes than many decimal digits.
8477 * Plus 32: Playing safe. */
8478 char ebuf[IV_DIG * 4 + NV_DIG + 32];
8479 /* large enough for "%#.#f" --chip */
8480 /* what about long double NVs? --jhi */
8482 PERL_UNUSED_ARG(maybe_tainted);
8484 /* no matter what, this is a string now */
8485 (void)SvPV_force(sv, origlen);
8487 /* special-case "", "%s", and "%-p" (SVf - see below) */
8490 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
8492 const char * const s = va_arg(*args, char*);
8493 sv_catpv(sv, s ? s : nullstr);
8495 else if (svix < svmax) {
8496 sv_catsv(sv, *svargs);
8497 if (DO_UTF8(*svargs))
8502 if (args && patlen == 3 && pat[0] == '%' &&
8503 pat[1] == '-' && pat[2] == 'p') {
8504 argsv = va_arg(*args, SV*);
8505 sv_catsv(sv, argsv);
8511 #ifndef USE_LONG_DOUBLE
8512 /* special-case "%.<number>[gf]" */
8513 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
8514 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
8515 unsigned digits = 0;
8519 while (*pp >= '0' && *pp <= '9')
8520 digits = 10 * digits + (*pp++ - '0');
8521 if (pp - pat == (int)patlen - 1) {
8529 /* Add check for digits != 0 because it seems that some
8530 gconverts are buggy in this case, and we don't yet have
8531 a Configure test for this. */
8532 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
8533 /* 0, point, slack */
8534 Gconvert(nv, (int)digits, 0, ebuf);
8536 if (*ebuf) /* May return an empty string for digits==0 */
8539 } else if (!digits) {
8542 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
8543 sv_catpvn(sv, p, l);
8549 #endif /* !USE_LONG_DOUBLE */
8551 if (!args && svix < svmax && DO_UTF8(*svargs))
8554 patend = (char*)pat + patlen;
8555 for (p = (char*)pat; p < patend; p = q) {
8558 bool vectorize = FALSE;
8559 bool vectorarg = FALSE;
8560 bool vec_utf8 = FALSE;
8566 bool has_precis = FALSE;
8569 bool is_utf8 = FALSE; /* is this item utf8? */
8570 #ifdef HAS_LDBL_SPRINTF_BUG
8571 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8572 with sfio - Allen <allens@cpan.org> */
8573 bool fix_ldbl_sprintf_bug = FALSE;
8577 U8 utf8buf[UTF8_MAXBYTES+1];
8578 STRLEN esignlen = 0;
8580 const char *eptr = Nullch;
8583 const U8 *vecstr = Null(U8*);
8590 /* we need a long double target in case HAS_LONG_DOUBLE but
8593 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
8601 const char *dotstr = ".";
8602 STRLEN dotstrlen = 1;
8603 I32 efix = 0; /* explicit format parameter index */
8604 I32 ewix = 0; /* explicit width index */
8605 I32 epix = 0; /* explicit precision index */
8606 I32 evix = 0; /* explicit vector index */
8607 bool asterisk = FALSE;
8609 /* echo everything up to the next format specification */
8610 for (q = p; q < patend && *q != '%'; ++q) ;
8612 if (has_utf8 && !pat_utf8)
8613 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
8615 sv_catpvn(sv, p, q - p);
8622 We allow format specification elements in this order:
8623 \d+\$ explicit format parameter index
8625 v|\*(\d+\$)?v vector with optional (optionally specified) arg
8626 0 flag (as above): repeated to allow "v02"
8627 \d+|\*(\d+\$)? width using optional (optionally specified) arg
8628 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8630 [%bcdefginopsuxDFOUX] format (mandatory)
8635 As of perl5.9.3, printf format checking is on by default.
8636 Internally, perl uses %p formats to provide an escape to
8637 some extended formatting. This block deals with those
8638 extensions: if it does not match, (char*)q is reset and
8639 the normal format processing code is used.
8641 Currently defined extensions are:
8642 %p include pointer address (standard)
8643 %-p (SVf) include an SV (previously %_)
8644 %-<num>p include an SV with precision <num>
8645 %1p (VDf) include a v-string (as %vd)
8646 %<num>p reserved for future extensions
8648 Robin Barker 2005-07-14
8655 EXPECT_NUMBER(q, n);
8662 argsv = va_arg(*args, SV*);
8663 eptr = SvPVx_const(argsv, elen);
8669 else if (n == vdNUMBER) { /* VDf */
8676 if (ckWARN_d(WARN_INTERNAL))
8677 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
8678 "internal %%<num>p might conflict with future printf extensions");
8684 if (EXPECT_NUMBER(q, width)) {
8725 if (EXPECT_NUMBER(q, ewix))
8734 if ((vectorarg = asterisk)) {
8747 EXPECT_NUMBER(q, width);
8753 vecsv = va_arg(*args, SV*);
8755 vecsv = (evix ? evix <= svmax : svix < svmax) ?
8756 svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
8757 dotstr = SvPV_const(vecsv, dotstrlen);
8764 else if (efix ? efix <= svmax : svix < svmax) {
8765 vecsv = svargs[efix ? efix-1 : svix++];
8766 vecstr = (U8*)SvPV_const(vecsv,veclen);
8767 vec_utf8 = DO_UTF8(vecsv);
8768 /* if this is a version object, we need to return the
8769 * stringified representation (which the SvPVX_const has
8770 * already done for us), but not vectorize the args
8772 if ( *q == 'd' && sv_derived_from(vecsv,"version") )
8774 q++; /* skip past the rest of the %vd format */
8775 eptr = (const char *) vecstr;
8789 i = va_arg(*args, int);
8791 i = (ewix ? ewix <= svmax : svix < svmax) ?
8792 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8794 width = (i < 0) ? -i : i;
8804 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
8806 /* XXX: todo, support specified precision parameter */
8810 i = va_arg(*args, int);
8812 i = (ewix ? ewix <= svmax : svix < svmax)
8813 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8814 precis = (i < 0) ? 0 : i;
8819 precis = precis * 10 + (*q++ - '0');
8828 case 'I': /* Ix, I32x, and I64x */
8830 if (q[1] == '6' && q[2] == '4') {
8836 if (q[1] == '3' && q[2] == '2') {
8846 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8857 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8858 if (*(q + 1) == 'l') { /* lld, llf */
8883 argsv = (efix ? efix <= svmax : svix < svmax) ?
8884 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
8891 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
8893 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
8895 eptr = (char*)utf8buf;
8896 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
8907 if (args && !vectorize) {
8908 eptr = va_arg(*args, char*);
8910 #ifdef MACOS_TRADITIONAL
8911 /* On MacOS, %#s format is used for Pascal strings */
8916 elen = strlen(eptr);
8918 eptr = (char *)nullstr;
8919 elen = sizeof nullstr - 1;
8923 eptr = SvPVx_const(argsv, elen);
8924 if (DO_UTF8(argsv)) {
8925 if (has_precis && precis < elen) {
8927 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
8930 if (width) { /* fudge width (can't fudge elen) */
8931 width += elen - sv_len_utf8(argsv);
8939 if (has_precis && elen > precis)
8946 if (alt || vectorize)
8948 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
8969 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8978 esignbuf[esignlen++] = plus;
8982 case 'h': iv = (short)va_arg(*args, int); break;
8983 case 'l': iv = va_arg(*args, long); break;
8984 case 'V': iv = va_arg(*args, IV); break;
8985 default: iv = va_arg(*args, int); break;
8987 case 'q': iv = va_arg(*args, Quad_t); break;
8992 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
8994 case 'h': iv = (short)tiv; break;
8995 case 'l': iv = (long)tiv; break;
8997 default: iv = tiv; break;
8999 case 'q': iv = (Quad_t)tiv; break;
9003 if ( !vectorize ) /* we already set uv above */
9008 esignbuf[esignlen++] = plus;
9012 esignbuf[esignlen++] = '-';
9055 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9066 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9067 case 'l': uv = va_arg(*args, unsigned long); break;
9068 case 'V': uv = va_arg(*args, UV); break;
9069 default: uv = va_arg(*args, unsigned); break;
9071 case 'q': uv = va_arg(*args, Uquad_t); break;
9076 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9078 case 'h': uv = (unsigned short)tuv; break;
9079 case 'l': uv = (unsigned long)tuv; break;
9081 default: uv = tuv; break;
9083 case 'q': uv = (Uquad_t)tuv; break;
9090 char *ptr = ebuf + sizeof ebuf;
9096 p = (char*)((c == 'X')
9097 ? "0123456789ABCDEF" : "0123456789abcdef");
9103 esignbuf[esignlen++] = '0';
9104 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9112 if (alt && *ptr != '0')
9121 esignbuf[esignlen++] = '0';
9122 esignbuf[esignlen++] = 'b';
9125 default: /* it had better be ten or less */
9129 } while (uv /= base);
9132 elen = (ebuf + sizeof ebuf) - ptr;
9136 zeros = precis - elen;
9137 else if (precis == 0 && elen == 1 && *eptr == '0')
9143 /* FLOATING POINT */
9146 c = 'f'; /* maybe %F isn't supported here */
9152 /* This is evil, but floating point is even more evil */
9154 /* for SV-style calling, we can only get NV
9155 for C-style calling, we assume %f is double;
9156 for simplicity we allow any of %Lf, %llf, %qf for long double
9160 #if defined(USE_LONG_DOUBLE)
9164 /* [perl #20339] - we should accept and ignore %lf rather than die */
9168 #if defined(USE_LONG_DOUBLE)
9169 intsize = args ? 0 : 'q';
9173 #if defined(HAS_LONG_DOUBLE)
9182 /* now we need (long double) if intsize == 'q', else (double) */
9183 nv = (args && !vectorize) ?
9184 #if LONG_DOUBLESIZE > DOUBLESIZE
9186 va_arg(*args, long double) :
9187 va_arg(*args, double)
9189 va_arg(*args, double)
9195 if (c != 'e' && c != 'E') {
9197 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9198 will cast our (long double) to (double) */
9199 (void)Perl_frexp(nv, &i);
9200 if (i == PERL_INT_MIN)
9201 Perl_die(aTHX_ "panic: frexp");
9203 need = BIT_DIGITS(i);
9205 need += has_precis ? precis : 6; /* known default */
9210 #ifdef HAS_LDBL_SPRINTF_BUG
9211 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9212 with sfio - Allen <allens@cpan.org> */
9215 # define MY_DBL_MAX DBL_MAX
9216 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9217 # if DOUBLESIZE >= 8
9218 # define MY_DBL_MAX 1.7976931348623157E+308L
9220 # define MY_DBL_MAX 3.40282347E+38L
9224 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9225 # define MY_DBL_MAX_BUG 1L
9227 # define MY_DBL_MAX_BUG MY_DBL_MAX
9231 # define MY_DBL_MIN DBL_MIN
9232 # else /* XXX guessing! -Allen */
9233 # if DOUBLESIZE >= 8
9234 # define MY_DBL_MIN 2.2250738585072014E-308L
9236 # define MY_DBL_MIN 1.17549435E-38L
9240 if ((intsize == 'q') && (c == 'f') &&
9241 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9243 /* it's going to be short enough that
9244 * long double precision is not needed */
9246 if ((nv <= 0L) && (nv >= -0L))
9247 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9249 /* would use Perl_fp_class as a double-check but not
9250 * functional on IRIX - see perl.h comments */
9252 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9253 /* It's within the range that a double can represent */
9254 #if defined(DBL_MAX) && !defined(DBL_MIN)
9255 if ((nv >= ((long double)1/DBL_MAX)) ||
9256 (nv <= (-(long double)1/DBL_MAX)))
9258 fix_ldbl_sprintf_bug = TRUE;
9261 if (fix_ldbl_sprintf_bug == TRUE) {
9271 # undef MY_DBL_MAX_BUG
9274 #endif /* HAS_LDBL_SPRINTF_BUG */
9276 need += 20; /* fudge factor */
9277 if (PL_efloatsize < need) {
9278 Safefree(PL_efloatbuf);
9279 PL_efloatsize = need + 20; /* more fudge */
9280 Newx(PL_efloatbuf, PL_efloatsize, char);
9281 PL_efloatbuf[0] = '\0';
9284 if ( !(width || left || plus || alt) && fill != '0'
9285 && has_precis && intsize != 'q' ) { /* Shortcuts */
9286 /* See earlier comment about buggy Gconvert when digits,
9288 if ( c == 'g' && precis) {
9289 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9290 /* May return an empty string for digits==0 */
9291 if (*PL_efloatbuf) {
9292 elen = strlen(PL_efloatbuf);
9293 goto float_converted;
9295 } else if ( c == 'f' && !precis) {
9296 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9301 char *ptr = ebuf + sizeof ebuf;
9304 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9305 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9306 if (intsize == 'q') {
9307 /* Copy the one or more characters in a long double
9308 * format before the 'base' ([efgEFG]) character to
9309 * the format string. */
9310 static char const prifldbl[] = PERL_PRIfldbl;
9311 char const *p = prifldbl + sizeof(prifldbl) - 3;
9312 while (p >= prifldbl) { *--ptr = *p--; }
9317 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9322 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9334 /* No taint. Otherwise we are in the strange situation
9335 * where printf() taints but print($float) doesn't.
9337 #if defined(HAS_LONG_DOUBLE)
9338 elen = ((intsize == 'q')
9339 ? my_sprintf(PL_efloatbuf, ptr, nv)
9340 : my_sprintf(PL_efloatbuf, ptr, (double)nv));
9342 elen = my_sprintf(PL_efloatbuf, ptr, nv);
9346 eptr = PL_efloatbuf;
9352 i = SvCUR(sv) - origlen;
9353 if (args && !vectorize) {
9355 case 'h': *(va_arg(*args, short*)) = i; break;
9356 default: *(va_arg(*args, int*)) = i; break;
9357 case 'l': *(va_arg(*args, long*)) = i; break;
9358 case 'V': *(va_arg(*args, IV*)) = i; break;
9360 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
9365 sv_setuv_mg(argsv, (UV)i);
9367 continue; /* not "break" */
9374 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
9375 && ckWARN(WARN_PRINTF))
9377 SV * const msg = sv_newmortal();
9378 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9379 (PL_op->op_type == OP_PRTF) ? "" : "s");
9382 Perl_sv_catpvf(aTHX_ msg,
9383 "\"%%%c\"", c & 0xFF);
9385 Perl_sv_catpvf(aTHX_ msg,
9386 "\"%%\\%03"UVof"\"",
9389 sv_catpv(msg, "end of string");
9390 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
9393 /* output mangled stuff ... */
9399 /* ... right here, because formatting flags should not apply */
9400 SvGROW(sv, SvCUR(sv) + elen + 1);
9402 Copy(eptr, p, elen, char);
9405 SvCUR_set(sv, p - SvPVX_const(sv));
9407 continue; /* not "break" */
9410 /* calculate width before utf8_upgrade changes it */
9411 have = esignlen + zeros + elen;
9413 if (is_utf8 != has_utf8) {
9416 sv_utf8_upgrade(sv);
9419 SV * const nsv = sv_2mortal(newSVpvn(eptr, elen));
9420 sv_utf8_upgrade(nsv);
9421 eptr = SvPVX_const(nsv);
9424 SvGROW(sv, SvCUR(sv) + elen + 1);
9429 need = (have > width ? have : width);
9432 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
9434 if (esignlen && fill == '0') {
9436 for (i = 0; i < (int)esignlen; i++)
9440 memset(p, fill, gap);
9443 if (esignlen && fill != '0') {
9445 for (i = 0; i < (int)esignlen; i++)
9450 for (i = zeros; i; i--)
9454 Copy(eptr, p, elen, char);
9458 memset(p, ' ', gap);
9463 Copy(dotstr, p, dotstrlen, char);
9467 vectorize = FALSE; /* done iterating over vecstr */
9474 SvCUR_set(sv, p - SvPVX_const(sv));
9482 /* =========================================================================
9484 =head1 Cloning an interpreter
9486 All the macros and functions in this section are for the private use of
9487 the main function, perl_clone().
9489 The foo_dup() functions make an exact copy of an existing foo thinngy.
9490 During the course of a cloning, a hash table is used to map old addresses
9491 to new addresses. The table is created and manipulated with the
9492 ptr_table_* functions.
9496 ============================================================================*/
9499 #if defined(USE_ITHREADS)
9501 #ifndef GpREFCNT_inc
9502 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
9506 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
9507 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
9508 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9509 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
9510 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9511 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
9512 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9513 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
9514 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
9515 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
9516 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9517 #define SAVEPV(p) (p ? savepv(p) : Nullch)
9518 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
9521 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
9522 regcomp.c. AMS 20010712 */
9525 Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
9530 struct reg_substr_datum *s;
9533 return (REGEXP *)NULL;
9535 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
9538 len = r->offsets[0];
9539 npar = r->nparens+1;
9541 Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
9542 Copy(r->program, ret->program, len+1, regnode);
9544 Newx(ret->startp, npar, I32);
9545 Copy(r->startp, ret->startp, npar, I32);
9546 Newx(ret->endp, npar, I32);
9547 Copy(r->startp, ret->startp, npar, I32);
9549 Newx(ret->substrs, 1, struct reg_substr_data);
9550 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
9551 s->min_offset = r->substrs->data[i].min_offset;
9552 s->max_offset = r->substrs->data[i].max_offset;
9553 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
9554 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
9557 ret->regstclass = NULL;
9560 const int count = r->data->count;
9563 Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
9564 char, struct reg_data);
9565 Newx(d->what, count, U8);
9568 for (i = 0; i < count; i++) {
9569 d->what[i] = r->data->what[i];
9570 switch (d->what[i]) {
9571 /* legal options are one of: sfpont
9572 see also regcomp.h and pregfree() */
9574 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
9577 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
9580 /* This is cheating. */
9581 Newx(d->data[i], 1, struct regnode_charclass_class);
9582 StructCopy(r->data->data[i], d->data[i],
9583 struct regnode_charclass_class);
9584 ret->regstclass = (regnode*)d->data[i];
9587 /* Compiled op trees are readonly, and can thus be
9588 shared without duplication. */
9590 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
9594 d->data[i] = r->data->data[i];
9597 d->data[i] = r->data->data[i];
9599 ((reg_trie_data*)d->data[i])->refcount++;
9603 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
9612 Newx(ret->offsets, 2*len+1, U32);
9613 Copy(r->offsets, ret->offsets, 2*len+1, U32);
9615 ret->precomp = SAVEPVN(r->precomp, r->prelen);
9616 ret->refcnt = r->refcnt;
9617 ret->minlen = r->minlen;
9618 ret->prelen = r->prelen;
9619 ret->nparens = r->nparens;
9620 ret->lastparen = r->lastparen;
9621 ret->lastcloseparen = r->lastcloseparen;
9622 ret->reganch = r->reganch;
9624 ret->sublen = r->sublen;
9626 if (RX_MATCH_COPIED(ret))
9627 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
9629 ret->subbeg = Nullch;
9630 #ifdef PERL_OLD_COPY_ON_WRITE
9631 ret->saved_copy = Nullsv;
9634 ptr_table_store(PL_ptr_table, r, ret);
9638 /* duplicate a file handle */
9641 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
9645 PERL_UNUSED_ARG(type);
9648 return (PerlIO*)NULL;
9650 /* look for it in the table first */
9651 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
9655 /* create anew and remember what it is */
9656 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
9657 ptr_table_store(PL_ptr_table, fp, ret);
9661 /* duplicate a directory handle */
9664 Perl_dirp_dup(pTHX_ DIR *dp)
9672 /* duplicate a typeglob */
9675 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
9680 /* look for it in the table first */
9681 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
9685 /* create anew and remember what it is */
9687 ptr_table_store(PL_ptr_table, gp, ret);
9690 ret->gp_refcnt = 0; /* must be before any other dups! */
9691 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
9692 ret->gp_io = io_dup_inc(gp->gp_io, param);
9693 ret->gp_form = cv_dup_inc(gp->gp_form, param);
9694 ret->gp_av = av_dup_inc(gp->gp_av, param);
9695 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
9696 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
9697 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
9698 ret->gp_cvgen = gp->gp_cvgen;
9699 ret->gp_line = gp->gp_line;
9700 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
9704 /* duplicate a chain of magic */
9707 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
9709 MAGIC *mgprev = (MAGIC*)NULL;
9712 return (MAGIC*)NULL;
9713 /* look for it in the table first */
9714 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
9718 for (; mg; mg = mg->mg_moremagic) {
9720 Newxz(nmg, 1, MAGIC);
9722 mgprev->mg_moremagic = nmg;
9725 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
9726 nmg->mg_private = mg->mg_private;
9727 nmg->mg_type = mg->mg_type;
9728 nmg->mg_flags = mg->mg_flags;
9729 if (mg->mg_type == PERL_MAGIC_qr) {
9730 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
9732 else if(mg->mg_type == PERL_MAGIC_backref) {
9733 const AV * const av = (AV*) mg->mg_obj;
9736 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
9738 for (i = AvFILLp(av); i >= 0; i--) {
9739 if (!svp[i]) continue;
9740 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
9743 else if (mg->mg_type == PERL_MAGIC_symtab) {
9744 nmg->mg_obj = mg->mg_obj;
9747 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
9748 ? sv_dup_inc(mg->mg_obj, param)
9749 : sv_dup(mg->mg_obj, param);
9751 nmg->mg_len = mg->mg_len;
9752 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
9753 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
9754 if (mg->mg_len > 0) {
9755 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
9756 if (mg->mg_type == PERL_MAGIC_overload_table &&
9757 AMT_AMAGIC((AMT*)mg->mg_ptr))
9759 AMT * const amtp = (AMT*)mg->mg_ptr;
9760 AMT * const namtp = (AMT*)nmg->mg_ptr;
9762 for (i = 1; i < NofAMmeth; i++) {
9763 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
9767 else if (mg->mg_len == HEf_SVKEY)
9768 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
9770 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
9771 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
9778 /* create a new pointer-mapping table */
9781 Perl_ptr_table_new(pTHX)
9784 Newxz(tbl, 1, PTR_TBL_t);
9787 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
9792 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
9794 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
9798 we use the PTE_SVSLOT 'reservation' made above, both here (in the
9799 following define) and at call to new_body_inline made below in
9800 Perl_ptr_table_store()
9803 #define del_pte(p) del_body_type(p, PTE_SVSLOT)
9805 /* map an existing pointer using a table */
9808 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
9810 PTR_TBL_ENT_t *tblent;
9811 const UV hash = PTR_TABLE_HASH(sv);
9813 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
9814 for (; tblent; tblent = tblent->next) {
9815 if (tblent->oldval == sv)
9816 return tblent->newval;
9821 /* add a new entry to a pointer-mapping table */
9824 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
9826 PTR_TBL_ENT_t *tblent, **otblent;
9827 /* XXX this may be pessimal on platforms where pointers aren't good
9828 * hash values e.g. if they grow faster in the most significant
9830 const UV hash = PTR_TABLE_HASH(oldsv);
9834 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
9835 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
9836 if (tblent->oldval == oldsv) {
9837 tblent->newval = newsv;
9841 new_body_inline(tblent, sizeof(struct ptr_tbl_ent), PTE_SVSLOT);
9842 tblent->oldval = oldsv;
9843 tblent->newval = newsv;
9844 tblent->next = *otblent;
9847 if (!empty && tbl->tbl_items > tbl->tbl_max)
9848 ptr_table_split(tbl);
9851 /* double the hash bucket size of an existing ptr table */
9854 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
9856 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
9857 const UV oldsize = tbl->tbl_max + 1;
9858 UV newsize = oldsize * 2;
9861 Renew(ary, newsize, PTR_TBL_ENT_t*);
9862 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
9863 tbl->tbl_max = --newsize;
9865 for (i=0; i < oldsize; i++, ary++) {
9866 PTR_TBL_ENT_t **curentp, **entp, *ent;
9869 curentp = ary + oldsize;
9870 for (entp = ary, ent = *ary; ent; ent = *entp) {
9871 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
9873 ent->next = *curentp;
9883 /* remove all the entries from a ptr table */
9886 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
9888 register PTR_TBL_ENT_t **array;
9889 register PTR_TBL_ENT_t *entry;
9893 if (!tbl || !tbl->tbl_items) {
9897 array = tbl->tbl_ary;
9903 PTR_TBL_ENT_t *oentry = entry;
9904 entry = entry->next;
9908 if (++riter > max) {
9911 entry = array[riter];
9918 /* clear and free a ptr table */
9921 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
9926 ptr_table_clear(tbl);
9927 Safefree(tbl->tbl_ary);
9933 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
9936 SvRV_set(dstr, SvWEAKREF(sstr)
9937 ? sv_dup(SvRV(sstr), param)
9938 : sv_dup_inc(SvRV(sstr), param));
9941 else if (SvPVX_const(sstr)) {
9942 /* Has something there */
9944 /* Normal PV - clone whole allocated space */
9945 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
9946 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9947 /* Not that normal - actually sstr is copy on write.
9948 But we are a true, independant SV, so: */
9949 SvREADONLY_off(dstr);
9954 /* Special case - not normally malloced for some reason */
9955 if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
9956 /* A "shared" PV - clone it as "shared" PV */
9958 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
9962 /* Some other special case - random pointer */
9963 SvPV_set(dstr, SvPVX(sstr));
9969 if (SvTYPE(dstr) == SVt_RV)
9970 SvRV_set(dstr, NULL);
9976 /* duplicate an SV of any type (including AV, HV etc) */
9979 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
9984 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
9986 /* look for it in the table first */
9987 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
9991 if(param->flags & CLONEf_JOIN_IN) {
9992 /** We are joining here so we don't want do clone
9993 something that is bad **/
9996 if(SvTYPE(sstr) == SVt_PVHV &&
9997 (hvname = HvNAME_get(sstr))) {
9998 /** don't clone stashes if they already exist **/
9999 return (SV*)gv_stashpv(hvname,0);
10003 /* create anew and remember what it is */
10006 #ifdef DEBUG_LEAKING_SCALARS
10007 dstr->sv_debug_optype = sstr->sv_debug_optype;
10008 dstr->sv_debug_line = sstr->sv_debug_line;
10009 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10010 dstr->sv_debug_cloned = 1;
10012 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10014 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
10018 ptr_table_store(PL_ptr_table, sstr, dstr);
10021 SvFLAGS(dstr) = SvFLAGS(sstr);
10022 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10023 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10026 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
10027 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10028 PL_watch_pvx, SvPVX_const(sstr));
10031 /* don't clone objects whose class has asked us not to */
10032 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10033 SvFLAGS(dstr) &= ~SVTYPEMASK;
10034 SvOBJECT_off(dstr);
10038 switch (SvTYPE(sstr)) {
10040 SvANY(dstr) = NULL;
10043 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
10044 SvIV_set(dstr, SvIVX(sstr));
10047 SvANY(dstr) = new_XNV();
10048 SvNV_set(dstr, SvNVX(sstr));
10051 SvANY(dstr) = &(dstr->sv_u.svu_rv);
10052 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10056 /* These are all the types that need complex bodies allocating. */
10057 size_t new_body_length;
10059 const svtype sv_type = SvTYPE(sstr);
10060 const struct body_details *const sv_type_details
10061 = bodies_by_type + sv_type;
10066 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]",
10072 new_body = new_NOARENA(sv_type_details);
10073 new_body_length = sv_type_details->copy;
10077 new_body_length = sv_type_details->copy;
10080 new_body_length = sv_type_details->copy;
10083 if (GvUNIQUE((GV*)sstr)) {
10084 /* Do sharing here, and fall through */
10091 new_body_length = sv_type_details->copy;
10095 new_body_length = sv_type_details->copy;
10098 new_body_length = sv_type_details->copy;
10100 assert(new_body_length);
10102 new_body_inline(new_body, new_body_length, SvTYPE(sstr));
10104 new_body = (void*)((char*)new_body + sv_type_details->offset);
10106 /* We always allocated the full length item with PURIFY */
10107 new_body_length += - sv_type_details->offset;
10108 new_body = my_safemalloc(new_body_length);
10112 SvANY(dstr) = new_body;
10115 Copy(((char*)SvANY(sstr)) - sv_type_details->offset,
10116 ((char*)SvANY(dstr)) - sv_type_details->offset,
10117 new_body_length, char);
10119 Copy(((char*)SvANY(sstr)),
10120 ((char*)SvANY(dstr)),
10121 new_body_length, char);
10124 if (SvTYPE(sstr) != SVt_PVAV && SvTYPE(sstr) != SVt_PVHV)
10125 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10127 /* The Copy above means that all the source (unduplicated) pointers
10128 are now in the destination. We can check the flags and the
10129 pointers in either, but it's possible that there's less cache
10130 missing by always going for the destination.
10131 FIXME - instrument and check that assumption */
10132 if (SvTYPE(sstr) >= SVt_PVMG) {
10134 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
10136 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
10139 switch (SvTYPE(sstr)) {
10151 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
10152 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
10153 LvTARG(dstr) = dstr;
10154 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
10155 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
10157 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
10160 GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr));
10161 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
10162 /* Don't call sv_add_backref here as it's going to be created
10163 as part of the magic cloning of the symbol table. */
10164 GvGP(dstr) = gp_dup(GvGP(dstr), param);
10165 (void)GpREFCNT_inc(GvGP(dstr));
10168 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
10169 if (IoOFP(dstr) == IoIFP(sstr))
10170 IoOFP(dstr) = IoIFP(dstr);
10172 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
10173 /* PL_rsfp_filters entries have fake IoDIRP() */
10174 if (IoDIRP(dstr) && !(IoFLAGS(dstr) & IOf_FAKE_DIRP))
10175 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
10176 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
10177 /* I have no idea why fake dirp (rsfps)
10178 should be treated differently but otherwise
10179 we end up with leaks -- sky*/
10180 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
10181 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
10182 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
10184 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
10185 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
10186 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
10188 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
10189 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
10190 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
10193 if (AvARRAY((AV*)sstr)) {
10194 SV **dst_ary, **src_ary;
10195 SSize_t items = AvFILLp((AV*)sstr) + 1;
10197 src_ary = AvARRAY((AV*)sstr);
10198 Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*);
10199 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10200 SvPV_set(dstr, (char*)dst_ary);
10201 AvALLOC((AV*)dstr) = dst_ary;
10202 if (AvREAL((AV*)sstr)) {
10203 while (items-- > 0)
10204 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10207 while (items-- > 0)
10208 *dst_ary++ = sv_dup(*src_ary++, param);
10210 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10211 while (items-- > 0) {
10212 *dst_ary++ = &PL_sv_undef;
10216 SvPV_set(dstr, Nullch);
10217 AvALLOC((AV*)dstr) = (SV**)NULL;
10224 if (HvARRAY((HV*)sstr)) {
10226 const bool sharekeys = !!HvSHAREKEYS(sstr);
10227 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
10228 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
10230 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
10231 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
10233 HvARRAY(dstr) = (HE**)darray;
10234 while (i <= sxhv->xhv_max) {
10235 const HE *source = HvARRAY(sstr)[i];
10236 HvARRAY(dstr)[i] = source
10237 ? he_dup(source, sharekeys, param) : 0;
10241 struct xpvhv_aux *saux = HvAUX(sstr);
10242 struct xpvhv_aux *daux = HvAUX(dstr);
10243 /* This flag isn't copied. */
10244 /* SvOOK_on(hv) attacks the IV flags. */
10245 SvFLAGS(dstr) |= SVf_OOK;
10247 hvname = saux->xhv_name;
10249 = hvname ? hek_dup(hvname, param) : hvname;
10251 daux->xhv_riter = saux->xhv_riter;
10252 daux->xhv_eiter = saux->xhv_eiter
10253 ? he_dup(saux->xhv_eiter,
10254 (bool)!!HvSHAREKEYS(sstr), param) : 0;
10258 SvPV_set(dstr, Nullch);
10260 /* Record stashes for possible cloning in Perl_clone(). */
10262 av_push(param->stashes, dstr);
10267 /* NOTE: not refcounted */
10268 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
10270 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
10272 if (CvCONST(dstr)) {
10273 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
10274 SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
10275 sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
10277 /* don't dup if copying back - CvGV isn't refcounted, so the
10278 * duped GV may never be freed. A bit of a hack! DAPM */
10279 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
10280 Nullgv : gv_dup(CvGV(dstr), param) ;
10281 if (!(param->flags & CLONEf_COPY_STACKS)) {
10284 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10286 CvWEAKOUTSIDE(sstr)
10287 ? cv_dup( CvOUTSIDE(dstr), param)
10288 : cv_dup_inc(CvOUTSIDE(dstr), param);
10290 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
10296 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10302 /* duplicate a context */
10305 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10307 PERL_CONTEXT *ncxs;
10310 return (PERL_CONTEXT*)NULL;
10312 /* look for it in the table first */
10313 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10317 /* create anew and remember what it is */
10318 Newxz(ncxs, max + 1, PERL_CONTEXT);
10319 ptr_table_store(PL_ptr_table, cxs, ncxs);
10322 PERL_CONTEXT *cx = &cxs[ix];
10323 PERL_CONTEXT *ncx = &ncxs[ix];
10324 ncx->cx_type = cx->cx_type;
10325 if (CxTYPE(cx) == CXt_SUBST) {
10326 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10329 ncx->blk_oldsp = cx->blk_oldsp;
10330 ncx->blk_oldcop = cx->blk_oldcop;
10331 ncx->blk_oldmarksp = cx->blk_oldmarksp;
10332 ncx->blk_oldscopesp = cx->blk_oldscopesp;
10333 ncx->blk_oldpm = cx->blk_oldpm;
10334 ncx->blk_gimme = cx->blk_gimme;
10335 switch (CxTYPE(cx)) {
10337 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
10338 ? cv_dup_inc(cx->blk_sub.cv, param)
10339 : cv_dup(cx->blk_sub.cv,param));
10340 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
10341 ? av_dup_inc(cx->blk_sub.argarray, param)
10343 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
10344 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
10345 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10346 ncx->blk_sub.lval = cx->blk_sub.lval;
10347 ncx->blk_sub.retop = cx->blk_sub.retop;
10350 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
10351 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
10352 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
10353 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
10354 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
10355 ncx->blk_eval.retop = cx->blk_eval.retop;
10358 ncx->blk_loop.label = cx->blk_loop.label;
10359 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
10360 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
10361 ncx->blk_loop.next_op = cx->blk_loop.next_op;
10362 ncx->blk_loop.last_op = cx->blk_loop.last_op;
10363 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
10364 ? cx->blk_loop.iterdata
10365 : gv_dup((GV*)cx->blk_loop.iterdata, param));
10366 ncx->blk_loop.oldcomppad
10367 = (PAD*)ptr_table_fetch(PL_ptr_table,
10368 cx->blk_loop.oldcomppad);
10369 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
10370 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
10371 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
10372 ncx->blk_loop.iterix = cx->blk_loop.iterix;
10373 ncx->blk_loop.itermax = cx->blk_loop.itermax;
10376 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
10377 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
10378 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
10379 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10380 ncx->blk_sub.retop = cx->blk_sub.retop;
10392 /* duplicate a stack info structure */
10395 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10400 return (PERL_SI*)NULL;
10402 /* look for it in the table first */
10403 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10407 /* create anew and remember what it is */
10408 Newxz(nsi, 1, PERL_SI);
10409 ptr_table_store(PL_ptr_table, si, nsi);
10411 nsi->si_stack = av_dup_inc(si->si_stack, param);
10412 nsi->si_cxix = si->si_cxix;
10413 nsi->si_cxmax = si->si_cxmax;
10414 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
10415 nsi->si_type = si->si_type;
10416 nsi->si_prev = si_dup(si->si_prev, param);
10417 nsi->si_next = si_dup(si->si_next, param);
10418 nsi->si_markoff = si->si_markoff;
10423 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
10424 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
10425 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
10426 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
10427 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
10428 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
10429 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
10430 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
10431 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
10432 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
10433 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
10434 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
10435 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
10436 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
10439 #define pv_dup_inc(p) SAVEPV(p)
10440 #define pv_dup(p) SAVEPV(p)
10441 #define svp_dup_inc(p,pp) any_dup(p,pp)
10443 /* map any object to the new equivent - either something in the
10444 * ptr table, or something in the interpreter structure
10448 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
10453 return (void*)NULL;
10455 /* look for it in the table first */
10456 ret = ptr_table_fetch(PL_ptr_table, v);
10460 /* see if it is part of the interpreter structure */
10461 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
10462 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
10470 /* duplicate the save stack */
10473 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
10475 ANY * const ss = proto_perl->Tsavestack;
10476 const I32 max = proto_perl->Tsavestack_max;
10477 I32 ix = proto_perl->Tsavestack_ix;
10489 void (*dptr) (void*);
10490 void (*dxptr) (pTHX_ void*);
10492 Newxz(nss, max, ANY);
10495 I32 i = POPINT(ss,ix);
10496 TOPINT(nss,ix) = i;
10498 case SAVEt_ITEM: /* normal string */
10499 sv = (SV*)POPPTR(ss,ix);
10500 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10501 sv = (SV*)POPPTR(ss,ix);
10502 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10504 case SAVEt_SV: /* scalar reference */
10505 sv = (SV*)POPPTR(ss,ix);
10506 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10507 gv = (GV*)POPPTR(ss,ix);
10508 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10510 case SAVEt_GENERIC_PVREF: /* generic char* */
10511 c = (char*)POPPTR(ss,ix);
10512 TOPPTR(nss,ix) = pv_dup(c);
10513 ptr = POPPTR(ss,ix);
10514 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10516 case SAVEt_SHARED_PVREF: /* char* in shared space */
10517 c = (char*)POPPTR(ss,ix);
10518 TOPPTR(nss,ix) = savesharedpv(c);
10519 ptr = POPPTR(ss,ix);
10520 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10522 case SAVEt_GENERIC_SVREF: /* generic sv */
10523 case SAVEt_SVREF: /* scalar reference */
10524 sv = (SV*)POPPTR(ss,ix);
10525 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10526 ptr = POPPTR(ss,ix);
10527 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
10529 case SAVEt_AV: /* array reference */
10530 av = (AV*)POPPTR(ss,ix);
10531 TOPPTR(nss,ix) = av_dup_inc(av, param);
10532 gv = (GV*)POPPTR(ss,ix);
10533 TOPPTR(nss,ix) = gv_dup(gv, param);
10535 case SAVEt_HV: /* hash reference */
10536 hv = (HV*)POPPTR(ss,ix);
10537 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10538 gv = (GV*)POPPTR(ss,ix);
10539 TOPPTR(nss,ix) = gv_dup(gv, param);
10541 case SAVEt_INT: /* int reference */
10542 ptr = POPPTR(ss,ix);
10543 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10544 intval = (int)POPINT(ss,ix);
10545 TOPINT(nss,ix) = intval;
10547 case SAVEt_LONG: /* long reference */
10548 ptr = POPPTR(ss,ix);
10549 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10550 longval = (long)POPLONG(ss,ix);
10551 TOPLONG(nss,ix) = longval;
10553 case SAVEt_I32: /* I32 reference */
10554 case SAVEt_I16: /* I16 reference */
10555 case SAVEt_I8: /* I8 reference */
10556 ptr = POPPTR(ss,ix);
10557 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10559 TOPINT(nss,ix) = i;
10561 case SAVEt_IV: /* IV reference */
10562 ptr = POPPTR(ss,ix);
10563 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10565 TOPIV(nss,ix) = iv;
10567 case SAVEt_SPTR: /* SV* reference */
10568 ptr = POPPTR(ss,ix);
10569 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10570 sv = (SV*)POPPTR(ss,ix);
10571 TOPPTR(nss,ix) = sv_dup(sv, param);
10573 case SAVEt_VPTR: /* random* reference */
10574 ptr = POPPTR(ss,ix);
10575 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10576 ptr = POPPTR(ss,ix);
10577 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10579 case SAVEt_PPTR: /* char* reference */
10580 ptr = POPPTR(ss,ix);
10581 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10582 c = (char*)POPPTR(ss,ix);
10583 TOPPTR(nss,ix) = pv_dup(c);
10585 case SAVEt_HPTR: /* HV* reference */
10586 ptr = POPPTR(ss,ix);
10587 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10588 hv = (HV*)POPPTR(ss,ix);
10589 TOPPTR(nss,ix) = hv_dup(hv, param);
10591 case SAVEt_APTR: /* AV* reference */
10592 ptr = POPPTR(ss,ix);
10593 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10594 av = (AV*)POPPTR(ss,ix);
10595 TOPPTR(nss,ix) = av_dup(av, param);
10598 gv = (GV*)POPPTR(ss,ix);
10599 TOPPTR(nss,ix) = gv_dup(gv, param);
10601 case SAVEt_GP: /* scalar reference */
10602 gp = (GP*)POPPTR(ss,ix);
10603 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
10604 (void)GpREFCNT_inc(gp);
10605 gv = (GV*)POPPTR(ss,ix);
10606 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10607 c = (char*)POPPTR(ss,ix);
10608 TOPPTR(nss,ix) = pv_dup(c);
10610 TOPIV(nss,ix) = iv;
10612 TOPIV(nss,ix) = iv;
10615 case SAVEt_MORTALIZESV:
10616 sv = (SV*)POPPTR(ss,ix);
10617 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10620 ptr = POPPTR(ss,ix);
10621 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
10622 /* these are assumed to be refcounted properly */
10624 switch (((OP*)ptr)->op_type) {
10626 case OP_LEAVESUBLV:
10630 case OP_LEAVEWRITE:
10631 TOPPTR(nss,ix) = ptr;
10636 TOPPTR(nss,ix) = Nullop;
10641 TOPPTR(nss,ix) = Nullop;
10644 c = (char*)POPPTR(ss,ix);
10645 TOPPTR(nss,ix) = pv_dup_inc(c);
10647 case SAVEt_CLEARSV:
10648 longval = POPLONG(ss,ix);
10649 TOPLONG(nss,ix) = longval;
10652 hv = (HV*)POPPTR(ss,ix);
10653 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10654 c = (char*)POPPTR(ss,ix);
10655 TOPPTR(nss,ix) = pv_dup_inc(c);
10657 TOPINT(nss,ix) = i;
10659 case SAVEt_DESTRUCTOR:
10660 ptr = POPPTR(ss,ix);
10661 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10662 dptr = POPDPTR(ss,ix);
10663 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
10664 any_dup(FPTR2DPTR(void *, dptr),
10667 case SAVEt_DESTRUCTOR_X:
10668 ptr = POPPTR(ss,ix);
10669 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10670 dxptr = POPDXPTR(ss,ix);
10671 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
10672 any_dup(FPTR2DPTR(void *, dxptr),
10675 case SAVEt_REGCONTEXT:
10678 TOPINT(nss,ix) = i;
10681 case SAVEt_STACK_POS: /* Position on Perl stack */
10683 TOPINT(nss,ix) = i;
10685 case SAVEt_AELEM: /* array element */
10686 sv = (SV*)POPPTR(ss,ix);
10687 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10689 TOPINT(nss,ix) = i;
10690 av = (AV*)POPPTR(ss,ix);
10691 TOPPTR(nss,ix) = av_dup_inc(av, param);
10693 case SAVEt_HELEM: /* hash element */
10694 sv = (SV*)POPPTR(ss,ix);
10695 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10696 sv = (SV*)POPPTR(ss,ix);
10697 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10698 hv = (HV*)POPPTR(ss,ix);
10699 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10702 ptr = POPPTR(ss,ix);
10703 TOPPTR(nss,ix) = ptr;
10707 TOPINT(nss,ix) = i;
10709 case SAVEt_COMPPAD:
10710 av = (AV*)POPPTR(ss,ix);
10711 TOPPTR(nss,ix) = av_dup(av, param);
10714 longval = (long)POPLONG(ss,ix);
10715 TOPLONG(nss,ix) = longval;
10716 ptr = POPPTR(ss,ix);
10717 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10718 sv = (SV*)POPPTR(ss,ix);
10719 TOPPTR(nss,ix) = sv_dup(sv, param);
10722 ptr = POPPTR(ss,ix);
10723 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10724 longval = (long)POPBOOL(ss,ix);
10725 TOPBOOL(nss,ix) = (bool)longval;
10727 case SAVEt_SET_SVFLAGS:
10729 TOPINT(nss,ix) = i;
10731 TOPINT(nss,ix) = i;
10732 sv = (SV*)POPPTR(ss,ix);
10733 TOPPTR(nss,ix) = sv_dup(sv, param);
10736 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
10744 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
10745 * flag to the result. This is done for each stash before cloning starts,
10746 * so we know which stashes want their objects cloned */
10749 do_mark_cloneable_stash(pTHX_ SV *sv)
10751 const HEK * const hvname = HvNAME_HEK((HV*)sv);
10753 GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
10754 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
10755 if (cloner && GvCV(cloner)) {
10762 XPUSHs(sv_2mortal(newSVhek(hvname)));
10764 call_sv((SV*)GvCV(cloner), G_SCALAR);
10771 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
10779 =for apidoc perl_clone
10781 Create and return a new interpreter by cloning the current one.
10783 perl_clone takes these flags as parameters:
10785 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
10786 without it we only clone the data and zero the stacks,
10787 with it we copy the stacks and the new perl interpreter is
10788 ready to run at the exact same point as the previous one.
10789 The pseudo-fork code uses COPY_STACKS while the
10790 threads->new doesn't.
10792 CLONEf_KEEP_PTR_TABLE
10793 perl_clone keeps a ptr_table with the pointer of the old
10794 variable as a key and the new variable as a value,
10795 this allows it to check if something has been cloned and not
10796 clone it again but rather just use the value and increase the
10797 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
10798 the ptr_table using the function
10799 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
10800 reason to keep it around is if you want to dup some of your own
10801 variable who are outside the graph perl scans, example of this
10802 code is in threads.xs create
10805 This is a win32 thing, it is ignored on unix, it tells perls
10806 win32host code (which is c++) to clone itself, this is needed on
10807 win32 if you want to run two threads at the same time,
10808 if you just want to do some stuff in a separate perl interpreter
10809 and then throw it away and return to the original one,
10810 you don't need to do anything.
10815 /* XXX the above needs expanding by someone who actually understands it ! */
10816 EXTERN_C PerlInterpreter *
10817 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
10820 perl_clone(PerlInterpreter *proto_perl, UV flags)
10823 #ifdef PERL_IMPLICIT_SYS
10825 /* perlhost.h so we need to call into it
10826 to clone the host, CPerlHost should have a c interface, sky */
10828 if (flags & CLONEf_CLONE_HOST) {
10829 return perl_clone_host(proto_perl,flags);
10831 return perl_clone_using(proto_perl, flags,
10833 proto_perl->IMemShared,
10834 proto_perl->IMemParse,
10836 proto_perl->IStdIO,
10840 proto_perl->IProc);
10844 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
10845 struct IPerlMem* ipM, struct IPerlMem* ipMS,
10846 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
10847 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
10848 struct IPerlDir* ipD, struct IPerlSock* ipS,
10849 struct IPerlProc* ipP)
10851 /* XXX many of the string copies here can be optimized if they're
10852 * constants; they need to be allocated as common memory and just
10853 * their pointers copied. */
10856 CLONE_PARAMS clone_params;
10857 CLONE_PARAMS* param = &clone_params;
10859 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
10860 /* for each stash, determine whether its objects should be cloned */
10861 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10862 PERL_SET_THX(my_perl);
10865 Poison(my_perl, 1, PerlInterpreter);
10867 PL_curcop = (COP *)Nullop;
10871 PL_savestack_ix = 0;
10872 PL_savestack_max = -1;
10873 PL_sig_pending = 0;
10874 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10875 # else /* !DEBUGGING */
10876 Zero(my_perl, 1, PerlInterpreter);
10877 # endif /* DEBUGGING */
10879 /* host pointers */
10881 PL_MemShared = ipMS;
10882 PL_MemParse = ipMP;
10889 #else /* !PERL_IMPLICIT_SYS */
10891 CLONE_PARAMS clone_params;
10892 CLONE_PARAMS* param = &clone_params;
10893 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
10894 /* for each stash, determine whether its objects should be cloned */
10895 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10896 PERL_SET_THX(my_perl);
10899 Poison(my_perl, 1, PerlInterpreter);
10901 PL_curcop = (COP *)Nullop;
10905 PL_savestack_ix = 0;
10906 PL_savestack_max = -1;
10907 PL_sig_pending = 0;
10908 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10909 # else /* !DEBUGGING */
10910 Zero(my_perl, 1, PerlInterpreter);
10911 # endif /* DEBUGGING */
10912 #endif /* PERL_IMPLICIT_SYS */
10913 param->flags = flags;
10914 param->proto_perl = proto_perl;
10916 Zero(&PL_body_arenaroots, 1, PL_body_arenaroots);
10917 Zero(&PL_body_roots, 1, PL_body_roots);
10919 PL_he_arenaroot = NULL;
10922 PL_nice_chunk = NULL;
10923 PL_nice_chunk_size = 0;
10925 PL_sv_objcount = 0;
10926 PL_sv_root = Nullsv;
10927 PL_sv_arenaroot = Nullsv;
10929 PL_debug = proto_perl->Idebug;
10931 PL_hash_seed = proto_perl->Ihash_seed;
10932 PL_rehash_seed = proto_perl->Irehash_seed;
10934 #ifdef USE_REENTRANT_API
10935 /* XXX: things like -Dm will segfault here in perlio, but doing
10936 * PERL_SET_CONTEXT(proto_perl);
10937 * breaks too many other things
10939 Perl_reentrant_init(aTHX);
10942 /* create SV map for pointer relocation */
10943 PL_ptr_table = ptr_table_new();
10945 /* initialize these special pointers as early as possible */
10946 SvANY(&PL_sv_undef) = NULL;
10947 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
10948 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
10949 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
10951 SvANY(&PL_sv_no) = new_XPVNV();
10952 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
10953 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
10954 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10955 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
10956 SvCUR_set(&PL_sv_no, 0);
10957 SvLEN_set(&PL_sv_no, 1);
10958 SvIV_set(&PL_sv_no, 0);
10959 SvNV_set(&PL_sv_no, 0);
10960 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
10962 SvANY(&PL_sv_yes) = new_XPVNV();
10963 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
10964 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
10965 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10966 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
10967 SvCUR_set(&PL_sv_yes, 1);
10968 SvLEN_set(&PL_sv_yes, 2);
10969 SvIV_set(&PL_sv_yes, 1);
10970 SvNV_set(&PL_sv_yes, 1);
10971 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
10973 /* create (a non-shared!) shared string table */
10974 PL_strtab = newHV();
10975 HvSHAREKEYS_off(PL_strtab);
10976 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
10977 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
10979 PL_compiling = proto_perl->Icompiling;
10981 /* These two PVs will be free'd special way so must set them same way op.c does */
10982 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
10983 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
10985 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
10986 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
10988 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
10989 if (!specialWARN(PL_compiling.cop_warnings))
10990 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
10991 if (!specialCopIO(PL_compiling.cop_io))
10992 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
10993 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
10995 /* pseudo environmental stuff */
10996 PL_origargc = proto_perl->Iorigargc;
10997 PL_origargv = proto_perl->Iorigargv;
10999 param->stashes = newAV(); /* Setup array of objects to call clone on */
11001 /* Set tainting stuff before PerlIO_debug can possibly get called */
11002 PL_tainting = proto_perl->Itainting;
11003 PL_taint_warn = proto_perl->Itaint_warn;
11005 #ifdef PERLIO_LAYERS
11006 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11007 PerlIO_clone(aTHX_ proto_perl, param);
11010 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11011 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11012 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11013 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11014 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11015 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11018 PL_minus_c = proto_perl->Iminus_c;
11019 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11020 PL_localpatches = proto_perl->Ilocalpatches;
11021 PL_splitstr = proto_perl->Isplitstr;
11022 PL_preprocess = proto_perl->Ipreprocess;
11023 PL_minus_n = proto_perl->Iminus_n;
11024 PL_minus_p = proto_perl->Iminus_p;
11025 PL_minus_l = proto_perl->Iminus_l;
11026 PL_minus_a = proto_perl->Iminus_a;
11027 PL_minus_F = proto_perl->Iminus_F;
11028 PL_doswitches = proto_perl->Idoswitches;
11029 PL_dowarn = proto_perl->Idowarn;
11030 PL_doextract = proto_perl->Idoextract;
11031 PL_sawampersand = proto_perl->Isawampersand;
11032 PL_unsafe = proto_perl->Iunsafe;
11033 PL_inplace = SAVEPV(proto_perl->Iinplace);
11034 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11035 PL_perldb = proto_perl->Iperldb;
11036 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11037 PL_exit_flags = proto_perl->Iexit_flags;
11039 /* magical thingies */
11040 /* XXX time(&PL_basetime) when asked for? */
11041 PL_basetime = proto_perl->Ibasetime;
11042 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11044 PL_maxsysfd = proto_perl->Imaxsysfd;
11045 PL_multiline = proto_perl->Imultiline;
11046 PL_statusvalue = proto_perl->Istatusvalue;
11048 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11050 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
11052 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11054 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11055 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11056 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11058 /* Clone the regex array */
11059 PL_regex_padav = newAV();
11061 const I32 len = av_len((AV*)proto_perl->Iregex_padav);
11062 SV** const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11064 av_push(PL_regex_padav,
11065 sv_dup_inc(regexen[0],param));
11066 for(i = 1; i <= len; i++) {
11067 if(SvREPADTMP(regexen[i])) {
11068 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11070 av_push(PL_regex_padav,
11072 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11073 SvIVX(regexen[i])), param)))
11078 PL_regex_pad = AvARRAY(PL_regex_padav);
11080 /* shortcuts to various I/O objects */
11081 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11082 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11083 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11084 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11085 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11086 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11088 /* shortcuts to regexp stuff */
11089 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11091 /* shortcuts to misc objects */
11092 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11094 /* shortcuts to debugging objects */
11095 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11096 PL_DBline = gv_dup(proto_perl->IDBline, param);
11097 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11098 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11099 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11100 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11101 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11102 PL_lineary = av_dup(proto_perl->Ilineary, param);
11103 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11105 /* symbol tables */
11106 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11107 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11108 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11109 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11110 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11112 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11113 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11114 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11115 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11116 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11117 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11119 PL_sub_generation = proto_perl->Isub_generation;
11121 /* funky return mechanisms */
11122 PL_forkprocess = proto_perl->Iforkprocess;
11124 /* subprocess state */
11125 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11127 /* internal state */
11128 PL_maxo = proto_perl->Imaxo;
11129 if (proto_perl->Iop_mask)
11130 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11132 PL_op_mask = Nullch;
11133 /* PL_asserting = proto_perl->Iasserting; */
11135 /* current interpreter roots */
11136 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11137 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11138 PL_main_start = proto_perl->Imain_start;
11139 PL_eval_root = proto_perl->Ieval_root;
11140 PL_eval_start = proto_perl->Ieval_start;
11142 /* runtime control stuff */
11143 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11144 PL_copline = proto_perl->Icopline;
11146 PL_filemode = proto_perl->Ifilemode;
11147 PL_lastfd = proto_perl->Ilastfd;
11148 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11151 PL_gensym = proto_perl->Igensym;
11152 PL_preambled = proto_perl->Ipreambled;
11153 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11154 PL_laststatval = proto_perl->Ilaststatval;
11155 PL_laststype = proto_perl->Ilaststype;
11156 PL_mess_sv = Nullsv;
11158 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11160 /* interpreter atexit processing */
11161 PL_exitlistlen = proto_perl->Iexitlistlen;
11162 if (PL_exitlistlen) {
11163 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11164 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11167 PL_exitlist = (PerlExitListEntry*)NULL;
11168 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11169 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11170 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11172 PL_profiledata = NULL;
11173 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
11174 /* PL_rsfp_filters entries have fake IoDIRP() */
11175 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
11177 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11179 PAD_CLONE_VARS(proto_perl, param);
11181 #ifdef HAVE_INTERP_INTERN
11182 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11185 /* more statics moved here */
11186 PL_generation = proto_perl->Igeneration;
11187 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11189 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11190 PL_in_clean_all = proto_perl->Iin_clean_all;
11192 PL_uid = proto_perl->Iuid;
11193 PL_euid = proto_perl->Ieuid;
11194 PL_gid = proto_perl->Igid;
11195 PL_egid = proto_perl->Iegid;
11196 PL_nomemok = proto_perl->Inomemok;
11197 PL_an = proto_perl->Ian;
11198 PL_evalseq = proto_perl->Ievalseq;
11199 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11200 PL_origalen = proto_perl->Iorigalen;
11201 #ifdef PERL_USES_PL_PIDSTATUS
11202 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11204 PL_osname = SAVEPV(proto_perl->Iosname);
11205 PL_sighandlerp = proto_perl->Isighandlerp;
11207 PL_runops = proto_perl->Irunops;
11209 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11212 PL_cshlen = proto_perl->Icshlen;
11213 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
11216 PL_lex_state = proto_perl->Ilex_state;
11217 PL_lex_defer = proto_perl->Ilex_defer;
11218 PL_lex_expect = proto_perl->Ilex_expect;
11219 PL_lex_formbrack = proto_perl->Ilex_formbrack;
11220 PL_lex_dojoin = proto_perl->Ilex_dojoin;
11221 PL_lex_starts = proto_perl->Ilex_starts;
11222 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
11223 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
11224 PL_lex_op = proto_perl->Ilex_op;
11225 PL_lex_inpat = proto_perl->Ilex_inpat;
11226 PL_lex_inwhat = proto_perl->Ilex_inwhat;
11227 PL_lex_brackets = proto_perl->Ilex_brackets;
11228 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11229 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
11230 PL_lex_casemods = proto_perl->Ilex_casemods;
11231 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11232 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
11234 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11235 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
11236 PL_nexttoke = proto_perl->Inexttoke;
11238 /* XXX This is probably masking the deeper issue of why
11239 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11240 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11241 * (A little debugging with a watchpoint on it may help.)
11243 if (SvANY(proto_perl->Ilinestr)) {
11244 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
11245 i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
11246 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11247 i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
11248 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11249 i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
11250 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11251 i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
11252 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11255 PL_linestr = NEWSV(65,79);
11256 sv_upgrade(PL_linestr,SVt_PVIV);
11257 sv_setpvn(PL_linestr,"",0);
11258 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
11260 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11261 PL_pending_ident = proto_perl->Ipending_ident;
11262 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
11264 PL_expect = proto_perl->Iexpect;
11266 PL_multi_start = proto_perl->Imulti_start;
11267 PL_multi_end = proto_perl->Imulti_end;
11268 PL_multi_open = proto_perl->Imulti_open;
11269 PL_multi_close = proto_perl->Imulti_close;
11271 PL_error_count = proto_perl->Ierror_count;
11272 PL_subline = proto_perl->Isubline;
11273 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
11275 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
11276 if (SvANY(proto_perl->Ilinestr)) {
11277 i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
11278 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11279 i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
11280 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11281 PL_last_lop_op = proto_perl->Ilast_lop_op;
11284 PL_last_uni = SvPVX(PL_linestr);
11285 PL_last_lop = SvPVX(PL_linestr);
11286 PL_last_lop_op = 0;
11288 PL_in_my = proto_perl->Iin_my;
11289 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
11291 PL_cryptseen = proto_perl->Icryptseen;
11294 PL_hints = proto_perl->Ihints;
11296 PL_amagic_generation = proto_perl->Iamagic_generation;
11298 #ifdef USE_LOCALE_COLLATE
11299 PL_collation_ix = proto_perl->Icollation_ix;
11300 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
11301 PL_collation_standard = proto_perl->Icollation_standard;
11302 PL_collxfrm_base = proto_perl->Icollxfrm_base;
11303 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
11304 #endif /* USE_LOCALE_COLLATE */
11306 #ifdef USE_LOCALE_NUMERIC
11307 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
11308 PL_numeric_standard = proto_perl->Inumeric_standard;
11309 PL_numeric_local = proto_perl->Inumeric_local;
11310 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11311 #endif /* !USE_LOCALE_NUMERIC */
11313 /* utf8 character classes */
11314 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11315 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11316 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11317 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11318 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
11319 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11320 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
11321 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
11322 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
11323 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
11324 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
11325 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
11326 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11327 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
11328 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11329 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11330 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11331 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11332 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11333 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11335 /* Did the locale setup indicate UTF-8? */
11336 PL_utf8locale = proto_perl->Iutf8locale;
11337 /* Unicode features (see perlrun/-C) */
11338 PL_unicode = proto_perl->Iunicode;
11340 /* Pre-5.8 signals control */
11341 PL_signals = proto_perl->Isignals;
11343 /* times() ticks per second */
11344 PL_clocktick = proto_perl->Iclocktick;
11346 /* Recursion stopper for PerlIO_find_layer */
11347 PL_in_load_module = proto_perl->Iin_load_module;
11349 /* sort() routine */
11350 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
11352 /* Not really needed/useful since the reenrant_retint is "volatile",
11353 * but do it for consistency's sake. */
11354 PL_reentrant_retint = proto_perl->Ireentrant_retint;
11356 /* Hooks to shared SVs and locks. */
11357 PL_sharehook = proto_perl->Isharehook;
11358 PL_lockhook = proto_perl->Ilockhook;
11359 PL_unlockhook = proto_perl->Iunlockhook;
11360 PL_threadhook = proto_perl->Ithreadhook;
11362 PL_runops_std = proto_perl->Irunops_std;
11363 PL_runops_dbg = proto_perl->Irunops_dbg;
11365 #ifdef THREADS_HAVE_PIDS
11366 PL_ppid = proto_perl->Ippid;
11370 PL_last_swash_hv = Nullhv; /* reinits on demand */
11371 PL_last_swash_klen = 0;
11372 PL_last_swash_key[0]= '\0';
11373 PL_last_swash_tmps = (U8*)NULL;
11374 PL_last_swash_slen = 0;
11376 PL_glob_index = proto_perl->Iglob_index;
11377 PL_srand_called = proto_perl->Isrand_called;
11378 PL_uudmap['M'] = 0; /* reinits on demand */
11379 PL_bitcount = Nullch; /* reinits on demand */
11381 if (proto_perl->Ipsig_pend) {
11382 Newxz(PL_psig_pend, SIG_SIZE, int);
11385 PL_psig_pend = (int*)NULL;
11388 if (proto_perl->Ipsig_ptr) {
11389 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
11390 Newxz(PL_psig_name, SIG_SIZE, SV*);
11391 for (i = 1; i < SIG_SIZE; i++) {
11392 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11393 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11397 PL_psig_ptr = (SV**)NULL;
11398 PL_psig_name = (SV**)NULL;
11401 /* thrdvar.h stuff */
11403 if (flags & CLONEf_COPY_STACKS) {
11404 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11405 PL_tmps_ix = proto_perl->Ttmps_ix;
11406 PL_tmps_max = proto_perl->Ttmps_max;
11407 PL_tmps_floor = proto_perl->Ttmps_floor;
11408 Newxz(PL_tmps_stack, PL_tmps_max, SV*);
11410 while (i <= PL_tmps_ix) {
11411 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
11415 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11416 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
11417 Newxz(PL_markstack, i, I32);
11418 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
11419 - proto_perl->Tmarkstack);
11420 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
11421 - proto_perl->Tmarkstack);
11422 Copy(proto_perl->Tmarkstack, PL_markstack,
11423 PL_markstack_ptr - PL_markstack + 1, I32);
11425 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
11426 * NOTE: unlike the others! */
11427 PL_scopestack_ix = proto_perl->Tscopestack_ix;
11428 PL_scopestack_max = proto_perl->Tscopestack_max;
11429 Newxz(PL_scopestack, PL_scopestack_max, I32);
11430 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
11432 /* NOTE: si_dup() looks at PL_markstack */
11433 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
11435 /* PL_curstack = PL_curstackinfo->si_stack; */
11436 PL_curstack = av_dup(proto_perl->Tcurstack, param);
11437 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
11439 /* next PUSHs() etc. set *(PL_stack_sp+1) */
11440 PL_stack_base = AvARRAY(PL_curstack);
11441 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
11442 - proto_perl->Tstack_base);
11443 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
11445 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
11446 * NOTE: unlike the others! */
11447 PL_savestack_ix = proto_perl->Tsavestack_ix;
11448 PL_savestack_max = proto_perl->Tsavestack_max;
11449 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
11450 PL_savestack = ss_dup(proto_perl, param);
11454 ENTER; /* perl_destruct() wants to LEAVE; */
11457 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
11458 PL_top_env = &PL_start_env;
11460 PL_op = proto_perl->Top;
11463 PL_Xpv = (XPV*)NULL;
11464 PL_na = proto_perl->Tna;
11466 PL_statbuf = proto_perl->Tstatbuf;
11467 PL_statcache = proto_perl->Tstatcache;
11468 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
11469 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
11471 PL_timesbuf = proto_perl->Ttimesbuf;
11474 PL_tainted = proto_perl->Ttainted;
11475 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
11476 PL_rs = sv_dup_inc(proto_perl->Trs, param);
11477 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
11478 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
11479 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
11480 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
11481 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
11482 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
11483 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
11485 PL_restartop = proto_perl->Trestartop;
11486 PL_in_eval = proto_perl->Tin_eval;
11487 PL_delaymagic = proto_perl->Tdelaymagic;
11488 PL_dirty = proto_perl->Tdirty;
11489 PL_localizing = proto_perl->Tlocalizing;
11491 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
11492 PL_hv_fetch_ent_mh = Nullhe;
11493 PL_modcount = proto_perl->Tmodcount;
11494 PL_lastgotoprobe = Nullop;
11495 PL_dumpindent = proto_perl->Tdumpindent;
11497 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
11498 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
11499 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
11500 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
11501 PL_efloatbuf = Nullch; /* reinits on demand */
11502 PL_efloatsize = 0; /* reinits on demand */
11506 PL_screamfirst = NULL;
11507 PL_screamnext = NULL;
11508 PL_maxscream = -1; /* reinits on demand */
11509 PL_lastscream = Nullsv;
11511 PL_watchaddr = NULL;
11512 PL_watchok = Nullch;
11514 PL_regdummy = proto_perl->Tregdummy;
11515 PL_regprecomp = Nullch;
11518 PL_colorset = 0; /* reinits PL_colors[] */
11519 /*PL_colors[6] = {0,0,0,0,0,0};*/
11520 PL_reginput = Nullch;
11521 PL_regbol = Nullch;
11522 PL_regeol = Nullch;
11523 PL_regstartp = (I32*)NULL;
11524 PL_regendp = (I32*)NULL;
11525 PL_reglastparen = (U32*)NULL;
11526 PL_reglastcloseparen = (U32*)NULL;
11527 PL_regtill = Nullch;
11528 PL_reg_start_tmp = (char**)NULL;
11529 PL_reg_start_tmpl = 0;
11530 PL_regdata = (struct reg_data*)NULL;
11533 PL_reg_eval_set = 0;
11535 PL_regprogram = (regnode*)NULL;
11537 PL_regcc = (CURCUR*)NULL;
11538 PL_reg_call_cc = (struct re_cc_state*)NULL;
11539 PL_reg_re = (regexp*)NULL;
11540 PL_reg_ganch = Nullch;
11541 PL_reg_sv = Nullsv;
11542 PL_reg_match_utf8 = FALSE;
11543 PL_reg_magic = (MAGIC*)NULL;
11545 PL_reg_oldcurpm = (PMOP*)NULL;
11546 PL_reg_curpm = (PMOP*)NULL;
11547 PL_reg_oldsaved = Nullch;
11548 PL_reg_oldsavedlen = 0;
11549 #ifdef PERL_OLD_COPY_ON_WRITE
11552 PL_reg_maxiter = 0;
11553 PL_reg_leftiter = 0;
11554 PL_reg_poscache = Nullch;
11555 PL_reg_poscache_size= 0;
11557 /* RE engine - function pointers */
11558 PL_regcompp = proto_perl->Tregcompp;
11559 PL_regexecp = proto_perl->Tregexecp;
11560 PL_regint_start = proto_perl->Tregint_start;
11561 PL_regint_string = proto_perl->Tregint_string;
11562 PL_regfree = proto_perl->Tregfree;
11564 PL_reginterp_cnt = 0;
11565 PL_reg_starttry = 0;
11567 /* Pluggable optimizer */
11568 PL_peepp = proto_perl->Tpeepp;
11570 PL_stashcache = newHV();
11572 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
11573 ptr_table_free(PL_ptr_table);
11574 PL_ptr_table = NULL;
11577 /* Call the ->CLONE method, if it exists, for each of the stashes
11578 identified by sv_dup() above.
11580 while(av_len(param->stashes) != -1) {
11581 HV* const stash = (HV*) av_shift(param->stashes);
11582 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
11583 if (cloner && GvCV(cloner)) {
11588 XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
11590 call_sv((SV*)GvCV(cloner), G_DISCARD);
11596 SvREFCNT_dec(param->stashes);
11598 /* orphaned? eg threads->new inside BEGIN or use */
11599 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
11600 (void)SvREFCNT_inc(PL_compcv);
11601 SAVEFREESV(PL_compcv);
11607 #endif /* USE_ITHREADS */
11610 =head1 Unicode Support
11612 =for apidoc sv_recode_to_utf8
11614 The encoding is assumed to be an Encode object, on entry the PV
11615 of the sv is assumed to be octets in that encoding, and the sv
11616 will be converted into Unicode (and UTF-8).
11618 If the sv already is UTF-8 (or if it is not POK), or if the encoding
11619 is not a reference, nothing is done to the sv. If the encoding is not
11620 an C<Encode::XS> Encoding object, bad things will happen.
11621 (See F<lib/encoding.pm> and L<Encode>).
11623 The PV of the sv is returned.
11628 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
11631 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
11645 Passing sv_yes is wrong - it needs to be or'ed set of constants
11646 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
11647 remove converted chars from source.
11649 Both will default the value - let them.
11651 XPUSHs(&PL_sv_yes);
11654 call_method("decode", G_SCALAR);
11658 s = SvPV_const(uni, len);
11659 if (s != SvPVX_const(sv)) {
11660 SvGROW(sv, len + 1);
11661 Move(s, SvPVX(sv), len + 1, char);
11662 SvCUR_set(sv, len);
11669 return SvPOKp(sv) ? SvPVX(sv) : NULL;
11673 =for apidoc sv_cat_decode
11675 The encoding is assumed to be an Encode object, the PV of the ssv is
11676 assumed to be octets in that encoding and decoding the input starts
11677 from the position which (PV + *offset) pointed to. The dsv will be
11678 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
11679 when the string tstr appears in decoding output or the input ends on
11680 the PV of the ssv. The value which the offset points will be modified
11681 to the last input position on the ssv.
11683 Returns TRUE if the terminator was found, else returns FALSE.
11688 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
11689 SV *ssv, int *offset, char *tstr, int tlen)
11693 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
11704 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
11705 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
11707 call_method("cat_decode", G_SCALAR);
11709 ret = SvTRUE(TOPs);
11710 *offset = SvIV(offsv);
11716 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
11722 * c-indentation-style: bsd
11723 * c-basic-offset: 4
11724 * indent-tabs-mode: t
11727 * ex: set ts=8 sts=4 sw=4 noet: