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)
1115 #define PTE_SVSLOT SVt_IV
1118 S_more_bodies (pTHX_ size_t size, svtype sv_type)
1120 void **arena_root = &PL_body_arenaroots[sv_type];
1121 void **root = &PL_body_roots[sv_type];
1124 const size_t count = PERL_ARENA_SIZE / size;
1126 Newx(start, count*size, char);
1127 *((void **) start) = *arena_root;
1128 *arena_root = (void *)start;
1130 end = start + (count-1) * size;
1132 /* The initial slot is used to link the arenas together, so it isn't to be
1133 linked into the list of ready-to-use bodies. */
1137 *root = (void *)start;
1139 while (start < end) {
1140 char * const next = start + size;
1141 *(void**) start = (void *)next;
1144 *(void **)start = 0;
1149 /* grab a new thing from the free list, allocating more if necessary */
1151 /* 1st, the inline version */
1153 #define new_body_inline(xpv, root, size, sv_type) \
1156 xpv = *((void **)(root)) \
1157 ? *((void **)(root)) : S_more_bodies(aTHX_ size, sv_type); \
1158 *(root) = *(void**)(xpv); \
1162 /* now use the inline version in the proper function */
1165 S_new_body(pTHX_ size_t size, svtype sv_type)
1168 new_body_inline(xpv, &PL_body_roots[sv_type], size, sv_type);
1172 /* return a thing to the free list */
1174 #define del_body(thing, root) \
1176 void **thing_copy = (void **)thing; \
1178 *thing_copy = *root; \
1179 *root = (void*)thing_copy; \
1184 Revisiting type 3 arenas, there are 4 body-types which have some
1185 members that are never accessed. They are XPV, XPVIV, XPVAV,
1186 XPVHV, which have corresponding types: xpv_allocated,
1187 xpviv_allocated, xpvav_allocated, xpvhv_allocated,
1189 For these types, the arenas are carved up into *_allocated size
1190 chunks, we thus avoid wasted memory for those unaccessed members.
1191 When bodies are allocated, we adjust the pointer back in memory by
1192 the size of the bit not allocated, so it's as if we allocated the
1193 full structure. (But things will all go boom if you write to the
1194 part that is "not there", because you'll be overwriting the last
1195 members of the preceding structure in memory.)
1197 We calculate the correction using the STRUCT_OFFSET macro. For example, if
1198 xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
1199 and the pointer is unchanged. If the allocated structure is smaller (no
1200 initial NV actually allocated) then the net effect is to subtract the size
1201 of the NV from the pointer, to return a new pointer as if an initial NV were
1204 This is the same trick as was used for NV and IV bodies. Ironically it
1205 doesn't need to be used for NV bodies any more, because NV is now at the
1206 start of the structure. IV bodies don't need it either, because they are
1207 no longer allocated. */
1209 /* The following 2 arrays hide the above details in a pair of
1210 lookup-tables, allowing us to be body-type agnostic.
1212 sizeof_body_by_svtype[] maps svtype to its body's allocated size.
1213 offset_by_type[] maps svtype to the body-pointer adjustment needed
1215 NB: elements in latter are 0 or <0, and are added during
1216 allocation, and subtracted during deallocation. It may be clearer
1217 to invert the values, and call it shrinkage_by_svtype.
1220 static int sizeof_body_by_svtype[] = {
1221 0, /* SVt_NULLs, SVt_IVs, SVt_NVs, SVt_RVs have no body */
1223 sizeof(xpv_allocated), /* 8 bytes on 686 */
1225 sizeof(xpv_allocated), /* 8 bytes on 686 */
1226 sizeof(xpviv_allocated), /* 12 */
1227 sizeof(XPVNV), /* 20 */
1228 sizeof(XPVMG), /* 28 */
1229 sizeof(XPVBM), /* 36 */
1230 sizeof(XPVGV), /* 48 */
1231 sizeof(XPVLV), /* 64 */
1232 sizeof(xpvav_allocated), /* 20 */
1233 sizeof(xpvhv_allocated), /* 20 */
1234 sizeof(XPVCV), /* 76 */
1235 sizeof(XPVFM), /* 80 */
1236 sizeof(XPVIO) /* 84 */
1238 #define SIZE_SVTYPES sizeof(sizeof_body_by_svtype)
1240 static int offset_by_svtype[] = {
1245 STRUCT_OFFSET(xpv_allocated, xpv_cur) - STRUCT_OFFSET(XPV, xpv_cur),
1246 STRUCT_OFFSET(xpviv_allocated, xpv_cur) - STRUCT_OFFSET(XPVIV, xpv_cur),
1252 STRUCT_OFFSET(xpvav_allocated, xav_fill) - STRUCT_OFFSET(XPVAV, xav_fill),
1253 STRUCT_OFFSET(xpvhv_allocated, xhv_fill) - STRUCT_OFFSET(XPVHV, xhv_fill),
1258 #define SIZE_OFFSETS sizeof(sizeof_body_by_svtype)
1260 /* they better stay synchronized, but this doesnt do it.
1261 #if SIZE_SVTYPES != SIZE_OFFSETS
1262 #error "declaration problem: sizeof_body_by_svtype != sizeof(offset_by_svtype)"
1267 #define new_body_type(sv_type) \
1268 S_new_body(aTHX_ sizeof_body_by_svtype[sv_type], sv_type) \
1269 + offset_by_svtype[sv_type]
1271 #define del_body_type(p, sv_type) \
1272 del_body(p, &PL_body_roots[sv_type])
1275 #define new_body_allocated(sv_type) \
1276 S_new_body(aTHX_ sizeof_body_by_svtype[sv_type], sv_type) \
1277 + offset_by_svtype[sv_type]
1279 #define del_body_allocated(p, sv_type) \
1280 del_body(p - offset_by_svtype[sv_type], &PL_body_roots[sv_type])
1283 #define my_safemalloc(s) (void*)safemalloc(s)
1284 #define my_safefree(p) safefree((char*)p)
1288 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1289 #define del_XNV(p) my_safefree(p)
1291 #define new_XPV() my_safemalloc(sizeof(XPV))
1292 #define del_XPV(p) my_safefree(p)
1294 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1295 #define del_XPVIV(p) my_safefree(p)
1297 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1298 #define del_XPVNV(p) my_safefree(p)
1300 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1301 #define del_XPVCV(p) my_safefree(p)
1303 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1304 #define del_XPVAV(p) my_safefree(p)
1306 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1307 #define del_XPVHV(p) my_safefree(p)
1309 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1310 #define del_XPVMG(p) my_safefree(p)
1312 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1313 #define del_XPVGV(p) my_safefree(p)
1315 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1316 #define del_XPVLV(p) my_safefree(p)
1318 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1319 #define del_XPVBM(p) my_safefree(p)
1323 #define new_XNV() new_body_type(SVt_NV)
1324 #define del_XNV(p) del_body_type(p, SVt_NV)
1326 #define new_XPV() new_body_allocated(SVt_PV)
1327 #define del_XPV(p) del_body_allocated(p, SVt_PV)
1329 #define new_XPVIV() new_body_allocated(SVt_PVIV)
1330 #define del_XPVIV(p) del_body_allocated(p, SVt_PVIV)
1332 #define new_XPVNV() new_body_type(SVt_PVNV)
1333 #define del_XPVNV(p) del_body_type(p, SVt_PVNV)
1335 #define new_XPVCV() new_body_type(SVt_PVCV)
1336 #define del_XPVCV(p) del_body_type(p, SVt_PVCV)
1338 #define new_XPVAV() new_body_allocated(SVt_PVAV)
1339 #define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
1341 #define new_XPVHV() new_body_allocated(SVt_PVHV)
1342 #define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
1344 #define new_XPVMG() new_body_type(SVt_PVMG)
1345 #define del_XPVMG(p) del_body_type(p, SVt_PVMG)
1347 #define new_XPVGV() new_body_type(SVt_PVGV)
1348 #define del_XPVGV(p) del_body_type(p, SVt_PVGV)
1350 #define new_XPVLV() new_body_type(SVt_PVLV)
1351 #define del_XPVLV(p) del_body_type(p, SVt_PVLV)
1353 #define new_XPVBM() new_body_type(SVt_PVBM)
1354 #define del_XPVBM(p) del_body_type(p, SVt_PVBM)
1358 /* no arena for you! */
1359 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1360 #define del_XPVFM(p) my_safefree(p)
1362 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1363 #define del_XPVIO(p) my_safefree(p)
1368 =for apidoc sv_upgrade
1370 Upgrade an SV to a more complex form. Generally adds a new body type to the
1371 SV, then copies across as much information as possible from the old body.
1372 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1378 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1380 void** old_body_arena;
1381 size_t old_body_offset;
1382 size_t old_body_length; /* Well, the length to copy. */
1384 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1385 /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct
1387 bool zero_nv = TRUE;
1390 size_t new_body_length;
1391 size_t new_body_offset;
1392 void** new_body_arena;
1393 void** new_body_arenaroot;
1394 const U32 old_type = SvTYPE(sv);
1396 if (mt != SVt_PV && SvIsCOW(sv)) {
1397 sv_force_normal_flags(sv, 0);
1400 if (SvTYPE(sv) == mt)
1403 if (SvTYPE(sv) > mt)
1404 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1405 (int)SvTYPE(sv), (int)mt);
1408 old_body = SvANY(sv);
1410 old_body_offset = 0;
1411 old_body_length = 0;
1412 new_body_offset = 0;
1413 new_body_length = ~0;
1415 /* Copying structures onto other structures that have been neatly zeroed
1416 has a subtle gotcha. Consider XPVMG
1418 +------+------+------+------+------+-------+-------+
1419 | NV | CUR | LEN | IV | MAGIC | STASH |
1420 +------+------+------+------+------+-------+-------+
1421 0 4 8 12 16 20 24 28
1423 where NVs are aligned to 8 bytes, so that sizeof that structure is
1424 actually 32 bytes long, with 4 bytes of padding at the end:
1426 +------+------+------+------+------+-------+-------+------+
1427 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1428 +------+------+------+------+------+-------+-------+------+
1429 0 4 8 12 16 20 24 28 32
1431 so what happens if you allocate memory for this structure:
1433 +------+------+------+------+------+-------+-------+------+------+...
1434 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1435 +------+------+------+------+------+-------+-------+------+------+...
1436 0 4 8 12 16 20 24 28 32 36
1438 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1439 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1440 started out as zero once, but it's quite possible that it isn't. So now,
1441 rather than a nicely zeroed GP, you have it pointing somewhere random.
1444 (In fact, GP ends up pointing at a previous GP structure, because the
1445 principle cause of the padding in XPVMG getting garbage is a copy of
1446 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob)
1448 So we are careful and work out the size of used parts of all the
1451 switch (SvTYPE(sv)) {
1457 else if (mt < SVt_PVIV)
1459 old_body_offset = STRUCT_OFFSET(XPVIV, xiv_iv);
1460 old_body_length = sizeof(IV);
1463 old_body_arena = &PL_body_roots[SVt_NV];
1464 old_body_length = sizeof(NV);
1465 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1474 old_body_arena = &PL_body_roots[SVt_PV];
1475 old_body_offset = - offset_by_svtype[SVt_PVIV];
1476 old_body_length = STRUCT_OFFSET(XPV, xpv_len)
1477 + sizeof (((XPV*)SvANY(sv))->xpv_len)
1481 else if (mt == SVt_NV)
1485 old_body_arena = &PL_body_roots[SVt_PVIV];
1486 old_body_offset = - offset_by_svtype[SVt_PVIV];
1487 old_body_length = STRUCT_OFFSET(XPVIV, xiv_u);
1488 old_body_length += sizeof (((XPVIV*)SvANY(sv))->xiv_u);
1489 old_body_length -= old_body_offset;
1492 old_body_arena = &PL_body_roots[SVt_PVNV];
1493 old_body_length = STRUCT_OFFSET(XPVNV, xiv_u)
1494 + sizeof (((XPVNV*)SvANY(sv))->xiv_u);
1495 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1500 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1501 there's no way that it can be safely upgraded, because perl.c
1502 expects to Safefree(SvANY(PL_mess_sv)) */
1503 assert(sv != PL_mess_sv);
1504 /* This flag bit is used to mean other things in other scalar types.
1505 Given that it only has meaning inside the pad, it shouldn't be set
1506 on anything that can get upgraded. */
1507 assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
1508 old_body_arena = &PL_body_roots[SVt_PVMG];
1509 old_body_length = STRUCT_OFFSET(XPVMG, xmg_stash)
1510 + sizeof (((XPVMG*)SvANY(sv))->xmg_stash);
1511 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1516 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1519 SvFLAGS(sv) &= ~SVTYPEMASK;
1524 Perl_croak(aTHX_ "Can't upgrade to undef");
1526 assert(old_type == SVt_NULL);
1527 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1531 assert(old_type == SVt_NULL);
1532 SvANY(sv) = new_XNV();
1536 assert(old_type == SVt_NULL);
1537 SvANY(sv) = &sv->sv_u.svu_rv;
1541 SvANY(sv) = new_XPVHV();
1544 HvTOTALKEYS(sv) = 0;
1549 SvANY(sv) = new_XPVAV();
1556 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1557 The target created by newSVrv also is, and it can have magic.
1558 However, it never has SvPVX set.
1560 if (old_type >= SVt_RV) {
1561 assert(SvPVX_const(sv) == 0);
1564 /* Could put this in the else clause below, as PVMG must have SvPVX
1565 0 already (the assertion above) */
1566 SvPV_set(sv, (char*)0);
1568 if (old_type >= SVt_PVMG) {
1569 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic);
1570 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1578 new_body = new_XPVIO();
1579 new_body_length = sizeof(XPVIO);
1582 new_body = new_XPVFM();
1583 new_body_length = sizeof(XPVFM);
1592 new_body_length = sizeof_body_by_svtype[mt];
1593 new_body_arena = &PL_body_roots[mt];
1594 new_body_arenaroot = &PL_body_arenaroots[mt];
1598 new_body_offset = - offset_by_svtype[SVt_PVIV];
1599 new_body_length = sizeof(XPVIV) - new_body_offset;
1600 new_body_arena = &PL_body_roots[SVt_PVIV];
1601 new_body_arenaroot = &PL_body_arenaroots[SVt_PVIV];
1602 /* XXX Is this still needed? Was it ever needed? Surely as there is
1603 no route from NV to PVIV, NOK can never be true */
1607 goto new_body_no_NV;
1609 new_body_offset = - offset_by_svtype[SVt_PV];
1610 new_body_length = sizeof(XPV) - new_body_offset;
1611 new_body_arena = &PL_body_roots[SVt_PV];
1612 new_body_arenaroot = &PL_body_arenaroots[SVt_PV];
1614 /* PV and PVIV don't have an NV slot. */
1615 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1620 assert(new_body_length);
1622 /* This points to the start of the allocated area. */
1623 new_body_inline(new_body, new_body_arena, new_body_length, mt);
1625 /* We always allocated the full length item with PURIFY */
1626 new_body_length += new_body_offset;
1627 new_body_offset = 0;
1628 new_body = my_safemalloc(new_body_length);
1632 Zero(new_body, new_body_length, char);
1633 new_body = ((char *)new_body) - new_body_offset;
1634 SvANY(sv) = new_body;
1636 if (old_body_length) {
1637 Copy((char *)old_body + old_body_offset,
1638 (char *)new_body + old_body_offset,
1639 old_body_length, char);
1642 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1648 IoPAGE_LEN(sv) = 60;
1649 if (old_type < SVt_RV)
1653 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", mt);
1657 if (old_body_arena) {
1659 my_safefree(old_body);
1661 del_body((void*)((char*)old_body + old_body_offset),
1668 =for apidoc sv_backoff
1670 Remove any string offset. You should normally use the C<SvOOK_off> macro
1677 Perl_sv_backoff(pTHX_ register SV *sv)
1680 assert(SvTYPE(sv) != SVt_PVHV);
1681 assert(SvTYPE(sv) != SVt_PVAV);
1683 const char * const s = SvPVX_const(sv);
1684 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1685 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1687 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1689 SvFLAGS(sv) &= ~SVf_OOK;
1696 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1697 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1698 Use the C<SvGROW> wrapper instead.
1704 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1708 #ifdef HAS_64K_LIMIT
1709 if (newlen >= 0x10000) {
1710 PerlIO_printf(Perl_debug_log,
1711 "Allocation too large: %"UVxf"\n", (UV)newlen);
1714 #endif /* HAS_64K_LIMIT */
1717 if (SvTYPE(sv) < SVt_PV) {
1718 sv_upgrade(sv, SVt_PV);
1719 s = SvPVX_mutable(sv);
1721 else if (SvOOK(sv)) { /* pv is offset? */
1723 s = SvPVX_mutable(sv);
1724 if (newlen > SvLEN(sv))
1725 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1726 #ifdef HAS_64K_LIMIT
1727 if (newlen >= 0x10000)
1732 s = SvPVX_mutable(sv);
1734 if (newlen > SvLEN(sv)) { /* need more room? */
1735 newlen = PERL_STRLEN_ROUNDUP(newlen);
1736 if (SvLEN(sv) && s) {
1738 const STRLEN l = malloced_size((void*)SvPVX_const(sv));
1744 s = saferealloc(s, newlen);
1747 s = safemalloc(newlen);
1748 if (SvPVX_const(sv) && SvCUR(sv)) {
1749 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1753 SvLEN_set(sv, newlen);
1759 =for apidoc sv_setiv
1761 Copies an integer into the given SV, upgrading first if necessary.
1762 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1768 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1770 SV_CHECK_THINKFIRST_COW_DROP(sv);
1771 switch (SvTYPE(sv)) {
1773 sv_upgrade(sv, SVt_IV);
1776 sv_upgrade(sv, SVt_PVNV);
1780 sv_upgrade(sv, SVt_PVIV);
1789 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1792 (void)SvIOK_only(sv); /* validate number */
1798 =for apidoc sv_setiv_mg
1800 Like C<sv_setiv>, but also handles 'set' magic.
1806 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1813 =for apidoc sv_setuv
1815 Copies an unsigned integer into the given SV, upgrading first if necessary.
1816 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1822 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1824 /* With these two if statements:
1825 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1828 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1830 If you wish to remove them, please benchmark to see what the effect is
1832 if (u <= (UV)IV_MAX) {
1833 sv_setiv(sv, (IV)u);
1842 =for apidoc sv_setuv_mg
1844 Like C<sv_setuv>, but also handles 'set' magic.
1850 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1859 =for apidoc sv_setnv
1861 Copies a double into the given SV, upgrading first if necessary.
1862 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1868 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1870 SV_CHECK_THINKFIRST_COW_DROP(sv);
1871 switch (SvTYPE(sv)) {
1874 sv_upgrade(sv, SVt_NV);
1879 sv_upgrade(sv, SVt_PVNV);
1888 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1892 (void)SvNOK_only(sv); /* validate number */
1897 =for apidoc sv_setnv_mg
1899 Like C<sv_setnv>, but also handles 'set' magic.
1905 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1911 /* Print an "isn't numeric" warning, using a cleaned-up,
1912 * printable version of the offending string
1916 S_not_a_number(pTHX_ SV *sv)
1923 dsv = sv_2mortal(newSVpvn("", 0));
1924 pv = sv_uni_display(dsv, sv, 10, 0);
1927 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1928 /* each *s can expand to 4 chars + "...\0",
1929 i.e. need room for 8 chars */
1931 const char *s, *end;
1932 for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit;
1935 if (ch & 128 && !isPRINT_LC(ch)) {
1944 else if (ch == '\r') {
1948 else if (ch == '\f') {
1952 else if (ch == '\\') {
1956 else if (ch == '\0') {
1960 else if (isPRINT_LC(ch))
1977 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1978 "Argument \"%s\" isn't numeric in %s", pv,
1981 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1982 "Argument \"%s\" isn't numeric", pv);
1986 =for apidoc looks_like_number
1988 Test if the content of an SV looks like a number (or is a number).
1989 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1990 non-numeric warning), even if your atof() doesn't grok them.
1996 Perl_looks_like_number(pTHX_ SV *sv)
1998 register const char *sbegin;
2002 sbegin = SvPVX_const(sv);
2005 else if (SvPOKp(sv))
2006 sbegin = SvPV_const(sv, len);
2008 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
2009 return grok_number(sbegin, len, NULL);
2012 /* Actually, ISO C leaves conversion of UV to IV undefined, but
2013 until proven guilty, assume that things are not that bad... */
2018 As 64 bit platforms often have an NV that doesn't preserve all bits of
2019 an IV (an assumption perl has been based on to date) it becomes necessary
2020 to remove the assumption that the NV always carries enough precision to
2021 recreate the IV whenever needed, and that the NV is the canonical form.
2022 Instead, IV/UV and NV need to be given equal rights. So as to not lose
2023 precision as a side effect of conversion (which would lead to insanity
2024 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
2025 1) to distinguish between IV/UV/NV slots that have cached a valid
2026 conversion where precision was lost and IV/UV/NV slots that have a
2027 valid conversion which has lost no precision
2028 2) to ensure that if a numeric conversion to one form is requested that
2029 would lose precision, the precise conversion (or differently
2030 imprecise conversion) is also performed and cached, to prevent
2031 requests for different numeric formats on the same SV causing
2032 lossy conversion chains. (lossless conversion chains are perfectly
2037 SvIOKp is true if the IV slot contains a valid value
2038 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
2039 SvNOKp is true if the NV slot contains a valid value
2040 SvNOK is true only if the NV value is accurate
2043 while converting from PV to NV, check to see if converting that NV to an
2044 IV(or UV) would lose accuracy over a direct conversion from PV to
2045 IV(or UV). If it would, cache both conversions, return NV, but mark
2046 SV as IOK NOKp (ie not NOK).
2048 While converting from PV to IV, check to see if converting that IV to an
2049 NV would lose accuracy over a direct conversion from PV to NV. If it
2050 would, cache both conversions, flag similarly.
2052 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2053 correctly because if IV & NV were set NV *always* overruled.
2054 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2055 changes - now IV and NV together means that the two are interchangeable:
2056 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
2058 The benefit of this is that operations such as pp_add know that if
2059 SvIOK is true for both left and right operands, then integer addition
2060 can be used instead of floating point (for cases where the result won't
2061 overflow). Before, floating point was always used, which could lead to
2062 loss of precision compared with integer addition.
2064 * making IV and NV equal status should make maths accurate on 64 bit
2066 * may speed up maths somewhat if pp_add and friends start to use
2067 integers when possible instead of fp. (Hopefully the overhead in
2068 looking for SvIOK and checking for overflow will not outweigh the
2069 fp to integer speedup)
2070 * will slow down integer operations (callers of SvIV) on "inaccurate"
2071 values, as the change from SvIOK to SvIOKp will cause a call into
2072 sv_2iv each time rather than a macro access direct to the IV slot
2073 * should speed up number->string conversion on integers as IV is
2074 favoured when IV and NV are equally accurate
2076 ####################################################################
2077 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2078 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2079 On the other hand, SvUOK is true iff UV.
2080 ####################################################################
2082 Your mileage will vary depending your CPU's relative fp to integer
2086 #ifndef NV_PRESERVES_UV
2087 # define IS_NUMBER_UNDERFLOW_IV 1
2088 # define IS_NUMBER_UNDERFLOW_UV 2
2089 # define IS_NUMBER_IV_AND_UV 2
2090 # define IS_NUMBER_OVERFLOW_IV 4
2091 # define IS_NUMBER_OVERFLOW_UV 5
2093 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2095 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2097 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2099 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));
2100 if (SvNVX(sv) < (NV)IV_MIN) {
2101 (void)SvIOKp_on(sv);
2103 SvIV_set(sv, IV_MIN);
2104 return IS_NUMBER_UNDERFLOW_IV;
2106 if (SvNVX(sv) > (NV)UV_MAX) {
2107 (void)SvIOKp_on(sv);
2110 SvUV_set(sv, UV_MAX);
2111 return IS_NUMBER_OVERFLOW_UV;
2113 (void)SvIOKp_on(sv);
2115 /* Can't use strtol etc to convert this string. (See truth table in
2117 if (SvNVX(sv) <= (UV)IV_MAX) {
2118 SvIV_set(sv, I_V(SvNVX(sv)));
2119 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2120 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2122 /* Integer is imprecise. NOK, IOKp */
2124 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2127 SvUV_set(sv, U_V(SvNVX(sv)));
2128 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2129 if (SvUVX(sv) == UV_MAX) {
2130 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2131 possibly be preserved by NV. Hence, it must be overflow.
2133 return IS_NUMBER_OVERFLOW_UV;
2135 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2137 /* Integer is imprecise. NOK, IOKp */
2139 return IS_NUMBER_OVERFLOW_IV;
2141 #endif /* !NV_PRESERVES_UV*/
2144 =for apidoc sv_2iv_flags
2146 Return the integer value of an SV, doing any necessary string
2147 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2148 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2154 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2158 if (SvGMAGICAL(sv)) {
2159 if (flags & SV_GMAGIC)
2164 return I_V(SvNVX(sv));
2166 if (SvPOKp(sv) && SvLEN(sv))
2169 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2170 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2176 if (SvTHINKFIRST(sv)) {
2179 SV * const tmpstr=AMG_CALLun(sv,numer);
2180 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2181 return SvIV(tmpstr);
2184 return PTR2IV(SvRV(sv));
2187 sv_force_normal_flags(sv, 0);
2189 if (SvREADONLY(sv) && !SvOK(sv)) {
2190 if (ckWARN(WARN_UNINITIALIZED))
2197 return (IV)(SvUVX(sv));
2204 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2205 * without also getting a cached IV/UV from it at the same time
2206 * (ie PV->NV conversion should detect loss of accuracy and cache
2207 * IV or UV at same time to avoid this. NWC */
2209 if (SvTYPE(sv) == SVt_NV)
2210 sv_upgrade(sv, SVt_PVNV);
2212 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2213 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2214 certainly cast into the IV range at IV_MAX, whereas the correct
2215 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2217 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2218 SvIV_set(sv, I_V(SvNVX(sv)));
2219 if (SvNVX(sv) == (NV) SvIVX(sv)
2220 #ifndef NV_PRESERVES_UV
2221 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2222 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2223 /* Don't flag it as "accurately an integer" if the number
2224 came from a (by definition imprecise) NV operation, and
2225 we're outside the range of NV integer precision */
2228 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2229 DEBUG_c(PerlIO_printf(Perl_debug_log,
2230 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2236 /* IV not precise. No need to convert from PV, as NV
2237 conversion would already have cached IV if it detected
2238 that PV->IV would be better than PV->NV->IV
2239 flags already correct - don't set public IOK. */
2240 DEBUG_c(PerlIO_printf(Perl_debug_log,
2241 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2246 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2247 but the cast (NV)IV_MIN rounds to a the value less (more
2248 negative) than IV_MIN which happens to be equal to SvNVX ??
2249 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2250 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2251 (NV)UVX == NVX are both true, but the values differ. :-(
2252 Hopefully for 2s complement IV_MIN is something like
2253 0x8000000000000000 which will be exact. NWC */
2256 SvUV_set(sv, U_V(SvNVX(sv)));
2258 (SvNVX(sv) == (NV) SvUVX(sv))
2259 #ifndef NV_PRESERVES_UV
2260 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2261 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2262 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2263 /* Don't flag it as "accurately an integer" if the number
2264 came from a (by definition imprecise) NV operation, and
2265 we're outside the range of NV integer precision */
2271 DEBUG_c(PerlIO_printf(Perl_debug_log,
2272 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2276 return (IV)SvUVX(sv);
2279 else if (SvPOKp(sv) && SvLEN(sv)) {
2281 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2282 /* We want to avoid a possible problem when we cache an IV which
2283 may be later translated to an NV, and the resulting NV is not
2284 the same as the direct translation of the initial string
2285 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2286 be careful to ensure that the value with the .456 is around if the
2287 NV value is requested in the future).
2289 This means that if we cache such an IV, we need to cache the
2290 NV as well. Moreover, we trade speed for space, and do not
2291 cache the NV if we are sure it's not needed.
2294 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2295 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2296 == IS_NUMBER_IN_UV) {
2297 /* It's definitely an integer, only upgrade to PVIV */
2298 if (SvTYPE(sv) < SVt_PVIV)
2299 sv_upgrade(sv, SVt_PVIV);
2301 } else if (SvTYPE(sv) < SVt_PVNV)
2302 sv_upgrade(sv, SVt_PVNV);
2304 /* If NV preserves UV then we only use the UV value if we know that
2305 we aren't going to call atof() below. If NVs don't preserve UVs
2306 then the value returned may have more precision than atof() will
2307 return, even though value isn't perfectly accurate. */
2308 if ((numtype & (IS_NUMBER_IN_UV
2309 #ifdef NV_PRESERVES_UV
2312 )) == IS_NUMBER_IN_UV) {
2313 /* This won't turn off the public IOK flag if it was set above */
2314 (void)SvIOKp_on(sv);
2316 if (!(numtype & IS_NUMBER_NEG)) {
2318 if (value <= (UV)IV_MAX) {
2319 SvIV_set(sv, (IV)value);
2321 SvUV_set(sv, value);
2325 /* 2s complement assumption */
2326 if (value <= (UV)IV_MIN) {
2327 SvIV_set(sv, -(IV)value);
2329 /* Too negative for an IV. This is a double upgrade, but
2330 I'm assuming it will be rare. */
2331 if (SvTYPE(sv) < SVt_PVNV)
2332 sv_upgrade(sv, SVt_PVNV);
2336 SvNV_set(sv, -(NV)value);
2337 SvIV_set(sv, IV_MIN);
2341 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2342 will be in the previous block to set the IV slot, and the next
2343 block to set the NV slot. So no else here. */
2345 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2346 != IS_NUMBER_IN_UV) {
2347 /* It wasn't an (integer that doesn't overflow the UV). */
2348 SvNV_set(sv, Atof(SvPVX_const(sv)));
2350 if (! numtype && ckWARN(WARN_NUMERIC))
2353 #if defined(USE_LONG_DOUBLE)
2354 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2355 PTR2UV(sv), SvNVX(sv)));
2357 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2358 PTR2UV(sv), SvNVX(sv)));
2362 #ifdef NV_PRESERVES_UV
2363 (void)SvIOKp_on(sv);
2365 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2366 SvIV_set(sv, I_V(SvNVX(sv)));
2367 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2370 /* Integer is imprecise. NOK, IOKp */
2372 /* UV will not work better than IV */
2374 if (SvNVX(sv) > (NV)UV_MAX) {
2376 /* Integer is inaccurate. NOK, IOKp, is UV */
2377 SvUV_set(sv, UV_MAX);
2380 SvUV_set(sv, U_V(SvNVX(sv)));
2381 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2382 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2386 /* Integer is imprecise. NOK, IOKp, is UV */
2392 #else /* NV_PRESERVES_UV */
2393 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2394 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2395 /* The IV slot will have been set from value returned by
2396 grok_number above. The NV slot has just been set using
2399 assert (SvIOKp(sv));
2401 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2402 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2403 /* Small enough to preserve all bits. */
2404 (void)SvIOKp_on(sv);
2406 SvIV_set(sv, I_V(SvNVX(sv)));
2407 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2409 /* Assumption: first non-preserved integer is < IV_MAX,
2410 this NV is in the preserved range, therefore: */
2411 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2413 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);
2417 0 0 already failed to read UV.
2418 0 1 already failed to read UV.
2419 1 0 you won't get here in this case. IV/UV
2420 slot set, public IOK, Atof() unneeded.
2421 1 1 already read UV.
2422 so there's no point in sv_2iuv_non_preserve() attempting
2423 to use atol, strtol, strtoul etc. */
2424 if (sv_2iuv_non_preserve (sv, numtype)
2425 >= IS_NUMBER_OVERFLOW_IV)
2429 #endif /* NV_PRESERVES_UV */
2432 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2434 if (SvTYPE(sv) < SVt_IV)
2435 /* Typically the caller expects that sv_any is not NULL now. */
2436 sv_upgrade(sv, SVt_IV);
2439 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2440 PTR2UV(sv),SvIVX(sv)));
2441 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2445 =for apidoc sv_2uv_flags
2447 Return the unsigned integer value of an SV, doing any necessary string
2448 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2449 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2455 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2459 if (SvGMAGICAL(sv)) {
2460 if (flags & SV_GMAGIC)
2465 return U_V(SvNVX(sv));
2466 if (SvPOKp(sv) && SvLEN(sv))
2469 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2470 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2476 if (SvTHINKFIRST(sv)) {
2479 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2480 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2481 return SvUV(tmpstr);
2482 return PTR2UV(SvRV(sv));
2485 sv_force_normal_flags(sv, 0);
2487 if (SvREADONLY(sv) && !SvOK(sv)) {
2488 if (ckWARN(WARN_UNINITIALIZED))
2498 return (UV)SvIVX(sv);
2502 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2503 * without also getting a cached IV/UV from it at the same time
2504 * (ie PV->NV conversion should detect loss of accuracy and cache
2505 * IV or UV at same time to avoid this. */
2506 /* IV-over-UV optimisation - choose to cache IV if possible */
2508 if (SvTYPE(sv) == SVt_NV)
2509 sv_upgrade(sv, SVt_PVNV);
2511 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2512 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2513 SvIV_set(sv, I_V(SvNVX(sv)));
2514 if (SvNVX(sv) == (NV) SvIVX(sv)
2515 #ifndef NV_PRESERVES_UV
2516 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2517 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2518 /* Don't flag it as "accurately an integer" if the number
2519 came from a (by definition imprecise) NV operation, and
2520 we're outside the range of NV integer precision */
2523 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2524 DEBUG_c(PerlIO_printf(Perl_debug_log,
2525 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2531 /* IV not precise. No need to convert from PV, as NV
2532 conversion would already have cached IV if it detected
2533 that PV->IV would be better than PV->NV->IV
2534 flags already correct - don't set public IOK. */
2535 DEBUG_c(PerlIO_printf(Perl_debug_log,
2536 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2541 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2542 but the cast (NV)IV_MIN rounds to a the value less (more
2543 negative) than IV_MIN which happens to be equal to SvNVX ??
2544 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2545 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2546 (NV)UVX == NVX are both true, but the values differ. :-(
2547 Hopefully for 2s complement IV_MIN is something like
2548 0x8000000000000000 which will be exact. NWC */
2551 SvUV_set(sv, U_V(SvNVX(sv)));
2553 (SvNVX(sv) == (NV) SvUVX(sv))
2554 #ifndef NV_PRESERVES_UV
2555 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2556 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2557 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2558 /* Don't flag it as "accurately an integer" if the number
2559 came from a (by definition imprecise) NV operation, and
2560 we're outside the range of NV integer precision */
2565 DEBUG_c(PerlIO_printf(Perl_debug_log,
2566 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2572 else if (SvPOKp(sv) && SvLEN(sv)) {
2574 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2576 /* We want to avoid a possible problem when we cache a UV which
2577 may be later translated to an NV, and the resulting NV is not
2578 the translation of the initial data.
2580 This means that if we cache such a UV, we need to cache the
2581 NV as well. Moreover, we trade speed for space, and do not
2582 cache the NV if not needed.
2585 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2586 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2587 == IS_NUMBER_IN_UV) {
2588 /* It's definitely an integer, only upgrade to PVIV */
2589 if (SvTYPE(sv) < SVt_PVIV)
2590 sv_upgrade(sv, SVt_PVIV);
2592 } else if (SvTYPE(sv) < SVt_PVNV)
2593 sv_upgrade(sv, SVt_PVNV);
2595 /* If NV preserves UV then we only use the UV value if we know that
2596 we aren't going to call atof() below. If NVs don't preserve UVs
2597 then the value returned may have more precision than atof() will
2598 return, even though it isn't accurate. */
2599 if ((numtype & (IS_NUMBER_IN_UV
2600 #ifdef NV_PRESERVES_UV
2603 )) == IS_NUMBER_IN_UV) {
2604 /* This won't turn off the public IOK flag if it was set above */
2605 (void)SvIOKp_on(sv);
2607 if (!(numtype & IS_NUMBER_NEG)) {
2609 if (value <= (UV)IV_MAX) {
2610 SvIV_set(sv, (IV)value);
2612 /* it didn't overflow, and it was positive. */
2613 SvUV_set(sv, value);
2617 /* 2s complement assumption */
2618 if (value <= (UV)IV_MIN) {
2619 SvIV_set(sv, -(IV)value);
2621 /* Too negative for an IV. This is a double upgrade, but
2622 I'm assuming it will be rare. */
2623 if (SvTYPE(sv) < SVt_PVNV)
2624 sv_upgrade(sv, SVt_PVNV);
2628 SvNV_set(sv, -(NV)value);
2629 SvIV_set(sv, IV_MIN);
2634 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2635 != IS_NUMBER_IN_UV) {
2636 /* It wasn't an integer, or it overflowed the UV. */
2637 SvNV_set(sv, Atof(SvPVX_const(sv)));
2639 if (! numtype && ckWARN(WARN_NUMERIC))
2642 #if defined(USE_LONG_DOUBLE)
2643 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2644 PTR2UV(sv), SvNVX(sv)));
2646 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2647 PTR2UV(sv), SvNVX(sv)));
2650 #ifdef NV_PRESERVES_UV
2651 (void)SvIOKp_on(sv);
2653 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2654 SvIV_set(sv, I_V(SvNVX(sv)));
2655 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2658 /* Integer is imprecise. NOK, IOKp */
2660 /* UV will not work better than IV */
2662 if (SvNVX(sv) > (NV)UV_MAX) {
2664 /* Integer is inaccurate. NOK, IOKp, is UV */
2665 SvUV_set(sv, UV_MAX);
2668 SvUV_set(sv, U_V(SvNVX(sv)));
2669 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2670 NV preservse UV so can do correct comparison. */
2671 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2675 /* Integer is imprecise. NOK, IOKp, is UV */
2680 #else /* NV_PRESERVES_UV */
2681 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2682 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2683 /* The UV slot will have been set from value returned by
2684 grok_number above. The NV slot has just been set using
2687 assert (SvIOKp(sv));
2689 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2690 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2691 /* Small enough to preserve all bits. */
2692 (void)SvIOKp_on(sv);
2694 SvIV_set(sv, I_V(SvNVX(sv)));
2695 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2697 /* Assumption: first non-preserved integer is < IV_MAX,
2698 this NV is in the preserved range, therefore: */
2699 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2701 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);
2704 sv_2iuv_non_preserve (sv, numtype);
2706 #endif /* NV_PRESERVES_UV */
2710 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2711 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2714 if (SvTYPE(sv) < SVt_IV)
2715 /* Typically the caller expects that sv_any is not NULL now. */
2716 sv_upgrade(sv, SVt_IV);
2720 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2721 PTR2UV(sv),SvUVX(sv)));
2722 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2728 Return the num value of an SV, doing any necessary string or integer
2729 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2736 Perl_sv_2nv(pTHX_ register SV *sv)
2740 if (SvGMAGICAL(sv)) {
2744 if (SvPOKp(sv) && SvLEN(sv)) {
2745 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2746 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2748 return Atof(SvPVX_const(sv));
2752 return (NV)SvUVX(sv);
2754 return (NV)SvIVX(sv);
2757 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2758 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2764 if (SvTHINKFIRST(sv)) {
2767 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2768 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2769 return SvNV(tmpstr);
2770 return PTR2NV(SvRV(sv));
2773 sv_force_normal_flags(sv, 0);
2775 if (SvREADONLY(sv) && !SvOK(sv)) {
2776 if (ckWARN(WARN_UNINITIALIZED))
2781 if (SvTYPE(sv) < SVt_NV) {
2782 if (SvTYPE(sv) == SVt_IV)
2783 sv_upgrade(sv, SVt_PVNV);
2785 sv_upgrade(sv, SVt_NV);
2786 #ifdef USE_LONG_DOUBLE
2788 STORE_NUMERIC_LOCAL_SET_STANDARD();
2789 PerlIO_printf(Perl_debug_log,
2790 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2791 PTR2UV(sv), SvNVX(sv));
2792 RESTORE_NUMERIC_LOCAL();
2796 STORE_NUMERIC_LOCAL_SET_STANDARD();
2797 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2798 PTR2UV(sv), SvNVX(sv));
2799 RESTORE_NUMERIC_LOCAL();
2803 else if (SvTYPE(sv) < SVt_PVNV)
2804 sv_upgrade(sv, SVt_PVNV);
2809 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2810 #ifdef NV_PRESERVES_UV
2813 /* Only set the public NV OK flag if this NV preserves the IV */
2814 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2815 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2816 : (SvIVX(sv) == I_V(SvNVX(sv))))
2822 else if (SvPOKp(sv) && SvLEN(sv)) {
2824 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2825 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2827 #ifdef NV_PRESERVES_UV
2828 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2829 == IS_NUMBER_IN_UV) {
2830 /* It's definitely an integer */
2831 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2833 SvNV_set(sv, Atof(SvPVX_const(sv)));
2836 SvNV_set(sv, Atof(SvPVX_const(sv)));
2837 /* Only set the public NV OK flag if this NV preserves the value in
2838 the PV at least as well as an IV/UV would.
2839 Not sure how to do this 100% reliably. */
2840 /* if that shift count is out of range then Configure's test is
2841 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2843 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2844 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2845 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2846 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2847 /* Can't use strtol etc to convert this string, so don't try.
2848 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2851 /* value has been set. It may not be precise. */
2852 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2853 /* 2s complement assumption for (UV)IV_MIN */
2854 SvNOK_on(sv); /* Integer is too negative. */
2859 if (numtype & IS_NUMBER_NEG) {
2860 SvIV_set(sv, -(IV)value);
2861 } else if (value <= (UV)IV_MAX) {
2862 SvIV_set(sv, (IV)value);
2864 SvUV_set(sv, value);
2868 if (numtype & IS_NUMBER_NOT_INT) {
2869 /* I believe that even if the original PV had decimals,
2870 they are lost beyond the limit of the FP precision.
2871 However, neither is canonical, so both only get p
2872 flags. NWC, 2000/11/25 */
2873 /* Both already have p flags, so do nothing */
2875 const NV nv = SvNVX(sv);
2876 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2877 if (SvIVX(sv) == I_V(nv)) {
2882 /* It had no "." so it must be integer. */
2885 /* between IV_MAX and NV(UV_MAX).
2886 Could be slightly > UV_MAX */
2888 if (numtype & IS_NUMBER_NOT_INT) {
2889 /* UV and NV both imprecise. */
2891 const UV nv_as_uv = U_V(nv);
2893 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2904 #endif /* NV_PRESERVES_UV */
2907 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2909 if (SvTYPE(sv) < SVt_NV)
2910 /* Typically the caller expects that sv_any is not NULL now. */
2911 /* XXX Ilya implies that this is a bug in callers that assume this
2912 and ideally should be fixed. */
2913 sv_upgrade(sv, SVt_NV);
2916 #if defined(USE_LONG_DOUBLE)
2918 STORE_NUMERIC_LOCAL_SET_STANDARD();
2919 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2920 PTR2UV(sv), SvNVX(sv));
2921 RESTORE_NUMERIC_LOCAL();
2925 STORE_NUMERIC_LOCAL_SET_STANDARD();
2926 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2927 PTR2UV(sv), SvNVX(sv));
2928 RESTORE_NUMERIC_LOCAL();
2934 /* asIV(): extract an integer from the string value of an SV.
2935 * Caller must validate PVX */
2938 S_asIV(pTHX_ SV *sv)
2941 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2943 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2944 == IS_NUMBER_IN_UV) {
2945 /* It's definitely an integer */
2946 if (numtype & IS_NUMBER_NEG) {
2947 if (value < (UV)IV_MIN)
2950 if (value < (UV)IV_MAX)
2955 if (ckWARN(WARN_NUMERIC))
2958 return I_V(Atof(SvPVX_const(sv)));
2961 /* asUV(): extract an unsigned integer from the string value of an SV
2962 * Caller must validate PVX */
2965 S_asUV(pTHX_ SV *sv)
2968 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2970 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2971 == IS_NUMBER_IN_UV) {
2972 /* It's definitely an integer */
2973 if (!(numtype & IS_NUMBER_NEG))
2977 if (ckWARN(WARN_NUMERIC))
2980 return U_V(Atof(SvPVX_const(sv)));
2983 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2984 * UV as a string towards the end of buf, and return pointers to start and
2987 * We assume that buf is at least TYPE_CHARS(UV) long.
2991 S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2993 char *ptr = buf + TYPE_CHARS(UV);
2994 char * const ebuf = ptr;
3007 *--ptr = '0' + (char)(uv % 10);
3016 =for apidoc sv_2pv_flags
3018 Returns a pointer to the string value of an SV, and sets *lp to its length.
3019 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
3021 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
3022 usually end up here too.
3028 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3033 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3034 char *tmpbuf = tbuf;
3035 STRLEN len = 0; /* Hush gcc. len is always initialised before use. */
3042 if (SvGMAGICAL(sv)) {
3043 if (flags & SV_GMAGIC)
3048 if (flags & SV_MUTABLE_RETURN)
3049 return SvPVX_mutable(sv);
3050 if (flags & SV_CONST_RETURN)
3051 return (char *)SvPVX_const(sv);
3055 len = SvIsUV(sv) ? my_sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv))
3056 : my_sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3058 goto tokensave_has_len;
3061 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3066 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3067 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3075 if (SvTHINKFIRST(sv)) {
3078 register const char *typestr;
3079 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3080 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3082 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
3085 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
3086 if (flags & SV_CONST_RETURN) {
3087 pv = (char *) SvPVX_const(tmpstr);
3089 pv = (flags & SV_MUTABLE_RETURN)
3090 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
3093 *lp = SvCUR(tmpstr);
3095 pv = sv_2pv_flags(tmpstr, lp, flags);
3106 typestr = "NULLREF";
3110 switch (SvTYPE(sv)) {
3112 if ( ((SvFLAGS(sv) &
3113 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3114 == (SVs_OBJECT|SVs_SMG))
3115 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3116 const regexp *re = (regexp *)mg->mg_obj;
3119 const char *fptr = "msix";
3124 char need_newline = 0;
3125 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3127 while((ch = *fptr++)) {
3129 reflags[left++] = ch;
3132 reflags[right--] = ch;
3137 reflags[left] = '-';
3141 mg->mg_len = re->prelen + 4 + left;
3143 * If /x was used, we have to worry about a regex
3144 * ending with a comment later being embedded
3145 * within another regex. If so, we don't want this
3146 * regex's "commentization" to leak out to the
3147 * right part of the enclosing regex, we must cap
3148 * it with a newline.
3150 * So, if /x was used, we scan backwards from the
3151 * end of the regex. If we find a '#' before we
3152 * find a newline, we need to add a newline
3153 * ourself. If we find a '\n' first (or if we
3154 * don't find '#' or '\n'), we don't need to add
3155 * anything. -jfriedl
3157 if (PMf_EXTENDED & re->reganch)
3159 const char *endptr = re->precomp + re->prelen;
3160 while (endptr >= re->precomp)
3162 const char c = *(endptr--);
3164 break; /* don't need another */
3166 /* we end while in a comment, so we
3168 mg->mg_len++; /* save space for it */
3169 need_newline = 1; /* note to add it */
3175 Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
3176 Copy("(?", mg->mg_ptr, 2, char);
3177 Copy(reflags, mg->mg_ptr+2, left, char);
3178 Copy(":", mg->mg_ptr+left+2, 1, char);
3179 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3181 mg->mg_ptr[mg->mg_len - 2] = '\n';
3182 mg->mg_ptr[mg->mg_len - 1] = ')';
3183 mg->mg_ptr[mg->mg_len] = 0;
3185 PL_reginterp_cnt += re->program[0].next_off;
3187 if (re->reganch & ROPT_UTF8)
3203 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3204 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3205 /* tied lvalues should appear to be
3206 * scalars for backwards compatitbility */
3207 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3208 ? "SCALAR" : "LVALUE"; break;
3209 case SVt_PVAV: typestr = "ARRAY"; break;
3210 case SVt_PVHV: typestr = "HASH"; break;
3211 case SVt_PVCV: typestr = "CODE"; break;
3212 case SVt_PVGV: typestr = "GLOB"; break;
3213 case SVt_PVFM: typestr = "FORMAT"; break;
3214 case SVt_PVIO: typestr = "IO"; break;
3215 default: typestr = "UNKNOWN"; break;
3219 const char * const name = HvNAME_get(SvSTASH(sv));
3220 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3221 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3224 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3228 *lp = strlen(typestr);
3229 return (char *)typestr;
3231 if (SvREADONLY(sv) && !SvOK(sv)) {
3232 if (ckWARN(WARN_UNINITIALIZED))
3239 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3240 /* I'm assuming that if both IV and NV are equally valid then
3241 converting the IV is going to be more efficient */
3242 const U32 isIOK = SvIOK(sv);
3243 const U32 isUIOK = SvIsUV(sv);
3244 char buf[TYPE_CHARS(UV)];
3247 if (SvTYPE(sv) < SVt_PVIV)
3248 sv_upgrade(sv, SVt_PVIV);
3250 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3252 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3253 /* inlined from sv_setpvn */
3254 SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
3255 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
3256 SvCUR_set(sv, ebuf - ptr);
3266 else if (SvNOKp(sv)) {
3267 if (SvTYPE(sv) < SVt_PVNV)
3268 sv_upgrade(sv, SVt_PVNV);
3269 /* The +20 is pure guesswork. Configure test needed. --jhi */
3270 s = SvGROW_mutable(sv, NV_DIG + 20);
3271 olderrno = errno; /* some Xenix systems wipe out errno here */
3273 if (SvNVX(sv) == 0.0)
3274 (void)strcpy(s,"0");
3278 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3281 #ifdef FIXNEGATIVEZERO
3282 if (*s == '-' && s[1] == '0' && !s[2])
3292 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
3296 if (SvTYPE(sv) < SVt_PV)
3297 /* Typically the caller expects that sv_any is not NULL now. */
3298 sv_upgrade(sv, SVt_PV);
3302 const STRLEN len = s - SvPVX_const(sv);
3308 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3309 PTR2UV(sv),SvPVX_const(sv)));
3310 if (flags & SV_CONST_RETURN)
3311 return (char *)SvPVX_const(sv);
3312 if (flags & SV_MUTABLE_RETURN)
3313 return SvPVX_mutable(sv);
3317 len = strlen(tmpbuf);
3320 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3321 /* Sneaky stuff here */
3325 tsv = newSVpvn(tmpbuf, len);
3334 #ifdef FIXNEGATIVEZERO
3335 if (len == 2 && tmpbuf[0] == '-' && tmpbuf[1] == '0') {
3341 SvUPGRADE(sv, SVt_PV);
3344 s = SvGROW_mutable(sv, len + 1);
3347 return memcpy(s, tmpbuf, len + 1);
3352 =for apidoc sv_copypv
3354 Copies a stringified representation of the source SV into the
3355 destination SV. Automatically performs any necessary mg_get and
3356 coercion of numeric values into strings. Guaranteed to preserve
3357 UTF-8 flag even from overloaded objects. Similar in nature to
3358 sv_2pv[_flags] but operates directly on an SV instead of just the
3359 string. Mostly uses sv_2pv_flags to do its work, except when that
3360 would lose the UTF-8'ness of the PV.
3366 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3369 const char * const s = SvPV_const(ssv,len);
3370 sv_setpvn(dsv,s,len);
3378 =for apidoc sv_2pvbyte
3380 Return a pointer to the byte-encoded representation of the SV, and set *lp
3381 to its length. May cause the SV to be downgraded from UTF-8 as a
3384 Usually accessed via the C<SvPVbyte> macro.
3390 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3392 sv_utf8_downgrade(sv,0);
3393 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3397 =for apidoc sv_2pvutf8
3399 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3400 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3402 Usually accessed via the C<SvPVutf8> macro.
3408 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3410 sv_utf8_upgrade(sv);
3411 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3416 =for apidoc sv_2bool
3418 This function is only called on magical items, and is only used by
3419 sv_true() or its macro equivalent.
3425 Perl_sv_2bool(pTHX_ register SV *sv)
3433 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3434 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3435 return (bool)SvTRUE(tmpsv);
3436 return SvRV(sv) != 0;
3439 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3441 (*sv->sv_u.svu_pv > '0' ||
3442 Xpvtmp->xpv_cur > 1 ||
3443 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3450 return SvIVX(sv) != 0;
3453 return SvNVX(sv) != 0.0;
3461 =for apidoc sv_utf8_upgrade
3463 Converts the PV of an SV to its UTF-8-encoded form.
3464 Forces the SV to string form if it is not already.
3465 Always sets the SvUTF8 flag to avoid future validity checks even
3466 if all the bytes have hibit clear.
3468 This is not as a general purpose byte encoding to Unicode interface:
3469 use the Encode extension for that.
3471 =for apidoc sv_utf8_upgrade_flags
3473 Converts the PV of an SV to its UTF-8-encoded form.
3474 Forces the SV to string form if it is not already.
3475 Always sets the SvUTF8 flag to avoid future validity checks even
3476 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3477 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3478 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3480 This is not as a general purpose byte encoding to Unicode interface:
3481 use the Encode extension for that.
3487 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3489 if (sv == &PL_sv_undef)
3493 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3494 (void) sv_2pv_flags(sv,&len, flags);
3498 (void) SvPV_force(sv,len);
3507 sv_force_normal_flags(sv, 0);
3510 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3511 sv_recode_to_utf8(sv, PL_encoding);
3512 else { /* Assume Latin-1/EBCDIC */
3513 /* This function could be much more efficient if we
3514 * had a FLAG in SVs to signal if there are any hibit
3515 * chars in the PV. Given that there isn't such a flag
3516 * make the loop as fast as possible. */
3517 const U8 *s = (U8 *) SvPVX_const(sv);
3518 const U8 * const e = (U8 *) SvEND(sv);
3524 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3528 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3529 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
3531 SvPV_free(sv); /* No longer using what was there before. */
3533 SvPV_set(sv, (char*)recoded);
3534 SvCUR_set(sv, len - 1);
3535 SvLEN_set(sv, len); /* No longer know the real size. */
3537 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3544 =for apidoc sv_utf8_downgrade
3546 Attempts to convert the PV of an SV from characters to bytes.
3547 If the PV contains a character beyond byte, this conversion will fail;
3548 in this case, either returns false or, if C<fail_ok> is not
3551 This is not as a general purpose Unicode to byte encoding interface:
3552 use the Encode extension for that.
3558 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3560 if (SvPOKp(sv) && SvUTF8(sv)) {
3566 sv_force_normal_flags(sv, 0);
3568 s = (U8 *) SvPV(sv, len);
3569 if (!utf8_to_bytes(s, &len)) {
3574 Perl_croak(aTHX_ "Wide character in %s",
3577 Perl_croak(aTHX_ "Wide character");
3588 =for apidoc sv_utf8_encode
3590 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3591 flag off so that it looks like octets again.
3597 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3599 (void) sv_utf8_upgrade(sv);
3601 sv_force_normal_flags(sv, 0);
3603 if (SvREADONLY(sv)) {
3604 Perl_croak(aTHX_ PL_no_modify);
3610 =for apidoc sv_utf8_decode
3612 If the PV of the SV is an octet sequence in UTF-8
3613 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3614 so that it looks like a character. If the PV contains only single-byte
3615 characters, the C<SvUTF8> flag stays being off.
3616 Scans PV for validity and returns false if the PV is invalid UTF-8.
3622 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3628 /* The octets may have got themselves encoded - get them back as
3631 if (!sv_utf8_downgrade(sv, TRUE))
3634 /* it is actually just a matter of turning the utf8 flag on, but
3635 * we want to make sure everything inside is valid utf8 first.
3637 c = (const U8 *) SvPVX_const(sv);
3638 if (!is_utf8_string(c, SvCUR(sv)+1))
3640 e = (const U8 *) SvEND(sv);
3643 if (!UTF8_IS_INVARIANT(ch)) {
3653 =for apidoc sv_setsv
3655 Copies the contents of the source SV C<ssv> into the destination SV
3656 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3657 function if the source SV needs to be reused. Does not handle 'set' magic.
3658 Loosely speaking, it performs a copy-by-value, obliterating any previous
3659 content of the destination.
3661 You probably want to use one of the assortment of wrappers, such as
3662 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3663 C<SvSetMagicSV_nosteal>.
3665 =for apidoc sv_setsv_flags
3667 Copies the contents of the source SV C<ssv> into the destination SV
3668 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3669 function if the source SV needs to be reused. Does not handle 'set' magic.
3670 Loosely speaking, it performs a copy-by-value, obliterating any previous
3671 content of the destination.
3672 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3673 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3674 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3675 and C<sv_setsv_nomg> are implemented in terms of this function.
3677 You probably want to use one of the assortment of wrappers, such as
3678 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3679 C<SvSetMagicSV_nosteal>.
3681 This is the primary function for copying scalars, and most other
3682 copy-ish functions and macros use this underneath.
3688 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3690 register U32 sflags;
3696 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3698 sstr = &PL_sv_undef;
3699 stype = SvTYPE(sstr);
3700 dtype = SvTYPE(dstr);
3705 /* need to nuke the magic */
3707 SvRMAGICAL_off(dstr);
3710 /* There's a lot of redundancy below but we're going for speed here */
3715 if (dtype != SVt_PVGV) {
3716 (void)SvOK_off(dstr);
3724 sv_upgrade(dstr, SVt_IV);
3727 sv_upgrade(dstr, SVt_PVNV);
3731 sv_upgrade(dstr, SVt_PVIV);
3734 (void)SvIOK_only(dstr);
3735 SvIV_set(dstr, SvIVX(sstr));
3738 if (SvTAINTED(sstr))
3749 sv_upgrade(dstr, SVt_NV);
3754 sv_upgrade(dstr, SVt_PVNV);
3757 SvNV_set(dstr, SvNVX(sstr));
3758 (void)SvNOK_only(dstr);
3759 if (SvTAINTED(sstr))
3767 sv_upgrade(dstr, SVt_RV);
3768 else if (dtype == SVt_PVGV &&
3769 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3772 if (GvIMPORTED(dstr) != GVf_IMPORTED
3773 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3775 GvIMPORTED_on(dstr);
3784 #ifdef PERL_OLD_COPY_ON_WRITE
3785 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3786 if (dtype < SVt_PVIV)
3787 sv_upgrade(dstr, SVt_PVIV);
3794 sv_upgrade(dstr, SVt_PV);
3797 if (dtype < SVt_PVIV)
3798 sv_upgrade(dstr, SVt_PVIV);
3801 if (dtype < SVt_PVNV)
3802 sv_upgrade(dstr, SVt_PVNV);
3809 const char * const type = sv_reftype(sstr,0);
3811 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3813 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3818 if (dtype <= SVt_PVGV) {
3820 if (dtype != SVt_PVGV) {
3821 const char * const name = GvNAME(sstr);
3822 const STRLEN len = GvNAMELEN(sstr);
3823 /* don't upgrade SVt_PVLV: it can hold a glob */
3824 if (dtype != SVt_PVLV)
3825 sv_upgrade(dstr, SVt_PVGV);
3826 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3827 GvSTASH(dstr) = GvSTASH(sstr);
3829 Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3830 GvNAME(dstr) = savepvn(name, len);
3831 GvNAMELEN(dstr) = len;
3832 SvFAKE_on(dstr); /* can coerce to non-glob */
3835 #ifdef GV_UNIQUE_CHECK
3836 if (GvUNIQUE((GV*)dstr)) {
3837 Perl_croak(aTHX_ PL_no_modify);
3841 (void)SvOK_off(dstr);
3842 GvINTRO_off(dstr); /* one-shot flag */
3844 GvGP(dstr) = gp_ref(GvGP(sstr));
3845 if (SvTAINTED(sstr))
3847 if (GvIMPORTED(dstr) != GVf_IMPORTED
3848 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3850 GvIMPORTED_on(dstr);
3858 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3860 if ((int)SvTYPE(sstr) != stype) {
3861 stype = SvTYPE(sstr);
3862 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3866 if (stype == SVt_PVLV)
3867 SvUPGRADE(dstr, SVt_PVNV);
3869 SvUPGRADE(dstr, (U32)stype);
3872 sflags = SvFLAGS(sstr);
3874 if (sflags & SVf_ROK) {
3875 if (dtype >= SVt_PV) {
3876 if (dtype == SVt_PVGV) {
3877 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3879 const int intro = GvINTRO(dstr);
3881 #ifdef GV_UNIQUE_CHECK
3882 if (GvUNIQUE((GV*)dstr)) {
3883 Perl_croak(aTHX_ PL_no_modify);
3888 GvINTRO_off(dstr); /* one-shot flag */
3889 GvLINE(dstr) = CopLINE(PL_curcop);
3890 GvEGV(dstr) = (GV*)dstr;
3893 switch (SvTYPE(sref)) {
3896 SAVEGENERICSV(GvAV(dstr));
3898 dref = (SV*)GvAV(dstr);
3899 GvAV(dstr) = (AV*)sref;
3900 if (!GvIMPORTED_AV(dstr)
3901 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3903 GvIMPORTED_AV_on(dstr);
3908 SAVEGENERICSV(GvHV(dstr));
3910 dref = (SV*)GvHV(dstr);
3911 GvHV(dstr) = (HV*)sref;
3912 if (!GvIMPORTED_HV(dstr)
3913 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3915 GvIMPORTED_HV_on(dstr);
3920 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3921 SvREFCNT_dec(GvCV(dstr));
3922 GvCV(dstr) = Nullcv;
3923 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3924 PL_sub_generation++;
3926 SAVEGENERICSV(GvCV(dstr));
3929 dref = (SV*)GvCV(dstr);
3930 if (GvCV(dstr) != (CV*)sref) {
3931 CV* const cv = GvCV(dstr);
3933 if (!GvCVGEN((GV*)dstr) &&
3934 (CvROOT(cv) || CvXSUB(cv)))
3936 /* Redefining a sub - warning is mandatory if
3937 it was a const and its value changed. */
3938 if (ckWARN(WARN_REDEFINE)
3940 && (!CvCONST((CV*)sref)
3941 || sv_cmp(cv_const_sv(cv),
3942 cv_const_sv((CV*)sref)))))
3944 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3946 ? "Constant subroutine %s::%s redefined"
3947 : "Subroutine %s::%s redefined",
3948 HvNAME_get(GvSTASH((GV*)dstr)),
3949 GvENAME((GV*)dstr));
3953 cv_ckproto(cv, (GV*)dstr,
3955 ? SvPVX_const(sref) : Nullch);
3957 GvCV(dstr) = (CV*)sref;
3958 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3959 GvASSUMECV_on(dstr);
3960 PL_sub_generation++;
3962 if (!GvIMPORTED_CV(dstr)
3963 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3965 GvIMPORTED_CV_on(dstr);
3970 SAVEGENERICSV(GvIOp(dstr));
3972 dref = (SV*)GvIOp(dstr);
3973 GvIOp(dstr) = (IO*)sref;
3977 SAVEGENERICSV(GvFORM(dstr));
3979 dref = (SV*)GvFORM(dstr);
3980 GvFORM(dstr) = (CV*)sref;
3984 SAVEGENERICSV(GvSV(dstr));
3986 dref = (SV*)GvSV(dstr);
3988 if (!GvIMPORTED_SV(dstr)
3989 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3991 GvIMPORTED_SV_on(dstr);
3997 if (SvTAINTED(sstr))
4001 if (SvPVX_const(dstr)) {
4007 (void)SvOK_off(dstr);
4008 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4010 if (sflags & SVp_NOK) {
4012 /* Only set the public OK flag if the source has public OK. */
4013 if (sflags & SVf_NOK)
4014 SvFLAGS(dstr) |= SVf_NOK;
4015 SvNV_set(dstr, SvNVX(sstr));
4017 if (sflags & SVp_IOK) {
4018 (void)SvIOKp_on(dstr);
4019 if (sflags & SVf_IOK)
4020 SvFLAGS(dstr) |= SVf_IOK;
4021 if (sflags & SVf_IVisUV)
4023 SvIV_set(dstr, SvIVX(sstr));
4025 if (SvAMAGIC(sstr)) {
4029 else if (sflags & SVp_POK) {
4033 * Check to see if we can just swipe the string. If so, it's a
4034 * possible small lose on short strings, but a big win on long ones.
4035 * It might even be a win on short strings if SvPVX_const(dstr)
4036 * has to be allocated and SvPVX_const(sstr) has to be freed.
4039 /* Whichever path we take through the next code, we want this true,
4040 and doing it now facilitates the COW check. */
4041 (void)SvPOK_only(dstr);
4044 /* We're not already COW */
4045 ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4046 #ifndef PERL_OLD_COPY_ON_WRITE
4047 /* or we are, but dstr isn't a suitable target. */
4048 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4053 (sflags & SVs_TEMP) && /* slated for free anyway? */
4054 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4055 (!(flags & SV_NOSTEAL)) &&
4056 /* and we're allowed to steal temps */
4057 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4058 SvLEN(sstr) && /* and really is a string */
4059 /* and won't be needed again, potentially */
4060 !(PL_op && PL_op->op_type == OP_AASSIGN))
4061 #ifdef PERL_OLD_COPY_ON_WRITE
4062 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4063 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4064 && SvTYPE(sstr) >= SVt_PVIV)
4067 /* Failed the swipe test, and it's not a shared hash key either.
4068 Have to copy the string. */
4069 STRLEN len = SvCUR(sstr);
4070 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4071 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4072 SvCUR_set(dstr, len);
4073 *SvEND(dstr) = '\0';
4075 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4077 /* Either it's a shared hash key, or it's suitable for
4078 copy-on-write or we can swipe the string. */
4080 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4084 #ifdef PERL_OLD_COPY_ON_WRITE
4086 /* I believe I should acquire a global SV mutex if
4087 it's a COW sv (not a shared hash key) to stop
4088 it going un copy-on-write.
4089 If the source SV has gone un copy on write between up there
4090 and down here, then (assert() that) it is of the correct
4091 form to make it copy on write again */
4092 if ((sflags & (SVf_FAKE | SVf_READONLY))
4093 != (SVf_FAKE | SVf_READONLY)) {
4094 SvREADONLY_on(sstr);
4096 /* Make the source SV into a loop of 1.
4097 (about to become 2) */
4098 SV_COW_NEXT_SV_SET(sstr, sstr);
4102 /* Initial code is common. */
4103 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4108 /* making another shared SV. */
4109 STRLEN cur = SvCUR(sstr);
4110 STRLEN len = SvLEN(sstr);
4111 #ifdef PERL_OLD_COPY_ON_WRITE
4113 assert (SvTYPE(dstr) >= SVt_PVIV);
4114 /* SvIsCOW_normal */
4115 /* splice us in between source and next-after-source. */
4116 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4117 SV_COW_NEXT_SV_SET(sstr, dstr);
4118 SvPV_set(dstr, SvPVX_mutable(sstr));
4122 /* SvIsCOW_shared_hash */
4123 DEBUG_C(PerlIO_printf(Perl_debug_log,
4124 "Copy on write: Sharing hash\n"));
4126 assert (SvTYPE(dstr) >= SVt_PV);
4128 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4130 SvLEN_set(dstr, len);
4131 SvCUR_set(dstr, cur);
4132 SvREADONLY_on(dstr);
4134 /* Relesase a global SV mutex. */
4137 { /* Passes the swipe test. */
4138 SvPV_set(dstr, SvPVX_mutable(sstr));
4139 SvLEN_set(dstr, SvLEN(sstr));
4140 SvCUR_set(dstr, SvCUR(sstr));
4143 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4144 SvPV_set(sstr, Nullch);
4150 if (sflags & SVf_UTF8)
4152 if (sflags & SVp_NOK) {
4154 if (sflags & SVf_NOK)
4155 SvFLAGS(dstr) |= SVf_NOK;
4156 SvNV_set(dstr, SvNVX(sstr));
4158 if (sflags & SVp_IOK) {
4159 (void)SvIOKp_on(dstr);
4160 if (sflags & SVf_IOK)
4161 SvFLAGS(dstr) |= SVf_IOK;
4162 if (sflags & SVf_IVisUV)
4164 SvIV_set(dstr, SvIVX(sstr));
4167 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4168 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4169 smg->mg_ptr, smg->mg_len);
4170 SvRMAGICAL_on(dstr);
4173 else if (sflags & SVp_IOK) {
4174 if (sflags & SVf_IOK)
4175 (void)SvIOK_only(dstr);
4177 (void)SvOK_off(dstr);
4178 (void)SvIOKp_on(dstr);
4180 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4181 if (sflags & SVf_IVisUV)
4183 SvIV_set(dstr, SvIVX(sstr));
4184 if (sflags & SVp_NOK) {
4185 if (sflags & SVf_NOK)
4186 (void)SvNOK_on(dstr);
4188 (void)SvNOKp_on(dstr);
4189 SvNV_set(dstr, SvNVX(sstr));
4192 else if (sflags & SVp_NOK) {
4193 if (sflags & SVf_NOK)
4194 (void)SvNOK_only(dstr);
4196 (void)SvOK_off(dstr);
4199 SvNV_set(dstr, SvNVX(sstr));
4202 if (dtype == SVt_PVGV) {
4203 if (ckWARN(WARN_MISC))
4204 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4207 (void)SvOK_off(dstr);
4209 if (SvTAINTED(sstr))
4214 =for apidoc sv_setsv_mg
4216 Like C<sv_setsv>, but also handles 'set' magic.
4222 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4224 sv_setsv(dstr,sstr);
4228 #ifdef PERL_OLD_COPY_ON_WRITE
4230 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4232 STRLEN cur = SvCUR(sstr);
4233 STRLEN len = SvLEN(sstr);
4234 register char *new_pv;
4237 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4245 if (SvTHINKFIRST(dstr))
4246 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4247 else if (SvPVX_const(dstr))
4248 Safefree(SvPVX_const(dstr));
4252 SvUPGRADE(dstr, SVt_PVIV);
4254 assert (SvPOK(sstr));
4255 assert (SvPOKp(sstr));
4256 assert (!SvIOK(sstr));
4257 assert (!SvIOKp(sstr));
4258 assert (!SvNOK(sstr));
4259 assert (!SvNOKp(sstr));
4261 if (SvIsCOW(sstr)) {
4263 if (SvLEN(sstr) == 0) {
4264 /* source is a COW shared hash key. */
4265 DEBUG_C(PerlIO_printf(Perl_debug_log,
4266 "Fast copy on write: Sharing hash\n"));
4267 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4270 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4272 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4273 SvUPGRADE(sstr, SVt_PVIV);
4274 SvREADONLY_on(sstr);
4276 DEBUG_C(PerlIO_printf(Perl_debug_log,
4277 "Fast copy on write: Converting sstr to COW\n"));
4278 SV_COW_NEXT_SV_SET(dstr, sstr);
4280 SV_COW_NEXT_SV_SET(sstr, dstr);
4281 new_pv = SvPVX_mutable(sstr);
4284 SvPV_set(dstr, new_pv);
4285 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4288 SvLEN_set(dstr, len);
4289 SvCUR_set(dstr, cur);
4298 =for apidoc sv_setpvn
4300 Copies a string into an SV. The C<len> parameter indicates the number of
4301 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4302 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4308 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4310 register char *dptr;
4312 SV_CHECK_THINKFIRST_COW_DROP(sv);
4318 /* len is STRLEN which is unsigned, need to copy to signed */
4321 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4323 SvUPGRADE(sv, SVt_PV);
4325 dptr = SvGROW(sv, len + 1);
4326 Move(ptr,dptr,len,char);
4329 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4334 =for apidoc sv_setpvn_mg
4336 Like C<sv_setpvn>, but also handles 'set' magic.
4342 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4344 sv_setpvn(sv,ptr,len);
4349 =for apidoc sv_setpv
4351 Copies a string into an SV. The string must be null-terminated. Does not
4352 handle 'set' magic. See C<sv_setpv_mg>.
4358 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4360 register STRLEN len;
4362 SV_CHECK_THINKFIRST_COW_DROP(sv);
4368 SvUPGRADE(sv, SVt_PV);
4370 SvGROW(sv, len + 1);
4371 Move(ptr,SvPVX(sv),len+1,char);
4373 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4378 =for apidoc sv_setpv_mg
4380 Like C<sv_setpv>, but also handles 'set' magic.
4386 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4393 =for apidoc sv_usepvn
4395 Tells an SV to use C<ptr> to find its string value. Normally the string is
4396 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4397 The C<ptr> should point to memory that was allocated by C<malloc>. The
4398 string length, C<len>, must be supplied. This function will realloc the
4399 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4400 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4401 See C<sv_usepvn_mg>.
4407 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4410 SV_CHECK_THINKFIRST_COW_DROP(sv);
4411 SvUPGRADE(sv, SVt_PV);
4416 if (SvPVX_const(sv))
4419 allocate = PERL_STRLEN_ROUNDUP(len + 1);
4420 ptr = saferealloc (ptr, allocate);
4423 SvLEN_set(sv, allocate);
4425 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4430 =for apidoc sv_usepvn_mg
4432 Like C<sv_usepvn>, but also handles 'set' magic.
4438 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4440 sv_usepvn(sv,ptr,len);
4444 #ifdef PERL_OLD_COPY_ON_WRITE
4445 /* Need to do this *after* making the SV normal, as we need the buffer
4446 pointer to remain valid until after we've copied it. If we let go too early,
4447 another thread could invalidate it by unsharing last of the same hash key
4448 (which it can do by means other than releasing copy-on-write Svs)
4449 or by changing the other copy-on-write SVs in the loop. */
4451 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
4453 if (len) { /* this SV was SvIsCOW_normal(sv) */
4454 /* we need to find the SV pointing to us. */
4455 SV * const current = SV_COW_NEXT_SV(after);
4457 if (current == sv) {
4458 /* The SV we point to points back to us (there were only two of us
4460 Hence other SV is no longer copy on write either. */
4462 SvREADONLY_off(after);
4464 /* We need to follow the pointers around the loop. */
4466 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4469 /* don't loop forever if the structure is bust, and we have
4470 a pointer into a closed loop. */
4471 assert (current != after);
4472 assert (SvPVX_const(current) == pvx);
4474 /* Make the SV before us point to the SV after us. */
4475 SV_COW_NEXT_SV_SET(current, after);
4478 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4483 Perl_sv_release_IVX(pTHX_ register SV *sv)
4486 sv_force_normal_flags(sv, 0);
4492 =for apidoc sv_force_normal_flags
4494 Undo various types of fakery on an SV: if the PV is a shared string, make
4495 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4496 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4497 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4498 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4499 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4500 set to some other value.) In addition, the C<flags> parameter gets passed to
4501 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4502 with flags set to 0.
4508 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4510 #ifdef PERL_OLD_COPY_ON_WRITE
4511 if (SvREADONLY(sv)) {
4512 /* At this point I believe I should acquire a global SV mutex. */
4514 const char * const pvx = SvPVX_const(sv);
4515 const STRLEN len = SvLEN(sv);
4516 const STRLEN cur = SvCUR(sv);
4517 SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
4519 PerlIO_printf(Perl_debug_log,
4520 "Copy on write: Force normal %ld\n",
4526 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4527 SvPV_set(sv, (char*)0);
4529 if (flags & SV_COW_DROP_PV) {
4530 /* OK, so we don't need to copy our buffer. */
4533 SvGROW(sv, cur + 1);
4534 Move(pvx,SvPVX(sv),cur,char);
4538 sv_release_COW(sv, pvx, len, next);
4543 else if (IN_PERL_RUNTIME)
4544 Perl_croak(aTHX_ PL_no_modify);
4545 /* At this point I believe that I can drop the global SV mutex. */
4548 if (SvREADONLY(sv)) {
4550 const char * const pvx = SvPVX_const(sv);
4551 const STRLEN len = SvCUR(sv);
4554 SvPV_set(sv, Nullch);
4556 SvGROW(sv, len + 1);
4557 Move(pvx,SvPVX(sv),len,char);
4559 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4561 else if (IN_PERL_RUNTIME)
4562 Perl_croak(aTHX_ PL_no_modify);
4566 sv_unref_flags(sv, flags);
4567 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4574 Efficient removal of characters from the beginning of the string buffer.
4575 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4576 the string buffer. The C<ptr> becomes the first character of the adjusted
4577 string. Uses the "OOK hack".
4578 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4579 refer to the same chunk of data.
4585 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
4587 register STRLEN delta;
4588 if (!ptr || !SvPOKp(sv))
4590 delta = ptr - SvPVX_const(sv);
4591 SV_CHECK_THINKFIRST(sv);
4592 if (SvTYPE(sv) < SVt_PVIV)
4593 sv_upgrade(sv,SVt_PVIV);
4596 if (!SvLEN(sv)) { /* make copy of shared string */
4597 const char *pvx = SvPVX_const(sv);
4598 const STRLEN len = SvCUR(sv);
4599 SvGROW(sv, len + 1);
4600 Move(pvx,SvPVX(sv),len,char);
4604 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
4605 and we do that anyway inside the SvNIOK_off
4607 SvFLAGS(sv) |= SVf_OOK;
4610 SvLEN_set(sv, SvLEN(sv) - delta);
4611 SvCUR_set(sv, SvCUR(sv) - delta);
4612 SvPV_set(sv, SvPVX(sv) + delta);
4613 SvIV_set(sv, SvIVX(sv) + delta);
4617 =for apidoc sv_catpvn
4619 Concatenates the string onto the end of the string which is in the SV. The
4620 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4621 status set, then the bytes appended should be valid UTF-8.
4622 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4624 =for apidoc sv_catpvn_flags
4626 Concatenates the string onto the end of the string which is in the SV. The
4627 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4628 status set, then the bytes appended should be valid UTF-8.
4629 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4630 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4631 in terms of this function.
4637 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4640 const char *dstr = SvPV_force_flags(dsv, dlen, flags);
4642 SvGROW(dsv, dlen + slen + 1);
4644 sstr = SvPVX_const(dsv);
4645 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4646 SvCUR_set(dsv, SvCUR(dsv) + slen);
4648 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4650 if (flags & SV_SMAGIC)
4655 =for apidoc sv_catsv
4657 Concatenates the string from SV C<ssv> onto the end of the string in
4658 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4659 not 'set' magic. See C<sv_catsv_mg>.
4661 =for apidoc sv_catsv_flags
4663 Concatenates the string from SV C<ssv> onto the end of the string in
4664 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4665 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4666 and C<sv_catsv_nomg> are implemented in terms of this function.
4671 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4676 if ((spv = SvPV_const(ssv, slen))) {
4677 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4678 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4679 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4680 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4681 dsv->sv_flags doesn't have that bit set.
4682 Andy Dougherty 12 Oct 2001
4684 const I32 sutf8 = DO_UTF8(ssv);
4687 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4689 dutf8 = DO_UTF8(dsv);
4691 if (dutf8 != sutf8) {
4693 /* Not modifying source SV, so taking a temporary copy. */
4694 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4696 sv_utf8_upgrade(csv);
4697 spv = SvPV_const(csv, slen);
4700 sv_utf8_upgrade_nomg(dsv);
4702 sv_catpvn_nomg(dsv, spv, slen);
4705 if (flags & SV_SMAGIC)
4710 =for apidoc sv_catpv
4712 Concatenates the string onto the end of the string which is in the SV.
4713 If the SV has the UTF-8 status set, then the bytes appended should be
4714 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4719 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4721 register STRLEN len;
4727 junk = SvPV_force(sv, tlen);
4729 SvGROW(sv, tlen + len + 1);
4731 ptr = SvPVX_const(sv);
4732 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4733 SvCUR_set(sv, SvCUR(sv) + len);
4734 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4739 =for apidoc sv_catpv_mg
4741 Like C<sv_catpv>, but also handles 'set' magic.
4747 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4756 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4757 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4764 Perl_newSV(pTHX_ STRLEN len)
4770 sv_upgrade(sv, SVt_PV);
4771 SvGROW(sv, len + 1);
4776 =for apidoc sv_magicext
4778 Adds magic to an SV, upgrading it if necessary. Applies the
4779 supplied vtable and returns a pointer to the magic added.
4781 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4782 In particular, you can add magic to SvREADONLY SVs, and add more than
4783 one instance of the same 'how'.
4785 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4786 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4787 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4788 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4790 (This is now used as a subroutine by C<sv_magic>.)
4795 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
4796 const char* name, I32 namlen)
4800 if (SvTYPE(sv) < SVt_PVMG) {
4801 SvUPGRADE(sv, SVt_PVMG);
4803 Newxz(mg, 1, MAGIC);
4804 mg->mg_moremagic = SvMAGIC(sv);
4805 SvMAGIC_set(sv, mg);
4807 /* Sometimes a magic contains a reference loop, where the sv and
4808 object refer to each other. To prevent a reference loop that
4809 would prevent such objects being freed, we look for such loops
4810 and if we find one we avoid incrementing the object refcount.
4812 Note we cannot do this to avoid self-tie loops as intervening RV must
4813 have its REFCNT incremented to keep it in existence.
4816 if (!obj || obj == sv ||
4817 how == PERL_MAGIC_arylen ||
4818 how == PERL_MAGIC_qr ||
4819 how == PERL_MAGIC_symtab ||
4820 (SvTYPE(obj) == SVt_PVGV &&
4821 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4822 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4823 GvFORM(obj) == (CV*)sv)))
4828 mg->mg_obj = SvREFCNT_inc(obj);
4829 mg->mg_flags |= MGf_REFCOUNTED;
4832 /* Normal self-ties simply pass a null object, and instead of
4833 using mg_obj directly, use the SvTIED_obj macro to produce a
4834 new RV as needed. For glob "self-ties", we are tieing the PVIO
4835 with an RV obj pointing to the glob containing the PVIO. In
4836 this case, to avoid a reference loop, we need to weaken the
4840 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4841 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4847 mg->mg_len = namlen;
4850 mg->mg_ptr = savepvn(name, namlen);
4851 else if (namlen == HEf_SVKEY)
4852 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4854 mg->mg_ptr = (char *) name;
4856 mg->mg_virtual = vtable;
4860 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4865 =for apidoc sv_magic
4867 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4868 then adds a new magic item of type C<how> to the head of the magic list.
4870 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4871 handling of the C<name> and C<namlen> arguments.
4873 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4874 to add more than one instance of the same 'how'.
4880 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4882 const MGVTBL *vtable;
4885 #ifdef PERL_OLD_COPY_ON_WRITE
4887 sv_force_normal_flags(sv, 0);
4889 if (SvREADONLY(sv)) {
4891 /* its okay to attach magic to shared strings; the subsequent
4892 * upgrade to PVMG will unshare the string */
4893 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4896 && how != PERL_MAGIC_regex_global
4897 && how != PERL_MAGIC_bm
4898 && how != PERL_MAGIC_fm
4899 && how != PERL_MAGIC_sv
4900 && how != PERL_MAGIC_backref
4903 Perl_croak(aTHX_ PL_no_modify);
4906 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4907 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4908 /* sv_magic() refuses to add a magic of the same 'how' as an
4911 if (how == PERL_MAGIC_taint)
4919 vtable = &PL_vtbl_sv;
4921 case PERL_MAGIC_overload:
4922 vtable = &PL_vtbl_amagic;
4924 case PERL_MAGIC_overload_elem:
4925 vtable = &PL_vtbl_amagicelem;
4927 case PERL_MAGIC_overload_table:
4928 vtable = &PL_vtbl_ovrld;
4931 vtable = &PL_vtbl_bm;
4933 case PERL_MAGIC_regdata:
4934 vtable = &PL_vtbl_regdata;
4936 case PERL_MAGIC_regdatum:
4937 vtable = &PL_vtbl_regdatum;
4939 case PERL_MAGIC_env:
4940 vtable = &PL_vtbl_env;
4943 vtable = &PL_vtbl_fm;
4945 case PERL_MAGIC_envelem:
4946 vtable = &PL_vtbl_envelem;
4948 case PERL_MAGIC_regex_global:
4949 vtable = &PL_vtbl_mglob;
4951 case PERL_MAGIC_isa:
4952 vtable = &PL_vtbl_isa;
4954 case PERL_MAGIC_isaelem:
4955 vtable = &PL_vtbl_isaelem;
4957 case PERL_MAGIC_nkeys:
4958 vtable = &PL_vtbl_nkeys;
4960 case PERL_MAGIC_dbfile:
4963 case PERL_MAGIC_dbline:
4964 vtable = &PL_vtbl_dbline;
4966 #ifdef USE_LOCALE_COLLATE
4967 case PERL_MAGIC_collxfrm:
4968 vtable = &PL_vtbl_collxfrm;
4970 #endif /* USE_LOCALE_COLLATE */
4971 case PERL_MAGIC_tied:
4972 vtable = &PL_vtbl_pack;
4974 case PERL_MAGIC_tiedelem:
4975 case PERL_MAGIC_tiedscalar:
4976 vtable = &PL_vtbl_packelem;
4979 vtable = &PL_vtbl_regexp;
4981 case PERL_MAGIC_sig:
4982 vtable = &PL_vtbl_sig;
4984 case PERL_MAGIC_sigelem:
4985 vtable = &PL_vtbl_sigelem;
4987 case PERL_MAGIC_taint:
4988 vtable = &PL_vtbl_taint;
4990 case PERL_MAGIC_uvar:
4991 vtable = &PL_vtbl_uvar;
4993 case PERL_MAGIC_vec:
4994 vtable = &PL_vtbl_vec;
4996 case PERL_MAGIC_arylen_p:
4997 case PERL_MAGIC_rhash:
4998 case PERL_MAGIC_symtab:
4999 case PERL_MAGIC_vstring:
5002 case PERL_MAGIC_utf8:
5003 vtable = &PL_vtbl_utf8;
5005 case PERL_MAGIC_substr:
5006 vtable = &PL_vtbl_substr;
5008 case PERL_MAGIC_defelem:
5009 vtable = &PL_vtbl_defelem;
5011 case PERL_MAGIC_glob:
5012 vtable = &PL_vtbl_glob;
5014 case PERL_MAGIC_arylen:
5015 vtable = &PL_vtbl_arylen;
5017 case PERL_MAGIC_pos:
5018 vtable = &PL_vtbl_pos;
5020 case PERL_MAGIC_backref:
5021 vtable = &PL_vtbl_backref;
5023 case PERL_MAGIC_ext:
5024 /* Reserved for use by extensions not perl internals. */
5025 /* Useful for attaching extension internal data to perl vars. */
5026 /* Note that multiple extensions may clash if magical scalars */
5027 /* etc holding private data from one are passed to another. */
5031 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5034 /* Rest of work is done else where */
5035 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5038 case PERL_MAGIC_taint:
5041 case PERL_MAGIC_ext:
5042 case PERL_MAGIC_dbfile:
5049 =for apidoc sv_unmagic
5051 Removes all magic of type C<type> from an SV.
5057 Perl_sv_unmagic(pTHX_ SV *sv, int type)
5061 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5064 for (mg = *mgp; mg; mg = *mgp) {
5065 if (mg->mg_type == type) {
5066 const MGVTBL* const vtbl = mg->mg_virtual;
5067 *mgp = mg->mg_moremagic;
5068 if (vtbl && vtbl->svt_free)
5069 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5070 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5072 Safefree(mg->mg_ptr);
5073 else if (mg->mg_len == HEf_SVKEY)
5074 SvREFCNT_dec((SV*)mg->mg_ptr);
5075 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
5076 Safefree(mg->mg_ptr);
5078 if (mg->mg_flags & MGf_REFCOUNTED)
5079 SvREFCNT_dec(mg->mg_obj);
5083 mgp = &mg->mg_moremagic;
5087 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5094 =for apidoc sv_rvweaken
5096 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5097 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5098 push a back-reference to this RV onto the array of backreferences
5099 associated with that magic.
5105 Perl_sv_rvweaken(pTHX_ SV *sv)
5108 if (!SvOK(sv)) /* let undefs pass */
5111 Perl_croak(aTHX_ "Can't weaken a nonreference");
5112 else if (SvWEAKREF(sv)) {
5113 if (ckWARN(WARN_MISC))
5114 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5118 Perl_sv_add_backref(aTHX_ tsv, sv);
5124 /* Give tsv backref magic if it hasn't already got it, then push a
5125 * back-reference to sv onto the array associated with the backref magic.
5129 Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
5133 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
5134 av = (AV*)mg->mg_obj;
5137 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5138 /* av now has a refcnt of 2, which avoids it getting freed
5139 * before us during global cleanup. The extra ref is removed
5140 * by magic_killbackrefs() when tsv is being freed */
5142 if (AvFILLp(av) >= AvMAX(av)) {
5143 av_extend(av, AvFILLp(av)+1);
5145 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5148 /* delete a back-reference to ourselves from the backref magic associated
5149 * with the SV we point to.
5153 S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
5159 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) {
5160 if (PL_in_clean_all)
5163 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
5164 Perl_croak(aTHX_ "panic: del_backref");
5165 av = (AV *)mg->mg_obj;
5167 /* We shouldn't be in here more than once, but for paranoia reasons lets
5169 for (i = AvFILLp(av); i >= 0; i--) {
5171 const SSize_t fill = AvFILLp(av);
5173 /* We weren't the last entry.
5174 An unordered list has this property that you can take the
5175 last element off the end to fill the hole, and it's still
5176 an unordered list :-)
5181 AvFILLp(av) = fill - 1;
5187 =for apidoc sv_insert
5189 Inserts a string at the specified offset/length within the SV. Similar to
5190 the Perl substr() function.
5196 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
5200 register char *midend;
5201 register char *bigend;
5207 Perl_croak(aTHX_ "Can't modify non-existent substring");
5208 SvPV_force(bigstr, curlen);
5209 (void)SvPOK_only_UTF8(bigstr);
5210 if (offset + len > curlen) {
5211 SvGROW(bigstr, offset+len+1);
5212 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5213 SvCUR_set(bigstr, offset+len);
5217 i = littlelen - len;
5218 if (i > 0) { /* string might grow */
5219 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5220 mid = big + offset + len;
5221 midend = bigend = big + SvCUR(bigstr);
5224 while (midend > mid) /* shove everything down */
5225 *--bigend = *--midend;
5226 Move(little,big+offset,littlelen,char);
5227 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5232 Move(little,SvPVX(bigstr)+offset,len,char);
5237 big = SvPVX(bigstr);
5240 bigend = big + SvCUR(bigstr);
5242 if (midend > bigend)
5243 Perl_croak(aTHX_ "panic: sv_insert");
5245 if (mid - big > bigend - midend) { /* faster to shorten from end */
5247 Move(little, mid, littlelen,char);
5250 i = bigend - midend;
5252 Move(midend, mid, i,char);
5256 SvCUR_set(bigstr, mid - big);
5258 else if ((i = mid - big)) { /* faster from front */
5259 midend -= littlelen;
5261 sv_chop(bigstr,midend-i);
5266 Move(little, mid, littlelen,char);
5268 else if (littlelen) {
5269 midend -= littlelen;
5270 sv_chop(bigstr,midend);
5271 Move(little,midend,littlelen,char);
5274 sv_chop(bigstr,midend);
5280 =for apidoc sv_replace
5282 Make the first argument a copy of the second, then delete the original.
5283 The target SV physically takes over ownership of the body of the source SV
5284 and inherits its flags; however, the target keeps any magic it owns,
5285 and any magic in the source is discarded.
5286 Note that this is a rather specialist SV copying operation; most of the
5287 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5293 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5295 const U32 refcnt = SvREFCNT(sv);
5296 SV_CHECK_THINKFIRST_COW_DROP(sv);
5297 if (SvREFCNT(nsv) != 1) {
5298 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
5299 UVuf " != 1)", (UV) SvREFCNT(nsv));
5301 if (SvMAGICAL(sv)) {
5305 sv_upgrade(nsv, SVt_PVMG);
5306 SvMAGIC_set(nsv, SvMAGIC(sv));
5307 SvFLAGS(nsv) |= SvMAGICAL(sv);
5309 SvMAGIC_set(sv, NULL);
5313 assert(!SvREFCNT(sv));
5314 #ifdef DEBUG_LEAKING_SCALARS
5315 sv->sv_flags = nsv->sv_flags;
5316 sv->sv_any = nsv->sv_any;
5317 sv->sv_refcnt = nsv->sv_refcnt;
5318 sv->sv_u = nsv->sv_u;
5320 StructCopy(nsv,sv,SV);
5322 /* Currently could join these into one piece of pointer arithmetic, but
5323 it would be unclear. */
5324 if(SvTYPE(sv) == SVt_IV)
5326 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5327 else if (SvTYPE(sv) == SVt_RV) {
5328 SvANY(sv) = &sv->sv_u.svu_rv;
5332 #ifdef PERL_OLD_COPY_ON_WRITE
5333 if (SvIsCOW_normal(nsv)) {
5334 /* We need to follow the pointers around the loop to make the
5335 previous SV point to sv, rather than nsv. */
5338 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5341 assert(SvPVX_const(current) == SvPVX_const(nsv));
5343 /* Make the SV before us point to the SV after us. */
5345 PerlIO_printf(Perl_debug_log, "previous is\n");
5347 PerlIO_printf(Perl_debug_log,
5348 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5349 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5351 SV_COW_NEXT_SV_SET(current, sv);
5354 SvREFCNT(sv) = refcnt;
5355 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5361 =for apidoc sv_clear
5363 Clear an SV: call any destructors, free up any memory used by the body,
5364 and free the body itself. The SV's head is I<not> freed, although
5365 its type is set to all 1's so that it won't inadvertently be assumed
5366 to be live during global destruction etc.
5367 This function should only be called when REFCNT is zero. Most of the time
5368 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5375 Perl_sv_clear(pTHX_ register SV *sv)
5378 void** old_body_arena;
5379 size_t old_body_offset;
5380 const U32 type = SvTYPE(sv);
5383 assert(SvREFCNT(sv) == 0);
5389 old_body_offset = 0;
5392 if (PL_defstash) { /* Still have a symbol table? */
5397 stash = SvSTASH(sv);
5398 destructor = StashHANDLER(stash,DESTROY);
5400 SV* const tmpref = newRV(sv);
5401 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5403 PUSHSTACKi(PERLSI_DESTROY);
5408 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5414 if(SvREFCNT(tmpref) < 2) {
5415 /* tmpref is not kept alive! */
5417 SvRV_set(tmpref, NULL);
5420 SvREFCNT_dec(tmpref);
5422 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5426 if (PL_in_clean_objs)
5427 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5429 /* DESTROY gave object new lease on life */
5435 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5436 SvOBJECT_off(sv); /* Curse the object. */
5437 if (type != SVt_PVIO)
5438 --PL_sv_objcount; /* XXX Might want something more general */
5441 if (type >= SVt_PVMG) {
5444 if (type == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
5445 SvREFCNT_dec(SvSTASH(sv));
5450 IoIFP(sv) != PerlIO_stdin() &&
5451 IoIFP(sv) != PerlIO_stdout() &&
5452 IoIFP(sv) != PerlIO_stderr())
5454 io_close((IO*)sv, FALSE);
5456 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5457 PerlDir_close(IoDIRP(sv));
5458 IoDIRP(sv) = (DIR*)NULL;
5459 Safefree(IoTOP_NAME(sv));
5460 Safefree(IoFMT_NAME(sv));
5461 Safefree(IoBOTTOM_NAME(sv));
5462 /* PVIOs aren't from arenas */
5465 old_body_arena = &PL_body_roots[SVt_PVBM];
5468 old_body_arena = &PL_body_roots[SVt_PVCV];
5470 /* PVFMs aren't from arenas */
5475 old_body_arena = &PL_body_roots[SVt_PVHV];
5476 old_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill);
5480 old_body_arena = &PL_body_roots[SVt_PVAV];
5481 old_body_offset = STRUCT_OFFSET(XPVAV, xav_fill);
5484 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5485 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5486 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5487 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5489 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5490 SvREFCNT_dec(LvTARG(sv));
5491 old_body_arena = &PL_body_roots[SVt_PVLV];
5495 Safefree(GvNAME(sv));
5496 /* If we're in a stash, we don't own a reference to it. However it does
5497 have a back reference to us, which needs to be cleared. */
5499 sv_del_backref((SV*)GvSTASH(sv), sv);
5500 old_body_arena = &PL_body_roots[SVt_PVGV];
5503 old_body_arena = &PL_body_roots[SVt_PVMG];
5506 old_body_arena = &PL_body_roots[SVt_PVNV];
5509 old_body_arena = &PL_body_roots[SVt_PVIV];
5510 old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur);
5512 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5514 SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
5515 /* Don't even bother with turning off the OOK flag. */
5519 old_body_arena = &PL_body_roots[SVt_PV];
5520 old_body_offset = STRUCT_OFFSET(XPV, xpv_cur);
5524 SV *target = SvRV(sv);
5526 sv_del_backref(target, sv);
5528 SvREFCNT_dec(target);
5530 #ifdef PERL_OLD_COPY_ON_WRITE
5531 else if (SvPVX_const(sv)) {
5533 /* I believe I need to grab the global SV mutex here and
5534 then recheck the COW status. */
5536 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5539 sv_release_COW(sv, SvPVX_const(sv), SvLEN(sv),
5540 SV_COW_NEXT_SV(sv));
5541 /* And drop it here. */
5543 } else if (SvLEN(sv)) {
5544 Safefree(SvPVX_const(sv));
5548 else if (SvPVX_const(sv) && SvLEN(sv))
5549 Safefree(SvPVX_mutable(sv));
5550 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5551 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5557 old_body_arena = PL_body_roots[SVt_NV];
5561 SvFLAGS(sv) &= SVf_BREAK;
5562 SvFLAGS(sv) |= SVTYPEMASK;
5565 if (old_body_arena) {
5566 del_body(((char *)SvANY(sv) + old_body_offset), old_body_arena);
5570 if (type > SVt_RV) {
5571 my_safefree(SvANY(sv));
5576 =for apidoc sv_newref
5578 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5585 Perl_sv_newref(pTHX_ SV *sv)
5595 Decrement an SV's reference count, and if it drops to zero, call
5596 C<sv_clear> to invoke destructors and free up any memory used by
5597 the body; finally, deallocate the SV's head itself.
5598 Normally called via a wrapper macro C<SvREFCNT_dec>.
5604 Perl_sv_free(pTHX_ SV *sv)
5609 if (SvREFCNT(sv) == 0) {
5610 if (SvFLAGS(sv) & SVf_BREAK)
5611 /* this SV's refcnt has been artificially decremented to
5612 * trigger cleanup */
5614 if (PL_in_clean_all) /* All is fair */
5616 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5617 /* make sure SvREFCNT(sv)==0 happens very seldom */
5618 SvREFCNT(sv) = (~(U32)0)/2;
5621 if (ckWARN_d(WARN_INTERNAL)) {
5622 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5623 "Attempt to free unreferenced scalar: SV 0x%"UVxf
5624 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5625 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5626 Perl_dump_sv_child(aTHX_ sv);
5631 if (--(SvREFCNT(sv)) > 0)
5633 Perl_sv_free2(aTHX_ sv);
5637 Perl_sv_free2(pTHX_ SV *sv)
5642 if (ckWARN_d(WARN_DEBUGGING))
5643 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5644 "Attempt to free temp prematurely: SV 0x%"UVxf
5645 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5649 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5650 /* make sure SvREFCNT(sv)==0 happens very seldom */
5651 SvREFCNT(sv) = (~(U32)0)/2;
5662 Returns the length of the string in the SV. Handles magic and type
5663 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5669 Perl_sv_len(pTHX_ register SV *sv)
5677 len = mg_length(sv);
5679 (void)SvPV_const(sv, len);
5684 =for apidoc sv_len_utf8
5686 Returns the number of characters in the string in an SV, counting wide
5687 UTF-8 bytes as a single character. Handles magic and type coercion.
5693 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
5694 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
5695 * (Note that the mg_len is not the length of the mg_ptr field.)
5700 Perl_sv_len_utf8(pTHX_ register SV *sv)
5706 return mg_length(sv);
5710 const U8 *s = (U8*)SvPV_const(sv, len);
5711 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
5713 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
5715 #ifdef PERL_UTF8_CACHE_ASSERT
5716 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
5720 ulen = Perl_utf8_length(aTHX_ s, s + len);
5721 if (!mg && !SvREADONLY(sv)) {
5722 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5723 mg = mg_find(sv, PERL_MAGIC_utf8);
5733 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
5734 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5735 * between UTF-8 and byte offsets. There are two (substr offset and substr
5736 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
5737 * and byte offset) cache positions.
5739 * The mg_len field is used by sv_len_utf8(), see its comments.
5740 * Note that the mg_len is not the length of the mg_ptr field.
5744 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i,
5745 I32 offsetp, const U8 *s, const U8 *start)
5749 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5751 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
5755 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5757 Newxz(*cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5758 (*mgp)->mg_ptr = (char *) *cachep;
5762 (*cachep)[i] = offsetp;
5763 (*cachep)[i+1] = s - start;
5771 * S_utf8_mg_pos() is used to query and update mg_ptr field of
5772 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5773 * between UTF-8 and byte offsets. See also the comments of
5774 * S_utf8_mg_pos_init().
5778 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)
5782 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5784 *mgp = mg_find(sv, PERL_MAGIC_utf8);
5785 if (*mgp && (*mgp)->mg_ptr) {
5786 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5787 ASSERT_UTF8_CACHE(*cachep);
5788 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
5790 else { /* We will skip to the right spot. */
5795 /* The assumption is that going backward is half
5796 * the speed of going forward (that's where the
5797 * 2 * backw in the below comes from). (The real
5798 * figure of course depends on the UTF-8 data.) */
5800 if ((*cachep)[i] > (STRLEN)uoff) {
5802 backw = (*cachep)[i] - (STRLEN)uoff;
5804 if (forw < 2 * backw)
5807 p = start + (*cachep)[i+1];
5809 /* Try this only for the substr offset (i == 0),
5810 * not for the substr length (i == 2). */
5811 else if (i == 0) { /* (*cachep)[i] < uoff */
5812 const STRLEN ulen = sv_len_utf8(sv);
5814 if ((STRLEN)uoff < ulen) {
5815 forw = (STRLEN)uoff - (*cachep)[i];
5816 backw = ulen - (STRLEN)uoff;
5818 if (forw < 2 * backw)
5819 p = start + (*cachep)[i+1];
5824 /* If the string is not long enough for uoff,
5825 * we could extend it, but not at this low a level. */
5829 if (forw < 2 * backw) {
5836 while (UTF8_IS_CONTINUATION(*p))
5841 /* Update the cache. */
5842 (*cachep)[i] = (STRLEN)uoff;
5843 (*cachep)[i+1] = p - start;
5845 /* Drop the stale "length" cache */
5854 if (found) { /* Setup the return values. */
5855 *offsetp = (*cachep)[i+1];
5856 *sp = start + *offsetp;
5859 *offsetp = send - start;
5861 else if (*sp < start) {
5867 #ifdef PERL_UTF8_CACHE_ASSERT
5872 while (n-- && s < send)
5876 assert(*offsetp == s - start);
5877 assert((*cachep)[0] == (STRLEN)uoff);
5878 assert((*cachep)[1] == *offsetp);
5880 ASSERT_UTF8_CACHE(*cachep);
5889 =for apidoc sv_pos_u2b
5891 Converts the value pointed to by offsetp from a count of UTF-8 chars from
5892 the start of the string, to a count of the equivalent number of bytes; if
5893 lenp is non-zero, it does the same to lenp, but this time starting from
5894 the offset, rather than from the start of the string. Handles magic and
5901 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
5902 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5903 * byte offsets. See also the comments of S_utf8_mg_pos().
5908 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5916 start = (U8*)SvPV_const(sv, len);
5920 const U8 *s = start;
5921 I32 uoffset = *offsetp;
5922 const U8 * const send = s + len;
5926 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
5928 if (!found && uoffset > 0) {
5929 while (s < send && uoffset--)
5933 if (utf8_mg_pos_init(sv, &mg, &cache, 0, *offsetp, s, start))
5935 *offsetp = s - start;
5940 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) {
5944 if (!found && *lenp > 0) {
5947 while (s < send && ulen--)
5951 utf8_mg_pos_init(sv, &mg, &cache, 2, *lenp, s, start);
5955 ASSERT_UTF8_CACHE(cache);
5967 =for apidoc sv_pos_b2u
5969 Converts the value pointed to by offsetp from a count of bytes from the
5970 start of the string, to a count of the equivalent number of UTF-8 chars.
5971 Handles magic and type coercion.
5977 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
5978 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5979 * byte offsets. See also the comments of S_utf8_mg_pos().
5984 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
5992 s = (const U8*)SvPV_const(sv, len);
5993 if ((I32)len < *offsetp)
5994 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5996 const U8* send = s + *offsetp;
5998 STRLEN *cache = NULL;
6002 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6003 mg = mg_find(sv, PERL_MAGIC_utf8);
6004 if (mg && mg->mg_ptr) {
6005 cache = (STRLEN *) mg->mg_ptr;
6006 if (cache[1] == (STRLEN)*offsetp) {
6007 /* An exact match. */
6008 *offsetp = cache[0];
6012 else if (cache[1] < (STRLEN)*offsetp) {
6013 /* We already know part of the way. */
6016 /* Let the below loop do the rest. */
6018 else { /* cache[1] > *offsetp */
6019 /* We already know all of the way, now we may
6020 * be able to walk back. The same assumption
6021 * is made as in S_utf8_mg_pos(), namely that
6022 * walking backward is twice slower than
6023 * walking forward. */
6024 const STRLEN forw = *offsetp;
6025 STRLEN backw = cache[1] - *offsetp;
6027 if (!(forw < 2 * backw)) {
6028 const U8 *p = s + cache[1];
6035 while (UTF8_IS_CONTINUATION(*p)) {
6043 *offsetp = cache[0];
6045 /* Drop the stale "length" cache */
6053 ASSERT_UTF8_CACHE(cache);
6059 /* Call utf8n_to_uvchr() to validate the sequence
6060 * (unless a simple non-UTF character) */
6061 if (!UTF8_IS_INVARIANT(*s))
6062 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
6071 if (!SvREADONLY(sv)) {
6073 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6074 mg = mg_find(sv, PERL_MAGIC_utf8);
6079 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6080 mg->mg_ptr = (char *) cache;
6085 cache[1] = *offsetp;
6086 /* Drop the stale "length" cache */
6099 Returns a boolean indicating whether the strings in the two SVs are
6100 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6101 coerce its args to strings if necessary.
6107 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6115 SV* svrecode = Nullsv;
6122 pv1 = SvPV_const(sv1, cur1);
6129 pv2 = SvPV_const(sv2, cur2);
6131 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6132 /* Differing utf8ness.
6133 * Do not UTF8size the comparands as a side-effect. */
6136 svrecode = newSVpvn(pv2, cur2);
6137 sv_recode_to_utf8(svrecode, PL_encoding);
6138 pv2 = SvPV_const(svrecode, cur2);
6141 svrecode = newSVpvn(pv1, cur1);
6142 sv_recode_to_utf8(svrecode, PL_encoding);
6143 pv1 = SvPV_const(svrecode, cur1);
6145 /* Now both are in UTF-8. */
6147 SvREFCNT_dec(svrecode);
6152 bool is_utf8 = TRUE;
6155 /* sv1 is the UTF-8 one,
6156 * if is equal it must be downgrade-able */
6157 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6163 /* sv2 is the UTF-8 one,
6164 * if is equal it must be downgrade-able */
6165 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6171 /* Downgrade not possible - cannot be eq */
6179 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6182 SvREFCNT_dec(svrecode);
6193 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6194 string in C<sv1> is less than, equal to, or greater than the string in
6195 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6196 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6202 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6205 const char *pv1, *pv2;
6208 SV *svrecode = Nullsv;
6215 pv1 = SvPV_const(sv1, cur1);
6222 pv2 = SvPV_const(sv2, cur2);
6224 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6225 /* Differing utf8ness.
6226 * Do not UTF8size the comparands as a side-effect. */
6229 svrecode = newSVpvn(pv2, cur2);
6230 sv_recode_to_utf8(svrecode, PL_encoding);
6231 pv2 = SvPV_const(svrecode, cur2);
6234 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6239 svrecode = newSVpvn(pv1, cur1);
6240 sv_recode_to_utf8(svrecode, PL_encoding);
6241 pv1 = SvPV_const(svrecode, cur1);
6244 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6250 cmp = cur2 ? -1 : 0;
6254 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6257 cmp = retval < 0 ? -1 : 1;
6258 } else if (cur1 == cur2) {
6261 cmp = cur1 < cur2 ? -1 : 1;
6266 SvREFCNT_dec(svrecode);
6275 =for apidoc sv_cmp_locale
6277 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6278 'use bytes' aware, handles get magic, and will coerce its args to strings
6279 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6285 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6287 #ifdef USE_LOCALE_COLLATE
6293 if (PL_collation_standard)
6297 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6299 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6301 if (!pv1 || !len1) {
6312 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6315 return retval < 0 ? -1 : 1;
6318 * When the result of collation is equality, that doesn't mean
6319 * that there are no differences -- some locales exclude some
6320 * characters from consideration. So to avoid false equalities,
6321 * we use the raw string as a tiebreaker.
6327 #endif /* USE_LOCALE_COLLATE */
6329 return sv_cmp(sv1, sv2);
6333 #ifdef USE_LOCALE_COLLATE
6336 =for apidoc sv_collxfrm
6338 Add Collate Transform magic to an SV if it doesn't already have it.
6340 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6341 scalar data of the variable, but transformed to such a format that a normal
6342 memory comparison can be used to compare the data according to the locale
6349 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6353 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6354 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6360 Safefree(mg->mg_ptr);
6361 s = SvPV_const(sv, len);
6362 if ((xf = mem_collxfrm(s, len, &xlen))) {
6363 if (SvREADONLY(sv)) {
6366 return xf + sizeof(PL_collation_ix);
6369 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6370 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6383 if (mg && mg->mg_ptr) {
6385 return mg->mg_ptr + sizeof(PL_collation_ix);
6393 #endif /* USE_LOCALE_COLLATE */
6398 Get a line from the filehandle and store it into the SV, optionally
6399 appending to the currently-stored string.
6405 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6409 register STDCHAR rslast;
6410 register STDCHAR *bp;
6416 if (SvTHINKFIRST(sv))
6417 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6418 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6420 However, perlbench says it's slower, because the existing swipe code
6421 is faster than copy on write.
6422 Swings and roundabouts. */
6423 SvUPGRADE(sv, SVt_PV);
6428 if (PerlIO_isutf8(fp)) {
6430 sv_utf8_upgrade_nomg(sv);
6431 sv_pos_u2b(sv,&append,0);
6433 } else if (SvUTF8(sv)) {
6434 SV * const tsv = NEWSV(0,0);
6435 sv_gets(tsv, fp, 0);
6436 sv_utf8_upgrade_nomg(tsv);
6437 SvCUR_set(sv,append);
6440 goto return_string_or_null;
6445 if (PerlIO_isutf8(fp))
6448 if (IN_PERL_COMPILETIME) {
6449 /* we always read code in line mode */
6453 else if (RsSNARF(PL_rs)) {
6454 /* If it is a regular disk file use size from stat() as estimate
6455 of amount we are going to read - may result in malloc-ing
6456 more memory than we realy need if layers bellow reduce
6457 size we read (e.g. CRLF or a gzip layer)
6460 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6461 const Off_t offset = PerlIO_tell(fp);
6462 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6463 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6469 else if (RsRECORD(PL_rs)) {
6473 /* Grab the size of the record we're getting */
6474 recsize = SvIV(SvRV(PL_rs));
6475 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6478 /* VMS wants read instead of fread, because fread doesn't respect */
6479 /* RMS record boundaries. This is not necessarily a good thing to be */
6480 /* doing, but we've got no other real choice - except avoid stdio
6481 as implementation - perhaps write a :vms layer ?
6483 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6485 bytesread = PerlIO_read(fp, buffer, recsize);
6489 SvCUR_set(sv, bytesread += append);
6490 buffer[bytesread] = '\0';
6491 goto return_string_or_null;
6493 else if (RsPARA(PL_rs)) {
6499 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6500 if (PerlIO_isutf8(fp)) {
6501 rsptr = SvPVutf8(PL_rs, rslen);
6504 if (SvUTF8(PL_rs)) {
6505 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6506 Perl_croak(aTHX_ "Wide character in $/");
6509 rsptr = SvPV_const(PL_rs, rslen);
6513 rslast = rslen ? rsptr[rslen - 1] : '\0';
6515 if (rspara) { /* have to do this both before and after */
6516 do { /* to make sure file boundaries work right */
6519 i = PerlIO_getc(fp);
6523 PerlIO_ungetc(fp,i);
6529 /* See if we know enough about I/O mechanism to cheat it ! */
6531 /* This used to be #ifdef test - it is made run-time test for ease
6532 of abstracting out stdio interface. One call should be cheap
6533 enough here - and may even be a macro allowing compile
6537 if (PerlIO_fast_gets(fp)) {
6540 * We're going to steal some values from the stdio struct
6541 * and put EVERYTHING in the innermost loop into registers.
6543 register STDCHAR *ptr;
6547 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6548 /* An ungetc()d char is handled separately from the regular
6549 * buffer, so we getc() it back out and stuff it in the buffer.
6551 i = PerlIO_getc(fp);
6552 if (i == EOF) return 0;
6553 *(--((*fp)->_ptr)) = (unsigned char) i;
6557 /* Here is some breathtakingly efficient cheating */
6559 cnt = PerlIO_get_cnt(fp); /* get count into register */
6560 /* make sure we have the room */
6561 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
6562 /* Not room for all of it
6563 if we are looking for a separator and room for some
6565 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
6566 /* just process what we have room for */
6567 shortbuffered = cnt - SvLEN(sv) + append + 1;
6568 cnt -= shortbuffered;
6572 /* remember that cnt can be negative */
6573 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
6578 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
6579 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
6580 DEBUG_P(PerlIO_printf(Perl_debug_log,
6581 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6582 DEBUG_P(PerlIO_printf(Perl_debug_log,
6583 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6584 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6585 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6590 while (cnt > 0) { /* this | eat */
6592 if ((*bp++ = *ptr++) == rslast) /* really | dust */
6593 goto thats_all_folks; /* screams | sed :-) */
6597 Copy(ptr, bp, cnt, char); /* this | eat */
6598 bp += cnt; /* screams | dust */
6599 ptr += cnt; /* louder | sed :-) */
6604 if (shortbuffered) { /* oh well, must extend */
6605 cnt = shortbuffered;
6607 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6609 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6610 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6614 DEBUG_P(PerlIO_printf(Perl_debug_log,
6615 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6616 PTR2UV(ptr),(long)cnt));
6617 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6619 DEBUG_P(PerlIO_printf(Perl_debug_log,
6620 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6621 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6622 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6624 /* This used to call 'filbuf' in stdio form, but as that behaves like
6625 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6626 another abstraction. */
6627 i = PerlIO_getc(fp); /* get more characters */
6629 DEBUG_P(PerlIO_printf(Perl_debug_log,
6630 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6631 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6632 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6634 cnt = PerlIO_get_cnt(fp);
6635 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
6636 DEBUG_P(PerlIO_printf(Perl_debug_log,
6637 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6639 if (i == EOF) /* all done for ever? */
6640 goto thats_really_all_folks;
6642 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6644 SvGROW(sv, bpx + cnt + 2);
6645 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6647 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
6649 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
6650 goto thats_all_folks;
6654 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
6655 memNE((char*)bp - rslen, rsptr, rslen))
6656 goto screamer; /* go back to the fray */
6657 thats_really_all_folks:
6659 cnt += shortbuffered;
6660 DEBUG_P(PerlIO_printf(Perl_debug_log,
6661 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6662 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
6663 DEBUG_P(PerlIO_printf(Perl_debug_log,
6664 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6665 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6666 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6668 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
6669 DEBUG_P(PerlIO_printf(Perl_debug_log,
6670 "Screamer: done, len=%ld, string=|%.*s|\n",
6671 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
6675 /*The big, slow, and stupid way. */
6676 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
6678 Newx(buf, 8192, STDCHAR);
6686 register const STDCHAR *bpe = buf + sizeof(buf);
6688 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6689 ; /* keep reading */
6693 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6694 /* Accomodate broken VAXC compiler, which applies U8 cast to
6695 * both args of ?: operator, causing EOF to change into 255
6698 i = (U8)buf[cnt - 1];
6704 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
6706 sv_catpvn(sv, (char *) buf, cnt);
6708 sv_setpvn(sv, (char *) buf, cnt);
6710 if (i != EOF && /* joy */
6712 SvCUR(sv) < rslen ||
6713 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6717 * If we're reading from a TTY and we get a short read,
6718 * indicating that the user hit his EOF character, we need
6719 * to notice it now, because if we try to read from the TTY
6720 * again, the EOF condition will disappear.
6722 * The comparison of cnt to sizeof(buf) is an optimization
6723 * that prevents unnecessary calls to feof().
6727 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
6731 #ifdef USE_HEAP_INSTEAD_OF_STACK
6736 if (rspara) { /* have to do this both before and after */
6737 while (i != EOF) { /* to make sure file boundaries work right */
6738 i = PerlIO_getc(fp);
6740 PerlIO_ungetc(fp,i);
6746 return_string_or_null:
6747 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
6753 Auto-increment of the value in the SV, doing string to numeric conversion
6754 if necessary. Handles 'get' magic.
6760 Perl_sv_inc(pTHX_ register SV *sv)
6768 if (SvTHINKFIRST(sv)) {
6770 sv_force_normal_flags(sv, 0);
6771 if (SvREADONLY(sv)) {
6772 if (IN_PERL_RUNTIME)
6773 Perl_croak(aTHX_ PL_no_modify);
6777 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6779 i = PTR2IV(SvRV(sv));
6784 flags = SvFLAGS(sv);
6785 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6786 /* It's (privately or publicly) a float, but not tested as an
6787 integer, so test it to see. */
6789 flags = SvFLAGS(sv);
6791 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6792 /* It's publicly an integer, or privately an integer-not-float */
6793 #ifdef PERL_PRESERVE_IVUV
6797 if (SvUVX(sv) == UV_MAX)
6798 sv_setnv(sv, UV_MAX_P1);
6800 (void)SvIOK_only_UV(sv);
6801 SvUV_set(sv, SvUVX(sv) + 1);
6803 if (SvIVX(sv) == IV_MAX)
6804 sv_setuv(sv, (UV)IV_MAX + 1);
6806 (void)SvIOK_only(sv);
6807 SvIV_set(sv, SvIVX(sv) + 1);
6812 if (flags & SVp_NOK) {
6813 (void)SvNOK_only(sv);
6814 SvNV_set(sv, SvNVX(sv) + 1.0);
6818 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
6819 if ((flags & SVTYPEMASK) < SVt_PVIV)
6820 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
6821 (void)SvIOK_only(sv);
6826 while (isALPHA(*d)) d++;
6827 while (isDIGIT(*d)) d++;
6829 #ifdef PERL_PRESERVE_IVUV
6830 /* Got to punt this as an integer if needs be, but we don't issue
6831 warnings. Probably ought to make the sv_iv_please() that does
6832 the conversion if possible, and silently. */
6833 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6834 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6835 /* Need to try really hard to see if it's an integer.
6836 9.22337203685478e+18 is an integer.
6837 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6838 so $a="9.22337203685478e+18"; $a+0; $a++
6839 needs to be the same as $a="9.22337203685478e+18"; $a++
6846 /* sv_2iv *should* have made this an NV */
6847 if (flags & SVp_NOK) {
6848 (void)SvNOK_only(sv);
6849 SvNV_set(sv, SvNVX(sv) + 1.0);
6852 /* I don't think we can get here. Maybe I should assert this
6853 And if we do get here I suspect that sv_setnv will croak. NWC
6855 #if defined(USE_LONG_DOUBLE)
6856 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",
6857 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6859 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6860 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6863 #endif /* PERL_PRESERVE_IVUV */
6864 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
6868 while (d >= SvPVX_const(sv)) {
6876 /* MKS: The original code here died if letters weren't consecutive.
6877 * at least it didn't have to worry about non-C locales. The
6878 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6879 * arranged in order (although not consecutively) and that only
6880 * [A-Za-z] are accepted by isALPHA in the C locale.
6882 if (*d != 'z' && *d != 'Z') {
6883 do { ++*d; } while (!isALPHA(*d));
6886 *(d--) -= 'z' - 'a';
6891 *(d--) -= 'z' - 'a' + 1;
6895 /* oh,oh, the number grew */
6896 SvGROW(sv, SvCUR(sv) + 2);
6897 SvCUR_set(sv, SvCUR(sv) + 1);
6898 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
6909 Auto-decrement of the value in the SV, doing string to numeric conversion
6910 if necessary. Handles 'get' magic.
6916 Perl_sv_dec(pTHX_ register SV *sv)
6923 if (SvTHINKFIRST(sv)) {
6925 sv_force_normal_flags(sv, 0);
6926 if (SvREADONLY(sv)) {
6927 if (IN_PERL_RUNTIME)
6928 Perl_croak(aTHX_ PL_no_modify);
6932 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6934 i = PTR2IV(SvRV(sv));
6939 /* Unlike sv_inc we don't have to worry about string-never-numbers
6940 and keeping them magic. But we mustn't warn on punting */
6941 flags = SvFLAGS(sv);
6942 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6943 /* It's publicly an integer, or privately an integer-not-float */
6944 #ifdef PERL_PRESERVE_IVUV
6948 if (SvUVX(sv) == 0) {
6949 (void)SvIOK_only(sv);
6953 (void)SvIOK_only_UV(sv);
6954 SvUV_set(sv, SvUVX(sv) - 1);
6957 if (SvIVX(sv) == IV_MIN)
6958 sv_setnv(sv, (NV)IV_MIN - 1.0);
6960 (void)SvIOK_only(sv);
6961 SvIV_set(sv, SvIVX(sv) - 1);
6966 if (flags & SVp_NOK) {
6967 SvNV_set(sv, SvNVX(sv) - 1.0);
6968 (void)SvNOK_only(sv);
6971 if (!(flags & SVp_POK)) {
6972 if ((flags & SVTYPEMASK) < SVt_PVIV)
6973 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
6975 (void)SvIOK_only(sv);
6978 #ifdef PERL_PRESERVE_IVUV
6980 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6981 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6982 /* Need to try really hard to see if it's an integer.
6983 9.22337203685478e+18 is an integer.
6984 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6985 so $a="9.22337203685478e+18"; $a+0; $a--
6986 needs to be the same as $a="9.22337203685478e+18"; $a--
6993 /* sv_2iv *should* have made this an NV */
6994 if (flags & SVp_NOK) {
6995 (void)SvNOK_only(sv);
6996 SvNV_set(sv, SvNVX(sv) - 1.0);
6999 /* I don't think we can get here. Maybe I should assert this
7000 And if we do get here I suspect that sv_setnv will croak. NWC
7002 #if defined(USE_LONG_DOUBLE)
7003 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",
7004 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7006 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7007 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7011 #endif /* PERL_PRESERVE_IVUV */
7012 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
7016 =for apidoc sv_mortalcopy
7018 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7019 The new SV is marked as mortal. It will be destroyed "soon", either by an
7020 explicit call to FREETMPS, or by an implicit call at places such as
7021 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7026 /* Make a string that will exist for the duration of the expression
7027 * evaluation. Actually, it may have to last longer than that, but
7028 * hopefully we won't free it until it has been assigned to a
7029 * permanent location. */
7032 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
7037 sv_setsv(sv,oldstr);
7039 PL_tmps_stack[++PL_tmps_ix] = sv;
7045 =for apidoc sv_newmortal
7047 Creates a new null SV which is mortal. The reference count of the SV is
7048 set to 1. It will be destroyed "soon", either by an explicit call to
7049 FREETMPS, or by an implicit call at places such as statement boundaries.
7050 See also C<sv_mortalcopy> and C<sv_2mortal>.
7056 Perl_sv_newmortal(pTHX)
7061 SvFLAGS(sv) = SVs_TEMP;
7063 PL_tmps_stack[++PL_tmps_ix] = sv;
7068 =for apidoc sv_2mortal
7070 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7071 by an explicit call to FREETMPS, or by an implicit call at places such as
7072 statement boundaries. SvTEMP() is turned on which means that the SV's
7073 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7074 and C<sv_mortalcopy>.
7080 Perl_sv_2mortal(pTHX_ register SV *sv)
7085 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7088 PL_tmps_stack[++PL_tmps_ix] = sv;
7096 Creates a new SV and copies a string into it. The reference count for the
7097 SV is set to 1. If C<len> is zero, Perl will compute the length using
7098 strlen(). For efficiency, consider using C<newSVpvn> instead.
7104 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
7109 sv_setpvn(sv,s,len ? len : strlen(s));
7114 =for apidoc newSVpvn
7116 Creates a new SV and copies a string into it. The reference count for the
7117 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7118 string. You are responsible for ensuring that the source string is at least
7119 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7125 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7130 sv_setpvn(sv,s,len);
7136 =for apidoc newSVhek
7138 Creates a new SV from the hash key structure. It will generate scalars that
7139 point to the shared string table where possible. Returns a new (undefined)
7140 SV if the hek is NULL.
7146 Perl_newSVhek(pTHX_ const HEK *hek)
7155 if (HEK_LEN(hek) == HEf_SVKEY) {
7156 return newSVsv(*(SV**)HEK_KEY(hek));
7158 const int flags = HEK_FLAGS(hek);
7159 if (flags & HVhek_WASUTF8) {
7161 Andreas would like keys he put in as utf8 to come back as utf8
7163 STRLEN utf8_len = HEK_LEN(hek);
7164 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7165 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
7168 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7170 } else if (flags & HVhek_REHASH) {
7171 /* We don't have a pointer to the hv, so we have to replicate the
7172 flag into every HEK. This hv is using custom a hasing
7173 algorithm. Hence we can't return a shared string scalar, as
7174 that would contain the (wrong) hash value, and might get passed
7175 into an hv routine with a regular hash */
7177 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7182 /* This will be overwhelminly the most common case. */
7183 return newSVpvn_share(HEK_KEY(hek),
7184 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
7190 =for apidoc newSVpvn_share
7192 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7193 table. If the string does not already exist in the table, it is created
7194 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
7195 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
7196 otherwise the hash is computed. The idea here is that as the string table
7197 is used for shared hash keys these strings will have SvPVX_const == HeKEY and
7198 hash lookup will avoid string compare.
7204 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7207 bool is_utf8 = FALSE;
7209 STRLEN tmplen = -len;
7211 /* See the note in hv.c:hv_fetch() --jhi */
7212 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7216 PERL_HASH(hash, src, len);
7218 sv_upgrade(sv, SVt_PV);
7219 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7231 #if defined(PERL_IMPLICIT_CONTEXT)
7233 /* pTHX_ magic can't cope with varargs, so this is a no-context
7234 * version of the main function, (which may itself be aliased to us).
7235 * Don't access this version directly.
7239 Perl_newSVpvf_nocontext(const char* pat, ...)
7244 va_start(args, pat);
7245 sv = vnewSVpvf(pat, &args);
7252 =for apidoc newSVpvf
7254 Creates a new SV and initializes it with the string formatted like
7261 Perl_newSVpvf(pTHX_ const char* pat, ...)
7265 va_start(args, pat);
7266 sv = vnewSVpvf(pat, &args);
7271 /* backend for newSVpvf() and newSVpvf_nocontext() */
7274 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7278 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7285 Creates a new SV and copies a floating point value into it.
7286 The reference count for the SV is set to 1.
7292 Perl_newSVnv(pTHX_ NV n)
7304 Creates a new SV and copies an integer into it. The reference count for the
7311 Perl_newSViv(pTHX_ IV i)
7323 Creates a new SV and copies an unsigned integer into it.
7324 The reference count for the SV is set to 1.
7330 Perl_newSVuv(pTHX_ UV u)
7340 =for apidoc newRV_noinc
7342 Creates an RV wrapper for an SV. The reference count for the original
7343 SV is B<not> incremented.
7349 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7354 sv_upgrade(sv, SVt_RV);
7356 SvRV_set(sv, tmpRef);
7361 /* newRV_inc is the official function name to use now.
7362 * newRV_inc is in fact #defined to newRV in sv.h
7366 Perl_newRV(pTHX_ SV *tmpRef)
7368 return newRV_noinc(SvREFCNT_inc(tmpRef));
7374 Creates a new SV which is an exact duplicate of the original SV.
7381 Perl_newSVsv(pTHX_ register SV *old)
7387 if (SvTYPE(old) == SVTYPEMASK) {
7388 if (ckWARN_d(WARN_INTERNAL))
7389 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7393 /* SV_GMAGIC is the default for sv_setv()
7394 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7395 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7396 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7401 =for apidoc sv_reset
7403 Underlying implementation for the C<reset> Perl function.
7404 Note that the perl-level function is vaguely deprecated.
7410 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
7413 char todo[PERL_UCHAR_MAX+1];
7418 if (!*s) { /* reset ?? searches */
7419 MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
7421 PMOP *pm = (PMOP *) mg->mg_obj;
7423 pm->op_pmdynflags &= ~PMdf_USED;
7430 /* reset variables */
7432 if (!HvARRAY(stash))
7435 Zero(todo, 256, char);
7438 I32 i = (unsigned char)*s;
7442 max = (unsigned char)*s++;
7443 for ( ; i <= max; i++) {
7446 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7448 for (entry = HvARRAY(stash)[i];
7450 entry = HeNEXT(entry))
7455 if (!todo[(U8)*HeKEY(entry)])
7457 gv = (GV*)HeVAL(entry);
7460 if (SvTHINKFIRST(sv)) {
7461 if (!SvREADONLY(sv) && SvROK(sv))
7463 /* XXX Is this continue a bug? Why should THINKFIRST
7464 exempt us from resetting arrays and hashes? */
7468 if (SvTYPE(sv) >= SVt_PV) {
7470 if (SvPVX_const(sv) != Nullch)
7478 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
7480 Perl_die(aTHX_ "Can't reset %%ENV on this system");
7483 # if defined(USE_ENVIRON_ARRAY)
7486 # endif /* USE_ENVIRON_ARRAY */
7497 Using various gambits, try to get an IO from an SV: the IO slot if its a
7498 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7499 named after the PV if we're a string.
7505 Perl_sv_2io(pTHX_ SV *sv)
7510 switch (SvTYPE(sv)) {
7518 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7522 Perl_croak(aTHX_ PL_no_usym, "filehandle");
7524 return sv_2io(SvRV(sv));
7525 gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
7531 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
7540 Using various gambits, try to get a CV from an SV; in addition, try if
7541 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7547 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7554 return *gvp = Nullgv, Nullcv;
7555 switch (SvTYPE(sv)) {
7573 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
7574 tryAMAGICunDEREF(to_cv);
7577 if (SvTYPE(sv) == SVt_PVCV) {
7586 Perl_croak(aTHX_ "Not a subroutine reference");
7591 gv = gv_fetchsv(sv, lref, SVt_PVCV);
7597 if (lref && !GvCVu(gv)) {
7600 tmpsv = NEWSV(704,0);
7601 gv_efullname3(tmpsv, gv, Nullch);
7602 /* XXX this is probably not what they think they're getting.
7603 * It has the same effect as "sub name;", i.e. just a forward
7605 newSUB(start_subparse(FALSE, 0),
7606 newSVOP(OP_CONST, 0, tmpsv),
7611 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
7621 Returns true if the SV has a true value by Perl's rules.
7622 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
7623 instead use an in-line version.
7629 Perl_sv_true(pTHX_ register SV *sv)
7634 register const XPV* const tXpv = (XPV*)SvANY(sv);
7636 (tXpv->xpv_cur > 1 ||
7637 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
7644 return SvIVX(sv) != 0;
7647 return SvNVX(sv) != 0.0;
7649 return sv_2bool(sv);
7655 =for apidoc sv_pvn_force
7657 Get a sensible string out of the SV somehow.
7658 A private implementation of the C<SvPV_force> macro for compilers which
7659 can't cope with complex macro expressions. Always use the macro instead.
7661 =for apidoc sv_pvn_force_flags
7663 Get a sensible string out of the SV somehow.
7664 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
7665 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
7666 implemented in terms of this function.
7667 You normally want to use the various wrapper macros instead: see
7668 C<SvPV_force> and C<SvPV_force_nomg>
7674 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
7677 if (SvTHINKFIRST(sv) && !SvROK(sv))
7678 sv_force_normal_flags(sv, 0);
7688 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
7689 const char * const ref = sv_reftype(sv,0);
7691 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
7692 ref, OP_NAME(PL_op));
7694 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
7696 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
7697 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
7699 s = sv_2pv_flags(sv, &len, flags);
7703 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
7706 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
7707 SvGROW(sv, len + 1);
7708 Move(s,SvPVX(sv),len,char);
7713 SvPOK_on(sv); /* validate pointer */
7715 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
7716 PTR2UV(sv),SvPVX_const(sv)));
7719 return SvPVX_mutable(sv);
7723 =for apidoc sv_pvbyten_force
7725 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
7731 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
7733 sv_pvn_force(sv,lp);
7734 sv_utf8_downgrade(sv,0);
7740 =for apidoc sv_pvutf8n_force
7742 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
7748 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
7750 sv_pvn_force(sv,lp);
7751 sv_utf8_upgrade(sv);
7757 =for apidoc sv_reftype
7759 Returns a string describing what the SV is a reference to.
7765 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
7767 /* The fact that I don't need to downcast to char * everywhere, only in ?:
7768 inside return suggests a const propagation bug in g++. */
7769 if (ob && SvOBJECT(sv)) {
7770 char * const name = HvNAME_get(SvSTASH(sv));
7771 return name ? name : (char *) "__ANON__";
7774 switch (SvTYPE(sv)) {
7791 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
7792 /* tied lvalues should appear to be
7793 * scalars for backwards compatitbility */
7794 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
7795 ? "SCALAR" : "LVALUE");
7796 case SVt_PVAV: return "ARRAY";
7797 case SVt_PVHV: return "HASH";
7798 case SVt_PVCV: return "CODE";
7799 case SVt_PVGV: return "GLOB";
7800 case SVt_PVFM: return "FORMAT";
7801 case SVt_PVIO: return "IO";
7802 default: return "UNKNOWN";
7808 =for apidoc sv_isobject
7810 Returns a boolean indicating whether the SV is an RV pointing to a blessed
7811 object. If the SV is not an RV, or if the object is not blessed, then this
7818 Perl_sv_isobject(pTHX_ SV *sv)
7834 Returns a boolean indicating whether the SV is blessed into the specified
7835 class. This does not check for subtypes; use C<sv_derived_from> to verify
7836 an inheritance relationship.
7842 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7853 hvname = HvNAME_get(SvSTASH(sv));
7857 return strEQ(hvname, name);
7863 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
7864 it will be upgraded to one. If C<classname> is non-null then the new SV will
7865 be blessed in the specified package. The new SV is returned and its
7866 reference count is 1.
7872 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7878 SV_CHECK_THINKFIRST_COW_DROP(rv);
7881 if (SvTYPE(rv) >= SVt_PVMG) {
7882 const U32 refcnt = SvREFCNT(rv);
7886 SvREFCNT(rv) = refcnt;
7889 if (SvTYPE(rv) < SVt_RV)
7890 sv_upgrade(rv, SVt_RV);
7891 else if (SvTYPE(rv) > SVt_RV) {
7902 HV* const stash = gv_stashpv(classname, TRUE);
7903 (void)sv_bless(rv, stash);
7909 =for apidoc sv_setref_pv
7911 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7912 argument will be upgraded to an RV. That RV will be modified to point to
7913 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7914 into the SV. The C<classname> argument indicates the package for the
7915 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7916 will have a reference count of 1, and the RV will be returned.
7918 Do not use with other Perl types such as HV, AV, SV, CV, because those
7919 objects will become corrupted by the pointer copy process.
7921 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7927 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7930 sv_setsv(rv, &PL_sv_undef);
7934 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7939 =for apidoc sv_setref_iv
7941 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7942 argument will be upgraded to an RV. That RV will be modified to point to
7943 the new SV. The C<classname> argument indicates the package for the
7944 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7945 will have a reference count of 1, and the RV will be returned.
7951 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7953 sv_setiv(newSVrv(rv,classname), iv);
7958 =for apidoc sv_setref_uv
7960 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7961 argument will be upgraded to an RV. That RV will be modified to point to
7962 the new SV. The C<classname> argument indicates the package for the
7963 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7964 will have a reference count of 1, and the RV will be returned.
7970 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7972 sv_setuv(newSVrv(rv,classname), uv);
7977 =for apidoc sv_setref_nv
7979 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7980 argument will be upgraded to an RV. That RV will be modified to point to
7981 the new SV. The C<classname> argument indicates the package for the
7982 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7983 will have a reference count of 1, and the RV will be returned.
7989 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7991 sv_setnv(newSVrv(rv,classname), nv);
7996 =for apidoc sv_setref_pvn
7998 Copies a string into a new SV, optionally blessing the SV. The length of the
7999 string must be specified with C<n>. The C<rv> argument will be upgraded to
8000 an RV. That RV will be modified to point to the new SV. The C<classname>
8001 argument indicates the package for the blessing. Set C<classname> to
8002 C<Nullch> to avoid the blessing. The new SV will have a reference count
8003 of 1, and the RV will be returned.
8005 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8011 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n)
8013 sv_setpvn(newSVrv(rv,classname), pv, n);
8018 =for apidoc sv_bless
8020 Blesses an SV into a specified package. The SV must be an RV. The package
8021 must be designated by its stash (see C<gv_stashpv()>). The reference count
8022 of the SV is unaffected.
8028 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8032 Perl_croak(aTHX_ "Can't bless non-reference value");
8034 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8035 if (SvREADONLY(tmpRef))
8036 Perl_croak(aTHX_ PL_no_modify);
8037 if (SvOBJECT(tmpRef)) {
8038 if (SvTYPE(tmpRef) != SVt_PVIO)
8040 SvREFCNT_dec(SvSTASH(tmpRef));
8043 SvOBJECT_on(tmpRef);
8044 if (SvTYPE(tmpRef) != SVt_PVIO)
8046 SvUPGRADE(tmpRef, SVt_PVMG);
8047 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
8054 if(SvSMAGICAL(tmpRef))
8055 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8063 /* Downgrades a PVGV to a PVMG.
8067 S_sv_unglob(pTHX_ SV *sv)
8071 assert(SvTYPE(sv) == SVt_PVGV);
8076 sv_del_backref((SV*)GvSTASH(sv), sv);
8077 GvSTASH(sv) = Nullhv;
8079 sv_unmagic(sv, PERL_MAGIC_glob);
8080 Safefree(GvNAME(sv));
8083 /* need to keep SvANY(sv) in the right arena */
8084 xpvmg = new_XPVMG();
8085 StructCopy(SvANY(sv), xpvmg, XPVMG);
8086 del_XPVGV(SvANY(sv));
8089 SvFLAGS(sv) &= ~SVTYPEMASK;
8090 SvFLAGS(sv) |= SVt_PVMG;
8094 =for apidoc sv_unref_flags
8096 Unsets the RV status of the SV, and decrements the reference count of
8097 whatever was being referenced by the RV. This can almost be thought of
8098 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8099 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8100 (otherwise the decrementing is conditional on the reference count being
8101 different from one or the reference being a readonly SV).
8108 Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags)
8110 SV* const target = SvRV(ref);
8112 if (SvWEAKREF(ref)) {
8113 sv_del_backref(target, ref);
8115 SvRV_set(ref, NULL);
8118 SvRV_set(ref, NULL);
8120 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
8121 assigned to as BEGIN {$a = \"Foo"} will fail. */
8122 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
8123 SvREFCNT_dec(target);
8124 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8125 sv_2mortal(target); /* Schedule for freeing later */
8129 =for apidoc sv_untaint
8131 Untaint an SV. Use C<SvTAINTED_off> instead.
8136 Perl_sv_untaint(pTHX_ SV *sv)
8138 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8139 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8146 =for apidoc sv_tainted
8148 Test an SV for taintedness. Use C<SvTAINTED> instead.
8153 Perl_sv_tainted(pTHX_ SV *sv)
8155 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8156 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8157 if (mg && (mg->mg_len & 1) )
8164 =for apidoc sv_setpviv
8166 Copies an integer into the given SV, also updating its string value.
8167 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8173 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8175 char buf[TYPE_CHARS(UV)];
8177 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8179 sv_setpvn(sv, ptr, ebuf - ptr);
8183 =for apidoc sv_setpviv_mg
8185 Like C<sv_setpviv>, but also handles 'set' magic.
8191 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8197 #if defined(PERL_IMPLICIT_CONTEXT)
8199 /* pTHX_ magic can't cope with varargs, so this is a no-context
8200 * version of the main function, (which may itself be aliased to us).
8201 * Don't access this version directly.
8205 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8209 va_start(args, pat);
8210 sv_vsetpvf(sv, pat, &args);
8214 /* pTHX_ magic can't cope with varargs, so this is a no-context
8215 * version of the main function, (which may itself be aliased to us).
8216 * Don't access this version directly.
8220 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8224 va_start(args, pat);
8225 sv_vsetpvf_mg(sv, pat, &args);
8231 =for apidoc sv_setpvf
8233 Works like C<sv_catpvf> but copies the text into the SV instead of
8234 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8240 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8243 va_start(args, pat);
8244 sv_vsetpvf(sv, pat, &args);
8249 =for apidoc sv_vsetpvf
8251 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8252 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8254 Usually used via its frontend C<sv_setpvf>.
8260 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8262 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8266 =for apidoc sv_setpvf_mg
8268 Like C<sv_setpvf>, but also handles 'set' magic.
8274 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8277 va_start(args, pat);
8278 sv_vsetpvf_mg(sv, pat, &args);
8283 =for apidoc sv_vsetpvf_mg
8285 Like C<sv_vsetpvf>, but also handles 'set' magic.
8287 Usually used via its frontend C<sv_setpvf_mg>.
8293 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8295 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8299 #if defined(PERL_IMPLICIT_CONTEXT)
8301 /* pTHX_ magic can't cope with varargs, so this is a no-context
8302 * version of the main function, (which may itself be aliased to us).
8303 * Don't access this version directly.
8307 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8311 va_start(args, pat);
8312 sv_vcatpvf(sv, pat, &args);
8316 /* pTHX_ magic can't cope with varargs, so this is a no-context
8317 * version of the main function, (which may itself be aliased to us).
8318 * Don't access this version directly.
8322 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8326 va_start(args, pat);
8327 sv_vcatpvf_mg(sv, pat, &args);
8333 =for apidoc sv_catpvf
8335 Processes its arguments like C<sprintf> and appends the formatted
8336 output to an SV. If the appended data contains "wide" characters
8337 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8338 and characters >255 formatted with %c), the original SV might get
8339 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
8340 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
8341 valid UTF-8; if the original SV was bytes, the pattern should be too.
8346 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8349 va_start(args, pat);
8350 sv_vcatpvf(sv, pat, &args);
8355 =for apidoc sv_vcatpvf
8357 Processes its arguments like C<vsprintf> and appends the formatted output
8358 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
8360 Usually used via its frontend C<sv_catpvf>.
8366 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8368 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8372 =for apidoc sv_catpvf_mg
8374 Like C<sv_catpvf>, but also handles 'set' magic.
8380 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8383 va_start(args, pat);
8384 sv_vcatpvf_mg(sv, pat, &args);
8389 =for apidoc sv_vcatpvf_mg
8391 Like C<sv_vcatpvf>, but also handles 'set' magic.
8393 Usually used via its frontend C<sv_catpvf_mg>.
8399 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8401 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8406 =for apidoc sv_vsetpvfn
8408 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
8411 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
8417 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8419 sv_setpvn(sv, "", 0);
8420 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8423 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
8426 S_expect_number(pTHX_ char** pattern)
8429 switch (**pattern) {
8430 case '1': case '2': case '3':
8431 case '4': case '5': case '6':
8432 case '7': case '8': case '9':
8433 while (isDIGIT(**pattern))
8434 var = var * 10 + (*(*pattern)++ - '0');
8438 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
8441 F0convert(NV nv, char *endbuf, STRLEN *len)
8443 const int neg = nv < 0;
8452 if (uv & 1 && uv == nv)
8453 uv--; /* Round to even */
8455 const unsigned dig = uv % 10;
8468 =for apidoc sv_vcatpvfn
8470 Processes its arguments like C<vsprintf> and appends the formatted output
8471 to an SV. Uses an array of SVs if the C style variable argument list is
8472 missing (NULL). When running with taint checks enabled, indicates via
8473 C<maybe_tainted> if results are untrustworthy (often due to the use of
8476 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
8482 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
8483 vecstr = (U8*)SvPV_const(vecsv,veclen);\
8484 vec_utf8 = DO_UTF8(vecsv);
8486 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
8489 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8496 static const char nullstr[] = "(null)";
8498 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
8499 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
8501 /* Times 4: a decimal digit takes more than 3 binary digits.
8502 * NV_DIG: mantissa takes than many decimal digits.
8503 * Plus 32: Playing safe. */
8504 char ebuf[IV_DIG * 4 + NV_DIG + 32];
8505 /* large enough for "%#.#f" --chip */
8506 /* what about long double NVs? --jhi */
8508 PERL_UNUSED_ARG(maybe_tainted);
8510 /* no matter what, this is a string now */
8511 (void)SvPV_force(sv, origlen);
8513 /* special-case "", "%s", and "%-p" (SVf - see below) */
8516 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
8518 const char * const s = va_arg(*args, char*);
8519 sv_catpv(sv, s ? s : nullstr);
8521 else if (svix < svmax) {
8522 sv_catsv(sv, *svargs);
8523 if (DO_UTF8(*svargs))
8528 if (args && patlen == 3 && pat[0] == '%' &&
8529 pat[1] == '-' && pat[2] == 'p') {
8530 argsv = va_arg(*args, SV*);
8531 sv_catsv(sv, argsv);
8537 #ifndef USE_LONG_DOUBLE
8538 /* special-case "%.<number>[gf]" */
8539 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
8540 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
8541 unsigned digits = 0;
8545 while (*pp >= '0' && *pp <= '9')
8546 digits = 10 * digits + (*pp++ - '0');
8547 if (pp - pat == (int)patlen - 1) {
8555 /* Add check for digits != 0 because it seems that some
8556 gconverts are buggy in this case, and we don't yet have
8557 a Configure test for this. */
8558 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
8559 /* 0, point, slack */
8560 Gconvert(nv, (int)digits, 0, ebuf);
8562 if (*ebuf) /* May return an empty string for digits==0 */
8565 } else if (!digits) {
8568 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
8569 sv_catpvn(sv, p, l);
8575 #endif /* !USE_LONG_DOUBLE */
8577 if (!args && svix < svmax && DO_UTF8(*svargs))
8580 patend = (char*)pat + patlen;
8581 for (p = (char*)pat; p < patend; p = q) {
8584 bool vectorize = FALSE;
8585 bool vectorarg = FALSE;
8586 bool vec_utf8 = FALSE;
8592 bool has_precis = FALSE;
8595 bool is_utf8 = FALSE; /* is this item utf8? */
8596 #ifdef HAS_LDBL_SPRINTF_BUG
8597 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8598 with sfio - Allen <allens@cpan.org> */
8599 bool fix_ldbl_sprintf_bug = FALSE;
8603 U8 utf8buf[UTF8_MAXBYTES+1];
8604 STRLEN esignlen = 0;
8606 const char *eptr = Nullch;
8609 const U8 *vecstr = Null(U8*);
8616 /* we need a long double target in case HAS_LONG_DOUBLE but
8619 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
8627 const char *dotstr = ".";
8628 STRLEN dotstrlen = 1;
8629 I32 efix = 0; /* explicit format parameter index */
8630 I32 ewix = 0; /* explicit width index */
8631 I32 epix = 0; /* explicit precision index */
8632 I32 evix = 0; /* explicit vector index */
8633 bool asterisk = FALSE;
8635 /* echo everything up to the next format specification */
8636 for (q = p; q < patend && *q != '%'; ++q) ;
8638 if (has_utf8 && !pat_utf8)
8639 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
8641 sv_catpvn(sv, p, q - p);
8648 We allow format specification elements in this order:
8649 \d+\$ explicit format parameter index
8651 v|\*(\d+\$)?v vector with optional (optionally specified) arg
8652 0 flag (as above): repeated to allow "v02"
8653 \d+|\*(\d+\$)? width using optional (optionally specified) arg
8654 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8656 [%bcdefginopsuxDFOUX] format (mandatory)
8661 As of perl5.9.3, printf format checking is on by default.
8662 Internally, perl uses %p formats to provide an escape to
8663 some extended formatting. This block deals with those
8664 extensions: if it does not match, (char*)q is reset and
8665 the normal format processing code is used.
8667 Currently defined extensions are:
8668 %p include pointer address (standard)
8669 %-p (SVf) include an SV (previously %_)
8670 %-<num>p include an SV with precision <num>
8671 %1p (VDf) include a v-string (as %vd)
8672 %<num>p reserved for future extensions
8674 Robin Barker 2005-07-14
8681 EXPECT_NUMBER(q, n);
8688 argsv = va_arg(*args, SV*);
8689 eptr = SvPVx_const(argsv, elen);
8695 else if (n == vdNUMBER) { /* VDf */
8702 if (ckWARN_d(WARN_INTERNAL))
8703 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
8704 "internal %%<num>p might conflict with future printf extensions");
8710 if (EXPECT_NUMBER(q, width)) {
8751 if (EXPECT_NUMBER(q, ewix))
8760 if ((vectorarg = asterisk)) {
8773 EXPECT_NUMBER(q, width);
8779 vecsv = va_arg(*args, SV*);
8781 vecsv = (evix ? evix <= svmax : svix < svmax) ?
8782 svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
8783 dotstr = SvPV_const(vecsv, dotstrlen);
8790 else if (efix ? efix <= svmax : svix < svmax) {
8791 vecsv = svargs[efix ? efix-1 : svix++];
8792 vecstr = (U8*)SvPV_const(vecsv,veclen);
8793 vec_utf8 = DO_UTF8(vecsv);
8794 /* if this is a version object, we need to return the
8795 * stringified representation (which the SvPVX_const has
8796 * already done for us), but not vectorize the args
8798 if ( *q == 'd' && sv_derived_from(vecsv,"version") )
8800 q++; /* skip past the rest of the %vd format */
8801 eptr = (const char *) vecstr;
8815 i = va_arg(*args, int);
8817 i = (ewix ? ewix <= svmax : svix < svmax) ?
8818 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8820 width = (i < 0) ? -i : i;
8830 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
8832 /* XXX: todo, support specified precision parameter */
8836 i = va_arg(*args, int);
8838 i = (ewix ? ewix <= svmax : svix < svmax)
8839 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8840 precis = (i < 0) ? 0 : i;
8845 precis = precis * 10 + (*q++ - '0');
8854 case 'I': /* Ix, I32x, and I64x */
8856 if (q[1] == '6' && q[2] == '4') {
8862 if (q[1] == '3' && q[2] == '2') {
8872 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8883 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8884 if (*(q + 1) == 'l') { /* lld, llf */
8909 argsv = (efix ? efix <= svmax : svix < svmax) ?
8910 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
8917 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
8919 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
8921 eptr = (char*)utf8buf;
8922 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
8933 if (args && !vectorize) {
8934 eptr = va_arg(*args, char*);
8936 #ifdef MACOS_TRADITIONAL
8937 /* On MacOS, %#s format is used for Pascal strings */
8942 elen = strlen(eptr);
8944 eptr = (char *)nullstr;
8945 elen = sizeof nullstr - 1;
8949 eptr = SvPVx_const(argsv, elen);
8950 if (DO_UTF8(argsv)) {
8951 if (has_precis && precis < elen) {
8953 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
8956 if (width) { /* fudge width (can't fudge elen) */
8957 width += elen - sv_len_utf8(argsv);
8965 if (has_precis && elen > precis)
8972 if (alt || vectorize)
8974 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
8995 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9004 esignbuf[esignlen++] = plus;
9008 case 'h': iv = (short)va_arg(*args, int); break;
9009 case 'l': iv = va_arg(*args, long); break;
9010 case 'V': iv = va_arg(*args, IV); break;
9011 default: iv = va_arg(*args, int); break;
9013 case 'q': iv = va_arg(*args, Quad_t); break;
9018 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
9020 case 'h': iv = (short)tiv; break;
9021 case 'l': iv = (long)tiv; break;
9023 default: iv = tiv; break;
9025 case 'q': iv = (Quad_t)tiv; break;
9029 if ( !vectorize ) /* we already set uv above */
9034 esignbuf[esignlen++] = plus;
9038 esignbuf[esignlen++] = '-';
9081 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9092 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9093 case 'l': uv = va_arg(*args, unsigned long); break;
9094 case 'V': uv = va_arg(*args, UV); break;
9095 default: uv = va_arg(*args, unsigned); break;
9097 case 'q': uv = va_arg(*args, Uquad_t); break;
9102 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9104 case 'h': uv = (unsigned short)tuv; break;
9105 case 'l': uv = (unsigned long)tuv; break;
9107 default: uv = tuv; break;
9109 case 'q': uv = (Uquad_t)tuv; break;
9116 char *ptr = ebuf + sizeof ebuf;
9122 p = (char*)((c == 'X')
9123 ? "0123456789ABCDEF" : "0123456789abcdef");
9129 esignbuf[esignlen++] = '0';
9130 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9138 if (alt && *ptr != '0')
9147 esignbuf[esignlen++] = '0';
9148 esignbuf[esignlen++] = 'b';
9151 default: /* it had better be ten or less */
9155 } while (uv /= base);
9158 elen = (ebuf + sizeof ebuf) - ptr;
9162 zeros = precis - elen;
9163 else if (precis == 0 && elen == 1 && *eptr == '0')
9169 /* FLOATING POINT */
9172 c = 'f'; /* maybe %F isn't supported here */
9178 /* This is evil, but floating point is even more evil */
9180 /* for SV-style calling, we can only get NV
9181 for C-style calling, we assume %f is double;
9182 for simplicity we allow any of %Lf, %llf, %qf for long double
9186 #if defined(USE_LONG_DOUBLE)
9190 /* [perl #20339] - we should accept and ignore %lf rather than die */
9194 #if defined(USE_LONG_DOUBLE)
9195 intsize = args ? 0 : 'q';
9199 #if defined(HAS_LONG_DOUBLE)
9208 /* now we need (long double) if intsize == 'q', else (double) */
9209 nv = (args && !vectorize) ?
9210 #if LONG_DOUBLESIZE > DOUBLESIZE
9212 va_arg(*args, long double) :
9213 va_arg(*args, double)
9215 va_arg(*args, double)
9221 if (c != 'e' && c != 'E') {
9223 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9224 will cast our (long double) to (double) */
9225 (void)Perl_frexp(nv, &i);
9226 if (i == PERL_INT_MIN)
9227 Perl_die(aTHX_ "panic: frexp");
9229 need = BIT_DIGITS(i);
9231 need += has_precis ? precis : 6; /* known default */
9236 #ifdef HAS_LDBL_SPRINTF_BUG
9237 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9238 with sfio - Allen <allens@cpan.org> */
9241 # define MY_DBL_MAX DBL_MAX
9242 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9243 # if DOUBLESIZE >= 8
9244 # define MY_DBL_MAX 1.7976931348623157E+308L
9246 # define MY_DBL_MAX 3.40282347E+38L
9250 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9251 # define MY_DBL_MAX_BUG 1L
9253 # define MY_DBL_MAX_BUG MY_DBL_MAX
9257 # define MY_DBL_MIN DBL_MIN
9258 # else /* XXX guessing! -Allen */
9259 # if DOUBLESIZE >= 8
9260 # define MY_DBL_MIN 2.2250738585072014E-308L
9262 # define MY_DBL_MIN 1.17549435E-38L
9266 if ((intsize == 'q') && (c == 'f') &&
9267 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9269 /* it's going to be short enough that
9270 * long double precision is not needed */
9272 if ((nv <= 0L) && (nv >= -0L))
9273 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9275 /* would use Perl_fp_class as a double-check but not
9276 * functional on IRIX - see perl.h comments */
9278 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9279 /* It's within the range that a double can represent */
9280 #if defined(DBL_MAX) && !defined(DBL_MIN)
9281 if ((nv >= ((long double)1/DBL_MAX)) ||
9282 (nv <= (-(long double)1/DBL_MAX)))
9284 fix_ldbl_sprintf_bug = TRUE;
9287 if (fix_ldbl_sprintf_bug == TRUE) {
9297 # undef MY_DBL_MAX_BUG
9300 #endif /* HAS_LDBL_SPRINTF_BUG */
9302 need += 20; /* fudge factor */
9303 if (PL_efloatsize < need) {
9304 Safefree(PL_efloatbuf);
9305 PL_efloatsize = need + 20; /* more fudge */
9306 Newx(PL_efloatbuf, PL_efloatsize, char);
9307 PL_efloatbuf[0] = '\0';
9310 if ( !(width || left || plus || alt) && fill != '0'
9311 && has_precis && intsize != 'q' ) { /* Shortcuts */
9312 /* See earlier comment about buggy Gconvert when digits,
9314 if ( c == 'g' && precis) {
9315 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9316 /* May return an empty string for digits==0 */
9317 if (*PL_efloatbuf) {
9318 elen = strlen(PL_efloatbuf);
9319 goto float_converted;
9321 } else if ( c == 'f' && !precis) {
9322 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9327 char *ptr = ebuf + sizeof ebuf;
9330 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9331 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9332 if (intsize == 'q') {
9333 /* Copy the one or more characters in a long double
9334 * format before the 'base' ([efgEFG]) character to
9335 * the format string. */
9336 static char const prifldbl[] = PERL_PRIfldbl;
9337 char const *p = prifldbl + sizeof(prifldbl) - 3;
9338 while (p >= prifldbl) { *--ptr = *p--; }
9343 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9348 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9360 /* No taint. Otherwise we are in the strange situation
9361 * where printf() taints but print($float) doesn't.
9363 #if defined(HAS_LONG_DOUBLE)
9364 elen = ((intsize == 'q')
9365 ? my_sprintf(PL_efloatbuf, ptr, nv)
9366 : my_sprintf(PL_efloatbuf, ptr, (double)nv));
9368 elen = my_sprintf(PL_efloatbuf, ptr, nv);
9372 eptr = PL_efloatbuf;
9378 i = SvCUR(sv) - origlen;
9379 if (args && !vectorize) {
9381 case 'h': *(va_arg(*args, short*)) = i; break;
9382 default: *(va_arg(*args, int*)) = i; break;
9383 case 'l': *(va_arg(*args, long*)) = i; break;
9384 case 'V': *(va_arg(*args, IV*)) = i; break;
9386 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
9391 sv_setuv_mg(argsv, (UV)i);
9393 continue; /* not "break" */
9400 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
9401 && ckWARN(WARN_PRINTF))
9403 SV * const msg = sv_newmortal();
9404 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9405 (PL_op->op_type == OP_PRTF) ? "" : "s");
9408 Perl_sv_catpvf(aTHX_ msg,
9409 "\"%%%c\"", c & 0xFF);
9411 Perl_sv_catpvf(aTHX_ msg,
9412 "\"%%\\%03"UVof"\"",
9415 sv_catpv(msg, "end of string");
9416 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
9419 /* output mangled stuff ... */
9425 /* ... right here, because formatting flags should not apply */
9426 SvGROW(sv, SvCUR(sv) + elen + 1);
9428 Copy(eptr, p, elen, char);
9431 SvCUR_set(sv, p - SvPVX_const(sv));
9433 continue; /* not "break" */
9436 /* calculate width before utf8_upgrade changes it */
9437 have = esignlen + zeros + elen;
9439 if (is_utf8 != has_utf8) {
9442 sv_utf8_upgrade(sv);
9445 SV * const nsv = sv_2mortal(newSVpvn(eptr, elen));
9446 sv_utf8_upgrade(nsv);
9447 eptr = SvPVX_const(nsv);
9450 SvGROW(sv, SvCUR(sv) + elen + 1);
9455 need = (have > width ? have : width);
9458 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
9460 if (esignlen && fill == '0') {
9462 for (i = 0; i < (int)esignlen; i++)
9466 memset(p, fill, gap);
9469 if (esignlen && fill != '0') {
9471 for (i = 0; i < (int)esignlen; i++)
9476 for (i = zeros; i; i--)
9480 Copy(eptr, p, elen, char);
9484 memset(p, ' ', gap);
9489 Copy(dotstr, p, dotstrlen, char);
9493 vectorize = FALSE; /* done iterating over vecstr */
9500 SvCUR_set(sv, p - SvPVX_const(sv));
9508 /* =========================================================================
9510 =head1 Cloning an interpreter
9512 All the macros and functions in this section are for the private use of
9513 the main function, perl_clone().
9515 The foo_dup() functions make an exact copy of an existing foo thinngy.
9516 During the course of a cloning, a hash table is used to map old addresses
9517 to new addresses. The table is created and manipulated with the
9518 ptr_table_* functions.
9522 ============================================================================*/
9525 #if defined(USE_ITHREADS)
9527 #ifndef GpREFCNT_inc
9528 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
9532 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
9533 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
9534 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9535 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
9536 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9537 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
9538 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9539 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
9540 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
9541 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
9542 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9543 #define SAVEPV(p) (p ? savepv(p) : Nullch)
9544 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
9547 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
9548 regcomp.c. AMS 20010712 */
9551 Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
9556 struct reg_substr_datum *s;
9559 return (REGEXP *)NULL;
9561 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
9564 len = r->offsets[0];
9565 npar = r->nparens+1;
9567 Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
9568 Copy(r->program, ret->program, len+1, regnode);
9570 Newx(ret->startp, npar, I32);
9571 Copy(r->startp, ret->startp, npar, I32);
9572 Newx(ret->endp, npar, I32);
9573 Copy(r->startp, ret->startp, npar, I32);
9575 Newx(ret->substrs, 1, struct reg_substr_data);
9576 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
9577 s->min_offset = r->substrs->data[i].min_offset;
9578 s->max_offset = r->substrs->data[i].max_offset;
9579 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
9580 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
9583 ret->regstclass = NULL;
9586 const int count = r->data->count;
9589 Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
9590 char, struct reg_data);
9591 Newx(d->what, count, U8);
9594 for (i = 0; i < count; i++) {
9595 d->what[i] = r->data->what[i];
9596 switch (d->what[i]) {
9597 /* legal options are one of: sfpont
9598 see also regcomp.h and pregfree() */
9600 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
9603 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
9606 /* This is cheating. */
9607 Newx(d->data[i], 1, struct regnode_charclass_class);
9608 StructCopy(r->data->data[i], d->data[i],
9609 struct regnode_charclass_class);
9610 ret->regstclass = (regnode*)d->data[i];
9613 /* Compiled op trees are readonly, and can thus be
9614 shared without duplication. */
9616 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
9620 d->data[i] = r->data->data[i];
9623 d->data[i] = r->data->data[i];
9625 ((reg_trie_data*)d->data[i])->refcount++;
9629 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
9638 Newx(ret->offsets, 2*len+1, U32);
9639 Copy(r->offsets, ret->offsets, 2*len+1, U32);
9641 ret->precomp = SAVEPVN(r->precomp, r->prelen);
9642 ret->refcnt = r->refcnt;
9643 ret->minlen = r->minlen;
9644 ret->prelen = r->prelen;
9645 ret->nparens = r->nparens;
9646 ret->lastparen = r->lastparen;
9647 ret->lastcloseparen = r->lastcloseparen;
9648 ret->reganch = r->reganch;
9650 ret->sublen = r->sublen;
9652 if (RX_MATCH_COPIED(ret))
9653 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
9655 ret->subbeg = Nullch;
9656 #ifdef PERL_OLD_COPY_ON_WRITE
9657 ret->saved_copy = Nullsv;
9660 ptr_table_store(PL_ptr_table, r, ret);
9664 /* duplicate a file handle */
9667 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
9671 PERL_UNUSED_ARG(type);
9674 return (PerlIO*)NULL;
9676 /* look for it in the table first */
9677 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
9681 /* create anew and remember what it is */
9682 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
9683 ptr_table_store(PL_ptr_table, fp, ret);
9687 /* duplicate a directory handle */
9690 Perl_dirp_dup(pTHX_ DIR *dp)
9698 /* duplicate a typeglob */
9701 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
9706 /* look for it in the table first */
9707 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
9711 /* create anew and remember what it is */
9713 ptr_table_store(PL_ptr_table, gp, ret);
9716 ret->gp_refcnt = 0; /* must be before any other dups! */
9717 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
9718 ret->gp_io = io_dup_inc(gp->gp_io, param);
9719 ret->gp_form = cv_dup_inc(gp->gp_form, param);
9720 ret->gp_av = av_dup_inc(gp->gp_av, param);
9721 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
9722 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
9723 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
9724 ret->gp_cvgen = gp->gp_cvgen;
9725 ret->gp_line = gp->gp_line;
9726 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
9730 /* duplicate a chain of magic */
9733 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
9735 MAGIC *mgprev = (MAGIC*)NULL;
9738 return (MAGIC*)NULL;
9739 /* look for it in the table first */
9740 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
9744 for (; mg; mg = mg->mg_moremagic) {
9746 Newxz(nmg, 1, MAGIC);
9748 mgprev->mg_moremagic = nmg;
9751 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
9752 nmg->mg_private = mg->mg_private;
9753 nmg->mg_type = mg->mg_type;
9754 nmg->mg_flags = mg->mg_flags;
9755 if (mg->mg_type == PERL_MAGIC_qr) {
9756 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
9758 else if(mg->mg_type == PERL_MAGIC_backref) {
9759 const AV * const av = (AV*) mg->mg_obj;
9762 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
9764 for (i = AvFILLp(av); i >= 0; i--) {
9765 if (!svp[i]) continue;
9766 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
9769 else if (mg->mg_type == PERL_MAGIC_symtab) {
9770 nmg->mg_obj = mg->mg_obj;
9773 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
9774 ? sv_dup_inc(mg->mg_obj, param)
9775 : sv_dup(mg->mg_obj, param);
9777 nmg->mg_len = mg->mg_len;
9778 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
9779 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
9780 if (mg->mg_len > 0) {
9781 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
9782 if (mg->mg_type == PERL_MAGIC_overload_table &&
9783 AMT_AMAGIC((AMT*)mg->mg_ptr))
9785 AMT * const amtp = (AMT*)mg->mg_ptr;
9786 AMT * const namtp = (AMT*)nmg->mg_ptr;
9788 for (i = 1; i < NofAMmeth; i++) {
9789 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
9793 else if (mg->mg_len == HEf_SVKEY)
9794 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
9796 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
9797 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
9804 /* create a new pointer-mapping table */
9807 Perl_ptr_table_new(pTHX)
9810 Newxz(tbl, 1, PTR_TBL_t);
9813 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
9818 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
9820 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
9824 we use the PTE_SVSLOT 'reservation' made above, both here (in the
9825 following define) and at call to new_body_inline made below in
9826 Perl_ptr_table_store()
9829 #define del_pte(p) del_body_type(p, PTE_SVSLOT)
9831 /* map an existing pointer using a table */
9834 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
9836 PTR_TBL_ENT_t *tblent;
9837 const UV hash = PTR_TABLE_HASH(sv);
9839 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
9840 for (; tblent; tblent = tblent->next) {
9841 if (tblent->oldval == sv)
9842 return tblent->newval;
9847 /* add a new entry to a pointer-mapping table */
9850 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
9852 PTR_TBL_ENT_t *tblent, **otblent;
9853 /* XXX this may be pessimal on platforms where pointers aren't good
9854 * hash values e.g. if they grow faster in the most significant
9856 const UV hash = PTR_TABLE_HASH(oldsv);
9860 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
9861 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
9862 if (tblent->oldval == oldsv) {
9863 tblent->newval = newsv;
9867 new_body_inline(tblent, &PL_body_roots[PTE_SVSLOT],
9868 sizeof(struct ptr_tbl_ent), PTE_SVSLOT);
9869 tblent->oldval = oldsv;
9870 tblent->newval = newsv;
9871 tblent->next = *otblent;
9874 if (!empty && tbl->tbl_items > tbl->tbl_max)
9875 ptr_table_split(tbl);
9878 /* double the hash bucket size of an existing ptr table */
9881 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
9883 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
9884 const UV oldsize = tbl->tbl_max + 1;
9885 UV newsize = oldsize * 2;
9888 Renew(ary, newsize, PTR_TBL_ENT_t*);
9889 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
9890 tbl->tbl_max = --newsize;
9892 for (i=0; i < oldsize; i++, ary++) {
9893 PTR_TBL_ENT_t **curentp, **entp, *ent;
9896 curentp = ary + oldsize;
9897 for (entp = ary, ent = *ary; ent; ent = *entp) {
9898 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
9900 ent->next = *curentp;
9910 /* remove all the entries from a ptr table */
9913 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
9915 register PTR_TBL_ENT_t **array;
9916 register PTR_TBL_ENT_t *entry;
9920 if (!tbl || !tbl->tbl_items) {
9924 array = tbl->tbl_ary;
9930 PTR_TBL_ENT_t *oentry = entry;
9931 entry = entry->next;
9935 if (++riter > max) {
9938 entry = array[riter];
9945 /* clear and free a ptr table */
9948 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
9953 ptr_table_clear(tbl);
9954 Safefree(tbl->tbl_ary);
9960 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
9963 SvRV_set(dstr, SvWEAKREF(sstr)
9964 ? sv_dup(SvRV(sstr), param)
9965 : sv_dup_inc(SvRV(sstr), param));
9968 else if (SvPVX_const(sstr)) {
9969 /* Has something there */
9971 /* Normal PV - clone whole allocated space */
9972 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
9973 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9974 /* Not that normal - actually sstr is copy on write.
9975 But we are a true, independant SV, so: */
9976 SvREADONLY_off(dstr);
9981 /* Special case - not normally malloced for some reason */
9982 if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
9983 /* A "shared" PV - clone it as "shared" PV */
9985 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
9989 /* Some other special case - random pointer */
9990 SvPV_set(dstr, SvPVX(sstr));
9996 if (SvTYPE(dstr) == SVt_RV)
9997 SvRV_set(dstr, NULL);
10003 /* duplicate an SV of any type (including AV, HV etc) */
10006 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
10011 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10013 /* look for it in the table first */
10014 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10018 if(param->flags & CLONEf_JOIN_IN) {
10019 /** We are joining here so we don't want do clone
10020 something that is bad **/
10021 const char *hvname;
10023 if(SvTYPE(sstr) == SVt_PVHV &&
10024 (hvname = HvNAME_get(sstr))) {
10025 /** don't clone stashes if they already exist **/
10026 return (SV*)gv_stashpv(hvname,0);
10030 /* create anew and remember what it is */
10033 #ifdef DEBUG_LEAKING_SCALARS
10034 dstr->sv_debug_optype = sstr->sv_debug_optype;
10035 dstr->sv_debug_line = sstr->sv_debug_line;
10036 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10037 dstr->sv_debug_cloned = 1;
10039 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10041 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
10045 ptr_table_store(PL_ptr_table, sstr, dstr);
10048 SvFLAGS(dstr) = SvFLAGS(sstr);
10049 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10050 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10053 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
10054 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10055 PL_watch_pvx, SvPVX_const(sstr));
10058 /* don't clone objects whose class has asked us not to */
10059 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10060 SvFLAGS(dstr) &= ~SVTYPEMASK;
10061 SvOBJECT_off(dstr);
10065 switch (SvTYPE(sstr)) {
10067 SvANY(dstr) = NULL;
10070 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
10071 SvIV_set(dstr, SvIVX(sstr));
10074 SvANY(dstr) = new_XNV();
10075 SvNV_set(dstr, SvNVX(sstr));
10078 SvANY(dstr) = &(dstr->sv_u.svu_rv);
10079 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10083 /* These are all the types that need complex bodies allocating. */
10084 size_t new_body_length;
10085 size_t new_body_offset = 0;
10086 void **new_body_arena;
10087 void **new_body_arenaroot;
10089 svtype sv_type = SvTYPE(sstr);
10093 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]",
10098 new_body = new_XPVIO();
10099 new_body_length = sizeof(XPVIO);
10102 new_body = new_XPVFM();
10103 new_body_length = sizeof(XPVFM);
10107 new_body_arena = &PL_body_roots[SVt_PVHV];
10108 new_body_arenaroot = &PL_body_arenaroots[SVt_PVHV];
10109 new_body_offset = - offset_by_svtype[SVt_PVHV];
10111 new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash)
10112 + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash)
10116 new_body_arena = &PL_body_roots[SVt_PVAV];
10117 new_body_arenaroot = &PL_body_arenaroots[SVt_PVAV];
10118 new_body_offset = - offset_by_svtype[SVt_PVAV];
10120 new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash)
10121 + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash)
10125 if (GvUNIQUE((GV*)sstr)) {
10126 /* Do sharing here, and fall through */
10133 new_body_length = sizeof_body_by_svtype[sv_type];
10134 new_body_arena = &PL_body_roots[sv_type];
10135 new_body_arenaroot = &PL_body_arenaroots[sv_type];
10139 new_body_offset = - offset_by_svtype[SVt_PVIV];
10140 new_body_length = sizeof(XPVIV) - new_body_offset;
10141 new_body_arena = &PL_body_roots[SVt_PVIV];
10142 new_body_arenaroot = &PL_body_arenaroots[SVt_PVIV];
10145 new_body_offset = - offset_by_svtype[SVt_PV];
10146 new_body_length = sizeof(XPV) - new_body_offset;
10147 new_body_arena = &PL_body_roots[SVt_PV];
10148 new_body_arenaroot = &PL_body_arenaroots[SVt_PV];
10150 assert(new_body_length);
10152 new_body_inline(new_body, new_body_arena,
10153 new_body_length, SvTYPE(sstr));
10155 new_body = (void*)((char*)new_body - new_body_offset);
10157 /* We always allocated the full length item with PURIFY */
10158 new_body_length += new_body_offset;
10159 new_body_offset = 0;
10160 new_body = my_safemalloc(new_body_length);
10164 SvANY(dstr) = new_body;
10166 Copy(((char*)SvANY(sstr)) + new_body_offset,
10167 ((char*)SvANY(dstr)) + new_body_offset,
10168 new_body_length, char);
10170 if (SvTYPE(sstr) != SVt_PVAV && SvTYPE(sstr) != SVt_PVHV)
10171 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10173 /* The Copy above means that all the source (unduplicated) pointers
10174 are now in the destination. We can check the flags and the
10175 pointers in either, but it's possible that there's less cache
10176 missing by always going for the destination.
10177 FIXME - instrument and check that assumption */
10178 if (SvTYPE(sstr) >= SVt_PVMG) {
10180 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
10182 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
10185 switch (SvTYPE(sstr)) {
10197 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
10198 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
10199 LvTARG(dstr) = dstr;
10200 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
10201 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
10203 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
10206 GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr));
10207 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
10208 /* Don't call sv_add_backref here as it's going to be created
10209 as part of the magic cloning of the symbol table. */
10210 GvGP(dstr) = gp_dup(GvGP(dstr), param);
10211 (void)GpREFCNT_inc(GvGP(dstr));
10214 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
10215 if (IoOFP(dstr) == IoIFP(sstr))
10216 IoOFP(dstr) = IoIFP(dstr);
10218 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
10219 /* PL_rsfp_filters entries have fake IoDIRP() */
10220 if (IoDIRP(dstr) && !(IoFLAGS(dstr) & IOf_FAKE_DIRP))
10221 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
10222 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
10223 /* I have no idea why fake dirp (rsfps)
10224 should be treated differently but otherwise
10225 we end up with leaks -- sky*/
10226 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
10227 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
10228 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
10230 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
10231 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
10232 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
10234 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
10235 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
10236 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
10239 if (AvARRAY((AV*)sstr)) {
10240 SV **dst_ary, **src_ary;
10241 SSize_t items = AvFILLp((AV*)sstr) + 1;
10243 src_ary = AvARRAY((AV*)sstr);
10244 Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*);
10245 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10246 SvPV_set(dstr, (char*)dst_ary);
10247 AvALLOC((AV*)dstr) = dst_ary;
10248 if (AvREAL((AV*)sstr)) {
10249 while (items-- > 0)
10250 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10253 while (items-- > 0)
10254 *dst_ary++ = sv_dup(*src_ary++, param);
10256 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10257 while (items-- > 0) {
10258 *dst_ary++ = &PL_sv_undef;
10262 SvPV_set(dstr, Nullch);
10263 AvALLOC((AV*)dstr) = (SV**)NULL;
10270 if (HvARRAY((HV*)sstr)) {
10272 const bool sharekeys = !!HvSHAREKEYS(sstr);
10273 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
10274 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
10276 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
10277 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
10279 HvARRAY(dstr) = (HE**)darray;
10280 while (i <= sxhv->xhv_max) {
10281 const HE *source = HvARRAY(sstr)[i];
10282 HvARRAY(dstr)[i] = source
10283 ? he_dup(source, sharekeys, param) : 0;
10287 struct xpvhv_aux *saux = HvAUX(sstr);
10288 struct xpvhv_aux *daux = HvAUX(dstr);
10289 /* This flag isn't copied. */
10290 /* SvOOK_on(hv) attacks the IV flags. */
10291 SvFLAGS(dstr) |= SVf_OOK;
10293 hvname = saux->xhv_name;
10295 = hvname ? hek_dup(hvname, param) : hvname;
10297 daux->xhv_riter = saux->xhv_riter;
10298 daux->xhv_eiter = saux->xhv_eiter
10299 ? he_dup(saux->xhv_eiter,
10300 (bool)!!HvSHAREKEYS(sstr), param) : 0;
10304 SvPV_set(dstr, Nullch);
10306 /* Record stashes for possible cloning in Perl_clone(). */
10308 av_push(param->stashes, dstr);
10313 /* NOTE: not refcounted */
10314 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
10316 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
10318 if (CvCONST(dstr)) {
10319 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
10320 SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
10321 sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
10323 /* don't dup if copying back - CvGV isn't refcounted, so the
10324 * duped GV may never be freed. A bit of a hack! DAPM */
10325 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
10326 Nullgv : gv_dup(CvGV(dstr), param) ;
10327 if (!(param->flags & CLONEf_COPY_STACKS)) {
10330 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10332 CvWEAKOUTSIDE(sstr)
10333 ? cv_dup( CvOUTSIDE(dstr), param)
10334 : cv_dup_inc(CvOUTSIDE(dstr), param);
10336 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
10342 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10348 /* duplicate a context */
10351 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10353 PERL_CONTEXT *ncxs;
10356 return (PERL_CONTEXT*)NULL;
10358 /* look for it in the table first */
10359 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10363 /* create anew and remember what it is */
10364 Newxz(ncxs, max + 1, PERL_CONTEXT);
10365 ptr_table_store(PL_ptr_table, cxs, ncxs);
10368 PERL_CONTEXT *cx = &cxs[ix];
10369 PERL_CONTEXT *ncx = &ncxs[ix];
10370 ncx->cx_type = cx->cx_type;
10371 if (CxTYPE(cx) == CXt_SUBST) {
10372 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10375 ncx->blk_oldsp = cx->blk_oldsp;
10376 ncx->blk_oldcop = cx->blk_oldcop;
10377 ncx->blk_oldmarksp = cx->blk_oldmarksp;
10378 ncx->blk_oldscopesp = cx->blk_oldscopesp;
10379 ncx->blk_oldpm = cx->blk_oldpm;
10380 ncx->blk_gimme = cx->blk_gimme;
10381 switch (CxTYPE(cx)) {
10383 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
10384 ? cv_dup_inc(cx->blk_sub.cv, param)
10385 : cv_dup(cx->blk_sub.cv,param));
10386 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
10387 ? av_dup_inc(cx->blk_sub.argarray, param)
10389 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
10390 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
10391 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10392 ncx->blk_sub.lval = cx->blk_sub.lval;
10393 ncx->blk_sub.retop = cx->blk_sub.retop;
10396 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
10397 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
10398 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
10399 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
10400 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
10401 ncx->blk_eval.retop = cx->blk_eval.retop;
10404 ncx->blk_loop.label = cx->blk_loop.label;
10405 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
10406 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
10407 ncx->blk_loop.next_op = cx->blk_loop.next_op;
10408 ncx->blk_loop.last_op = cx->blk_loop.last_op;
10409 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
10410 ? cx->blk_loop.iterdata
10411 : gv_dup((GV*)cx->blk_loop.iterdata, param));
10412 ncx->blk_loop.oldcomppad
10413 = (PAD*)ptr_table_fetch(PL_ptr_table,
10414 cx->blk_loop.oldcomppad);
10415 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
10416 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
10417 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
10418 ncx->blk_loop.iterix = cx->blk_loop.iterix;
10419 ncx->blk_loop.itermax = cx->blk_loop.itermax;
10422 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
10423 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
10424 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
10425 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10426 ncx->blk_sub.retop = cx->blk_sub.retop;
10438 /* duplicate a stack info structure */
10441 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10446 return (PERL_SI*)NULL;
10448 /* look for it in the table first */
10449 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10453 /* create anew and remember what it is */
10454 Newxz(nsi, 1, PERL_SI);
10455 ptr_table_store(PL_ptr_table, si, nsi);
10457 nsi->si_stack = av_dup_inc(si->si_stack, param);
10458 nsi->si_cxix = si->si_cxix;
10459 nsi->si_cxmax = si->si_cxmax;
10460 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
10461 nsi->si_type = si->si_type;
10462 nsi->si_prev = si_dup(si->si_prev, param);
10463 nsi->si_next = si_dup(si->si_next, param);
10464 nsi->si_markoff = si->si_markoff;
10469 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
10470 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
10471 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
10472 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
10473 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
10474 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
10475 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
10476 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
10477 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
10478 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
10479 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
10480 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
10481 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
10482 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
10485 #define pv_dup_inc(p) SAVEPV(p)
10486 #define pv_dup(p) SAVEPV(p)
10487 #define svp_dup_inc(p,pp) any_dup(p,pp)
10489 /* map any object to the new equivent - either something in the
10490 * ptr table, or something in the interpreter structure
10494 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
10499 return (void*)NULL;
10501 /* look for it in the table first */
10502 ret = ptr_table_fetch(PL_ptr_table, v);
10506 /* see if it is part of the interpreter structure */
10507 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
10508 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
10516 /* duplicate the save stack */
10519 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
10521 ANY * const ss = proto_perl->Tsavestack;
10522 const I32 max = proto_perl->Tsavestack_max;
10523 I32 ix = proto_perl->Tsavestack_ix;
10535 void (*dptr) (void*);
10536 void (*dxptr) (pTHX_ void*);
10538 Newxz(nss, max, ANY);
10541 I32 i = POPINT(ss,ix);
10542 TOPINT(nss,ix) = i;
10544 case SAVEt_ITEM: /* normal string */
10545 sv = (SV*)POPPTR(ss,ix);
10546 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10547 sv = (SV*)POPPTR(ss,ix);
10548 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10550 case SAVEt_SV: /* scalar reference */
10551 sv = (SV*)POPPTR(ss,ix);
10552 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10553 gv = (GV*)POPPTR(ss,ix);
10554 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10556 case SAVEt_GENERIC_PVREF: /* generic char* */
10557 c = (char*)POPPTR(ss,ix);
10558 TOPPTR(nss,ix) = pv_dup(c);
10559 ptr = POPPTR(ss,ix);
10560 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10562 case SAVEt_SHARED_PVREF: /* char* in shared space */
10563 c = (char*)POPPTR(ss,ix);
10564 TOPPTR(nss,ix) = savesharedpv(c);
10565 ptr = POPPTR(ss,ix);
10566 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10568 case SAVEt_GENERIC_SVREF: /* generic sv */
10569 case SAVEt_SVREF: /* scalar reference */
10570 sv = (SV*)POPPTR(ss,ix);
10571 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10572 ptr = POPPTR(ss,ix);
10573 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
10575 case SAVEt_AV: /* array reference */
10576 av = (AV*)POPPTR(ss,ix);
10577 TOPPTR(nss,ix) = av_dup_inc(av, param);
10578 gv = (GV*)POPPTR(ss,ix);
10579 TOPPTR(nss,ix) = gv_dup(gv, param);
10581 case SAVEt_HV: /* hash reference */
10582 hv = (HV*)POPPTR(ss,ix);
10583 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10584 gv = (GV*)POPPTR(ss,ix);
10585 TOPPTR(nss,ix) = gv_dup(gv, param);
10587 case SAVEt_INT: /* int reference */
10588 ptr = POPPTR(ss,ix);
10589 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10590 intval = (int)POPINT(ss,ix);
10591 TOPINT(nss,ix) = intval;
10593 case SAVEt_LONG: /* long reference */
10594 ptr = POPPTR(ss,ix);
10595 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10596 longval = (long)POPLONG(ss,ix);
10597 TOPLONG(nss,ix) = longval;
10599 case SAVEt_I32: /* I32 reference */
10600 case SAVEt_I16: /* I16 reference */
10601 case SAVEt_I8: /* I8 reference */
10602 ptr = POPPTR(ss,ix);
10603 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10605 TOPINT(nss,ix) = i;
10607 case SAVEt_IV: /* IV reference */
10608 ptr = POPPTR(ss,ix);
10609 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10611 TOPIV(nss,ix) = iv;
10613 case SAVEt_SPTR: /* SV* reference */
10614 ptr = POPPTR(ss,ix);
10615 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10616 sv = (SV*)POPPTR(ss,ix);
10617 TOPPTR(nss,ix) = sv_dup(sv, param);
10619 case SAVEt_VPTR: /* random* reference */
10620 ptr = POPPTR(ss,ix);
10621 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10622 ptr = POPPTR(ss,ix);
10623 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10625 case SAVEt_PPTR: /* char* reference */
10626 ptr = POPPTR(ss,ix);
10627 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10628 c = (char*)POPPTR(ss,ix);
10629 TOPPTR(nss,ix) = pv_dup(c);
10631 case SAVEt_HPTR: /* HV* reference */
10632 ptr = POPPTR(ss,ix);
10633 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10634 hv = (HV*)POPPTR(ss,ix);
10635 TOPPTR(nss,ix) = hv_dup(hv, param);
10637 case SAVEt_APTR: /* AV* reference */
10638 ptr = POPPTR(ss,ix);
10639 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10640 av = (AV*)POPPTR(ss,ix);
10641 TOPPTR(nss,ix) = av_dup(av, param);
10644 gv = (GV*)POPPTR(ss,ix);
10645 TOPPTR(nss,ix) = gv_dup(gv, param);
10647 case SAVEt_GP: /* scalar reference */
10648 gp = (GP*)POPPTR(ss,ix);
10649 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
10650 (void)GpREFCNT_inc(gp);
10651 gv = (GV*)POPPTR(ss,ix);
10652 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10653 c = (char*)POPPTR(ss,ix);
10654 TOPPTR(nss,ix) = pv_dup(c);
10656 TOPIV(nss,ix) = iv;
10658 TOPIV(nss,ix) = iv;
10661 case SAVEt_MORTALIZESV:
10662 sv = (SV*)POPPTR(ss,ix);
10663 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10666 ptr = POPPTR(ss,ix);
10667 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
10668 /* these are assumed to be refcounted properly */
10670 switch (((OP*)ptr)->op_type) {
10672 case OP_LEAVESUBLV:
10676 case OP_LEAVEWRITE:
10677 TOPPTR(nss,ix) = ptr;
10682 TOPPTR(nss,ix) = Nullop;
10687 TOPPTR(nss,ix) = Nullop;
10690 c = (char*)POPPTR(ss,ix);
10691 TOPPTR(nss,ix) = pv_dup_inc(c);
10693 case SAVEt_CLEARSV:
10694 longval = POPLONG(ss,ix);
10695 TOPLONG(nss,ix) = longval;
10698 hv = (HV*)POPPTR(ss,ix);
10699 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10700 c = (char*)POPPTR(ss,ix);
10701 TOPPTR(nss,ix) = pv_dup_inc(c);
10703 TOPINT(nss,ix) = i;
10705 case SAVEt_DESTRUCTOR:
10706 ptr = POPPTR(ss,ix);
10707 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10708 dptr = POPDPTR(ss,ix);
10709 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
10710 any_dup(FPTR2DPTR(void *, dptr),
10713 case SAVEt_DESTRUCTOR_X:
10714 ptr = POPPTR(ss,ix);
10715 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10716 dxptr = POPDXPTR(ss,ix);
10717 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
10718 any_dup(FPTR2DPTR(void *, dxptr),
10721 case SAVEt_REGCONTEXT:
10724 TOPINT(nss,ix) = i;
10727 case SAVEt_STACK_POS: /* Position on Perl stack */
10729 TOPINT(nss,ix) = i;
10731 case SAVEt_AELEM: /* array element */
10732 sv = (SV*)POPPTR(ss,ix);
10733 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10735 TOPINT(nss,ix) = i;
10736 av = (AV*)POPPTR(ss,ix);
10737 TOPPTR(nss,ix) = av_dup_inc(av, param);
10739 case SAVEt_HELEM: /* hash element */
10740 sv = (SV*)POPPTR(ss,ix);
10741 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10742 sv = (SV*)POPPTR(ss,ix);
10743 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10744 hv = (HV*)POPPTR(ss,ix);
10745 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10748 ptr = POPPTR(ss,ix);
10749 TOPPTR(nss,ix) = ptr;
10753 TOPINT(nss,ix) = i;
10755 case SAVEt_COMPPAD:
10756 av = (AV*)POPPTR(ss,ix);
10757 TOPPTR(nss,ix) = av_dup(av, param);
10760 longval = (long)POPLONG(ss,ix);
10761 TOPLONG(nss,ix) = longval;
10762 ptr = POPPTR(ss,ix);
10763 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10764 sv = (SV*)POPPTR(ss,ix);
10765 TOPPTR(nss,ix) = sv_dup(sv, param);
10768 ptr = POPPTR(ss,ix);
10769 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10770 longval = (long)POPBOOL(ss,ix);
10771 TOPBOOL(nss,ix) = (bool)longval;
10773 case SAVEt_SET_SVFLAGS:
10775 TOPINT(nss,ix) = i;
10777 TOPINT(nss,ix) = i;
10778 sv = (SV*)POPPTR(ss,ix);
10779 TOPPTR(nss,ix) = sv_dup(sv, param);
10782 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
10790 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
10791 * flag to the result. This is done for each stash before cloning starts,
10792 * so we know which stashes want their objects cloned */
10795 do_mark_cloneable_stash(pTHX_ SV *sv)
10797 const HEK * const hvname = HvNAME_HEK((HV*)sv);
10799 GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
10800 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
10801 if (cloner && GvCV(cloner)) {
10808 XPUSHs(sv_2mortal(newSVhek(hvname)));
10810 call_sv((SV*)GvCV(cloner), G_SCALAR);
10817 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
10825 =for apidoc perl_clone
10827 Create and return a new interpreter by cloning the current one.
10829 perl_clone takes these flags as parameters:
10831 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
10832 without it we only clone the data and zero the stacks,
10833 with it we copy the stacks and the new perl interpreter is
10834 ready to run at the exact same point as the previous one.
10835 The pseudo-fork code uses COPY_STACKS while the
10836 threads->new doesn't.
10838 CLONEf_KEEP_PTR_TABLE
10839 perl_clone keeps a ptr_table with the pointer of the old
10840 variable as a key and the new variable as a value,
10841 this allows it to check if something has been cloned and not
10842 clone it again but rather just use the value and increase the
10843 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
10844 the ptr_table using the function
10845 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
10846 reason to keep it around is if you want to dup some of your own
10847 variable who are outside the graph perl scans, example of this
10848 code is in threads.xs create
10851 This is a win32 thing, it is ignored on unix, it tells perls
10852 win32host code (which is c++) to clone itself, this is needed on
10853 win32 if you want to run two threads at the same time,
10854 if you just want to do some stuff in a separate perl interpreter
10855 and then throw it away and return to the original one,
10856 you don't need to do anything.
10861 /* XXX the above needs expanding by someone who actually understands it ! */
10862 EXTERN_C PerlInterpreter *
10863 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
10866 perl_clone(PerlInterpreter *proto_perl, UV flags)
10869 #ifdef PERL_IMPLICIT_SYS
10871 /* perlhost.h so we need to call into it
10872 to clone the host, CPerlHost should have a c interface, sky */
10874 if (flags & CLONEf_CLONE_HOST) {
10875 return perl_clone_host(proto_perl,flags);
10877 return perl_clone_using(proto_perl, flags,
10879 proto_perl->IMemShared,
10880 proto_perl->IMemParse,
10882 proto_perl->IStdIO,
10886 proto_perl->IProc);
10890 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
10891 struct IPerlMem* ipM, struct IPerlMem* ipMS,
10892 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
10893 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
10894 struct IPerlDir* ipD, struct IPerlSock* ipS,
10895 struct IPerlProc* ipP)
10897 /* XXX many of the string copies here can be optimized if they're
10898 * constants; they need to be allocated as common memory and just
10899 * their pointers copied. */
10902 CLONE_PARAMS clone_params;
10903 CLONE_PARAMS* param = &clone_params;
10905 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
10906 /* for each stash, determine whether its objects should be cloned */
10907 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10908 PERL_SET_THX(my_perl);
10911 Poison(my_perl, 1, PerlInterpreter);
10913 PL_curcop = (COP *)Nullop;
10917 PL_savestack_ix = 0;
10918 PL_savestack_max = -1;
10919 PL_sig_pending = 0;
10920 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10921 # else /* !DEBUGGING */
10922 Zero(my_perl, 1, PerlInterpreter);
10923 # endif /* DEBUGGING */
10925 /* host pointers */
10927 PL_MemShared = ipMS;
10928 PL_MemParse = ipMP;
10935 #else /* !PERL_IMPLICIT_SYS */
10937 CLONE_PARAMS clone_params;
10938 CLONE_PARAMS* param = &clone_params;
10939 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
10940 /* for each stash, determine whether its objects should be cloned */
10941 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10942 PERL_SET_THX(my_perl);
10945 Poison(my_perl, 1, PerlInterpreter);
10947 PL_curcop = (COP *)Nullop;
10951 PL_savestack_ix = 0;
10952 PL_savestack_max = -1;
10953 PL_sig_pending = 0;
10954 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10955 # else /* !DEBUGGING */
10956 Zero(my_perl, 1, PerlInterpreter);
10957 # endif /* DEBUGGING */
10958 #endif /* PERL_IMPLICIT_SYS */
10959 param->flags = flags;
10960 param->proto_perl = proto_perl;
10962 Zero(&PL_body_arenaroots, 1, PL_body_arenaroots);
10963 Zero(&PL_body_roots, 1, PL_body_roots);
10965 PL_he_arenaroot = NULL;
10968 PL_nice_chunk = NULL;
10969 PL_nice_chunk_size = 0;
10971 PL_sv_objcount = 0;
10972 PL_sv_root = Nullsv;
10973 PL_sv_arenaroot = Nullsv;
10975 PL_debug = proto_perl->Idebug;
10977 PL_hash_seed = proto_perl->Ihash_seed;
10978 PL_rehash_seed = proto_perl->Irehash_seed;
10980 #ifdef USE_REENTRANT_API
10981 /* XXX: things like -Dm will segfault here in perlio, but doing
10982 * PERL_SET_CONTEXT(proto_perl);
10983 * breaks too many other things
10985 Perl_reentrant_init(aTHX);
10988 /* create SV map for pointer relocation */
10989 PL_ptr_table = ptr_table_new();
10991 /* initialize these special pointers as early as possible */
10992 SvANY(&PL_sv_undef) = NULL;
10993 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
10994 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
10995 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
10997 SvANY(&PL_sv_no) = new_XPVNV();
10998 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
10999 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11000 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11001 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
11002 SvCUR_set(&PL_sv_no, 0);
11003 SvLEN_set(&PL_sv_no, 1);
11004 SvIV_set(&PL_sv_no, 0);
11005 SvNV_set(&PL_sv_no, 0);
11006 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11008 SvANY(&PL_sv_yes) = new_XPVNV();
11009 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11010 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11011 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11012 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
11013 SvCUR_set(&PL_sv_yes, 1);
11014 SvLEN_set(&PL_sv_yes, 2);
11015 SvIV_set(&PL_sv_yes, 1);
11016 SvNV_set(&PL_sv_yes, 1);
11017 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11019 /* create (a non-shared!) shared string table */
11020 PL_strtab = newHV();
11021 HvSHAREKEYS_off(PL_strtab);
11022 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
11023 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11025 PL_compiling = proto_perl->Icompiling;
11027 /* These two PVs will be free'd special way so must set them same way op.c does */
11028 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11029 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11031 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11032 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11034 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11035 if (!specialWARN(PL_compiling.cop_warnings))
11036 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
11037 if (!specialCopIO(PL_compiling.cop_io))
11038 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
11039 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
11041 /* pseudo environmental stuff */
11042 PL_origargc = proto_perl->Iorigargc;
11043 PL_origargv = proto_perl->Iorigargv;
11045 param->stashes = newAV(); /* Setup array of objects to call clone on */
11047 /* Set tainting stuff before PerlIO_debug can possibly get called */
11048 PL_tainting = proto_perl->Itainting;
11049 PL_taint_warn = proto_perl->Itaint_warn;
11051 #ifdef PERLIO_LAYERS
11052 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11053 PerlIO_clone(aTHX_ proto_perl, param);
11056 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11057 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11058 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11059 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11060 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11061 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11064 PL_minus_c = proto_perl->Iminus_c;
11065 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11066 PL_localpatches = proto_perl->Ilocalpatches;
11067 PL_splitstr = proto_perl->Isplitstr;
11068 PL_preprocess = proto_perl->Ipreprocess;
11069 PL_minus_n = proto_perl->Iminus_n;
11070 PL_minus_p = proto_perl->Iminus_p;
11071 PL_minus_l = proto_perl->Iminus_l;
11072 PL_minus_a = proto_perl->Iminus_a;
11073 PL_minus_F = proto_perl->Iminus_F;
11074 PL_doswitches = proto_perl->Idoswitches;
11075 PL_dowarn = proto_perl->Idowarn;
11076 PL_doextract = proto_perl->Idoextract;
11077 PL_sawampersand = proto_perl->Isawampersand;
11078 PL_unsafe = proto_perl->Iunsafe;
11079 PL_inplace = SAVEPV(proto_perl->Iinplace);
11080 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11081 PL_perldb = proto_perl->Iperldb;
11082 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11083 PL_exit_flags = proto_perl->Iexit_flags;
11085 /* magical thingies */
11086 /* XXX time(&PL_basetime) when asked for? */
11087 PL_basetime = proto_perl->Ibasetime;
11088 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11090 PL_maxsysfd = proto_perl->Imaxsysfd;
11091 PL_multiline = proto_perl->Imultiline;
11092 PL_statusvalue = proto_perl->Istatusvalue;
11094 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11096 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
11098 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11100 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11101 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11102 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11104 /* Clone the regex array */
11105 PL_regex_padav = newAV();
11107 const I32 len = av_len((AV*)proto_perl->Iregex_padav);
11108 SV** const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11110 av_push(PL_regex_padav,
11111 sv_dup_inc(regexen[0],param));
11112 for(i = 1; i <= len; i++) {
11113 if(SvREPADTMP(regexen[i])) {
11114 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11116 av_push(PL_regex_padav,
11118 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11119 SvIVX(regexen[i])), param)))
11124 PL_regex_pad = AvARRAY(PL_regex_padav);
11126 /* shortcuts to various I/O objects */
11127 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11128 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11129 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11130 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11131 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11132 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11134 /* shortcuts to regexp stuff */
11135 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11137 /* shortcuts to misc objects */
11138 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11140 /* shortcuts to debugging objects */
11141 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11142 PL_DBline = gv_dup(proto_perl->IDBline, param);
11143 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11144 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11145 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11146 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11147 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11148 PL_lineary = av_dup(proto_perl->Ilineary, param);
11149 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11151 /* symbol tables */
11152 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11153 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11154 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11155 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11156 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11158 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11159 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11160 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11161 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11162 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11163 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11165 PL_sub_generation = proto_perl->Isub_generation;
11167 /* funky return mechanisms */
11168 PL_forkprocess = proto_perl->Iforkprocess;
11170 /* subprocess state */
11171 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11173 /* internal state */
11174 PL_maxo = proto_perl->Imaxo;
11175 if (proto_perl->Iop_mask)
11176 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11178 PL_op_mask = Nullch;
11179 /* PL_asserting = proto_perl->Iasserting; */
11181 /* current interpreter roots */
11182 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11183 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11184 PL_main_start = proto_perl->Imain_start;
11185 PL_eval_root = proto_perl->Ieval_root;
11186 PL_eval_start = proto_perl->Ieval_start;
11188 /* runtime control stuff */
11189 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11190 PL_copline = proto_perl->Icopline;
11192 PL_filemode = proto_perl->Ifilemode;
11193 PL_lastfd = proto_perl->Ilastfd;
11194 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11197 PL_gensym = proto_perl->Igensym;
11198 PL_preambled = proto_perl->Ipreambled;
11199 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11200 PL_laststatval = proto_perl->Ilaststatval;
11201 PL_laststype = proto_perl->Ilaststype;
11202 PL_mess_sv = Nullsv;
11204 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11206 /* interpreter atexit processing */
11207 PL_exitlistlen = proto_perl->Iexitlistlen;
11208 if (PL_exitlistlen) {
11209 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11210 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11213 PL_exitlist = (PerlExitListEntry*)NULL;
11214 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11215 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11216 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11218 PL_profiledata = NULL;
11219 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
11220 /* PL_rsfp_filters entries have fake IoDIRP() */
11221 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
11223 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11225 PAD_CLONE_VARS(proto_perl, param);
11227 #ifdef HAVE_INTERP_INTERN
11228 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11231 /* more statics moved here */
11232 PL_generation = proto_perl->Igeneration;
11233 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11235 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11236 PL_in_clean_all = proto_perl->Iin_clean_all;
11238 PL_uid = proto_perl->Iuid;
11239 PL_euid = proto_perl->Ieuid;
11240 PL_gid = proto_perl->Igid;
11241 PL_egid = proto_perl->Iegid;
11242 PL_nomemok = proto_perl->Inomemok;
11243 PL_an = proto_perl->Ian;
11244 PL_evalseq = proto_perl->Ievalseq;
11245 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11246 PL_origalen = proto_perl->Iorigalen;
11247 #ifdef PERL_USES_PL_PIDSTATUS
11248 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11250 PL_osname = SAVEPV(proto_perl->Iosname);
11251 PL_sighandlerp = proto_perl->Isighandlerp;
11253 PL_runops = proto_perl->Irunops;
11255 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11258 PL_cshlen = proto_perl->Icshlen;
11259 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
11262 PL_lex_state = proto_perl->Ilex_state;
11263 PL_lex_defer = proto_perl->Ilex_defer;
11264 PL_lex_expect = proto_perl->Ilex_expect;
11265 PL_lex_formbrack = proto_perl->Ilex_formbrack;
11266 PL_lex_dojoin = proto_perl->Ilex_dojoin;
11267 PL_lex_starts = proto_perl->Ilex_starts;
11268 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
11269 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
11270 PL_lex_op = proto_perl->Ilex_op;
11271 PL_lex_inpat = proto_perl->Ilex_inpat;
11272 PL_lex_inwhat = proto_perl->Ilex_inwhat;
11273 PL_lex_brackets = proto_perl->Ilex_brackets;
11274 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11275 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
11276 PL_lex_casemods = proto_perl->Ilex_casemods;
11277 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11278 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
11280 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11281 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
11282 PL_nexttoke = proto_perl->Inexttoke;
11284 /* XXX This is probably masking the deeper issue of why
11285 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11286 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11287 * (A little debugging with a watchpoint on it may help.)
11289 if (SvANY(proto_perl->Ilinestr)) {
11290 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
11291 i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
11292 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11293 i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
11294 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11295 i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
11296 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11297 i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
11298 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11301 PL_linestr = NEWSV(65,79);
11302 sv_upgrade(PL_linestr,SVt_PVIV);
11303 sv_setpvn(PL_linestr,"",0);
11304 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
11306 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11307 PL_pending_ident = proto_perl->Ipending_ident;
11308 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
11310 PL_expect = proto_perl->Iexpect;
11312 PL_multi_start = proto_perl->Imulti_start;
11313 PL_multi_end = proto_perl->Imulti_end;
11314 PL_multi_open = proto_perl->Imulti_open;
11315 PL_multi_close = proto_perl->Imulti_close;
11317 PL_error_count = proto_perl->Ierror_count;
11318 PL_subline = proto_perl->Isubline;
11319 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
11321 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
11322 if (SvANY(proto_perl->Ilinestr)) {
11323 i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
11324 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11325 i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
11326 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11327 PL_last_lop_op = proto_perl->Ilast_lop_op;
11330 PL_last_uni = SvPVX(PL_linestr);
11331 PL_last_lop = SvPVX(PL_linestr);
11332 PL_last_lop_op = 0;
11334 PL_in_my = proto_perl->Iin_my;
11335 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
11337 PL_cryptseen = proto_perl->Icryptseen;
11340 PL_hints = proto_perl->Ihints;
11342 PL_amagic_generation = proto_perl->Iamagic_generation;
11344 #ifdef USE_LOCALE_COLLATE
11345 PL_collation_ix = proto_perl->Icollation_ix;
11346 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
11347 PL_collation_standard = proto_perl->Icollation_standard;
11348 PL_collxfrm_base = proto_perl->Icollxfrm_base;
11349 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
11350 #endif /* USE_LOCALE_COLLATE */
11352 #ifdef USE_LOCALE_NUMERIC
11353 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
11354 PL_numeric_standard = proto_perl->Inumeric_standard;
11355 PL_numeric_local = proto_perl->Inumeric_local;
11356 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11357 #endif /* !USE_LOCALE_NUMERIC */
11359 /* utf8 character classes */
11360 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11361 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11362 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11363 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11364 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
11365 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11366 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
11367 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
11368 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
11369 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
11370 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
11371 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
11372 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11373 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
11374 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11375 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11376 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11377 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11378 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11379 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11381 /* Did the locale setup indicate UTF-8? */
11382 PL_utf8locale = proto_perl->Iutf8locale;
11383 /* Unicode features (see perlrun/-C) */
11384 PL_unicode = proto_perl->Iunicode;
11386 /* Pre-5.8 signals control */
11387 PL_signals = proto_perl->Isignals;
11389 /* times() ticks per second */
11390 PL_clocktick = proto_perl->Iclocktick;
11392 /* Recursion stopper for PerlIO_find_layer */
11393 PL_in_load_module = proto_perl->Iin_load_module;
11395 /* sort() routine */
11396 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
11398 /* Not really needed/useful since the reenrant_retint is "volatile",
11399 * but do it for consistency's sake. */
11400 PL_reentrant_retint = proto_perl->Ireentrant_retint;
11402 /* Hooks to shared SVs and locks. */
11403 PL_sharehook = proto_perl->Isharehook;
11404 PL_lockhook = proto_perl->Ilockhook;
11405 PL_unlockhook = proto_perl->Iunlockhook;
11406 PL_threadhook = proto_perl->Ithreadhook;
11408 PL_runops_std = proto_perl->Irunops_std;
11409 PL_runops_dbg = proto_perl->Irunops_dbg;
11411 #ifdef THREADS_HAVE_PIDS
11412 PL_ppid = proto_perl->Ippid;
11416 PL_last_swash_hv = Nullhv; /* reinits on demand */
11417 PL_last_swash_klen = 0;
11418 PL_last_swash_key[0]= '\0';
11419 PL_last_swash_tmps = (U8*)NULL;
11420 PL_last_swash_slen = 0;
11422 PL_glob_index = proto_perl->Iglob_index;
11423 PL_srand_called = proto_perl->Isrand_called;
11424 PL_uudmap['M'] = 0; /* reinits on demand */
11425 PL_bitcount = Nullch; /* reinits on demand */
11427 if (proto_perl->Ipsig_pend) {
11428 Newxz(PL_psig_pend, SIG_SIZE, int);
11431 PL_psig_pend = (int*)NULL;
11434 if (proto_perl->Ipsig_ptr) {
11435 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
11436 Newxz(PL_psig_name, SIG_SIZE, SV*);
11437 for (i = 1; i < SIG_SIZE; i++) {
11438 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11439 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11443 PL_psig_ptr = (SV**)NULL;
11444 PL_psig_name = (SV**)NULL;
11447 /* thrdvar.h stuff */
11449 if (flags & CLONEf_COPY_STACKS) {
11450 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11451 PL_tmps_ix = proto_perl->Ttmps_ix;
11452 PL_tmps_max = proto_perl->Ttmps_max;
11453 PL_tmps_floor = proto_perl->Ttmps_floor;
11454 Newxz(PL_tmps_stack, PL_tmps_max, SV*);
11456 while (i <= PL_tmps_ix) {
11457 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
11461 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11462 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
11463 Newxz(PL_markstack, i, I32);
11464 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
11465 - proto_perl->Tmarkstack);
11466 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
11467 - proto_perl->Tmarkstack);
11468 Copy(proto_perl->Tmarkstack, PL_markstack,
11469 PL_markstack_ptr - PL_markstack + 1, I32);
11471 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
11472 * NOTE: unlike the others! */
11473 PL_scopestack_ix = proto_perl->Tscopestack_ix;
11474 PL_scopestack_max = proto_perl->Tscopestack_max;
11475 Newxz(PL_scopestack, PL_scopestack_max, I32);
11476 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
11478 /* NOTE: si_dup() looks at PL_markstack */
11479 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
11481 /* PL_curstack = PL_curstackinfo->si_stack; */
11482 PL_curstack = av_dup(proto_perl->Tcurstack, param);
11483 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
11485 /* next PUSHs() etc. set *(PL_stack_sp+1) */
11486 PL_stack_base = AvARRAY(PL_curstack);
11487 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
11488 - proto_perl->Tstack_base);
11489 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
11491 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
11492 * NOTE: unlike the others! */
11493 PL_savestack_ix = proto_perl->Tsavestack_ix;
11494 PL_savestack_max = proto_perl->Tsavestack_max;
11495 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
11496 PL_savestack = ss_dup(proto_perl, param);
11500 ENTER; /* perl_destruct() wants to LEAVE; */
11503 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
11504 PL_top_env = &PL_start_env;
11506 PL_op = proto_perl->Top;
11509 PL_Xpv = (XPV*)NULL;
11510 PL_na = proto_perl->Tna;
11512 PL_statbuf = proto_perl->Tstatbuf;
11513 PL_statcache = proto_perl->Tstatcache;
11514 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
11515 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
11517 PL_timesbuf = proto_perl->Ttimesbuf;
11520 PL_tainted = proto_perl->Ttainted;
11521 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
11522 PL_rs = sv_dup_inc(proto_perl->Trs, param);
11523 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
11524 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
11525 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
11526 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
11527 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
11528 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
11529 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
11531 PL_restartop = proto_perl->Trestartop;
11532 PL_in_eval = proto_perl->Tin_eval;
11533 PL_delaymagic = proto_perl->Tdelaymagic;
11534 PL_dirty = proto_perl->Tdirty;
11535 PL_localizing = proto_perl->Tlocalizing;
11537 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
11538 PL_hv_fetch_ent_mh = Nullhe;
11539 PL_modcount = proto_perl->Tmodcount;
11540 PL_lastgotoprobe = Nullop;
11541 PL_dumpindent = proto_perl->Tdumpindent;
11543 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
11544 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
11545 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
11546 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
11547 PL_efloatbuf = Nullch; /* reinits on demand */
11548 PL_efloatsize = 0; /* reinits on demand */
11552 PL_screamfirst = NULL;
11553 PL_screamnext = NULL;
11554 PL_maxscream = -1; /* reinits on demand */
11555 PL_lastscream = Nullsv;
11557 PL_watchaddr = NULL;
11558 PL_watchok = Nullch;
11560 PL_regdummy = proto_perl->Tregdummy;
11561 PL_regprecomp = Nullch;
11564 PL_colorset = 0; /* reinits PL_colors[] */
11565 /*PL_colors[6] = {0,0,0,0,0,0};*/
11566 PL_reginput = Nullch;
11567 PL_regbol = Nullch;
11568 PL_regeol = Nullch;
11569 PL_regstartp = (I32*)NULL;
11570 PL_regendp = (I32*)NULL;
11571 PL_reglastparen = (U32*)NULL;
11572 PL_reglastcloseparen = (U32*)NULL;
11573 PL_regtill = Nullch;
11574 PL_reg_start_tmp = (char**)NULL;
11575 PL_reg_start_tmpl = 0;
11576 PL_regdata = (struct reg_data*)NULL;
11579 PL_reg_eval_set = 0;
11581 PL_regprogram = (regnode*)NULL;
11583 PL_regcc = (CURCUR*)NULL;
11584 PL_reg_call_cc = (struct re_cc_state*)NULL;
11585 PL_reg_re = (regexp*)NULL;
11586 PL_reg_ganch = Nullch;
11587 PL_reg_sv = Nullsv;
11588 PL_reg_match_utf8 = FALSE;
11589 PL_reg_magic = (MAGIC*)NULL;
11591 PL_reg_oldcurpm = (PMOP*)NULL;
11592 PL_reg_curpm = (PMOP*)NULL;
11593 PL_reg_oldsaved = Nullch;
11594 PL_reg_oldsavedlen = 0;
11595 #ifdef PERL_OLD_COPY_ON_WRITE
11598 PL_reg_maxiter = 0;
11599 PL_reg_leftiter = 0;
11600 PL_reg_poscache = Nullch;
11601 PL_reg_poscache_size= 0;
11603 /* RE engine - function pointers */
11604 PL_regcompp = proto_perl->Tregcompp;
11605 PL_regexecp = proto_perl->Tregexecp;
11606 PL_regint_start = proto_perl->Tregint_start;
11607 PL_regint_string = proto_perl->Tregint_string;
11608 PL_regfree = proto_perl->Tregfree;
11610 PL_reginterp_cnt = 0;
11611 PL_reg_starttry = 0;
11613 /* Pluggable optimizer */
11614 PL_peepp = proto_perl->Tpeepp;
11616 PL_stashcache = newHV();
11618 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
11619 ptr_table_free(PL_ptr_table);
11620 PL_ptr_table = NULL;
11623 /* Call the ->CLONE method, if it exists, for each of the stashes
11624 identified by sv_dup() above.
11626 while(av_len(param->stashes) != -1) {
11627 HV* const stash = (HV*) av_shift(param->stashes);
11628 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
11629 if (cloner && GvCV(cloner)) {
11634 XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
11636 call_sv((SV*)GvCV(cloner), G_DISCARD);
11642 SvREFCNT_dec(param->stashes);
11644 /* orphaned? eg threads->new inside BEGIN or use */
11645 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
11646 (void)SvREFCNT_inc(PL_compcv);
11647 SAVEFREESV(PL_compcv);
11653 #endif /* USE_ITHREADS */
11656 =head1 Unicode Support
11658 =for apidoc sv_recode_to_utf8
11660 The encoding is assumed to be an Encode object, on entry the PV
11661 of the sv is assumed to be octets in that encoding, and the sv
11662 will be converted into Unicode (and UTF-8).
11664 If the sv already is UTF-8 (or if it is not POK), or if the encoding
11665 is not a reference, nothing is done to the sv. If the encoding is not
11666 an C<Encode::XS> Encoding object, bad things will happen.
11667 (See F<lib/encoding.pm> and L<Encode>).
11669 The PV of the sv is returned.
11674 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
11677 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
11691 Passing sv_yes is wrong - it needs to be or'ed set of constants
11692 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
11693 remove converted chars from source.
11695 Both will default the value - let them.
11697 XPUSHs(&PL_sv_yes);
11700 call_method("decode", G_SCALAR);
11704 s = SvPV_const(uni, len);
11705 if (s != SvPVX_const(sv)) {
11706 SvGROW(sv, len + 1);
11707 Move(s, SvPVX(sv), len + 1, char);
11708 SvCUR_set(sv, len);
11715 return SvPOKp(sv) ? SvPVX(sv) : NULL;
11719 =for apidoc sv_cat_decode
11721 The encoding is assumed to be an Encode object, the PV of the ssv is
11722 assumed to be octets in that encoding and decoding the input starts
11723 from the position which (PV + *offset) pointed to. The dsv will be
11724 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
11725 when the string tstr appears in decoding output or the input ends on
11726 the PV of the ssv. The value which the offset points will be modified
11727 to the last input position on the ssv.
11729 Returns TRUE if the terminator was found, else returns FALSE.
11734 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
11735 SV *ssv, int *offset, char *tstr, int tlen)
11739 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
11750 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
11751 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
11753 call_method("cat_decode", G_SCALAR);
11755 ret = SvTRUE(TOPs);
11756 *offset = SvIV(offsv);
11762 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
11768 * c-indentation-style: bsd
11769 * c-basic-offset: 4
11770 * indent-tabs-mode: t
11773 * ex: set ts=8 sts=4 sw=4 noet: