3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
9 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
12 * This file contains the code that creates, manipulates and destroys
13 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
14 * structure of an SV, so their creation and destruction is handled
15 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
16 * level functions (eg. substr, split, join) for each of the types are
28 /* Missing proto on LynxOS */
29 char *gconvert(double, int, int, char *);
32 #ifdef PERL_UTF8_CACHE_ASSERT
33 /* The cache element 0 is the Unicode offset;
34 * the cache element 1 is the byte offset of the element 0;
35 * the cache element 2 is the Unicode length of the substring;
36 * the cache element 3 is the byte length of the substring;
37 * The checking of the substring side would be good
38 * but substr() has enough code paths to make my head spin;
39 * if adding more checks watch out for the following tests:
40 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
41 * lib/utf8.t lib/Unicode/Collate/t/index.t
44 #define ASSERT_UTF8_CACHE(cache) \
45 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
47 #define ASSERT_UTF8_CACHE(cache) NOOP
50 #ifdef PERL_OLD_COPY_ON_WRITE
51 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
52 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
53 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
57 /* ============================================================================
59 =head1 Allocation and deallocation of SVs.
61 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
62 av, hv...) contains type and reference count information, as well as a
63 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
64 specific to each type.
66 In all but the most memory-paranoid configuations (ex: PURIFY), this
67 allocation is done using arenas, which by default are approximately 4K
68 chunks of memory parcelled up into N heads or bodies (of same size).
69 Sv-bodies are allocated by their sv-type, guaranteeing size
70 consistency needed to allocate safely from arrays.
72 The first slot in each arena is reserved, and is used to hold a link
73 to the next arena. In the case of heads, the unused first slot also
74 contains some flags and a note of the number of slots. Snaked through
75 each arena chain is a linked list of free items; when this becomes
76 empty, an extra arena is allocated and divided up into N items which
77 are threaded into the free list.
79 The following global variables are associated with arenas:
81 PL_sv_arenaroot pointer to list of SV arenas
82 PL_sv_root pointer to list of free SV structures
84 PL_body_arenaroots[] array of pointers to list of arenas, 1 per svtype
85 PL_body_roots[] array of pointers to list of free bodies of svtype
86 arrays are indexed by the svtype needed
88 Note that some of the larger and more rarely used body types (eg
89 xpvio) are not allocated using arenas, but are instead just
90 malloc()/free()ed as required.
92 In addition, a few SV heads are not allocated from an arena, but are
93 instead directly created as static or auto variables, eg PL_sv_undef.
94 The size of arenas can be changed from the default by setting
95 PERL_ARENA_SIZE appropriately at compile time.
97 The SV arena serves the secondary purpose of allowing still-live SVs
98 to be located and destroyed during final cleanup.
100 At the lowest level, the macros new_SV() and del_SV() grab and free
101 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
102 to return the SV to the free list with error checking.) new_SV() calls
103 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
104 SVs in the free list have their SvTYPE field set to all ones.
106 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
107 that allocate and return individual body types. Normally these are mapped
108 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
109 instead mapped directly to malloc()/free() if PURIFY is defined. The
110 new/del functions remove from, or add to, the appropriate PL_foo_root
111 list, and call more_xiv() etc to add a new arena if the list is empty.
113 At the time of very final cleanup, sv_free_arenas() is called from
114 perl_destruct() to physically free all the arenas allocated since the
115 start of the interpreter. Note that this also clears PL_he_arenaroot,
116 which is otherwise dealt with in hv.c.
118 Manipulation of any of the PL_*root pointers is protected by enclosing
119 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
120 if threads are enabled.
122 The function visit() scans the SV arenas list, and calls a specified
123 function for each SV it finds which is still live - ie which has an SvTYPE
124 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
125 following functions (specified as [function that calls visit()] / [function
126 called by visit() for each SV]):
128 sv_report_used() / do_report_used()
129 dump all remaining SVs (debugging aid)
131 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
132 Attempt to free all objects pointed to by RVs,
133 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
134 try to do the same for all objects indirectly
135 referenced by typeglobs too. Called once from
136 perl_destruct(), prior to calling sv_clean_all()
139 sv_clean_all() / do_clean_all()
140 SvREFCNT_dec(sv) each remaining SV, possibly
141 triggering an sv_free(). It also sets the
142 SVf_BREAK flag on the SV to indicate that the
143 refcnt has been artificially lowered, and thus
144 stopping sv_free() from giving spurious warnings
145 about SVs which unexpectedly have a refcnt
146 of zero. called repeatedly from perl_destruct()
147 until there are no SVs left.
149 =head2 Arena allocator API Summary
151 Private API to rest of sv.c
155 new_XIV(), del_XIV(),
156 new_XNV(), del_XNV(),
161 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
166 ============================================================================ */
171 * "A time to plant, and a time to uproot what was planted..."
175 * nice_chunk and nice_chunk size need to be set
176 * and queried under the protection of sv_mutex
179 Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
184 new_chunk = (void *)(chunk);
185 new_chunk_size = (chunk_size);
186 if (new_chunk_size > PL_nice_chunk_size) {
187 Safefree(PL_nice_chunk);
188 PL_nice_chunk = (char *) new_chunk;
189 PL_nice_chunk_size = new_chunk_size;
196 #ifdef DEBUG_LEAKING_SCALARS
197 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
199 # define FREE_SV_DEBUG_FILE(sv)
203 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
204 /* Whilst I'd love to do this, it seems that things like to check on
206 # define POSION_SV_HEAD(sv) Poison(sv, 1, struct STRUCT_SV)
208 # define POSION_SV_HEAD(sv) Poison(&SvANY(sv), 1, void *), \
209 Poison(&SvREFCNT(sv), 1, U32)
211 # define SvARENA_CHAIN(sv) SvANY(sv)
212 # define POSION_SV_HEAD(sv)
215 #define plant_SV(p) \
217 FREE_SV_DEBUG_FILE(p); \
219 SvARENA_CHAIN(p) = (void *)PL_sv_root; \
220 SvFLAGS(p) = SVTYPEMASK; \
225 /* sv_mutex must be held while calling uproot_SV() */
226 #define uproot_SV(p) \
229 PL_sv_root = (SV*)SvARENA_CHAIN(p); \
234 /* make some more SVs by adding another arena */
236 /* sv_mutex must be held while calling more_sv() */
243 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
244 PL_nice_chunk = Nullch;
245 PL_nice_chunk_size = 0;
248 char *chunk; /* must use New here to match call to */
249 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
250 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
256 /* new_SV(): return a new, empty SV head */
258 #ifdef DEBUG_LEAKING_SCALARS
259 /* provide a real function for a debugger to play with */
269 sv = S_more_sv(aTHX);
274 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
275 sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
276 (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
277 sv->sv_debug_inpad = 0;
278 sv->sv_debug_cloned = 0;
279 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
283 # define new_SV(p) (p)=S_new_SV(aTHX)
292 (p) = S_more_sv(aTHX); \
301 /* del_SV(): return an empty SV head to the free list */
316 S_del_sv(pTHX_ SV *p)
321 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
322 const SV * const sv = sva + 1;
323 const SV * const svend = &sva[SvREFCNT(sva)];
324 if (p >= sv && p < svend) {
330 if (ckWARN_d(WARN_INTERNAL))
331 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
332 "Attempt to free non-arena SV: 0x%"UVxf
333 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
340 #else /* ! DEBUGGING */
342 #define del_SV(p) plant_SV(p)
344 #endif /* DEBUGGING */
348 =head1 SV Manipulation Functions
350 =for apidoc sv_add_arena
352 Given a chunk of memory, link it to the head of the list of arenas,
353 and split it into a list of free SVs.
359 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
365 /* The first SV in an arena isn't an SV. */
366 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
367 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
368 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
370 PL_sv_arenaroot = sva;
371 PL_sv_root = sva + 1;
373 svend = &sva[SvREFCNT(sva) - 1];
376 SvARENA_CHAIN(sv) = (void *)(SV*)(sv + 1);
380 /* Must always set typemask because it's awlays checked in on cleanup
381 when the arenas are walked looking for objects. */
382 SvFLAGS(sv) = SVTYPEMASK;
385 SvARENA_CHAIN(sv) = 0;
389 SvFLAGS(sv) = SVTYPEMASK;
392 /* visit(): call the named function for each non-free SV in the arenas
393 * whose flags field matches the flags/mask args. */
396 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
401 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
402 register const SV * const svend = &sva[SvREFCNT(sva)];
404 for (sv = sva + 1; sv < svend; ++sv) {
405 if (SvTYPE(sv) != SVTYPEMASK
406 && (sv->sv_flags & mask) == flags
419 /* called by sv_report_used() for each live SV */
422 do_report_used(pTHX_ SV *sv)
424 if (SvTYPE(sv) != SVTYPEMASK) {
425 PerlIO_printf(Perl_debug_log, "****\n");
432 =for apidoc sv_report_used
434 Dump the contents of all SVs not yet freed. (Debugging aid).
440 Perl_sv_report_used(pTHX)
443 visit(do_report_used, 0, 0);
447 /* called by sv_clean_objs() for each live SV */
450 do_clean_objs(pTHX_ SV *ref)
453 SV * const target = SvRV(ref);
454 if (SvOBJECT(target)) {
455 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
456 if (SvWEAKREF(ref)) {
457 sv_del_backref(target, ref);
463 SvREFCNT_dec(target);
468 /* XXX Might want to check arrays, etc. */
471 /* called by sv_clean_objs() for each live SV */
473 #ifndef DISABLE_DESTRUCTOR_KLUDGE
475 do_clean_named_objs(pTHX_ SV *sv)
477 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
479 #ifdef PERL_DONT_CREATE_GVSV
482 SvOBJECT(GvSV(sv))) ||
483 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
484 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
485 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
486 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
488 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
489 SvFLAGS(sv) |= SVf_BREAK;
497 =for apidoc sv_clean_objs
499 Attempt to destroy all objects not yet freed
505 Perl_sv_clean_objs(pTHX)
507 PL_in_clean_objs = TRUE;
508 visit(do_clean_objs, SVf_ROK, SVf_ROK);
509 #ifndef DISABLE_DESTRUCTOR_KLUDGE
510 /* some barnacles may yet remain, clinging to typeglobs */
511 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
513 PL_in_clean_objs = FALSE;
516 /* called by sv_clean_all() for each live SV */
519 do_clean_all(pTHX_ SV *sv)
521 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
522 SvFLAGS(sv) |= SVf_BREAK;
523 if (PL_comppad == (AV*)sv) {
525 PL_curpad = Null(SV**);
531 =for apidoc sv_clean_all
533 Decrement the refcnt of each remaining SV, possibly triggering a
534 cleanup. This function may have to be called multiple times to free
535 SVs which are in complex self-referential hierarchies.
541 Perl_sv_clean_all(pTHX)
544 PL_in_clean_all = TRUE;
545 cleaned = visit(do_clean_all, 0,0);
546 PL_in_clean_all = FALSE;
551 S_free_arena(pTHX_ void **root) {
553 void ** const next = *(void **)root;
560 =for apidoc sv_free_arenas
562 Deallocate the memory used by all arenas. Note that all the individual SV
563 heads and bodies within the arenas must already have been freed.
567 #define free_arena(name) \
569 S_free_arena(aTHX_ (void**) PL_ ## name ## _arenaroot); \
570 PL_ ## name ## _arenaroot = 0; \
571 PL_ ## name ## _root = 0; \
575 Perl_sv_free_arenas(pTHX)
581 /* Free arenas here, but be careful about fake ones. (We assume
582 contiguity of the fake ones with the corresponding real ones.) */
584 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
585 svanext = (SV*) SvANY(sva);
586 while (svanext && SvFAKE(svanext))
587 svanext = (SV*) SvANY(svanext);
593 for (i=0; i<SVt_LAST; i++) {
594 S_free_arena(aTHX_ (void**) PL_body_arenaroots[i]);
595 PL_body_arenaroots[i] = 0;
596 PL_body_roots[i] = 0;
601 Safefree(PL_nice_chunk);
602 PL_nice_chunk = Nullch;
603 PL_nice_chunk_size = 0;
608 /* ---------------------------------------------------------------------
610 * support functions for report_uninit()
613 /* the maxiumum size of array or hash where we will scan looking
614 * for the undefined element that triggered the warning */
616 #define FUV_MAX_SEARCH_SIZE 1000
618 /* Look for an entry in the hash whose value has the same SV as val;
619 * If so, return a mortal copy of the key. */
622 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
628 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
629 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
634 for (i=HvMAX(hv); i>0; i--) {
636 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
637 if (HeVAL(entry) != val)
639 if ( HeVAL(entry) == &PL_sv_undef ||
640 HeVAL(entry) == &PL_sv_placeholder)
644 if (HeKLEN(entry) == HEf_SVKEY)
645 return sv_mortalcopy(HeKEY_sv(entry));
646 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
652 /* Look for an entry in the array whose value has the same SV as val;
653 * If so, return the index, otherwise return -1. */
656 S_find_array_subscript(pTHX_ AV *av, SV* val)
660 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
661 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
665 for (i=AvFILLp(av); i>=0; i--) {
666 if (svp[i] == val && svp[i] != &PL_sv_undef)
672 /* S_varname(): return the name of a variable, optionally with a subscript.
673 * If gv is non-zero, use the name of that global, along with gvtype (one
674 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
675 * targ. Depending on the value of the subscript_type flag, return:
678 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
679 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
680 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
681 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
684 S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
685 SV* keyname, I32 aindex, int subscript_type)
688 SV * const name = sv_newmortal();
694 /* as gv_fullname4(), but add literal '^' for $^FOO names */
696 gv_fullname4(name, gv, buffer, 0);
698 if ((unsigned int)SvPVX(name)[1] <= 26) {
700 buffer[1] = SvPVX(name)[1] + 'A' - 1;
702 /* Swap the 1 unprintable control character for the 2 byte pretty
703 version - ie substr($name, 1, 1) = $buffer; */
704 sv_insert(name, 1, 1, buffer, 2);
709 CV * const cv = find_runcv(&unused);
713 if (!cv || !CvPADLIST(cv))
715 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
716 sv = *av_fetch(av, targ, FALSE);
717 /* SvLEN in a pad name is not to be trusted */
718 sv_setpv(name, SvPV_nolen_const(sv));
721 if (subscript_type == FUV_SUBSCRIPT_HASH) {
722 SV * const sv = NEWSV(0,0);
724 Perl_sv_catpvf(aTHX_ name, "{%s}",
725 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
728 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
730 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
732 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
733 sv_insert(name, 0, 0, "within ", 7);
740 =for apidoc find_uninit_var
742 Find the name of the undefined variable (if any) that caused the operator o
743 to issue a "Use of uninitialized value" warning.
744 If match is true, only return a name if it's value matches uninit_sv.
745 So roughly speaking, if a unary operator (such as OP_COS) generates a
746 warning, then following the direct child of the op may yield an
747 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
748 other hand, with OP_ADD there are two branches to follow, so we only print
749 the variable name if we get an exact match.
751 The name is returned as a mortal SV.
753 Assumes that PL_op is the op that originally triggered the error, and that
754 PL_comppad/PL_curpad points to the currently executing pad.
760 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
768 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
769 uninit_sv == &PL_sv_placeholder)))
772 switch (obase->op_type) {
779 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
780 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
783 int subscript_type = FUV_SUBSCRIPT_WITHIN;
785 if (pad) { /* @lex, %lex */
786 sv = PAD_SVl(obase->op_targ);
790 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
791 /* @global, %global */
792 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
795 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
797 else /* @{expr}, %{expr} */
798 return find_uninit_var(cUNOPx(obase)->op_first,
802 /* attempt to find a match within the aggregate */
804 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
806 subscript_type = FUV_SUBSCRIPT_HASH;
809 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
811 subscript_type = FUV_SUBSCRIPT_ARRAY;
814 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
817 return varname(gv, hash ? '%' : '@', obase->op_targ,
818 keysv, index, subscript_type);
822 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
824 return varname(Nullgv, '$', obase->op_targ,
825 Nullsv, 0, FUV_SUBSCRIPT_NONE);
828 gv = cGVOPx_gv(obase);
829 if (!gv || (match && GvSV(gv) != uninit_sv))
831 return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
834 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
837 av = (AV*)PAD_SV(obase->op_targ);
838 if (!av || SvRMAGICAL(av))
840 svp = av_fetch(av, (I32)obase->op_private, FALSE);
841 if (!svp || *svp != uninit_sv)
844 return varname(Nullgv, '$', obase->op_targ,
845 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
848 gv = cGVOPx_gv(obase);
854 if (!av || SvRMAGICAL(av))
856 svp = av_fetch(av, (I32)obase->op_private, FALSE);
857 if (!svp || *svp != uninit_sv)
860 return varname(gv, '$', 0,
861 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
866 o = cUNOPx(obase)->op_first;
867 if (!o || o->op_type != OP_NULL ||
868 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
870 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
875 /* $a[uninit_expr] or $h{uninit_expr} */
876 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
879 o = cBINOPx(obase)->op_first;
880 kid = cBINOPx(obase)->op_last;
882 /* get the av or hv, and optionally the gv */
884 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
885 sv = PAD_SV(o->op_targ);
887 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
888 && cUNOPo->op_first->op_type == OP_GV)
890 gv = cGVOPx_gv(cUNOPo->op_first);
893 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
898 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
899 /* index is constant */
903 if (obase->op_type == OP_HELEM) {
904 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
905 if (!he || HeVAL(he) != uninit_sv)
909 SV ** const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
910 if (!svp || *svp != uninit_sv)
914 if (obase->op_type == OP_HELEM)
915 return varname(gv, '%', o->op_targ,
916 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
918 return varname(gv, '@', o->op_targ, Nullsv,
919 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
923 /* index is an expression;
924 * attempt to find a match within the aggregate */
925 if (obase->op_type == OP_HELEM) {
926 SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
928 return varname(gv, '%', o->op_targ,
929 keysv, 0, FUV_SUBSCRIPT_HASH);
932 const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
934 return varname(gv, '@', o->op_targ,
935 Nullsv, index, FUV_SUBSCRIPT_ARRAY);
940 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
942 o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
948 /* only examine RHS */
949 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
952 o = cUNOPx(obase)->op_first;
953 if (o->op_type == OP_PUSHMARK)
956 if (!o->op_sibling) {
957 /* one-arg version of open is highly magical */
959 if (o->op_type == OP_GV) { /* open FOO; */
961 if (match && GvSV(gv) != uninit_sv)
963 return varname(gv, '$', 0,
964 Nullsv, 0, FUV_SUBSCRIPT_NONE);
966 /* other possibilities not handled are:
967 * open $x; or open my $x; should return '${*$x}'
968 * open expr; should return '$'.expr ideally
974 /* ops where $_ may be an implicit arg */
978 if ( !(obase->op_flags & OPf_STACKED)) {
979 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
980 ? PAD_SVl(obase->op_targ)
984 sv_setpvn(sv, "$_", 2);
992 /* skip filehandle as it can't produce 'undef' warning */
993 o = cUNOPx(obase)->op_first;
994 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
995 o = o->op_sibling->op_sibling;
1002 match = 1; /* XS or custom code could trigger random warnings */
1007 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
1008 return sv_2mortal(newSVpvn("${$/}", 5));
1013 if (!(obase->op_flags & OPf_KIDS))
1015 o = cUNOPx(obase)->op_first;
1021 /* if all except one arg are constant, or have no side-effects,
1022 * or are optimized away, then it's unambiguous */
1024 for (kid=o; kid; kid = kid->op_sibling) {
1026 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
1027 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
1028 || (kid->op_type == OP_PUSHMARK)
1032 if (o2) { /* more than one found */
1039 return find_uninit_var(o2, uninit_sv, match);
1043 sv = find_uninit_var(o, uninit_sv, 1);
1055 =for apidoc report_uninit
1057 Print appropriate "Use of uninitialized variable" warning
1063 Perl_report_uninit(pTHX_ SV* uninit_sv)
1066 SV* varname = Nullsv;
1068 varname = find_uninit_var(PL_op, uninit_sv,0);
1070 sv_insert(varname, 0, 0, " ", 1);
1072 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1073 varname ? SvPV_nolen_const(varname) : "",
1074 " in ", OP_DESC(PL_op));
1077 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1082 Here are mid-level routines that manage the allocation of bodies out
1083 of the various arenas. There are 5 kinds of arenas:
1085 1. SV-head arenas, which are discussed and handled above
1086 2. regular body arenas
1087 3. arenas for reduced-size bodies
1088 4. Hash-Entry arenas
1089 5. pte arenas (thread related)
1091 Arena types 2 & 3 are chained by body-type off an array of
1092 arena-root pointers, which is indexed by svtype. Some of the
1093 larger/less used body types are malloced singly, since a large
1094 unused block of them is wasteful. Also, several svtypes dont have
1095 bodies; the data fits into the sv-head itself. The arena-root
1096 pointer thus has a few unused root-pointers (which may be hijacked
1097 later for arena types 4,5)
1099 3 differs from 2 as an optimization; some body types have several
1100 unused fields in the front of the structure (which are kept in-place
1101 for consistency). These bodies can be allocated in smaller chunks,
1102 because the leading fields arent accessed. Pointers to such bodies
1103 are decremented to point at the unused 'ghost' memory, knowing that
1104 the pointers are used with offsets to the real memory.
1106 HE, HEK arenas are managed separately, with separate code, but may
1107 be merge-able later..
1109 PTE arenas are not sv-bodies, but they share these mid-level
1110 mechanics, so are considered here. The new mid-level mechanics rely
1111 on the sv_type of the body being allocated, so we just reserve one
1112 of the unused body-slots for PTEs, then use it in those (2) PTE
1113 contexts below (line ~10k)
1117 S_more_bodies (pTHX_ size_t size, svtype sv_type)
1119 void **arena_root = &PL_body_arenaroots[sv_type];
1120 void **root = &PL_body_roots[sv_type];
1123 const size_t count = PERL_ARENA_SIZE / size;
1125 Newx(start, count*size, char);
1126 *((void **) start) = *arena_root;
1127 *arena_root = (void *)start;
1129 end = start + (count-1) * size;
1131 /* The initial slot is used to link the arenas together, so it isn't to be
1132 linked into the list of ready-to-use bodies. */
1136 *root = (void *)start;
1138 while (start < end) {
1139 char * const next = start + size;
1140 *(void**) start = (void *)next;
1143 *(void **)start = 0;
1148 /* grab a new thing from the free list, allocating more if necessary */
1150 /* 1st, the inline version */
1152 #define new_body_inline(xpv, root, size, sv_type) \
1155 xpv = *((void **)(root)) \
1156 ? *((void **)(root)) : S_more_bodies(aTHX_ size, sv_type); \
1157 *(root) = *(void**)(xpv); \
1161 /* now use the inline version in the proper function */
1165 /* This isn't being used with -DPURIFY, so don't declare it. Otherwise
1166 compilers issue warnings. */
1169 S_new_body(pTHX_ size_t size, svtype sv_type)
1172 new_body_inline(xpv, &PL_body_roots[sv_type], size, sv_type);
1178 /* return a thing to the free list */
1180 #define del_body(thing, root) \
1182 void **thing_copy = (void **)thing; \
1184 *thing_copy = *root; \
1185 *root = (void*)thing_copy; \
1190 Revisiting type 3 arenas, there are 4 body-types which have some
1191 members that are never accessed. They are XPV, XPVIV, XPVAV,
1192 XPVHV, which have corresponding types: xpv_allocated,
1193 xpviv_allocated, xpvav_allocated, xpvhv_allocated,
1195 For these types, the arenas are carved up into *_allocated size
1196 chunks, we thus avoid wasted memory for those unaccessed members.
1197 When bodies are allocated, we adjust the pointer back in memory by
1198 the size of the bit not allocated, so it's as if we allocated the
1199 full structure. (But things will all go boom if you write to the
1200 part that is "not there", because you'll be overwriting the last
1201 members of the preceding structure in memory.)
1203 We calculate the correction using the STRUCT_OFFSET macro. For example, if
1204 xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
1205 and the pointer is unchanged. If the allocated structure is smaller (no
1206 initial NV actually allocated) then the net effect is to subtract the size
1207 of the NV from the pointer, to return a new pointer as if an initial NV were
1210 This is the same trick as was used for NV and IV bodies. Ironically it
1211 doesn't need to be used for NV bodies any more, because NV is now at the
1212 start of the structure. IV bodies don't need it either, because they are
1213 no longer allocated. */
1215 /* The following 2 arrays hide the above details in a pair of
1216 lookup-tables, allowing us to be body-type agnostic.
1218 sizeof_body_by_svtype[] maps svtype to its body's allocated size.
1219 offset_by_type[] maps svtype to the body-pointer adjustment needed
1221 NB: elements in latter are 0 or <0, and are added during
1222 allocation, and subtracted during deallocation. It may be clearer
1223 to invert the values, and call it shrinkage_by_svtype.
1226 static int sizeof_body_by_svtype[] = {
1227 0, /* SVt_NULLs, SVt_IVs, SVt_NVs, SVt_RVs have no body */
1229 sizeof(xpv_allocated), /* 8 bytes on 686 */
1231 sizeof(xpv_allocated), /* 8 bytes on 686 */
1232 sizeof(xpviv_allocated), /* 12 */
1233 sizeof(XPVNV), /* 20 */
1234 sizeof(XPVMG), /* 28 */
1235 sizeof(XPVBM), /* 36 */
1236 sizeof(XPVGV), /* 48 */
1237 sizeof(XPVLV), /* 64 */
1238 sizeof(xpvav_allocated), /* 20 */
1239 sizeof(xpvhv_allocated), /* 20 */
1240 sizeof(XPVCV), /* 76 */
1241 sizeof(XPVFM), /* 80 */
1242 sizeof(XPVIO) /* 84 */
1244 #define SIZE_SVTYPES sizeof(sizeof_body_by_svtype)
1246 static int offset_by_svtype[] = {
1251 STRUCT_OFFSET(xpv_allocated, xpv_cur) - STRUCT_OFFSET(XPV, xpv_cur),
1252 STRUCT_OFFSET(xpviv_allocated, xpv_cur) - STRUCT_OFFSET(XPVIV, xpv_cur),
1258 STRUCT_OFFSET(xpvav_allocated, xav_fill) - STRUCT_OFFSET(XPVAV, xav_fill),
1259 STRUCT_OFFSET(xpvhv_allocated, xhv_fill) - STRUCT_OFFSET(XPVHV, xhv_fill),
1264 #define SIZE_OFFSETS sizeof(sizeof_body_by_svtype)
1266 /* they better stay synchronized, but this doesnt do it.
1267 #if SIZE_SVTYPES != SIZE_OFFSETS
1268 #error "declaration problem: sizeof_body_by_svtype != sizeof(offset_by_svtype)"
1273 #define new_body_type(sv_type) \
1274 (void *)((char *)S_new_body(aTHX_ sizeof_body_by_svtype[sv_type], sv_type)\
1275 + offset_by_svtype[sv_type])
1277 #define del_body_type(p, sv_type) \
1278 del_body(p, &PL_body_roots[sv_type])
1281 #define new_body_allocated(sv_type) \
1282 (void *)((char *)S_new_body(aTHX_ sizeof_body_by_svtype[sv_type], sv_type)\
1283 + offset_by_svtype[sv_type])
1285 #define del_body_allocated(p, sv_type) \
1286 del_body(p - offset_by_svtype[sv_type], &PL_body_roots[sv_type])
1289 #define my_safemalloc(s) (void*)safemalloc(s)
1290 #define my_safefree(p) safefree((char*)p)
1294 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1295 #define del_XNV(p) my_safefree(p)
1297 #define new_XPV() my_safemalloc(sizeof(XPV))
1298 #define del_XPV(p) my_safefree(p)
1300 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1301 #define del_XPVIV(p) my_safefree(p)
1303 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1304 #define del_XPVNV(p) my_safefree(p)
1306 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1307 #define del_XPVCV(p) my_safefree(p)
1309 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1310 #define del_XPVAV(p) my_safefree(p)
1312 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1313 #define del_XPVHV(p) my_safefree(p)
1315 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1316 #define del_XPVMG(p) my_safefree(p)
1318 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1319 #define del_XPVGV(p) my_safefree(p)
1321 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1322 #define del_XPVLV(p) my_safefree(p)
1324 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1325 #define del_XPVBM(p) my_safefree(p)
1329 #define new_XNV() new_body_type(SVt_NV)
1330 #define del_XNV(p) del_body_type(p, SVt_NV)
1332 #define new_XPV() new_body_allocated(SVt_PV)
1333 #define del_XPV(p) del_body_allocated(p, SVt_PV)
1335 #define new_XPVIV() new_body_allocated(SVt_PVIV)
1336 #define del_XPVIV(p) del_body_allocated(p, SVt_PVIV)
1338 #define new_XPVNV() new_body_type(SVt_PVNV)
1339 #define del_XPVNV(p) del_body_type(p, SVt_PVNV)
1341 #define new_XPVCV() new_body_type(SVt_PVCV)
1342 #define del_XPVCV(p) del_body_type(p, SVt_PVCV)
1344 #define new_XPVAV() new_body_allocated(SVt_PVAV)
1345 #define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
1347 #define new_XPVHV() new_body_allocated(SVt_PVHV)
1348 #define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
1350 #define new_XPVMG() new_body_type(SVt_PVMG)
1351 #define del_XPVMG(p) del_body_type(p, SVt_PVMG)
1353 #define new_XPVGV() new_body_type(SVt_PVGV)
1354 #define del_XPVGV(p) del_body_type(p, SVt_PVGV)
1356 #define new_XPVLV() new_body_type(SVt_PVLV)
1357 #define del_XPVLV(p) del_body_type(p, SVt_PVLV)
1359 #define new_XPVBM() new_body_type(SVt_PVBM)
1360 #define del_XPVBM(p) del_body_type(p, SVt_PVBM)
1364 /* no arena for you! */
1365 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1366 #define del_XPVFM(p) my_safefree(p)
1368 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1369 #define del_XPVIO(p) my_safefree(p)
1374 =for apidoc sv_upgrade
1376 Upgrade an SV to a more complex form. Generally adds a new body type to the
1377 SV, then copies across as much information as possible from the old body.
1378 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1384 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1386 void** old_body_arena;
1387 size_t old_body_offset;
1388 size_t old_body_length; /* Well, the length to copy. */
1390 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1391 /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct
1393 bool zero_nv = TRUE;
1396 size_t new_body_length;
1397 size_t new_body_offset;
1398 void** new_body_arena;
1399 void** new_body_arenaroot;
1400 const U32 old_type = SvTYPE(sv);
1402 if (mt != SVt_PV && SvIsCOW(sv)) {
1403 sv_force_normal_flags(sv, 0);
1410 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1411 (int)old_type, (int)mt);
1414 old_body = SvANY(sv);
1416 old_body_offset = 0;
1417 old_body_length = 0;
1418 new_body_offset = 0;
1419 new_body_length = ~0;
1421 /* Copying structures onto other structures that have been neatly zeroed
1422 has a subtle gotcha. Consider XPVMG
1424 +------+------+------+------+------+-------+-------+
1425 | NV | CUR | LEN | IV | MAGIC | STASH |
1426 +------+------+------+------+------+-------+-------+
1427 0 4 8 12 16 20 24 28
1429 where NVs are aligned to 8 bytes, so that sizeof that structure is
1430 actually 32 bytes long, with 4 bytes of padding at the end:
1432 +------+------+------+------+------+-------+-------+------+
1433 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1434 +------+------+------+------+------+-------+-------+------+
1435 0 4 8 12 16 20 24 28 32
1437 so what happens if you allocate memory for this structure:
1439 +------+------+------+------+------+-------+-------+------+------+...
1440 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1441 +------+------+------+------+------+-------+-------+------+------+...
1442 0 4 8 12 16 20 24 28 32 36
1444 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1445 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1446 started out as zero once, but it's quite possible that it isn't. So now,
1447 rather than a nicely zeroed GP, you have it pointing somewhere random.
1450 (In fact, GP ends up pointing at a previous GP structure, because the
1451 principle cause of the padding in XPVMG getting garbage is a copy of
1452 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob)
1454 So we are careful and work out the size of used parts of all the
1463 else if (mt < SVt_PVIV)
1465 old_body_offset = STRUCT_OFFSET(XPVIV, xiv_iv);
1466 old_body_length = sizeof(IV);
1469 old_body_arena = &PL_body_roots[SVt_NV];
1470 old_body_length = sizeof(NV);
1471 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1480 old_body_arena = &PL_body_roots[SVt_PV];
1481 old_body_offset = - offset_by_svtype[SVt_PVIV];
1482 old_body_length = STRUCT_OFFSET(XPV, xpv_len)
1483 + sizeof (((XPV*)SvANY(sv))->xpv_len)
1487 else if (mt == SVt_NV)
1491 old_body_arena = &PL_body_roots[SVt_PVIV];
1492 old_body_offset = - offset_by_svtype[SVt_PVIV];
1493 old_body_length = STRUCT_OFFSET(XPVIV, xiv_u);
1494 old_body_length += sizeof (((XPVIV*)SvANY(sv))->xiv_u);
1495 old_body_length -= old_body_offset;
1498 old_body_arena = &PL_body_roots[SVt_PVNV];
1499 old_body_length = STRUCT_OFFSET(XPVNV, xiv_u)
1500 + sizeof (((XPVNV*)SvANY(sv))->xiv_u);
1501 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1506 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1507 there's no way that it can be safely upgraded, because perl.c
1508 expects to Safefree(SvANY(PL_mess_sv)) */
1509 assert(sv != PL_mess_sv);
1510 /* This flag bit is used to mean other things in other scalar types.
1511 Given that it only has meaning inside the pad, it shouldn't be set
1512 on anything that can get upgraded. */
1513 assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
1514 old_body_arena = &PL_body_roots[SVt_PVMG];
1515 old_body_length = STRUCT_OFFSET(XPVMG, xmg_stash)
1516 + sizeof (((XPVMG*)SvANY(sv))->xmg_stash);
1517 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1522 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1525 SvFLAGS(sv) &= ~SVTYPEMASK;
1530 Perl_croak(aTHX_ "Can't upgrade to undef");
1532 assert(old_type == SVt_NULL);
1533 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1537 assert(old_type == SVt_NULL);
1538 SvANY(sv) = new_XNV();
1542 assert(old_type == SVt_NULL);
1543 SvANY(sv) = &sv->sv_u.svu_rv;
1547 SvANY(sv) = new_XPVHV();
1550 HvTOTALKEYS(sv) = 0;
1555 SvANY(sv) = new_XPVAV();
1562 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1563 The target created by newSVrv also is, and it can have magic.
1564 However, it never has SvPVX set.
1566 if (old_type >= SVt_RV) {
1567 assert(SvPVX_const(sv) == 0);
1570 /* Could put this in the else clause below, as PVMG must have SvPVX
1571 0 already (the assertion above) */
1572 SvPV_set(sv, (char*)0);
1574 if (old_type >= SVt_PVMG) {
1575 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic);
1576 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1584 new_body = new_XPVIO();
1585 new_body_length = sizeof(XPVIO);
1588 new_body = new_XPVFM();
1589 new_body_length = sizeof(XPVFM);
1598 new_body_length = sizeof_body_by_svtype[mt];
1599 new_body_arena = &PL_body_roots[mt];
1600 new_body_arenaroot = &PL_body_arenaroots[mt];
1604 new_body_offset = - offset_by_svtype[SVt_PVIV];
1605 new_body_length = sizeof(XPVIV) - new_body_offset;
1606 new_body_arena = &PL_body_roots[SVt_PVIV];
1607 new_body_arenaroot = &PL_body_arenaroots[SVt_PVIV];
1608 /* XXX Is this still needed? Was it ever needed? Surely as there is
1609 no route from NV to PVIV, NOK can never be true */
1613 goto new_body_no_NV;
1615 new_body_offset = - offset_by_svtype[SVt_PV];
1616 new_body_length = sizeof(XPV) - new_body_offset;
1617 new_body_arena = &PL_body_roots[SVt_PV];
1618 new_body_arenaroot = &PL_body_arenaroots[SVt_PV];
1620 /* PV and PVIV don't have an NV slot. */
1621 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1626 assert(new_body_length);
1628 /* This points to the start of the allocated area. */
1629 new_body_inline(new_body, new_body_arena, new_body_length, mt);
1631 /* We always allocated the full length item with PURIFY */
1632 new_body_length += new_body_offset;
1633 new_body_offset = 0;
1634 new_body = my_safemalloc(new_body_length);
1638 Zero(new_body, new_body_length, char);
1639 new_body = ((char *)new_body) - new_body_offset;
1640 SvANY(sv) = new_body;
1642 if (old_body_length) {
1643 Copy((char *)old_body + old_body_offset,
1644 (char *)new_body + old_body_offset,
1645 old_body_length, char);
1648 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1654 IoPAGE_LEN(sv) = 60;
1655 if (old_type < SVt_RV)
1659 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", mt);
1663 if (old_body_arena) {
1665 my_safefree(old_body);
1667 del_body((void*)((char*)old_body + old_body_offset),
1674 =for apidoc sv_backoff
1676 Remove any string offset. You should normally use the C<SvOOK_off> macro
1683 Perl_sv_backoff(pTHX_ register SV *sv)
1686 assert(SvTYPE(sv) != SVt_PVHV);
1687 assert(SvTYPE(sv) != SVt_PVAV);
1689 const char * const s = SvPVX_const(sv);
1690 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1691 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1693 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1695 SvFLAGS(sv) &= ~SVf_OOK;
1702 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1703 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1704 Use the C<SvGROW> wrapper instead.
1710 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1714 #ifdef HAS_64K_LIMIT
1715 if (newlen >= 0x10000) {
1716 PerlIO_printf(Perl_debug_log,
1717 "Allocation too large: %"UVxf"\n", (UV)newlen);
1720 #endif /* HAS_64K_LIMIT */
1723 if (SvTYPE(sv) < SVt_PV) {
1724 sv_upgrade(sv, SVt_PV);
1725 s = SvPVX_mutable(sv);
1727 else if (SvOOK(sv)) { /* pv is offset? */
1729 s = SvPVX_mutable(sv);
1730 if (newlen > SvLEN(sv))
1731 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1732 #ifdef HAS_64K_LIMIT
1733 if (newlen >= 0x10000)
1738 s = SvPVX_mutable(sv);
1740 if (newlen > SvLEN(sv)) { /* need more room? */
1741 newlen = PERL_STRLEN_ROUNDUP(newlen);
1742 if (SvLEN(sv) && s) {
1744 const STRLEN l = malloced_size((void*)SvPVX_const(sv));
1750 s = saferealloc(s, newlen);
1753 s = safemalloc(newlen);
1754 if (SvPVX_const(sv) && SvCUR(sv)) {
1755 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1759 SvLEN_set(sv, newlen);
1765 =for apidoc sv_setiv
1767 Copies an integer into the given SV, upgrading first if necessary.
1768 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1774 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1776 SV_CHECK_THINKFIRST_COW_DROP(sv);
1777 switch (SvTYPE(sv)) {
1779 sv_upgrade(sv, SVt_IV);
1782 sv_upgrade(sv, SVt_PVNV);
1786 sv_upgrade(sv, SVt_PVIV);
1795 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1798 (void)SvIOK_only(sv); /* validate number */
1804 =for apidoc sv_setiv_mg
1806 Like C<sv_setiv>, but also handles 'set' magic.
1812 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1819 =for apidoc sv_setuv
1821 Copies an unsigned integer into the given SV, upgrading first if necessary.
1822 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1828 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1830 /* With these two if statements:
1831 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1834 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1836 If you wish to remove them, please benchmark to see what the effect is
1838 if (u <= (UV)IV_MAX) {
1839 sv_setiv(sv, (IV)u);
1848 =for apidoc sv_setuv_mg
1850 Like C<sv_setuv>, but also handles 'set' magic.
1856 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1865 =for apidoc sv_setnv
1867 Copies a double into the given SV, upgrading first if necessary.
1868 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1874 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1876 SV_CHECK_THINKFIRST_COW_DROP(sv);
1877 switch (SvTYPE(sv)) {
1880 sv_upgrade(sv, SVt_NV);
1885 sv_upgrade(sv, SVt_PVNV);
1894 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1898 (void)SvNOK_only(sv); /* validate number */
1903 =for apidoc sv_setnv_mg
1905 Like C<sv_setnv>, but also handles 'set' magic.
1911 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1917 /* Print an "isn't numeric" warning, using a cleaned-up,
1918 * printable version of the offending string
1922 S_not_a_number(pTHX_ SV *sv)
1929 dsv = sv_2mortal(newSVpvn("", 0));
1930 pv = sv_uni_display(dsv, sv, 10, 0);
1933 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1934 /* each *s can expand to 4 chars + "...\0",
1935 i.e. need room for 8 chars */
1937 const char *s, *end;
1938 for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit;
1941 if (ch & 128 && !isPRINT_LC(ch)) {
1950 else if (ch == '\r') {
1954 else if (ch == '\f') {
1958 else if (ch == '\\') {
1962 else if (ch == '\0') {
1966 else if (isPRINT_LC(ch))
1983 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1984 "Argument \"%s\" isn't numeric in %s", pv,
1987 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1988 "Argument \"%s\" isn't numeric", pv);
1992 =for apidoc looks_like_number
1994 Test if the content of an SV looks like a number (or is a number).
1995 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1996 non-numeric warning), even if your atof() doesn't grok them.
2002 Perl_looks_like_number(pTHX_ SV *sv)
2004 register const char *sbegin;
2008 sbegin = SvPVX_const(sv);
2011 else if (SvPOKp(sv))
2012 sbegin = SvPV_const(sv, len);
2014 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
2015 return grok_number(sbegin, len, NULL);
2018 /* Actually, ISO C leaves conversion of UV to IV undefined, but
2019 until proven guilty, assume that things are not that bad... */
2024 As 64 bit platforms often have an NV that doesn't preserve all bits of
2025 an IV (an assumption perl has been based on to date) it becomes necessary
2026 to remove the assumption that the NV always carries enough precision to
2027 recreate the IV whenever needed, and that the NV is the canonical form.
2028 Instead, IV/UV and NV need to be given equal rights. So as to not lose
2029 precision as a side effect of conversion (which would lead to insanity
2030 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
2031 1) to distinguish between IV/UV/NV slots that have cached a valid
2032 conversion where precision was lost and IV/UV/NV slots that have a
2033 valid conversion which has lost no precision
2034 2) to ensure that if a numeric conversion to one form is requested that
2035 would lose precision, the precise conversion (or differently
2036 imprecise conversion) is also performed and cached, to prevent
2037 requests for different numeric formats on the same SV causing
2038 lossy conversion chains. (lossless conversion chains are perfectly
2043 SvIOKp is true if the IV slot contains a valid value
2044 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
2045 SvNOKp is true if the NV slot contains a valid value
2046 SvNOK is true only if the NV value is accurate
2049 while converting from PV to NV, check to see if converting that NV to an
2050 IV(or UV) would lose accuracy over a direct conversion from PV to
2051 IV(or UV). If it would, cache both conversions, return NV, but mark
2052 SV as IOK NOKp (ie not NOK).
2054 While converting from PV to IV, check to see if converting that IV to an
2055 NV would lose accuracy over a direct conversion from PV to NV. If it
2056 would, cache both conversions, flag similarly.
2058 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2059 correctly because if IV & NV were set NV *always* overruled.
2060 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2061 changes - now IV and NV together means that the two are interchangeable:
2062 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
2064 The benefit of this is that operations such as pp_add know that if
2065 SvIOK is true for both left and right operands, then integer addition
2066 can be used instead of floating point (for cases where the result won't
2067 overflow). Before, floating point was always used, which could lead to
2068 loss of precision compared with integer addition.
2070 * making IV and NV equal status should make maths accurate on 64 bit
2072 * may speed up maths somewhat if pp_add and friends start to use
2073 integers when possible instead of fp. (Hopefully the overhead in
2074 looking for SvIOK and checking for overflow will not outweigh the
2075 fp to integer speedup)
2076 * will slow down integer operations (callers of SvIV) on "inaccurate"
2077 values, as the change from SvIOK to SvIOKp will cause a call into
2078 sv_2iv each time rather than a macro access direct to the IV slot
2079 * should speed up number->string conversion on integers as IV is
2080 favoured when IV and NV are equally accurate
2082 ####################################################################
2083 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2084 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2085 On the other hand, SvUOK is true iff UV.
2086 ####################################################################
2088 Your mileage will vary depending your CPU's relative fp to integer
2092 #ifndef NV_PRESERVES_UV
2093 # define IS_NUMBER_UNDERFLOW_IV 1
2094 # define IS_NUMBER_UNDERFLOW_UV 2
2095 # define IS_NUMBER_IV_AND_UV 2
2096 # define IS_NUMBER_OVERFLOW_IV 4
2097 # define IS_NUMBER_OVERFLOW_UV 5
2099 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2101 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2103 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2105 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));
2106 if (SvNVX(sv) < (NV)IV_MIN) {
2107 (void)SvIOKp_on(sv);
2109 SvIV_set(sv, IV_MIN);
2110 return IS_NUMBER_UNDERFLOW_IV;
2112 if (SvNVX(sv) > (NV)UV_MAX) {
2113 (void)SvIOKp_on(sv);
2116 SvUV_set(sv, UV_MAX);
2117 return IS_NUMBER_OVERFLOW_UV;
2119 (void)SvIOKp_on(sv);
2121 /* Can't use strtol etc to convert this string. (See truth table in
2123 if (SvNVX(sv) <= (UV)IV_MAX) {
2124 SvIV_set(sv, I_V(SvNVX(sv)));
2125 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2126 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2128 /* Integer is imprecise. NOK, IOKp */
2130 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2133 SvUV_set(sv, U_V(SvNVX(sv)));
2134 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2135 if (SvUVX(sv) == UV_MAX) {
2136 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2137 possibly be preserved by NV. Hence, it must be overflow.
2139 return IS_NUMBER_OVERFLOW_UV;
2141 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2143 /* Integer is imprecise. NOK, IOKp */
2145 return IS_NUMBER_OVERFLOW_IV;
2147 #endif /* !NV_PRESERVES_UV*/
2150 =for apidoc sv_2iv_flags
2152 Return the integer value of an SV, doing any necessary string
2153 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2154 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2160 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2164 if (SvGMAGICAL(sv)) {
2165 if (flags & SV_GMAGIC)
2170 return I_V(SvNVX(sv));
2172 if (SvPOKp(sv) && SvLEN(sv))
2175 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2176 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2182 if (SvTHINKFIRST(sv)) {
2185 SV * const tmpstr=AMG_CALLun(sv,numer);
2186 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2187 return SvIV(tmpstr);
2190 return PTR2IV(SvRV(sv));
2193 sv_force_normal_flags(sv, 0);
2195 if (SvREADONLY(sv) && !SvOK(sv)) {
2196 if (ckWARN(WARN_UNINITIALIZED))
2203 return (IV)(SvUVX(sv));
2210 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2211 * without also getting a cached IV/UV from it at the same time
2212 * (ie PV->NV conversion should detect loss of accuracy and cache
2213 * IV or UV at same time to avoid this. NWC */
2215 if (SvTYPE(sv) == SVt_NV)
2216 sv_upgrade(sv, SVt_PVNV);
2218 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2219 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2220 certainly cast into the IV range at IV_MAX, whereas the correct
2221 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2223 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2224 SvIV_set(sv, I_V(SvNVX(sv)));
2225 if (SvNVX(sv) == (NV) SvIVX(sv)
2226 #ifndef NV_PRESERVES_UV
2227 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2228 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2229 /* Don't flag it as "accurately an integer" if the number
2230 came from a (by definition imprecise) NV operation, and
2231 we're outside the range of NV integer precision */
2234 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2235 DEBUG_c(PerlIO_printf(Perl_debug_log,
2236 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2242 /* IV not precise. No need to convert from PV, as NV
2243 conversion would already have cached IV if it detected
2244 that PV->IV would be better than PV->NV->IV
2245 flags already correct - don't set public IOK. */
2246 DEBUG_c(PerlIO_printf(Perl_debug_log,
2247 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2252 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2253 but the cast (NV)IV_MIN rounds to a the value less (more
2254 negative) than IV_MIN which happens to be equal to SvNVX ??
2255 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2256 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2257 (NV)UVX == NVX are both true, but the values differ. :-(
2258 Hopefully for 2s complement IV_MIN is something like
2259 0x8000000000000000 which will be exact. NWC */
2262 SvUV_set(sv, U_V(SvNVX(sv)));
2264 (SvNVX(sv) == (NV) SvUVX(sv))
2265 #ifndef NV_PRESERVES_UV
2266 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2267 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2268 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2269 /* Don't flag it as "accurately an integer" if the number
2270 came from a (by definition imprecise) NV operation, and
2271 we're outside the range of NV integer precision */
2277 DEBUG_c(PerlIO_printf(Perl_debug_log,
2278 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2282 return (IV)SvUVX(sv);
2285 else if (SvPOKp(sv) && SvLEN(sv)) {
2287 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2288 /* We want to avoid a possible problem when we cache an IV which
2289 may be later translated to an NV, and the resulting NV is not
2290 the same as the direct translation of the initial string
2291 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2292 be careful to ensure that the value with the .456 is around if the
2293 NV value is requested in the future).
2295 This means that if we cache such an IV, we need to cache the
2296 NV as well. Moreover, we trade speed for space, and do not
2297 cache the NV if we are sure it's not needed.
2300 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2301 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2302 == IS_NUMBER_IN_UV) {
2303 /* It's definitely an integer, only upgrade to PVIV */
2304 if (SvTYPE(sv) < SVt_PVIV)
2305 sv_upgrade(sv, SVt_PVIV);
2307 } else if (SvTYPE(sv) < SVt_PVNV)
2308 sv_upgrade(sv, SVt_PVNV);
2310 /* If NV preserves UV then we only use the UV value if we know that
2311 we aren't going to call atof() below. If NVs don't preserve UVs
2312 then the value returned may have more precision than atof() will
2313 return, even though value isn't perfectly accurate. */
2314 if ((numtype & (IS_NUMBER_IN_UV
2315 #ifdef NV_PRESERVES_UV
2318 )) == IS_NUMBER_IN_UV) {
2319 /* This won't turn off the public IOK flag if it was set above */
2320 (void)SvIOKp_on(sv);
2322 if (!(numtype & IS_NUMBER_NEG)) {
2324 if (value <= (UV)IV_MAX) {
2325 SvIV_set(sv, (IV)value);
2327 SvUV_set(sv, value);
2331 /* 2s complement assumption */
2332 if (value <= (UV)IV_MIN) {
2333 SvIV_set(sv, -(IV)value);
2335 /* Too negative for an IV. This is a double upgrade, but
2336 I'm assuming it will be rare. */
2337 if (SvTYPE(sv) < SVt_PVNV)
2338 sv_upgrade(sv, SVt_PVNV);
2342 SvNV_set(sv, -(NV)value);
2343 SvIV_set(sv, IV_MIN);
2347 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2348 will be in the previous block to set the IV slot, and the next
2349 block to set the NV slot. So no else here. */
2351 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2352 != IS_NUMBER_IN_UV) {
2353 /* It wasn't an (integer that doesn't overflow the UV). */
2354 SvNV_set(sv, Atof(SvPVX_const(sv)));
2356 if (! numtype && ckWARN(WARN_NUMERIC))
2359 #if defined(USE_LONG_DOUBLE)
2360 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2361 PTR2UV(sv), SvNVX(sv)));
2363 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2364 PTR2UV(sv), SvNVX(sv)));
2368 #ifdef NV_PRESERVES_UV
2369 (void)SvIOKp_on(sv);
2371 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2372 SvIV_set(sv, I_V(SvNVX(sv)));
2373 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2376 /* Integer is imprecise. NOK, IOKp */
2378 /* UV will not work better than IV */
2380 if (SvNVX(sv) > (NV)UV_MAX) {
2382 /* Integer is inaccurate. NOK, IOKp, is UV */
2383 SvUV_set(sv, UV_MAX);
2386 SvUV_set(sv, U_V(SvNVX(sv)));
2387 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2388 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2392 /* Integer is imprecise. NOK, IOKp, is UV */
2398 #else /* NV_PRESERVES_UV */
2399 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2400 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2401 /* The IV slot will have been set from value returned by
2402 grok_number above. The NV slot has just been set using
2405 assert (SvIOKp(sv));
2407 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2408 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2409 /* Small enough to preserve all bits. */
2410 (void)SvIOKp_on(sv);
2412 SvIV_set(sv, I_V(SvNVX(sv)));
2413 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2415 /* Assumption: first non-preserved integer is < IV_MAX,
2416 this NV is in the preserved range, therefore: */
2417 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2419 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);
2423 0 0 already failed to read UV.
2424 0 1 already failed to read UV.
2425 1 0 you won't get here in this case. IV/UV
2426 slot set, public IOK, Atof() unneeded.
2427 1 1 already read UV.
2428 so there's no point in sv_2iuv_non_preserve() attempting
2429 to use atol, strtol, strtoul etc. */
2430 if (sv_2iuv_non_preserve (sv, numtype)
2431 >= IS_NUMBER_OVERFLOW_IV)
2435 #endif /* NV_PRESERVES_UV */
2438 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2440 if (SvTYPE(sv) < SVt_IV)
2441 /* Typically the caller expects that sv_any is not NULL now. */
2442 sv_upgrade(sv, SVt_IV);
2445 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2446 PTR2UV(sv),SvIVX(sv)));
2447 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2451 =for apidoc sv_2uv_flags
2453 Return the unsigned integer value of an SV, doing any necessary string
2454 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2455 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2461 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2465 if (SvGMAGICAL(sv)) {
2466 if (flags & SV_GMAGIC)
2471 return U_V(SvNVX(sv));
2472 if (SvPOKp(sv) && SvLEN(sv))
2475 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2476 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2482 if (SvTHINKFIRST(sv)) {
2485 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2486 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2487 return SvUV(tmpstr);
2488 return PTR2UV(SvRV(sv));
2491 sv_force_normal_flags(sv, 0);
2493 if (SvREADONLY(sv) && !SvOK(sv)) {
2494 if (ckWARN(WARN_UNINITIALIZED))
2504 return (UV)SvIVX(sv);
2508 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2509 * without also getting a cached IV/UV from it at the same time
2510 * (ie PV->NV conversion should detect loss of accuracy and cache
2511 * IV or UV at same time to avoid this. */
2512 /* IV-over-UV optimisation - choose to cache IV if possible */
2514 if (SvTYPE(sv) == SVt_NV)
2515 sv_upgrade(sv, SVt_PVNV);
2517 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2518 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2519 SvIV_set(sv, I_V(SvNVX(sv)));
2520 if (SvNVX(sv) == (NV) SvIVX(sv)
2521 #ifndef NV_PRESERVES_UV
2522 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2523 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2524 /* Don't flag it as "accurately an integer" if the number
2525 came from a (by definition imprecise) NV operation, and
2526 we're outside the range of NV integer precision */
2529 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2530 DEBUG_c(PerlIO_printf(Perl_debug_log,
2531 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2537 /* IV not precise. No need to convert from PV, as NV
2538 conversion would already have cached IV if it detected
2539 that PV->IV would be better than PV->NV->IV
2540 flags already correct - don't set public IOK. */
2541 DEBUG_c(PerlIO_printf(Perl_debug_log,
2542 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2547 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2548 but the cast (NV)IV_MIN rounds to a the value less (more
2549 negative) than IV_MIN which happens to be equal to SvNVX ??
2550 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2551 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2552 (NV)UVX == NVX are both true, but the values differ. :-(
2553 Hopefully for 2s complement IV_MIN is something like
2554 0x8000000000000000 which will be exact. NWC */
2557 SvUV_set(sv, U_V(SvNVX(sv)));
2559 (SvNVX(sv) == (NV) SvUVX(sv))
2560 #ifndef NV_PRESERVES_UV
2561 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2562 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2563 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2564 /* Don't flag it as "accurately an integer" if the number
2565 came from a (by definition imprecise) NV operation, and
2566 we're outside the range of NV integer precision */
2571 DEBUG_c(PerlIO_printf(Perl_debug_log,
2572 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2578 else if (SvPOKp(sv) && SvLEN(sv)) {
2580 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2582 /* We want to avoid a possible problem when we cache a UV which
2583 may be later translated to an NV, and the resulting NV is not
2584 the translation of the initial data.
2586 This means that if we cache such a UV, we need to cache the
2587 NV as well. Moreover, we trade speed for space, and do not
2588 cache the NV if not needed.
2591 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2592 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2593 == IS_NUMBER_IN_UV) {
2594 /* It's definitely an integer, only upgrade to PVIV */
2595 if (SvTYPE(sv) < SVt_PVIV)
2596 sv_upgrade(sv, SVt_PVIV);
2598 } else if (SvTYPE(sv) < SVt_PVNV)
2599 sv_upgrade(sv, SVt_PVNV);
2601 /* If NV preserves UV then we only use the UV value if we know that
2602 we aren't going to call atof() below. If NVs don't preserve UVs
2603 then the value returned may have more precision than atof() will
2604 return, even though it isn't accurate. */
2605 if ((numtype & (IS_NUMBER_IN_UV
2606 #ifdef NV_PRESERVES_UV
2609 )) == IS_NUMBER_IN_UV) {
2610 /* This won't turn off the public IOK flag if it was set above */
2611 (void)SvIOKp_on(sv);
2613 if (!(numtype & IS_NUMBER_NEG)) {
2615 if (value <= (UV)IV_MAX) {
2616 SvIV_set(sv, (IV)value);
2618 /* it didn't overflow, and it was positive. */
2619 SvUV_set(sv, value);
2623 /* 2s complement assumption */
2624 if (value <= (UV)IV_MIN) {
2625 SvIV_set(sv, -(IV)value);
2627 /* Too negative for an IV. This is a double upgrade, but
2628 I'm assuming it will be rare. */
2629 if (SvTYPE(sv) < SVt_PVNV)
2630 sv_upgrade(sv, SVt_PVNV);
2634 SvNV_set(sv, -(NV)value);
2635 SvIV_set(sv, IV_MIN);
2640 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2641 != IS_NUMBER_IN_UV) {
2642 /* It wasn't an integer, or it overflowed the UV. */
2643 SvNV_set(sv, Atof(SvPVX_const(sv)));
2645 if (! numtype && ckWARN(WARN_NUMERIC))
2648 #if defined(USE_LONG_DOUBLE)
2649 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2650 PTR2UV(sv), SvNVX(sv)));
2652 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2653 PTR2UV(sv), SvNVX(sv)));
2656 #ifdef NV_PRESERVES_UV
2657 (void)SvIOKp_on(sv);
2659 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2660 SvIV_set(sv, I_V(SvNVX(sv)));
2661 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2664 /* Integer is imprecise. NOK, IOKp */
2666 /* UV will not work better than IV */
2668 if (SvNVX(sv) > (NV)UV_MAX) {
2670 /* Integer is inaccurate. NOK, IOKp, is UV */
2671 SvUV_set(sv, UV_MAX);
2674 SvUV_set(sv, U_V(SvNVX(sv)));
2675 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2676 NV preservse UV so can do correct comparison. */
2677 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2681 /* Integer is imprecise. NOK, IOKp, is UV */
2686 #else /* NV_PRESERVES_UV */
2687 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2688 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2689 /* The UV slot will have been set from value returned by
2690 grok_number above. The NV slot has just been set using
2693 assert (SvIOKp(sv));
2695 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2696 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2697 /* Small enough to preserve all bits. */
2698 (void)SvIOKp_on(sv);
2700 SvIV_set(sv, I_V(SvNVX(sv)));
2701 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2703 /* Assumption: first non-preserved integer is < IV_MAX,
2704 this NV is in the preserved range, therefore: */
2705 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2707 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);
2710 sv_2iuv_non_preserve (sv, numtype);
2712 #endif /* NV_PRESERVES_UV */
2716 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2717 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2720 if (SvTYPE(sv) < SVt_IV)
2721 /* Typically the caller expects that sv_any is not NULL now. */
2722 sv_upgrade(sv, SVt_IV);
2726 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2727 PTR2UV(sv),SvUVX(sv)));
2728 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2734 Return the num value of an SV, doing any necessary string or integer
2735 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2742 Perl_sv_2nv(pTHX_ register SV *sv)
2746 if (SvGMAGICAL(sv)) {
2750 if (SvPOKp(sv) && SvLEN(sv)) {
2751 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2752 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2754 return Atof(SvPVX_const(sv));
2758 return (NV)SvUVX(sv);
2760 return (NV)SvIVX(sv);
2763 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2764 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2770 if (SvTHINKFIRST(sv)) {
2773 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2774 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2775 return SvNV(tmpstr);
2776 return PTR2NV(SvRV(sv));
2779 sv_force_normal_flags(sv, 0);
2781 if (SvREADONLY(sv) && !SvOK(sv)) {
2782 if (ckWARN(WARN_UNINITIALIZED))
2787 if (SvTYPE(sv) < SVt_NV) {
2788 if (SvTYPE(sv) == SVt_IV)
2789 sv_upgrade(sv, SVt_PVNV);
2791 sv_upgrade(sv, SVt_NV);
2792 #ifdef USE_LONG_DOUBLE
2794 STORE_NUMERIC_LOCAL_SET_STANDARD();
2795 PerlIO_printf(Perl_debug_log,
2796 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2797 PTR2UV(sv), SvNVX(sv));
2798 RESTORE_NUMERIC_LOCAL();
2802 STORE_NUMERIC_LOCAL_SET_STANDARD();
2803 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2804 PTR2UV(sv), SvNVX(sv));
2805 RESTORE_NUMERIC_LOCAL();
2809 else if (SvTYPE(sv) < SVt_PVNV)
2810 sv_upgrade(sv, SVt_PVNV);
2815 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2816 #ifdef NV_PRESERVES_UV
2819 /* Only set the public NV OK flag if this NV preserves the IV */
2820 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2821 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2822 : (SvIVX(sv) == I_V(SvNVX(sv))))
2828 else if (SvPOKp(sv) && SvLEN(sv)) {
2830 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2831 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2833 #ifdef NV_PRESERVES_UV
2834 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2835 == IS_NUMBER_IN_UV) {
2836 /* It's definitely an integer */
2837 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2839 SvNV_set(sv, Atof(SvPVX_const(sv)));
2842 SvNV_set(sv, Atof(SvPVX_const(sv)));
2843 /* Only set the public NV OK flag if this NV preserves the value in
2844 the PV at least as well as an IV/UV would.
2845 Not sure how to do this 100% reliably. */
2846 /* if that shift count is out of range then Configure's test is
2847 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2849 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2850 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2851 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2852 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2853 /* Can't use strtol etc to convert this string, so don't try.
2854 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2857 /* value has been set. It may not be precise. */
2858 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2859 /* 2s complement assumption for (UV)IV_MIN */
2860 SvNOK_on(sv); /* Integer is too negative. */
2865 if (numtype & IS_NUMBER_NEG) {
2866 SvIV_set(sv, -(IV)value);
2867 } else if (value <= (UV)IV_MAX) {
2868 SvIV_set(sv, (IV)value);
2870 SvUV_set(sv, value);
2874 if (numtype & IS_NUMBER_NOT_INT) {
2875 /* I believe that even if the original PV had decimals,
2876 they are lost beyond the limit of the FP precision.
2877 However, neither is canonical, so both only get p
2878 flags. NWC, 2000/11/25 */
2879 /* Both already have p flags, so do nothing */
2881 const NV nv = SvNVX(sv);
2882 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2883 if (SvIVX(sv) == I_V(nv)) {
2888 /* It had no "." so it must be integer. */
2891 /* between IV_MAX and NV(UV_MAX).
2892 Could be slightly > UV_MAX */
2894 if (numtype & IS_NUMBER_NOT_INT) {
2895 /* UV and NV both imprecise. */
2897 const UV nv_as_uv = U_V(nv);
2899 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2910 #endif /* NV_PRESERVES_UV */
2913 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2915 if (SvTYPE(sv) < SVt_NV)
2916 /* Typically the caller expects that sv_any is not NULL now. */
2917 /* XXX Ilya implies that this is a bug in callers that assume this
2918 and ideally should be fixed. */
2919 sv_upgrade(sv, SVt_NV);
2922 #if defined(USE_LONG_DOUBLE)
2924 STORE_NUMERIC_LOCAL_SET_STANDARD();
2925 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2926 PTR2UV(sv), SvNVX(sv));
2927 RESTORE_NUMERIC_LOCAL();
2931 STORE_NUMERIC_LOCAL_SET_STANDARD();
2932 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2933 PTR2UV(sv), SvNVX(sv));
2934 RESTORE_NUMERIC_LOCAL();
2940 /* asIV(): extract an integer from the string value of an SV.
2941 * Caller must validate PVX */
2944 S_asIV(pTHX_ SV *sv)
2947 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2949 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2950 == IS_NUMBER_IN_UV) {
2951 /* It's definitely an integer */
2952 if (numtype & IS_NUMBER_NEG) {
2953 if (value < (UV)IV_MIN)
2956 if (value < (UV)IV_MAX)
2961 if (ckWARN(WARN_NUMERIC))
2964 return I_V(Atof(SvPVX_const(sv)));
2967 /* asUV(): extract an unsigned integer from the string value of an SV
2968 * Caller must validate PVX */
2971 S_asUV(pTHX_ SV *sv)
2974 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2976 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2977 == IS_NUMBER_IN_UV) {
2978 /* It's definitely an integer */
2979 if (!(numtype & IS_NUMBER_NEG))
2983 if (ckWARN(WARN_NUMERIC))
2986 return U_V(Atof(SvPVX_const(sv)));
2989 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2990 * UV as a string towards the end of buf, and return pointers to start and
2993 * We assume that buf is at least TYPE_CHARS(UV) long.
2997 S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2999 char *ptr = buf + TYPE_CHARS(UV);
3000 char * const ebuf = ptr;
3013 *--ptr = '0' + (char)(uv % 10);
3022 =for apidoc sv_2pv_flags
3024 Returns a pointer to the string value of an SV, and sets *lp to its length.
3025 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
3027 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
3028 usually end up here too.
3034 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3039 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3040 char *tmpbuf = tbuf;
3041 STRLEN len = 0; /* Hush gcc. len is always initialised before use. */
3048 if (SvGMAGICAL(sv)) {
3049 if (flags & SV_GMAGIC)
3054 if (flags & SV_MUTABLE_RETURN)
3055 return SvPVX_mutable(sv);
3056 if (flags & SV_CONST_RETURN)
3057 return (char *)SvPVX_const(sv);
3061 len = SvIsUV(sv) ? my_sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv))
3062 : my_sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3064 goto tokensave_has_len;
3067 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3072 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3073 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3081 if (SvTHINKFIRST(sv)) {
3084 register const char *typestr;
3085 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3086 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3088 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
3091 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
3092 if (flags & SV_CONST_RETURN) {
3093 pv = (char *) SvPVX_const(tmpstr);
3095 pv = (flags & SV_MUTABLE_RETURN)
3096 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
3099 *lp = SvCUR(tmpstr);
3101 pv = sv_2pv_flags(tmpstr, lp, flags);
3112 typestr = "NULLREF";
3116 switch (SvTYPE(sv)) {
3118 if ( ((SvFLAGS(sv) &
3119 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3120 == (SVs_OBJECT|SVs_SMG))
3121 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3122 const regexp *re = (regexp *)mg->mg_obj;
3125 const char *fptr = "msix";
3130 char need_newline = 0;
3131 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3133 while((ch = *fptr++)) {
3135 reflags[left++] = ch;
3138 reflags[right--] = ch;
3143 reflags[left] = '-';
3147 mg->mg_len = re->prelen + 4 + left;
3149 * If /x was used, we have to worry about a regex
3150 * ending with a comment later being embedded
3151 * within another regex. If so, we don't want this
3152 * regex's "commentization" to leak out to the
3153 * right part of the enclosing regex, we must cap
3154 * it with a newline.
3156 * So, if /x was used, we scan backwards from the
3157 * end of the regex. If we find a '#' before we
3158 * find a newline, we need to add a newline
3159 * ourself. If we find a '\n' first (or if we
3160 * don't find '#' or '\n'), we don't need to add
3161 * anything. -jfriedl
3163 if (PMf_EXTENDED & re->reganch)
3165 const char *endptr = re->precomp + re->prelen;
3166 while (endptr >= re->precomp)
3168 const char c = *(endptr--);
3170 break; /* don't need another */
3172 /* we end while in a comment, so we
3174 mg->mg_len++; /* save space for it */
3175 need_newline = 1; /* note to add it */
3181 Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
3182 Copy("(?", mg->mg_ptr, 2, char);
3183 Copy(reflags, mg->mg_ptr+2, left, char);
3184 Copy(":", mg->mg_ptr+left+2, 1, char);
3185 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3187 mg->mg_ptr[mg->mg_len - 2] = '\n';
3188 mg->mg_ptr[mg->mg_len - 1] = ')';
3189 mg->mg_ptr[mg->mg_len] = 0;
3191 PL_reginterp_cnt += re->program[0].next_off;
3193 if (re->reganch & ROPT_UTF8)
3209 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3210 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3211 /* tied lvalues should appear to be
3212 * scalars for backwards compatitbility */
3213 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3214 ? "SCALAR" : "LVALUE"; break;
3215 case SVt_PVAV: typestr = "ARRAY"; break;
3216 case SVt_PVHV: typestr = "HASH"; break;
3217 case SVt_PVCV: typestr = "CODE"; break;
3218 case SVt_PVGV: typestr = "GLOB"; break;
3219 case SVt_PVFM: typestr = "FORMAT"; break;
3220 case SVt_PVIO: typestr = "IO"; break;
3221 default: typestr = "UNKNOWN"; break;
3225 const char * const name = HvNAME_get(SvSTASH(sv));
3226 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3227 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3230 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3234 *lp = strlen(typestr);
3235 return (char *)typestr;
3237 if (SvREADONLY(sv) && !SvOK(sv)) {
3238 if (ckWARN(WARN_UNINITIALIZED))
3245 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3246 /* I'm assuming that if both IV and NV are equally valid then
3247 converting the IV is going to be more efficient */
3248 const U32 isIOK = SvIOK(sv);
3249 const U32 isUIOK = SvIsUV(sv);
3250 char buf[TYPE_CHARS(UV)];
3253 if (SvTYPE(sv) < SVt_PVIV)
3254 sv_upgrade(sv, SVt_PVIV);
3256 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3258 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3259 /* inlined from sv_setpvn */
3260 SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
3261 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
3262 SvCUR_set(sv, ebuf - ptr);
3272 else if (SvNOKp(sv)) {
3273 if (SvTYPE(sv) < SVt_PVNV)
3274 sv_upgrade(sv, SVt_PVNV);
3275 /* The +20 is pure guesswork. Configure test needed. --jhi */
3276 s = SvGROW_mutable(sv, NV_DIG + 20);
3277 olderrno = errno; /* some Xenix systems wipe out errno here */
3279 if (SvNVX(sv) == 0.0)
3280 (void)strcpy(s,"0");
3284 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3287 #ifdef FIXNEGATIVEZERO
3288 if (*s == '-' && s[1] == '0' && !s[2])
3298 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
3302 if (SvTYPE(sv) < SVt_PV)
3303 /* Typically the caller expects that sv_any is not NULL now. */
3304 sv_upgrade(sv, SVt_PV);
3308 const STRLEN len = s - SvPVX_const(sv);
3314 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3315 PTR2UV(sv),SvPVX_const(sv)));
3316 if (flags & SV_CONST_RETURN)
3317 return (char *)SvPVX_const(sv);
3318 if (flags & SV_MUTABLE_RETURN)
3319 return SvPVX_mutable(sv);
3323 len = strlen(tmpbuf);
3326 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3327 /* Sneaky stuff here */
3331 tsv = newSVpvn(tmpbuf, len);
3340 #ifdef FIXNEGATIVEZERO
3341 if (len == 2 && tmpbuf[0] == '-' && tmpbuf[1] == '0') {
3347 SvUPGRADE(sv, SVt_PV);
3350 s = SvGROW_mutable(sv, len + 1);
3353 return memcpy(s, tmpbuf, len + 1);
3358 =for apidoc sv_copypv
3360 Copies a stringified representation of the source SV into the
3361 destination SV. Automatically performs any necessary mg_get and
3362 coercion of numeric values into strings. Guaranteed to preserve
3363 UTF-8 flag even from overloaded objects. Similar in nature to
3364 sv_2pv[_flags] but operates directly on an SV instead of just the
3365 string. Mostly uses sv_2pv_flags to do its work, except when that
3366 would lose the UTF-8'ness of the PV.
3372 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3375 const char * const s = SvPV_const(ssv,len);
3376 sv_setpvn(dsv,s,len);
3384 =for apidoc sv_2pvbyte
3386 Return a pointer to the byte-encoded representation of the SV, and set *lp
3387 to its length. May cause the SV to be downgraded from UTF-8 as a
3390 Usually accessed via the C<SvPVbyte> macro.
3396 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3398 sv_utf8_downgrade(sv,0);
3399 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3403 =for apidoc sv_2pvutf8
3405 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3406 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3408 Usually accessed via the C<SvPVutf8> macro.
3414 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3416 sv_utf8_upgrade(sv);
3417 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3422 =for apidoc sv_2bool
3424 This function is only called on magical items, and is only used by
3425 sv_true() or its macro equivalent.
3431 Perl_sv_2bool(pTHX_ register SV *sv)
3439 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3440 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3441 return (bool)SvTRUE(tmpsv);
3442 return SvRV(sv) != 0;
3445 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3447 (*sv->sv_u.svu_pv > '0' ||
3448 Xpvtmp->xpv_cur > 1 ||
3449 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3456 return SvIVX(sv) != 0;
3459 return SvNVX(sv) != 0.0;
3467 =for apidoc sv_utf8_upgrade
3469 Converts the PV of an SV to its UTF-8-encoded form.
3470 Forces the SV to string form if it is not already.
3471 Always sets the SvUTF8 flag to avoid future validity checks even
3472 if all the bytes have hibit clear.
3474 This is not as a general purpose byte encoding to Unicode interface:
3475 use the Encode extension for that.
3477 =for apidoc sv_utf8_upgrade_flags
3479 Converts the PV of an SV to its UTF-8-encoded form.
3480 Forces the SV to string form if it is not already.
3481 Always sets the SvUTF8 flag to avoid future validity checks even
3482 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3483 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3484 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3486 This is not as a general purpose byte encoding to Unicode interface:
3487 use the Encode extension for that.
3493 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3495 if (sv == &PL_sv_undef)
3499 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3500 (void) sv_2pv_flags(sv,&len, flags);
3504 (void) SvPV_force(sv,len);
3513 sv_force_normal_flags(sv, 0);
3516 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3517 sv_recode_to_utf8(sv, PL_encoding);
3518 else { /* Assume Latin-1/EBCDIC */
3519 /* This function could be much more efficient if we
3520 * had a FLAG in SVs to signal if there are any hibit
3521 * chars in the PV. Given that there isn't such a flag
3522 * make the loop as fast as possible. */
3523 const U8 *s = (U8 *) SvPVX_const(sv);
3524 const U8 * const e = (U8 *) SvEND(sv);
3530 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3534 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3535 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
3537 SvPV_free(sv); /* No longer using what was there before. */
3539 SvPV_set(sv, (char*)recoded);
3540 SvCUR_set(sv, len - 1);
3541 SvLEN_set(sv, len); /* No longer know the real size. */
3543 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3550 =for apidoc sv_utf8_downgrade
3552 Attempts to convert the PV of an SV from characters to bytes.
3553 If the PV contains a character beyond byte, this conversion will fail;
3554 in this case, either returns false or, if C<fail_ok> is not
3557 This is not as a general purpose Unicode to byte encoding interface:
3558 use the Encode extension for that.
3564 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3566 if (SvPOKp(sv) && SvUTF8(sv)) {
3572 sv_force_normal_flags(sv, 0);
3574 s = (U8 *) SvPV(sv, len);
3575 if (!utf8_to_bytes(s, &len)) {
3580 Perl_croak(aTHX_ "Wide character in %s",
3583 Perl_croak(aTHX_ "Wide character");
3594 =for apidoc sv_utf8_encode
3596 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3597 flag off so that it looks like octets again.
3603 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3605 (void) sv_utf8_upgrade(sv);
3607 sv_force_normal_flags(sv, 0);
3609 if (SvREADONLY(sv)) {
3610 Perl_croak(aTHX_ PL_no_modify);
3616 =for apidoc sv_utf8_decode
3618 If the PV of the SV is an octet sequence in UTF-8
3619 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3620 so that it looks like a character. If the PV contains only single-byte
3621 characters, the C<SvUTF8> flag stays being off.
3622 Scans PV for validity and returns false if the PV is invalid UTF-8.
3628 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3634 /* The octets may have got themselves encoded - get them back as
3637 if (!sv_utf8_downgrade(sv, TRUE))
3640 /* it is actually just a matter of turning the utf8 flag on, but
3641 * we want to make sure everything inside is valid utf8 first.
3643 c = (const U8 *) SvPVX_const(sv);
3644 if (!is_utf8_string(c, SvCUR(sv)+1))
3646 e = (const U8 *) SvEND(sv);
3649 if (!UTF8_IS_INVARIANT(ch)) {
3659 =for apidoc sv_setsv
3661 Copies the contents of the source SV C<ssv> into the destination SV
3662 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3663 function if the source SV needs to be reused. Does not handle 'set' magic.
3664 Loosely speaking, it performs a copy-by-value, obliterating any previous
3665 content of the destination.
3667 You probably want to use one of the assortment of wrappers, such as
3668 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3669 C<SvSetMagicSV_nosteal>.
3671 =for apidoc sv_setsv_flags
3673 Copies the contents of the source SV C<ssv> into the destination SV
3674 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3675 function if the source SV needs to be reused. Does not handle 'set' magic.
3676 Loosely speaking, it performs a copy-by-value, obliterating any previous
3677 content of the destination.
3678 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3679 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3680 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3681 and C<sv_setsv_nomg> are implemented in terms of this function.
3683 You probably want to use one of the assortment of wrappers, such as
3684 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3685 C<SvSetMagicSV_nosteal>.
3687 This is the primary function for copying scalars, and most other
3688 copy-ish functions and macros use this underneath.
3694 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3696 register U32 sflags;
3702 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3704 sstr = &PL_sv_undef;
3705 stype = SvTYPE(sstr);
3706 dtype = SvTYPE(dstr);
3711 /* need to nuke the magic */
3713 SvRMAGICAL_off(dstr);
3716 /* There's a lot of redundancy below but we're going for speed here */
3721 if (dtype != SVt_PVGV) {
3722 (void)SvOK_off(dstr);
3730 sv_upgrade(dstr, SVt_IV);
3733 sv_upgrade(dstr, SVt_PVNV);
3737 sv_upgrade(dstr, SVt_PVIV);
3740 (void)SvIOK_only(dstr);
3741 SvIV_set(dstr, SvIVX(sstr));
3744 if (SvTAINTED(sstr))
3755 sv_upgrade(dstr, SVt_NV);
3760 sv_upgrade(dstr, SVt_PVNV);
3763 SvNV_set(dstr, SvNVX(sstr));
3764 (void)SvNOK_only(dstr);
3765 if (SvTAINTED(sstr))
3773 sv_upgrade(dstr, SVt_RV);
3774 else if (dtype == SVt_PVGV &&
3775 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3778 if (GvIMPORTED(dstr) != GVf_IMPORTED
3779 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3781 GvIMPORTED_on(dstr);
3790 #ifdef PERL_OLD_COPY_ON_WRITE
3791 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3792 if (dtype < SVt_PVIV)
3793 sv_upgrade(dstr, SVt_PVIV);
3800 sv_upgrade(dstr, SVt_PV);
3803 if (dtype < SVt_PVIV)
3804 sv_upgrade(dstr, SVt_PVIV);
3807 if (dtype < SVt_PVNV)
3808 sv_upgrade(dstr, SVt_PVNV);
3815 const char * const type = sv_reftype(sstr,0);
3817 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3819 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3824 if (dtype <= SVt_PVGV) {
3826 if (dtype != SVt_PVGV) {
3827 const char * const name = GvNAME(sstr);
3828 const STRLEN len = GvNAMELEN(sstr);
3829 /* don't upgrade SVt_PVLV: it can hold a glob */
3830 if (dtype != SVt_PVLV)
3831 sv_upgrade(dstr, SVt_PVGV);
3832 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3833 GvSTASH(dstr) = GvSTASH(sstr);
3835 Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3836 GvNAME(dstr) = savepvn(name, len);
3837 GvNAMELEN(dstr) = len;
3838 SvFAKE_on(dstr); /* can coerce to non-glob */
3841 #ifdef GV_UNIQUE_CHECK
3842 if (GvUNIQUE((GV*)dstr)) {
3843 Perl_croak(aTHX_ PL_no_modify);
3847 (void)SvOK_off(dstr);
3848 GvINTRO_off(dstr); /* one-shot flag */
3850 GvGP(dstr) = gp_ref(GvGP(sstr));
3851 if (SvTAINTED(sstr))
3853 if (GvIMPORTED(dstr) != GVf_IMPORTED
3854 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3856 GvIMPORTED_on(dstr);
3864 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3866 if ((int)SvTYPE(sstr) != stype) {
3867 stype = SvTYPE(sstr);
3868 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3872 if (stype == SVt_PVLV)
3873 SvUPGRADE(dstr, SVt_PVNV);
3875 SvUPGRADE(dstr, (U32)stype);
3878 sflags = SvFLAGS(sstr);
3880 if (sflags & SVf_ROK) {
3881 if (dtype >= SVt_PV) {
3882 if (dtype == SVt_PVGV) {
3883 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3885 const int intro = GvINTRO(dstr);
3887 #ifdef GV_UNIQUE_CHECK
3888 if (GvUNIQUE((GV*)dstr)) {
3889 Perl_croak(aTHX_ PL_no_modify);
3894 GvINTRO_off(dstr); /* one-shot flag */
3895 GvLINE(dstr) = CopLINE(PL_curcop);
3896 GvEGV(dstr) = (GV*)dstr;
3899 switch (SvTYPE(sref)) {
3902 SAVEGENERICSV(GvAV(dstr));
3904 dref = (SV*)GvAV(dstr);
3905 GvAV(dstr) = (AV*)sref;
3906 if (!GvIMPORTED_AV(dstr)
3907 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3909 GvIMPORTED_AV_on(dstr);
3914 SAVEGENERICSV(GvHV(dstr));
3916 dref = (SV*)GvHV(dstr);
3917 GvHV(dstr) = (HV*)sref;
3918 if (!GvIMPORTED_HV(dstr)
3919 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3921 GvIMPORTED_HV_on(dstr);
3926 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3927 SvREFCNT_dec(GvCV(dstr));
3928 GvCV(dstr) = Nullcv;
3929 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3930 PL_sub_generation++;
3932 SAVEGENERICSV(GvCV(dstr));
3935 dref = (SV*)GvCV(dstr);
3936 if (GvCV(dstr) != (CV*)sref) {
3937 CV* const cv = GvCV(dstr);
3939 if (!GvCVGEN((GV*)dstr) &&
3940 (CvROOT(cv) || CvXSUB(cv)))
3942 /* Redefining a sub - warning is mandatory if
3943 it was a const and its value changed. */
3944 if (ckWARN(WARN_REDEFINE)
3946 && (!CvCONST((CV*)sref)
3947 || sv_cmp(cv_const_sv(cv),
3948 cv_const_sv((CV*)sref)))))
3950 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3952 ? "Constant subroutine %s::%s redefined"
3953 : "Subroutine %s::%s redefined",
3954 HvNAME_get(GvSTASH((GV*)dstr)),
3955 GvENAME((GV*)dstr));
3959 cv_ckproto(cv, (GV*)dstr,
3961 ? SvPVX_const(sref) : Nullch);
3963 GvCV(dstr) = (CV*)sref;
3964 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3965 GvASSUMECV_on(dstr);
3966 PL_sub_generation++;
3968 if (!GvIMPORTED_CV(dstr)
3969 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3971 GvIMPORTED_CV_on(dstr);
3976 SAVEGENERICSV(GvIOp(dstr));
3978 dref = (SV*)GvIOp(dstr);
3979 GvIOp(dstr) = (IO*)sref;
3983 SAVEGENERICSV(GvFORM(dstr));
3985 dref = (SV*)GvFORM(dstr);
3986 GvFORM(dstr) = (CV*)sref;
3990 SAVEGENERICSV(GvSV(dstr));
3992 dref = (SV*)GvSV(dstr);
3994 if (!GvIMPORTED_SV(dstr)
3995 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3997 GvIMPORTED_SV_on(dstr);
4003 if (SvTAINTED(sstr))
4007 if (SvPVX_const(dstr)) {
4013 (void)SvOK_off(dstr);
4014 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4016 if (sflags & SVp_NOK) {
4018 /* Only set the public OK flag if the source has public OK. */
4019 if (sflags & SVf_NOK)
4020 SvFLAGS(dstr) |= SVf_NOK;
4021 SvNV_set(dstr, SvNVX(sstr));
4023 if (sflags & SVp_IOK) {
4024 (void)SvIOKp_on(dstr);
4025 if (sflags & SVf_IOK)
4026 SvFLAGS(dstr) |= SVf_IOK;
4027 if (sflags & SVf_IVisUV)
4029 SvIV_set(dstr, SvIVX(sstr));
4031 if (SvAMAGIC(sstr)) {
4035 else if (sflags & SVp_POK) {
4039 * Check to see if we can just swipe the string. If so, it's a
4040 * possible small lose on short strings, but a big win on long ones.
4041 * It might even be a win on short strings if SvPVX_const(dstr)
4042 * has to be allocated and SvPVX_const(sstr) has to be freed.
4045 /* Whichever path we take through the next code, we want this true,
4046 and doing it now facilitates the COW check. */
4047 (void)SvPOK_only(dstr);
4050 /* We're not already COW */
4051 ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4052 #ifndef PERL_OLD_COPY_ON_WRITE
4053 /* or we are, but dstr isn't a suitable target. */
4054 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4059 (sflags & SVs_TEMP) && /* slated for free anyway? */
4060 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4061 (!(flags & SV_NOSTEAL)) &&
4062 /* and we're allowed to steal temps */
4063 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4064 SvLEN(sstr) && /* and really is a string */
4065 /* and won't be needed again, potentially */
4066 !(PL_op && PL_op->op_type == OP_AASSIGN))
4067 #ifdef PERL_OLD_COPY_ON_WRITE
4068 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4069 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4070 && SvTYPE(sstr) >= SVt_PVIV)
4073 /* Failed the swipe test, and it's not a shared hash key either.
4074 Have to copy the string. */
4075 STRLEN len = SvCUR(sstr);
4076 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4077 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4078 SvCUR_set(dstr, len);
4079 *SvEND(dstr) = '\0';
4081 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4083 /* Either it's a shared hash key, or it's suitable for
4084 copy-on-write or we can swipe the string. */
4086 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4090 #ifdef PERL_OLD_COPY_ON_WRITE
4092 /* I believe I should acquire a global SV mutex if
4093 it's a COW sv (not a shared hash key) to stop
4094 it going un copy-on-write.
4095 If the source SV has gone un copy on write between up there
4096 and down here, then (assert() that) it is of the correct
4097 form to make it copy on write again */
4098 if ((sflags & (SVf_FAKE | SVf_READONLY))
4099 != (SVf_FAKE | SVf_READONLY)) {
4100 SvREADONLY_on(sstr);
4102 /* Make the source SV into a loop of 1.
4103 (about to become 2) */
4104 SV_COW_NEXT_SV_SET(sstr, sstr);
4108 /* Initial code is common. */
4109 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4114 /* making another shared SV. */
4115 STRLEN cur = SvCUR(sstr);
4116 STRLEN len = SvLEN(sstr);
4117 #ifdef PERL_OLD_COPY_ON_WRITE
4119 assert (SvTYPE(dstr) >= SVt_PVIV);
4120 /* SvIsCOW_normal */
4121 /* splice us in between source and next-after-source. */
4122 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4123 SV_COW_NEXT_SV_SET(sstr, dstr);
4124 SvPV_set(dstr, SvPVX_mutable(sstr));
4128 /* SvIsCOW_shared_hash */
4129 DEBUG_C(PerlIO_printf(Perl_debug_log,
4130 "Copy on write: Sharing hash\n"));
4132 assert (SvTYPE(dstr) >= SVt_PV);
4134 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4136 SvLEN_set(dstr, len);
4137 SvCUR_set(dstr, cur);
4138 SvREADONLY_on(dstr);
4140 /* Relesase a global SV mutex. */
4143 { /* Passes the swipe test. */
4144 SvPV_set(dstr, SvPVX_mutable(sstr));
4145 SvLEN_set(dstr, SvLEN(sstr));
4146 SvCUR_set(dstr, SvCUR(sstr));
4149 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4150 SvPV_set(sstr, Nullch);
4156 if (sflags & SVf_UTF8)
4158 if (sflags & SVp_NOK) {
4160 if (sflags & SVf_NOK)
4161 SvFLAGS(dstr) |= SVf_NOK;
4162 SvNV_set(dstr, SvNVX(sstr));
4164 if (sflags & SVp_IOK) {
4165 (void)SvIOKp_on(dstr);
4166 if (sflags & SVf_IOK)
4167 SvFLAGS(dstr) |= SVf_IOK;
4168 if (sflags & SVf_IVisUV)
4170 SvIV_set(dstr, SvIVX(sstr));
4173 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4174 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4175 smg->mg_ptr, smg->mg_len);
4176 SvRMAGICAL_on(dstr);
4179 else if (sflags & SVp_IOK) {
4180 if (sflags & SVf_IOK)
4181 (void)SvIOK_only(dstr);
4183 (void)SvOK_off(dstr);
4184 (void)SvIOKp_on(dstr);
4186 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4187 if (sflags & SVf_IVisUV)
4189 SvIV_set(dstr, SvIVX(sstr));
4190 if (sflags & SVp_NOK) {
4191 if (sflags & SVf_NOK)
4192 (void)SvNOK_on(dstr);
4194 (void)SvNOKp_on(dstr);
4195 SvNV_set(dstr, SvNVX(sstr));
4198 else if (sflags & SVp_NOK) {
4199 if (sflags & SVf_NOK)
4200 (void)SvNOK_only(dstr);
4202 (void)SvOK_off(dstr);
4205 SvNV_set(dstr, SvNVX(sstr));
4208 if (dtype == SVt_PVGV) {
4209 if (ckWARN(WARN_MISC))
4210 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4213 (void)SvOK_off(dstr);
4215 if (SvTAINTED(sstr))
4220 =for apidoc sv_setsv_mg
4222 Like C<sv_setsv>, but also handles 'set' magic.
4228 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4230 sv_setsv(dstr,sstr);
4234 #ifdef PERL_OLD_COPY_ON_WRITE
4236 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4238 STRLEN cur = SvCUR(sstr);
4239 STRLEN len = SvLEN(sstr);
4240 register char *new_pv;
4243 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4251 if (SvTHINKFIRST(dstr))
4252 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4253 else if (SvPVX_const(dstr))
4254 Safefree(SvPVX_const(dstr));
4258 SvUPGRADE(dstr, SVt_PVIV);
4260 assert (SvPOK(sstr));
4261 assert (SvPOKp(sstr));
4262 assert (!SvIOK(sstr));
4263 assert (!SvIOKp(sstr));
4264 assert (!SvNOK(sstr));
4265 assert (!SvNOKp(sstr));
4267 if (SvIsCOW(sstr)) {
4269 if (SvLEN(sstr) == 0) {
4270 /* source is a COW shared hash key. */
4271 DEBUG_C(PerlIO_printf(Perl_debug_log,
4272 "Fast copy on write: Sharing hash\n"));
4273 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4276 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4278 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4279 SvUPGRADE(sstr, SVt_PVIV);
4280 SvREADONLY_on(sstr);
4282 DEBUG_C(PerlIO_printf(Perl_debug_log,
4283 "Fast copy on write: Converting sstr to COW\n"));
4284 SV_COW_NEXT_SV_SET(dstr, sstr);
4286 SV_COW_NEXT_SV_SET(sstr, dstr);
4287 new_pv = SvPVX_mutable(sstr);
4290 SvPV_set(dstr, new_pv);
4291 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4294 SvLEN_set(dstr, len);
4295 SvCUR_set(dstr, cur);
4304 =for apidoc sv_setpvn
4306 Copies a string into an SV. The C<len> parameter indicates the number of
4307 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4308 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4314 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4316 register char *dptr;
4318 SV_CHECK_THINKFIRST_COW_DROP(sv);
4324 /* len is STRLEN which is unsigned, need to copy to signed */
4327 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4329 SvUPGRADE(sv, SVt_PV);
4331 dptr = SvGROW(sv, len + 1);
4332 Move(ptr,dptr,len,char);
4335 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4340 =for apidoc sv_setpvn_mg
4342 Like C<sv_setpvn>, but also handles 'set' magic.
4348 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4350 sv_setpvn(sv,ptr,len);
4355 =for apidoc sv_setpv
4357 Copies a string into an SV. The string must be null-terminated. Does not
4358 handle 'set' magic. See C<sv_setpv_mg>.
4364 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4366 register STRLEN len;
4368 SV_CHECK_THINKFIRST_COW_DROP(sv);
4374 SvUPGRADE(sv, SVt_PV);
4376 SvGROW(sv, len + 1);
4377 Move(ptr,SvPVX(sv),len+1,char);
4379 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4384 =for apidoc sv_setpv_mg
4386 Like C<sv_setpv>, but also handles 'set' magic.
4392 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4399 =for apidoc sv_usepvn
4401 Tells an SV to use C<ptr> to find its string value. Normally the string is
4402 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4403 The C<ptr> should point to memory that was allocated by C<malloc>. The
4404 string length, C<len>, must be supplied. This function will realloc the
4405 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4406 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4407 See C<sv_usepvn_mg>.
4413 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4416 SV_CHECK_THINKFIRST_COW_DROP(sv);
4417 SvUPGRADE(sv, SVt_PV);
4422 if (SvPVX_const(sv))
4425 allocate = PERL_STRLEN_ROUNDUP(len + 1);
4426 ptr = saferealloc (ptr, allocate);
4429 SvLEN_set(sv, allocate);
4431 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4436 =for apidoc sv_usepvn_mg
4438 Like C<sv_usepvn>, but also handles 'set' magic.
4444 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4446 sv_usepvn(sv,ptr,len);
4450 #ifdef PERL_OLD_COPY_ON_WRITE
4451 /* Need to do this *after* making the SV normal, as we need the buffer
4452 pointer to remain valid until after we've copied it. If we let go too early,
4453 another thread could invalidate it by unsharing last of the same hash key
4454 (which it can do by means other than releasing copy-on-write Svs)
4455 or by changing the other copy-on-write SVs in the loop. */
4457 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
4459 if (len) { /* this SV was SvIsCOW_normal(sv) */
4460 /* we need to find the SV pointing to us. */
4461 SV * const current = SV_COW_NEXT_SV(after);
4463 if (current == sv) {
4464 /* The SV we point to points back to us (there were only two of us
4466 Hence other SV is no longer copy on write either. */
4468 SvREADONLY_off(after);
4470 /* We need to follow the pointers around the loop. */
4472 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4475 /* don't loop forever if the structure is bust, and we have
4476 a pointer into a closed loop. */
4477 assert (current != after);
4478 assert (SvPVX_const(current) == pvx);
4480 /* Make the SV before us point to the SV after us. */
4481 SV_COW_NEXT_SV_SET(current, after);
4484 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4489 Perl_sv_release_IVX(pTHX_ register SV *sv)
4492 sv_force_normal_flags(sv, 0);
4498 =for apidoc sv_force_normal_flags
4500 Undo various types of fakery on an SV: if the PV is a shared string, make
4501 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4502 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4503 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4504 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4505 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4506 set to some other value.) In addition, the C<flags> parameter gets passed to
4507 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4508 with flags set to 0.
4514 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4516 #ifdef PERL_OLD_COPY_ON_WRITE
4517 if (SvREADONLY(sv)) {
4518 /* At this point I believe I should acquire a global SV mutex. */
4520 const char * const pvx = SvPVX_const(sv);
4521 const STRLEN len = SvLEN(sv);
4522 const STRLEN cur = SvCUR(sv);
4523 SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
4525 PerlIO_printf(Perl_debug_log,
4526 "Copy on write: Force normal %ld\n",
4532 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4533 SvPV_set(sv, (char*)0);
4535 if (flags & SV_COW_DROP_PV) {
4536 /* OK, so we don't need to copy our buffer. */
4539 SvGROW(sv, cur + 1);
4540 Move(pvx,SvPVX(sv),cur,char);
4544 sv_release_COW(sv, pvx, len, next);
4549 else if (IN_PERL_RUNTIME)
4550 Perl_croak(aTHX_ PL_no_modify);
4551 /* At this point I believe that I can drop the global SV mutex. */
4554 if (SvREADONLY(sv)) {
4556 const char * const pvx = SvPVX_const(sv);
4557 const STRLEN len = SvCUR(sv);
4560 SvPV_set(sv, Nullch);
4562 SvGROW(sv, len + 1);
4563 Move(pvx,SvPVX(sv),len,char);
4565 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4567 else if (IN_PERL_RUNTIME)
4568 Perl_croak(aTHX_ PL_no_modify);
4572 sv_unref_flags(sv, flags);
4573 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4580 Efficient removal of characters from the beginning of the string buffer.
4581 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4582 the string buffer. The C<ptr> becomes the first character of the adjusted
4583 string. Uses the "OOK hack".
4584 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4585 refer to the same chunk of data.
4591 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
4593 register STRLEN delta;
4594 if (!ptr || !SvPOKp(sv))
4596 delta = ptr - SvPVX_const(sv);
4597 SV_CHECK_THINKFIRST(sv);
4598 if (SvTYPE(sv) < SVt_PVIV)
4599 sv_upgrade(sv,SVt_PVIV);
4602 if (!SvLEN(sv)) { /* make copy of shared string */
4603 const char *pvx = SvPVX_const(sv);
4604 const STRLEN len = SvCUR(sv);
4605 SvGROW(sv, len + 1);
4606 Move(pvx,SvPVX(sv),len,char);
4610 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
4611 and we do that anyway inside the SvNIOK_off
4613 SvFLAGS(sv) |= SVf_OOK;
4616 SvLEN_set(sv, SvLEN(sv) - delta);
4617 SvCUR_set(sv, SvCUR(sv) - delta);
4618 SvPV_set(sv, SvPVX(sv) + delta);
4619 SvIV_set(sv, SvIVX(sv) + delta);
4623 =for apidoc sv_catpvn
4625 Concatenates the string onto the end of the string which is in the SV. The
4626 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4627 status set, then the bytes appended should be valid UTF-8.
4628 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4630 =for apidoc sv_catpvn_flags
4632 Concatenates the string onto the end of the string which is in the SV. The
4633 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4634 status set, then the bytes appended should be valid UTF-8.
4635 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4636 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4637 in terms of this function.
4643 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4646 const char *dstr = SvPV_force_flags(dsv, dlen, flags);
4648 SvGROW(dsv, dlen + slen + 1);
4650 sstr = SvPVX_const(dsv);
4651 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4652 SvCUR_set(dsv, SvCUR(dsv) + slen);
4654 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4656 if (flags & SV_SMAGIC)
4661 =for apidoc sv_catsv
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>. Handles 'get' magic, but
4665 not 'set' magic. See C<sv_catsv_mg>.
4667 =for apidoc sv_catsv_flags
4669 Concatenates the string from SV C<ssv> onto the end of the string in
4670 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4671 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4672 and C<sv_catsv_nomg> are implemented in terms of this function.
4677 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4682 if ((spv = SvPV_const(ssv, slen))) {
4683 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4684 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4685 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4686 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4687 dsv->sv_flags doesn't have that bit set.
4688 Andy Dougherty 12 Oct 2001
4690 const I32 sutf8 = DO_UTF8(ssv);
4693 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4695 dutf8 = DO_UTF8(dsv);
4697 if (dutf8 != sutf8) {
4699 /* Not modifying source SV, so taking a temporary copy. */
4700 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4702 sv_utf8_upgrade(csv);
4703 spv = SvPV_const(csv, slen);
4706 sv_utf8_upgrade_nomg(dsv);
4708 sv_catpvn_nomg(dsv, spv, slen);
4711 if (flags & SV_SMAGIC)
4716 =for apidoc sv_catpv
4718 Concatenates the string onto the end of the string which is in the SV.
4719 If the SV has the UTF-8 status set, then the bytes appended should be
4720 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4725 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4727 register STRLEN len;
4733 junk = SvPV_force(sv, tlen);
4735 SvGROW(sv, tlen + len + 1);
4737 ptr = SvPVX_const(sv);
4738 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4739 SvCUR_set(sv, SvCUR(sv) + len);
4740 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4745 =for apidoc sv_catpv_mg
4747 Like C<sv_catpv>, but also handles 'set' magic.
4753 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4762 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4763 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4770 Perl_newSV(pTHX_ STRLEN len)
4776 sv_upgrade(sv, SVt_PV);
4777 SvGROW(sv, len + 1);
4782 =for apidoc sv_magicext
4784 Adds magic to an SV, upgrading it if necessary. Applies the
4785 supplied vtable and returns a pointer to the magic added.
4787 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4788 In particular, you can add magic to SvREADONLY SVs, and add more than
4789 one instance of the same 'how'.
4791 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4792 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4793 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4794 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4796 (This is now used as a subroutine by C<sv_magic>.)
4801 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
4802 const char* name, I32 namlen)
4806 if (SvTYPE(sv) < SVt_PVMG) {
4807 SvUPGRADE(sv, SVt_PVMG);
4809 Newxz(mg, 1, MAGIC);
4810 mg->mg_moremagic = SvMAGIC(sv);
4811 SvMAGIC_set(sv, mg);
4813 /* Sometimes a magic contains a reference loop, where the sv and
4814 object refer to each other. To prevent a reference loop that
4815 would prevent such objects being freed, we look for such loops
4816 and if we find one we avoid incrementing the object refcount.
4818 Note we cannot do this to avoid self-tie loops as intervening RV must
4819 have its REFCNT incremented to keep it in existence.
4822 if (!obj || obj == sv ||
4823 how == PERL_MAGIC_arylen ||
4824 how == PERL_MAGIC_qr ||
4825 how == PERL_MAGIC_symtab ||
4826 (SvTYPE(obj) == SVt_PVGV &&
4827 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4828 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4829 GvFORM(obj) == (CV*)sv)))
4834 mg->mg_obj = SvREFCNT_inc(obj);
4835 mg->mg_flags |= MGf_REFCOUNTED;
4838 /* Normal self-ties simply pass a null object, and instead of
4839 using mg_obj directly, use the SvTIED_obj macro to produce a
4840 new RV as needed. For glob "self-ties", we are tieing the PVIO
4841 with an RV obj pointing to the glob containing the PVIO. In
4842 this case, to avoid a reference loop, we need to weaken the
4846 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4847 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4853 mg->mg_len = namlen;
4856 mg->mg_ptr = savepvn(name, namlen);
4857 else if (namlen == HEf_SVKEY)
4858 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4860 mg->mg_ptr = (char *) name;
4862 mg->mg_virtual = vtable;
4866 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4871 =for apidoc sv_magic
4873 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4874 then adds a new magic item of type C<how> to the head of the magic list.
4876 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4877 handling of the C<name> and C<namlen> arguments.
4879 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4880 to add more than one instance of the same 'how'.
4886 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4888 const MGVTBL *vtable;
4891 #ifdef PERL_OLD_COPY_ON_WRITE
4893 sv_force_normal_flags(sv, 0);
4895 if (SvREADONLY(sv)) {
4897 /* its okay to attach magic to shared strings; the subsequent
4898 * upgrade to PVMG will unshare the string */
4899 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4902 && how != PERL_MAGIC_regex_global
4903 && how != PERL_MAGIC_bm
4904 && how != PERL_MAGIC_fm
4905 && how != PERL_MAGIC_sv
4906 && how != PERL_MAGIC_backref
4909 Perl_croak(aTHX_ PL_no_modify);
4912 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4913 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4914 /* sv_magic() refuses to add a magic of the same 'how' as an
4917 if (how == PERL_MAGIC_taint)
4925 vtable = &PL_vtbl_sv;
4927 case PERL_MAGIC_overload:
4928 vtable = &PL_vtbl_amagic;
4930 case PERL_MAGIC_overload_elem:
4931 vtable = &PL_vtbl_amagicelem;
4933 case PERL_MAGIC_overload_table:
4934 vtable = &PL_vtbl_ovrld;
4937 vtable = &PL_vtbl_bm;
4939 case PERL_MAGIC_regdata:
4940 vtable = &PL_vtbl_regdata;
4942 case PERL_MAGIC_regdatum:
4943 vtable = &PL_vtbl_regdatum;
4945 case PERL_MAGIC_env:
4946 vtable = &PL_vtbl_env;
4949 vtable = &PL_vtbl_fm;
4951 case PERL_MAGIC_envelem:
4952 vtable = &PL_vtbl_envelem;
4954 case PERL_MAGIC_regex_global:
4955 vtable = &PL_vtbl_mglob;
4957 case PERL_MAGIC_isa:
4958 vtable = &PL_vtbl_isa;
4960 case PERL_MAGIC_isaelem:
4961 vtable = &PL_vtbl_isaelem;
4963 case PERL_MAGIC_nkeys:
4964 vtable = &PL_vtbl_nkeys;
4966 case PERL_MAGIC_dbfile:
4969 case PERL_MAGIC_dbline:
4970 vtable = &PL_vtbl_dbline;
4972 #ifdef USE_LOCALE_COLLATE
4973 case PERL_MAGIC_collxfrm:
4974 vtable = &PL_vtbl_collxfrm;
4976 #endif /* USE_LOCALE_COLLATE */
4977 case PERL_MAGIC_tied:
4978 vtable = &PL_vtbl_pack;
4980 case PERL_MAGIC_tiedelem:
4981 case PERL_MAGIC_tiedscalar:
4982 vtable = &PL_vtbl_packelem;
4985 vtable = &PL_vtbl_regexp;
4987 case PERL_MAGIC_sig:
4988 vtable = &PL_vtbl_sig;
4990 case PERL_MAGIC_sigelem:
4991 vtable = &PL_vtbl_sigelem;
4993 case PERL_MAGIC_taint:
4994 vtable = &PL_vtbl_taint;
4996 case PERL_MAGIC_uvar:
4997 vtable = &PL_vtbl_uvar;
4999 case PERL_MAGIC_vec:
5000 vtable = &PL_vtbl_vec;
5002 case PERL_MAGIC_arylen_p:
5003 case PERL_MAGIC_rhash:
5004 case PERL_MAGIC_symtab:
5005 case PERL_MAGIC_vstring:
5008 case PERL_MAGIC_utf8:
5009 vtable = &PL_vtbl_utf8;
5011 case PERL_MAGIC_substr:
5012 vtable = &PL_vtbl_substr;
5014 case PERL_MAGIC_defelem:
5015 vtable = &PL_vtbl_defelem;
5017 case PERL_MAGIC_glob:
5018 vtable = &PL_vtbl_glob;
5020 case PERL_MAGIC_arylen:
5021 vtable = &PL_vtbl_arylen;
5023 case PERL_MAGIC_pos:
5024 vtable = &PL_vtbl_pos;
5026 case PERL_MAGIC_backref:
5027 vtable = &PL_vtbl_backref;
5029 case PERL_MAGIC_ext:
5030 /* Reserved for use by extensions not perl internals. */
5031 /* Useful for attaching extension internal data to perl vars. */
5032 /* Note that multiple extensions may clash if magical scalars */
5033 /* etc holding private data from one are passed to another. */
5037 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5040 /* Rest of work is done else where */
5041 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5044 case PERL_MAGIC_taint:
5047 case PERL_MAGIC_ext:
5048 case PERL_MAGIC_dbfile:
5055 =for apidoc sv_unmagic
5057 Removes all magic of type C<type> from an SV.
5063 Perl_sv_unmagic(pTHX_ SV *sv, int type)
5067 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5070 for (mg = *mgp; mg; mg = *mgp) {
5071 if (mg->mg_type == type) {
5072 const MGVTBL* const vtbl = mg->mg_virtual;
5073 *mgp = mg->mg_moremagic;
5074 if (vtbl && vtbl->svt_free)
5075 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5076 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5078 Safefree(mg->mg_ptr);
5079 else if (mg->mg_len == HEf_SVKEY)
5080 SvREFCNT_dec((SV*)mg->mg_ptr);
5081 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
5082 Safefree(mg->mg_ptr);
5084 if (mg->mg_flags & MGf_REFCOUNTED)
5085 SvREFCNT_dec(mg->mg_obj);
5089 mgp = &mg->mg_moremagic;
5093 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5100 =for apidoc sv_rvweaken
5102 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5103 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5104 push a back-reference to this RV onto the array of backreferences
5105 associated with that magic.
5111 Perl_sv_rvweaken(pTHX_ SV *sv)
5114 if (!SvOK(sv)) /* let undefs pass */
5117 Perl_croak(aTHX_ "Can't weaken a nonreference");
5118 else if (SvWEAKREF(sv)) {
5119 if (ckWARN(WARN_MISC))
5120 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5124 Perl_sv_add_backref(aTHX_ tsv, sv);
5130 /* Give tsv backref magic if it hasn't already got it, then push a
5131 * back-reference to sv onto the array associated with the backref magic.
5135 Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
5139 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
5140 av = (AV*)mg->mg_obj;
5143 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5144 /* av now has a refcnt of 2, which avoids it getting freed
5145 * before us during global cleanup. The extra ref is removed
5146 * by magic_killbackrefs() when tsv is being freed */
5148 if (AvFILLp(av) >= AvMAX(av)) {
5149 av_extend(av, AvFILLp(av)+1);
5151 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5154 /* delete a back-reference to ourselves from the backref magic associated
5155 * with the SV we point to.
5159 S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
5165 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) {
5166 if (PL_in_clean_all)
5169 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
5170 Perl_croak(aTHX_ "panic: del_backref");
5171 av = (AV *)mg->mg_obj;
5173 /* We shouldn't be in here more than once, but for paranoia reasons lets
5175 for (i = AvFILLp(av); i >= 0; i--) {
5177 const SSize_t fill = AvFILLp(av);
5179 /* We weren't the last entry.
5180 An unordered list has this property that you can take the
5181 last element off the end to fill the hole, and it's still
5182 an unordered list :-)
5187 AvFILLp(av) = fill - 1;
5193 =for apidoc sv_insert
5195 Inserts a string at the specified offset/length within the SV. Similar to
5196 the Perl substr() function.
5202 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
5206 register char *midend;
5207 register char *bigend;
5213 Perl_croak(aTHX_ "Can't modify non-existent substring");
5214 SvPV_force(bigstr, curlen);
5215 (void)SvPOK_only_UTF8(bigstr);
5216 if (offset + len > curlen) {
5217 SvGROW(bigstr, offset+len+1);
5218 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5219 SvCUR_set(bigstr, offset+len);
5223 i = littlelen - len;
5224 if (i > 0) { /* string might grow */
5225 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5226 mid = big + offset + len;
5227 midend = bigend = big + SvCUR(bigstr);
5230 while (midend > mid) /* shove everything down */
5231 *--bigend = *--midend;
5232 Move(little,big+offset,littlelen,char);
5233 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5238 Move(little,SvPVX(bigstr)+offset,len,char);
5243 big = SvPVX(bigstr);
5246 bigend = big + SvCUR(bigstr);
5248 if (midend > bigend)
5249 Perl_croak(aTHX_ "panic: sv_insert");
5251 if (mid - big > bigend - midend) { /* faster to shorten from end */
5253 Move(little, mid, littlelen,char);
5256 i = bigend - midend;
5258 Move(midend, mid, i,char);
5262 SvCUR_set(bigstr, mid - big);
5264 else if ((i = mid - big)) { /* faster from front */
5265 midend -= littlelen;
5267 sv_chop(bigstr,midend-i);
5272 Move(little, mid, littlelen,char);
5274 else if (littlelen) {
5275 midend -= littlelen;
5276 sv_chop(bigstr,midend);
5277 Move(little,midend,littlelen,char);
5280 sv_chop(bigstr,midend);
5286 =for apidoc sv_replace
5288 Make the first argument a copy of the second, then delete the original.
5289 The target SV physically takes over ownership of the body of the source SV
5290 and inherits its flags; however, the target keeps any magic it owns,
5291 and any magic in the source is discarded.
5292 Note that this is a rather specialist SV copying operation; most of the
5293 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5299 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5301 const U32 refcnt = SvREFCNT(sv);
5302 SV_CHECK_THINKFIRST_COW_DROP(sv);
5303 if (SvREFCNT(nsv) != 1) {
5304 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
5305 UVuf " != 1)", (UV) SvREFCNT(nsv));
5307 if (SvMAGICAL(sv)) {
5311 sv_upgrade(nsv, SVt_PVMG);
5312 SvMAGIC_set(nsv, SvMAGIC(sv));
5313 SvFLAGS(nsv) |= SvMAGICAL(sv);
5315 SvMAGIC_set(sv, NULL);
5319 assert(!SvREFCNT(sv));
5320 #ifdef DEBUG_LEAKING_SCALARS
5321 sv->sv_flags = nsv->sv_flags;
5322 sv->sv_any = nsv->sv_any;
5323 sv->sv_refcnt = nsv->sv_refcnt;
5324 sv->sv_u = nsv->sv_u;
5326 StructCopy(nsv,sv,SV);
5328 /* Currently could join these into one piece of pointer arithmetic, but
5329 it would be unclear. */
5330 if(SvTYPE(sv) == SVt_IV)
5332 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5333 else if (SvTYPE(sv) == SVt_RV) {
5334 SvANY(sv) = &sv->sv_u.svu_rv;
5338 #ifdef PERL_OLD_COPY_ON_WRITE
5339 if (SvIsCOW_normal(nsv)) {
5340 /* We need to follow the pointers around the loop to make the
5341 previous SV point to sv, rather than nsv. */
5344 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5347 assert(SvPVX_const(current) == SvPVX_const(nsv));
5349 /* Make the SV before us point to the SV after us. */
5351 PerlIO_printf(Perl_debug_log, "previous is\n");
5353 PerlIO_printf(Perl_debug_log,
5354 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5355 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5357 SV_COW_NEXT_SV_SET(current, sv);
5360 SvREFCNT(sv) = refcnt;
5361 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5367 =for apidoc sv_clear
5369 Clear an SV: call any destructors, free up any memory used by the body,
5370 and free the body itself. The SV's head is I<not> freed, although
5371 its type is set to all 1's so that it won't inadvertently be assumed
5372 to be live during global destruction etc.
5373 This function should only be called when REFCNT is zero. Most of the time
5374 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5381 Perl_sv_clear(pTHX_ register SV *sv)
5384 void** old_body_arena;
5385 size_t old_body_offset;
5386 const U32 type = SvTYPE(sv);
5389 assert(SvREFCNT(sv) == 0);
5395 old_body_offset = 0;
5398 if (PL_defstash) { /* Still have a symbol table? */
5403 stash = SvSTASH(sv);
5404 destructor = StashHANDLER(stash,DESTROY);
5406 SV* const tmpref = newRV(sv);
5407 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5409 PUSHSTACKi(PERLSI_DESTROY);
5414 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5420 if(SvREFCNT(tmpref) < 2) {
5421 /* tmpref is not kept alive! */
5423 SvRV_set(tmpref, NULL);
5426 SvREFCNT_dec(tmpref);
5428 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5432 if (PL_in_clean_objs)
5433 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5435 /* DESTROY gave object new lease on life */
5441 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5442 SvOBJECT_off(sv); /* Curse the object. */
5443 if (type != SVt_PVIO)
5444 --PL_sv_objcount; /* XXX Might want something more general */
5447 if (type >= SVt_PVMG) {
5450 if (type == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
5451 SvREFCNT_dec(SvSTASH(sv));
5456 IoIFP(sv) != PerlIO_stdin() &&
5457 IoIFP(sv) != PerlIO_stdout() &&
5458 IoIFP(sv) != PerlIO_stderr())
5460 io_close((IO*)sv, FALSE);
5462 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5463 PerlDir_close(IoDIRP(sv));
5464 IoDIRP(sv) = (DIR*)NULL;
5465 Safefree(IoTOP_NAME(sv));
5466 Safefree(IoFMT_NAME(sv));
5467 Safefree(IoBOTTOM_NAME(sv));
5468 /* PVIOs aren't from arenas */
5471 old_body_arena = &PL_body_roots[SVt_PVBM];
5474 old_body_arena = &PL_body_roots[SVt_PVCV];
5476 /* PVFMs aren't from arenas */
5481 old_body_arena = &PL_body_roots[SVt_PVHV];
5482 old_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill);
5486 old_body_arena = &PL_body_roots[SVt_PVAV];
5487 old_body_offset = STRUCT_OFFSET(XPVAV, xav_fill);
5490 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5491 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5492 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5493 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5495 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5496 SvREFCNT_dec(LvTARG(sv));
5497 old_body_arena = &PL_body_roots[SVt_PVLV];
5501 Safefree(GvNAME(sv));
5502 /* If we're in a stash, we don't own a reference to it. However it does
5503 have a back reference to us, which needs to be cleared. */
5505 sv_del_backref((SV*)GvSTASH(sv), sv);
5506 old_body_arena = &PL_body_roots[SVt_PVGV];
5509 old_body_arena = &PL_body_roots[SVt_PVMG];
5512 old_body_arena = &PL_body_roots[SVt_PVNV];
5515 old_body_arena = &PL_body_roots[SVt_PVIV];
5516 old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur);
5518 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5520 SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
5521 /* Don't even bother with turning off the OOK flag. */
5525 old_body_arena = &PL_body_roots[SVt_PV];
5526 old_body_offset = STRUCT_OFFSET(XPV, xpv_cur);
5530 SV *target = SvRV(sv);
5532 sv_del_backref(target, sv);
5534 SvREFCNT_dec(target);
5536 #ifdef PERL_OLD_COPY_ON_WRITE
5537 else if (SvPVX_const(sv)) {
5539 /* I believe I need to grab the global SV mutex here and
5540 then recheck the COW status. */
5542 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5545 sv_release_COW(sv, SvPVX_const(sv), SvLEN(sv),
5546 SV_COW_NEXT_SV(sv));
5547 /* And drop it here. */
5549 } else if (SvLEN(sv)) {
5550 Safefree(SvPVX_const(sv));
5554 else if (SvPVX_const(sv) && SvLEN(sv))
5555 Safefree(SvPVX_mutable(sv));
5556 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5557 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5563 old_body_arena = PL_body_roots[SVt_NV];
5567 SvFLAGS(sv) &= SVf_BREAK;
5568 SvFLAGS(sv) |= SVTYPEMASK;
5571 if (old_body_arena) {
5572 del_body(((char *)SvANY(sv) + old_body_offset), old_body_arena);
5576 if (type > SVt_RV) {
5577 my_safefree(SvANY(sv));
5582 =for apidoc sv_newref
5584 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5591 Perl_sv_newref(pTHX_ SV *sv)
5601 Decrement an SV's reference count, and if it drops to zero, call
5602 C<sv_clear> to invoke destructors and free up any memory used by
5603 the body; finally, deallocate the SV's head itself.
5604 Normally called via a wrapper macro C<SvREFCNT_dec>.
5610 Perl_sv_free(pTHX_ SV *sv)
5615 if (SvREFCNT(sv) == 0) {
5616 if (SvFLAGS(sv) & SVf_BREAK)
5617 /* this SV's refcnt has been artificially decremented to
5618 * trigger cleanup */
5620 if (PL_in_clean_all) /* All is fair */
5622 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5623 /* make sure SvREFCNT(sv)==0 happens very seldom */
5624 SvREFCNT(sv) = (~(U32)0)/2;
5627 if (ckWARN_d(WARN_INTERNAL)) {
5628 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5629 "Attempt to free unreferenced scalar: SV 0x%"UVxf
5630 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5631 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5632 Perl_dump_sv_child(aTHX_ sv);
5637 if (--(SvREFCNT(sv)) > 0)
5639 Perl_sv_free2(aTHX_ sv);
5643 Perl_sv_free2(pTHX_ SV *sv)
5648 if (ckWARN_d(WARN_DEBUGGING))
5649 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5650 "Attempt to free temp prematurely: SV 0x%"UVxf
5651 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5655 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5656 /* make sure SvREFCNT(sv)==0 happens very seldom */
5657 SvREFCNT(sv) = (~(U32)0)/2;
5668 Returns the length of the string in the SV. Handles magic and type
5669 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5675 Perl_sv_len(pTHX_ register SV *sv)
5683 len = mg_length(sv);
5685 (void)SvPV_const(sv, len);
5690 =for apidoc sv_len_utf8
5692 Returns the number of characters in the string in an SV, counting wide
5693 UTF-8 bytes as a single character. Handles magic and type coercion.
5699 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
5700 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
5701 * (Note that the mg_len is not the length of the mg_ptr field.)
5706 Perl_sv_len_utf8(pTHX_ register SV *sv)
5712 return mg_length(sv);
5716 const U8 *s = (U8*)SvPV_const(sv, len);
5717 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
5719 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
5721 #ifdef PERL_UTF8_CACHE_ASSERT
5722 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
5726 ulen = Perl_utf8_length(aTHX_ s, s + len);
5727 if (!mg && !SvREADONLY(sv)) {
5728 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5729 mg = mg_find(sv, PERL_MAGIC_utf8);
5739 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
5740 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5741 * between UTF-8 and byte offsets. There are two (substr offset and substr
5742 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
5743 * and byte offset) cache positions.
5745 * The mg_len field is used by sv_len_utf8(), see its comments.
5746 * Note that the mg_len is not the length of the mg_ptr field.
5750 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i,
5751 I32 offsetp, const U8 *s, const U8 *start)
5755 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5757 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
5761 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5763 Newxz(*cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5764 (*mgp)->mg_ptr = (char *) *cachep;
5768 (*cachep)[i] = offsetp;
5769 (*cachep)[i+1] = s - start;
5777 * S_utf8_mg_pos() is used to query and update mg_ptr field of
5778 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5779 * between UTF-8 and byte offsets. See also the comments of
5780 * S_utf8_mg_pos_init().
5784 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)
5788 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5790 *mgp = mg_find(sv, PERL_MAGIC_utf8);
5791 if (*mgp && (*mgp)->mg_ptr) {
5792 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5793 ASSERT_UTF8_CACHE(*cachep);
5794 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
5796 else { /* We will skip to the right spot. */
5801 /* The assumption is that going backward is half
5802 * the speed of going forward (that's where the
5803 * 2 * backw in the below comes from). (The real
5804 * figure of course depends on the UTF-8 data.) */
5806 if ((*cachep)[i] > (STRLEN)uoff) {
5808 backw = (*cachep)[i] - (STRLEN)uoff;
5810 if (forw < 2 * backw)
5813 p = start + (*cachep)[i+1];
5815 /* Try this only for the substr offset (i == 0),
5816 * not for the substr length (i == 2). */
5817 else if (i == 0) { /* (*cachep)[i] < uoff */
5818 const STRLEN ulen = sv_len_utf8(sv);
5820 if ((STRLEN)uoff < ulen) {
5821 forw = (STRLEN)uoff - (*cachep)[i];
5822 backw = ulen - (STRLEN)uoff;
5824 if (forw < 2 * backw)
5825 p = start + (*cachep)[i+1];
5830 /* If the string is not long enough for uoff,
5831 * we could extend it, but not at this low a level. */
5835 if (forw < 2 * backw) {
5842 while (UTF8_IS_CONTINUATION(*p))
5847 /* Update the cache. */
5848 (*cachep)[i] = (STRLEN)uoff;
5849 (*cachep)[i+1] = p - start;
5851 /* Drop the stale "length" cache */
5860 if (found) { /* Setup the return values. */
5861 *offsetp = (*cachep)[i+1];
5862 *sp = start + *offsetp;
5865 *offsetp = send - start;
5867 else if (*sp < start) {
5873 #ifdef PERL_UTF8_CACHE_ASSERT
5878 while (n-- && s < send)
5882 assert(*offsetp == s - start);
5883 assert((*cachep)[0] == (STRLEN)uoff);
5884 assert((*cachep)[1] == *offsetp);
5886 ASSERT_UTF8_CACHE(*cachep);
5895 =for apidoc sv_pos_u2b
5897 Converts the value pointed to by offsetp from a count of UTF-8 chars from
5898 the start of the string, to a count of the equivalent number of bytes; if
5899 lenp is non-zero, it does the same to lenp, but this time starting from
5900 the offset, rather than from the start of the string. Handles magic and
5907 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
5908 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5909 * byte offsets. See also the comments of S_utf8_mg_pos().
5914 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5922 start = (U8*)SvPV_const(sv, len);
5926 const U8 *s = start;
5927 I32 uoffset = *offsetp;
5928 const U8 * const send = s + len;
5932 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
5934 if (!found && uoffset > 0) {
5935 while (s < send && uoffset--)
5939 if (utf8_mg_pos_init(sv, &mg, &cache, 0, *offsetp, s, start))
5941 *offsetp = s - start;
5946 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) {
5950 if (!found && *lenp > 0) {
5953 while (s < send && ulen--)
5957 utf8_mg_pos_init(sv, &mg, &cache, 2, *lenp, s, start);
5961 ASSERT_UTF8_CACHE(cache);
5973 =for apidoc sv_pos_b2u
5975 Converts the value pointed to by offsetp from a count of bytes from the
5976 start of the string, to a count of the equivalent number of UTF-8 chars.
5977 Handles magic and type coercion.
5983 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
5984 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5985 * byte offsets. See also the comments of S_utf8_mg_pos().
5990 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
5998 s = (const U8*)SvPV_const(sv, len);
5999 if ((I32)len < *offsetp)
6000 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6002 const U8* send = s + *offsetp;
6004 STRLEN *cache = NULL;
6008 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6009 mg = mg_find(sv, PERL_MAGIC_utf8);
6010 if (mg && mg->mg_ptr) {
6011 cache = (STRLEN *) mg->mg_ptr;
6012 if (cache[1] == (STRLEN)*offsetp) {
6013 /* An exact match. */
6014 *offsetp = cache[0];
6018 else if (cache[1] < (STRLEN)*offsetp) {
6019 /* We already know part of the way. */
6022 /* Let the below loop do the rest. */
6024 else { /* cache[1] > *offsetp */
6025 /* We already know all of the way, now we may
6026 * be able to walk back. The same assumption
6027 * is made as in S_utf8_mg_pos(), namely that
6028 * walking backward is twice slower than
6029 * walking forward. */
6030 const STRLEN forw = *offsetp;
6031 STRLEN backw = cache[1] - *offsetp;
6033 if (!(forw < 2 * backw)) {
6034 const U8 *p = s + cache[1];
6041 while (UTF8_IS_CONTINUATION(*p)) {
6049 *offsetp = cache[0];
6051 /* Drop the stale "length" cache */
6059 ASSERT_UTF8_CACHE(cache);
6065 /* Call utf8n_to_uvchr() to validate the sequence
6066 * (unless a simple non-UTF character) */
6067 if (!UTF8_IS_INVARIANT(*s))
6068 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
6077 if (!SvREADONLY(sv)) {
6079 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6080 mg = mg_find(sv, PERL_MAGIC_utf8);
6085 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6086 mg->mg_ptr = (char *) cache;
6091 cache[1] = *offsetp;
6092 /* Drop the stale "length" cache */
6105 Returns a boolean indicating whether the strings in the two SVs are
6106 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6107 coerce its args to strings if necessary.
6113 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6121 SV* svrecode = Nullsv;
6128 pv1 = SvPV_const(sv1, cur1);
6135 pv2 = SvPV_const(sv2, cur2);
6137 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6138 /* Differing utf8ness.
6139 * Do not UTF8size the comparands as a side-effect. */
6142 svrecode = newSVpvn(pv2, cur2);
6143 sv_recode_to_utf8(svrecode, PL_encoding);
6144 pv2 = SvPV_const(svrecode, cur2);
6147 svrecode = newSVpvn(pv1, cur1);
6148 sv_recode_to_utf8(svrecode, PL_encoding);
6149 pv1 = SvPV_const(svrecode, cur1);
6151 /* Now both are in UTF-8. */
6153 SvREFCNT_dec(svrecode);
6158 bool is_utf8 = TRUE;
6161 /* sv1 is the UTF-8 one,
6162 * if is equal it must be downgrade-able */
6163 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6169 /* sv2 is the UTF-8 one,
6170 * if is equal it must be downgrade-able */
6171 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6177 /* Downgrade not possible - cannot be eq */
6185 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6188 SvREFCNT_dec(svrecode);
6199 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6200 string in C<sv1> is less than, equal to, or greater than the string in
6201 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6202 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6208 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6211 const char *pv1, *pv2;
6214 SV *svrecode = Nullsv;
6221 pv1 = SvPV_const(sv1, cur1);
6228 pv2 = SvPV_const(sv2, cur2);
6230 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6231 /* Differing utf8ness.
6232 * Do not UTF8size the comparands as a side-effect. */
6235 svrecode = newSVpvn(pv2, cur2);
6236 sv_recode_to_utf8(svrecode, PL_encoding);
6237 pv2 = SvPV_const(svrecode, cur2);
6240 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6245 svrecode = newSVpvn(pv1, cur1);
6246 sv_recode_to_utf8(svrecode, PL_encoding);
6247 pv1 = SvPV_const(svrecode, cur1);
6250 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6256 cmp = cur2 ? -1 : 0;
6260 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6263 cmp = retval < 0 ? -1 : 1;
6264 } else if (cur1 == cur2) {
6267 cmp = cur1 < cur2 ? -1 : 1;
6272 SvREFCNT_dec(svrecode);
6281 =for apidoc sv_cmp_locale
6283 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6284 'use bytes' aware, handles get magic, and will coerce its args to strings
6285 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6291 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6293 #ifdef USE_LOCALE_COLLATE
6299 if (PL_collation_standard)
6303 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6305 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6307 if (!pv1 || !len1) {
6318 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6321 return retval < 0 ? -1 : 1;
6324 * When the result of collation is equality, that doesn't mean
6325 * that there are no differences -- some locales exclude some
6326 * characters from consideration. So to avoid false equalities,
6327 * we use the raw string as a tiebreaker.
6333 #endif /* USE_LOCALE_COLLATE */
6335 return sv_cmp(sv1, sv2);
6339 #ifdef USE_LOCALE_COLLATE
6342 =for apidoc sv_collxfrm
6344 Add Collate Transform magic to an SV if it doesn't already have it.
6346 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6347 scalar data of the variable, but transformed to such a format that a normal
6348 memory comparison can be used to compare the data according to the locale
6355 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6359 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6360 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6366 Safefree(mg->mg_ptr);
6367 s = SvPV_const(sv, len);
6368 if ((xf = mem_collxfrm(s, len, &xlen))) {
6369 if (SvREADONLY(sv)) {
6372 return xf + sizeof(PL_collation_ix);
6375 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6376 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6389 if (mg && mg->mg_ptr) {
6391 return mg->mg_ptr + sizeof(PL_collation_ix);
6399 #endif /* USE_LOCALE_COLLATE */
6404 Get a line from the filehandle and store it into the SV, optionally
6405 appending to the currently-stored string.
6411 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6415 register STDCHAR rslast;
6416 register STDCHAR *bp;
6422 if (SvTHINKFIRST(sv))
6423 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6424 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6426 However, perlbench says it's slower, because the existing swipe code
6427 is faster than copy on write.
6428 Swings and roundabouts. */
6429 SvUPGRADE(sv, SVt_PV);
6434 if (PerlIO_isutf8(fp)) {
6436 sv_utf8_upgrade_nomg(sv);
6437 sv_pos_u2b(sv,&append,0);
6439 } else if (SvUTF8(sv)) {
6440 SV * const tsv = NEWSV(0,0);
6441 sv_gets(tsv, fp, 0);
6442 sv_utf8_upgrade_nomg(tsv);
6443 SvCUR_set(sv,append);
6446 goto return_string_or_null;
6451 if (PerlIO_isutf8(fp))
6454 if (IN_PERL_COMPILETIME) {
6455 /* we always read code in line mode */
6459 else if (RsSNARF(PL_rs)) {
6460 /* If it is a regular disk file use size from stat() as estimate
6461 of amount we are going to read - may result in malloc-ing
6462 more memory than we realy need if layers bellow reduce
6463 size we read (e.g. CRLF or a gzip layer)
6466 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6467 const Off_t offset = PerlIO_tell(fp);
6468 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6469 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6475 else if (RsRECORD(PL_rs)) {
6479 /* Grab the size of the record we're getting */
6480 recsize = SvIV(SvRV(PL_rs));
6481 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6484 /* VMS wants read instead of fread, because fread doesn't respect */
6485 /* RMS record boundaries. This is not necessarily a good thing to be */
6486 /* doing, but we've got no other real choice - except avoid stdio
6487 as implementation - perhaps write a :vms layer ?
6489 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6491 bytesread = PerlIO_read(fp, buffer, recsize);
6495 SvCUR_set(sv, bytesread += append);
6496 buffer[bytesread] = '\0';
6497 goto return_string_or_null;
6499 else if (RsPARA(PL_rs)) {
6505 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6506 if (PerlIO_isutf8(fp)) {
6507 rsptr = SvPVutf8(PL_rs, rslen);
6510 if (SvUTF8(PL_rs)) {
6511 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6512 Perl_croak(aTHX_ "Wide character in $/");
6515 rsptr = SvPV_const(PL_rs, rslen);
6519 rslast = rslen ? rsptr[rslen - 1] : '\0';
6521 if (rspara) { /* have to do this both before and after */
6522 do { /* to make sure file boundaries work right */
6525 i = PerlIO_getc(fp);
6529 PerlIO_ungetc(fp,i);
6535 /* See if we know enough about I/O mechanism to cheat it ! */
6537 /* This used to be #ifdef test - it is made run-time test for ease
6538 of abstracting out stdio interface. One call should be cheap
6539 enough here - and may even be a macro allowing compile
6543 if (PerlIO_fast_gets(fp)) {
6546 * We're going to steal some values from the stdio struct
6547 * and put EVERYTHING in the innermost loop into registers.
6549 register STDCHAR *ptr;
6553 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6554 /* An ungetc()d char is handled separately from the regular
6555 * buffer, so we getc() it back out and stuff it in the buffer.
6557 i = PerlIO_getc(fp);
6558 if (i == EOF) return 0;
6559 *(--((*fp)->_ptr)) = (unsigned char) i;
6563 /* Here is some breathtakingly efficient cheating */
6565 cnt = PerlIO_get_cnt(fp); /* get count into register */
6566 /* make sure we have the room */
6567 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
6568 /* Not room for all of it
6569 if we are looking for a separator and room for some
6571 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
6572 /* just process what we have room for */
6573 shortbuffered = cnt - SvLEN(sv) + append + 1;
6574 cnt -= shortbuffered;
6578 /* remember that cnt can be negative */
6579 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
6584 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
6585 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
6586 DEBUG_P(PerlIO_printf(Perl_debug_log,
6587 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6588 DEBUG_P(PerlIO_printf(Perl_debug_log,
6589 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6590 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6591 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6596 while (cnt > 0) { /* this | eat */
6598 if ((*bp++ = *ptr++) == rslast) /* really | dust */
6599 goto thats_all_folks; /* screams | sed :-) */
6603 Copy(ptr, bp, cnt, char); /* this | eat */
6604 bp += cnt; /* screams | dust */
6605 ptr += cnt; /* louder | sed :-) */
6610 if (shortbuffered) { /* oh well, must extend */
6611 cnt = shortbuffered;
6613 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6615 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6616 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6620 DEBUG_P(PerlIO_printf(Perl_debug_log,
6621 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6622 PTR2UV(ptr),(long)cnt));
6623 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6625 DEBUG_P(PerlIO_printf(Perl_debug_log,
6626 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6627 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6628 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6630 /* This used to call 'filbuf' in stdio form, but as that behaves like
6631 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6632 another abstraction. */
6633 i = PerlIO_getc(fp); /* get more characters */
6635 DEBUG_P(PerlIO_printf(Perl_debug_log,
6636 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6637 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6638 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6640 cnt = PerlIO_get_cnt(fp);
6641 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
6642 DEBUG_P(PerlIO_printf(Perl_debug_log,
6643 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6645 if (i == EOF) /* all done for ever? */
6646 goto thats_really_all_folks;
6648 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6650 SvGROW(sv, bpx + cnt + 2);
6651 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6653 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
6655 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
6656 goto thats_all_folks;
6660 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
6661 memNE((char*)bp - rslen, rsptr, rslen))
6662 goto screamer; /* go back to the fray */
6663 thats_really_all_folks:
6665 cnt += shortbuffered;
6666 DEBUG_P(PerlIO_printf(Perl_debug_log,
6667 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6668 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
6669 DEBUG_P(PerlIO_printf(Perl_debug_log,
6670 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6671 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6672 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6674 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
6675 DEBUG_P(PerlIO_printf(Perl_debug_log,
6676 "Screamer: done, len=%ld, string=|%.*s|\n",
6677 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
6681 /*The big, slow, and stupid way. */
6682 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
6684 Newx(buf, 8192, STDCHAR);
6692 register const STDCHAR *bpe = buf + sizeof(buf);
6694 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6695 ; /* keep reading */
6699 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6700 /* Accomodate broken VAXC compiler, which applies U8 cast to
6701 * both args of ?: operator, causing EOF to change into 255
6704 i = (U8)buf[cnt - 1];
6710 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
6712 sv_catpvn(sv, (char *) buf, cnt);
6714 sv_setpvn(sv, (char *) buf, cnt);
6716 if (i != EOF && /* joy */
6718 SvCUR(sv) < rslen ||
6719 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6723 * If we're reading from a TTY and we get a short read,
6724 * indicating that the user hit his EOF character, we need
6725 * to notice it now, because if we try to read from the TTY
6726 * again, the EOF condition will disappear.
6728 * The comparison of cnt to sizeof(buf) is an optimization
6729 * that prevents unnecessary calls to feof().
6733 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
6737 #ifdef USE_HEAP_INSTEAD_OF_STACK
6742 if (rspara) { /* have to do this both before and after */
6743 while (i != EOF) { /* to make sure file boundaries work right */
6744 i = PerlIO_getc(fp);
6746 PerlIO_ungetc(fp,i);
6752 return_string_or_null:
6753 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
6759 Auto-increment of the value in the SV, doing string to numeric conversion
6760 if necessary. Handles 'get' magic.
6766 Perl_sv_inc(pTHX_ register SV *sv)
6774 if (SvTHINKFIRST(sv)) {
6776 sv_force_normal_flags(sv, 0);
6777 if (SvREADONLY(sv)) {
6778 if (IN_PERL_RUNTIME)
6779 Perl_croak(aTHX_ PL_no_modify);
6783 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6785 i = PTR2IV(SvRV(sv));
6790 flags = SvFLAGS(sv);
6791 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6792 /* It's (privately or publicly) a float, but not tested as an
6793 integer, so test it to see. */
6795 flags = SvFLAGS(sv);
6797 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6798 /* It's publicly an integer, or privately an integer-not-float */
6799 #ifdef PERL_PRESERVE_IVUV
6803 if (SvUVX(sv) == UV_MAX)
6804 sv_setnv(sv, UV_MAX_P1);
6806 (void)SvIOK_only_UV(sv);
6807 SvUV_set(sv, SvUVX(sv) + 1);
6809 if (SvIVX(sv) == IV_MAX)
6810 sv_setuv(sv, (UV)IV_MAX + 1);
6812 (void)SvIOK_only(sv);
6813 SvIV_set(sv, SvIVX(sv) + 1);
6818 if (flags & SVp_NOK) {
6819 (void)SvNOK_only(sv);
6820 SvNV_set(sv, SvNVX(sv) + 1.0);
6824 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
6825 if ((flags & SVTYPEMASK) < SVt_PVIV)
6826 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
6827 (void)SvIOK_only(sv);
6832 while (isALPHA(*d)) d++;
6833 while (isDIGIT(*d)) d++;
6835 #ifdef PERL_PRESERVE_IVUV
6836 /* Got to punt this as an integer if needs be, but we don't issue
6837 warnings. Probably ought to make the sv_iv_please() that does
6838 the conversion if possible, and silently. */
6839 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6840 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6841 /* Need to try really hard to see if it's an integer.
6842 9.22337203685478e+18 is an integer.
6843 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6844 so $a="9.22337203685478e+18"; $a+0; $a++
6845 needs to be the same as $a="9.22337203685478e+18"; $a++
6852 /* sv_2iv *should* have made this an NV */
6853 if (flags & SVp_NOK) {
6854 (void)SvNOK_only(sv);
6855 SvNV_set(sv, SvNVX(sv) + 1.0);
6858 /* I don't think we can get here. Maybe I should assert this
6859 And if we do get here I suspect that sv_setnv will croak. NWC
6861 #if defined(USE_LONG_DOUBLE)
6862 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",
6863 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6865 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6866 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6869 #endif /* PERL_PRESERVE_IVUV */
6870 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
6874 while (d >= SvPVX_const(sv)) {
6882 /* MKS: The original code here died if letters weren't consecutive.
6883 * at least it didn't have to worry about non-C locales. The
6884 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6885 * arranged in order (although not consecutively) and that only
6886 * [A-Za-z] are accepted by isALPHA in the C locale.
6888 if (*d != 'z' && *d != 'Z') {
6889 do { ++*d; } while (!isALPHA(*d));
6892 *(d--) -= 'z' - 'a';
6897 *(d--) -= 'z' - 'a' + 1;
6901 /* oh,oh, the number grew */
6902 SvGROW(sv, SvCUR(sv) + 2);
6903 SvCUR_set(sv, SvCUR(sv) + 1);
6904 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
6915 Auto-decrement of the value in the SV, doing string to numeric conversion
6916 if necessary. Handles 'get' magic.
6922 Perl_sv_dec(pTHX_ register SV *sv)
6929 if (SvTHINKFIRST(sv)) {
6931 sv_force_normal_flags(sv, 0);
6932 if (SvREADONLY(sv)) {
6933 if (IN_PERL_RUNTIME)
6934 Perl_croak(aTHX_ PL_no_modify);
6938 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6940 i = PTR2IV(SvRV(sv));
6945 /* Unlike sv_inc we don't have to worry about string-never-numbers
6946 and keeping them magic. But we mustn't warn on punting */
6947 flags = SvFLAGS(sv);
6948 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6949 /* It's publicly an integer, or privately an integer-not-float */
6950 #ifdef PERL_PRESERVE_IVUV
6954 if (SvUVX(sv) == 0) {
6955 (void)SvIOK_only(sv);
6959 (void)SvIOK_only_UV(sv);
6960 SvUV_set(sv, SvUVX(sv) - 1);
6963 if (SvIVX(sv) == IV_MIN)
6964 sv_setnv(sv, (NV)IV_MIN - 1.0);
6966 (void)SvIOK_only(sv);
6967 SvIV_set(sv, SvIVX(sv) - 1);
6972 if (flags & SVp_NOK) {
6973 SvNV_set(sv, SvNVX(sv) - 1.0);
6974 (void)SvNOK_only(sv);
6977 if (!(flags & SVp_POK)) {
6978 if ((flags & SVTYPEMASK) < SVt_PVIV)
6979 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
6981 (void)SvIOK_only(sv);
6984 #ifdef PERL_PRESERVE_IVUV
6986 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6987 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6988 /* Need to try really hard to see if it's an integer.
6989 9.22337203685478e+18 is an integer.
6990 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6991 so $a="9.22337203685478e+18"; $a+0; $a--
6992 needs to be the same as $a="9.22337203685478e+18"; $a--
6999 /* sv_2iv *should* have made this an NV */
7000 if (flags & SVp_NOK) {
7001 (void)SvNOK_only(sv);
7002 SvNV_set(sv, SvNVX(sv) - 1.0);
7005 /* I don't think we can get here. Maybe I should assert this
7006 And if we do get here I suspect that sv_setnv will croak. NWC
7008 #if defined(USE_LONG_DOUBLE)
7009 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",
7010 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7012 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7013 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7017 #endif /* PERL_PRESERVE_IVUV */
7018 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
7022 =for apidoc sv_mortalcopy
7024 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7025 The new SV is marked as mortal. It will be destroyed "soon", either by an
7026 explicit call to FREETMPS, or by an implicit call at places such as
7027 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7032 /* Make a string that will exist for the duration of the expression
7033 * evaluation. Actually, it may have to last longer than that, but
7034 * hopefully we won't free it until it has been assigned to a
7035 * permanent location. */
7038 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
7043 sv_setsv(sv,oldstr);
7045 PL_tmps_stack[++PL_tmps_ix] = sv;
7051 =for apidoc sv_newmortal
7053 Creates a new null SV which is mortal. The reference count of the SV is
7054 set to 1. It will be destroyed "soon", either by an explicit call to
7055 FREETMPS, or by an implicit call at places such as statement boundaries.
7056 See also C<sv_mortalcopy> and C<sv_2mortal>.
7062 Perl_sv_newmortal(pTHX)
7067 SvFLAGS(sv) = SVs_TEMP;
7069 PL_tmps_stack[++PL_tmps_ix] = sv;
7074 =for apidoc sv_2mortal
7076 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7077 by an explicit call to FREETMPS, or by an implicit call at places such as
7078 statement boundaries. SvTEMP() is turned on which means that the SV's
7079 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7080 and C<sv_mortalcopy>.
7086 Perl_sv_2mortal(pTHX_ register SV *sv)
7091 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7094 PL_tmps_stack[++PL_tmps_ix] = sv;
7102 Creates a new SV and copies a string into it. The reference count for the
7103 SV is set to 1. If C<len> is zero, Perl will compute the length using
7104 strlen(). For efficiency, consider using C<newSVpvn> instead.
7110 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
7115 sv_setpvn(sv,s,len ? len : strlen(s));
7120 =for apidoc newSVpvn
7122 Creates a new SV and copies a string into it. The reference count for the
7123 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7124 string. You are responsible for ensuring that the source string is at least
7125 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7131 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7136 sv_setpvn(sv,s,len);
7142 =for apidoc newSVhek
7144 Creates a new SV from the hash key structure. It will generate scalars that
7145 point to the shared string table where possible. Returns a new (undefined)
7146 SV if the hek is NULL.
7152 Perl_newSVhek(pTHX_ const HEK *hek)
7161 if (HEK_LEN(hek) == HEf_SVKEY) {
7162 return newSVsv(*(SV**)HEK_KEY(hek));
7164 const int flags = HEK_FLAGS(hek);
7165 if (flags & HVhek_WASUTF8) {
7167 Andreas would like keys he put in as utf8 to come back as utf8
7169 STRLEN utf8_len = HEK_LEN(hek);
7170 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7171 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
7174 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7176 } else if (flags & HVhek_REHASH) {
7177 /* We don't have a pointer to the hv, so we have to replicate the
7178 flag into every HEK. This hv is using custom a hasing
7179 algorithm. Hence we can't return a shared string scalar, as
7180 that would contain the (wrong) hash value, and might get passed
7181 into an hv routine with a regular hash */
7183 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7188 /* This will be overwhelminly the most common case. */
7189 return newSVpvn_share(HEK_KEY(hek),
7190 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
7196 =for apidoc newSVpvn_share
7198 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7199 table. If the string does not already exist in the table, it is created
7200 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
7201 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
7202 otherwise the hash is computed. The idea here is that as the string table
7203 is used for shared hash keys these strings will have SvPVX_const == HeKEY and
7204 hash lookup will avoid string compare.
7210 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7213 bool is_utf8 = FALSE;
7215 STRLEN tmplen = -len;
7217 /* See the note in hv.c:hv_fetch() --jhi */
7218 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7222 PERL_HASH(hash, src, len);
7224 sv_upgrade(sv, SVt_PV);
7225 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7237 #if defined(PERL_IMPLICIT_CONTEXT)
7239 /* pTHX_ magic can't cope with varargs, so this is a no-context
7240 * version of the main function, (which may itself be aliased to us).
7241 * Don't access this version directly.
7245 Perl_newSVpvf_nocontext(const char* pat, ...)
7250 va_start(args, pat);
7251 sv = vnewSVpvf(pat, &args);
7258 =for apidoc newSVpvf
7260 Creates a new SV and initializes it with the string formatted like
7267 Perl_newSVpvf(pTHX_ const char* pat, ...)
7271 va_start(args, pat);
7272 sv = vnewSVpvf(pat, &args);
7277 /* backend for newSVpvf() and newSVpvf_nocontext() */
7280 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7284 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7291 Creates a new SV and copies a floating point value into it.
7292 The reference count for the SV is set to 1.
7298 Perl_newSVnv(pTHX_ NV n)
7310 Creates a new SV and copies an integer into it. The reference count for the
7317 Perl_newSViv(pTHX_ IV i)
7329 Creates a new SV and copies an unsigned integer into it.
7330 The reference count for the SV is set to 1.
7336 Perl_newSVuv(pTHX_ UV u)
7346 =for apidoc newRV_noinc
7348 Creates an RV wrapper for an SV. The reference count for the original
7349 SV is B<not> incremented.
7355 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7360 sv_upgrade(sv, SVt_RV);
7362 SvRV_set(sv, tmpRef);
7367 /* newRV_inc is the official function name to use now.
7368 * newRV_inc is in fact #defined to newRV in sv.h
7372 Perl_newRV(pTHX_ SV *tmpRef)
7374 return newRV_noinc(SvREFCNT_inc(tmpRef));
7380 Creates a new SV which is an exact duplicate of the original SV.
7387 Perl_newSVsv(pTHX_ register SV *old)
7393 if (SvTYPE(old) == SVTYPEMASK) {
7394 if (ckWARN_d(WARN_INTERNAL))
7395 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7399 /* SV_GMAGIC is the default for sv_setv()
7400 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7401 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7402 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7407 =for apidoc sv_reset
7409 Underlying implementation for the C<reset> Perl function.
7410 Note that the perl-level function is vaguely deprecated.
7416 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
7419 char todo[PERL_UCHAR_MAX+1];
7424 if (!*s) { /* reset ?? searches */
7425 MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
7427 PMOP *pm = (PMOP *) mg->mg_obj;
7429 pm->op_pmdynflags &= ~PMdf_USED;
7436 /* reset variables */
7438 if (!HvARRAY(stash))
7441 Zero(todo, 256, char);
7444 I32 i = (unsigned char)*s;
7448 max = (unsigned char)*s++;
7449 for ( ; i <= max; i++) {
7452 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7454 for (entry = HvARRAY(stash)[i];
7456 entry = HeNEXT(entry))
7461 if (!todo[(U8)*HeKEY(entry)])
7463 gv = (GV*)HeVAL(entry);
7466 if (SvTHINKFIRST(sv)) {
7467 if (!SvREADONLY(sv) && SvROK(sv))
7469 /* XXX Is this continue a bug? Why should THINKFIRST
7470 exempt us from resetting arrays and hashes? */
7474 if (SvTYPE(sv) >= SVt_PV) {
7476 if (SvPVX_const(sv) != Nullch)
7484 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
7486 Perl_die(aTHX_ "Can't reset %%ENV on this system");
7489 # if defined(USE_ENVIRON_ARRAY)
7492 # endif /* USE_ENVIRON_ARRAY */
7503 Using various gambits, try to get an IO from an SV: the IO slot if its a
7504 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7505 named after the PV if we're a string.
7511 Perl_sv_2io(pTHX_ SV *sv)
7516 switch (SvTYPE(sv)) {
7524 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7528 Perl_croak(aTHX_ PL_no_usym, "filehandle");
7530 return sv_2io(SvRV(sv));
7531 gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
7537 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
7546 Using various gambits, try to get a CV from an SV; in addition, try if
7547 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7553 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7560 return *gvp = Nullgv, Nullcv;
7561 switch (SvTYPE(sv)) {
7579 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
7580 tryAMAGICunDEREF(to_cv);
7583 if (SvTYPE(sv) == SVt_PVCV) {
7592 Perl_croak(aTHX_ "Not a subroutine reference");
7597 gv = gv_fetchsv(sv, lref, SVt_PVCV);
7603 if (lref && !GvCVu(gv)) {
7606 tmpsv = NEWSV(704,0);
7607 gv_efullname3(tmpsv, gv, Nullch);
7608 /* XXX this is probably not what they think they're getting.
7609 * It has the same effect as "sub name;", i.e. just a forward
7611 newSUB(start_subparse(FALSE, 0),
7612 newSVOP(OP_CONST, 0, tmpsv),
7617 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
7627 Returns true if the SV has a true value by Perl's rules.
7628 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
7629 instead use an in-line version.
7635 Perl_sv_true(pTHX_ register SV *sv)
7640 register const XPV* const tXpv = (XPV*)SvANY(sv);
7642 (tXpv->xpv_cur > 1 ||
7643 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
7650 return SvIVX(sv) != 0;
7653 return SvNVX(sv) != 0.0;
7655 return sv_2bool(sv);
7661 =for apidoc sv_pvn_force
7663 Get a sensible string out of the SV somehow.
7664 A private implementation of the C<SvPV_force> macro for compilers which
7665 can't cope with complex macro expressions. Always use the macro instead.
7667 =for apidoc sv_pvn_force_flags
7669 Get a sensible string out of the SV somehow.
7670 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
7671 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
7672 implemented in terms of this function.
7673 You normally want to use the various wrapper macros instead: see
7674 C<SvPV_force> and C<SvPV_force_nomg>
7680 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
7683 if (SvTHINKFIRST(sv) && !SvROK(sv))
7684 sv_force_normal_flags(sv, 0);
7694 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
7695 const char * const ref = sv_reftype(sv,0);
7697 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
7698 ref, OP_NAME(PL_op));
7700 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
7702 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
7703 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
7705 s = sv_2pv_flags(sv, &len, flags);
7709 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
7712 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
7713 SvGROW(sv, len + 1);
7714 Move(s,SvPVX(sv),len,char);
7719 SvPOK_on(sv); /* validate pointer */
7721 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
7722 PTR2UV(sv),SvPVX_const(sv)));
7725 return SvPVX_mutable(sv);
7729 =for apidoc sv_pvbyten_force
7731 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
7737 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
7739 sv_pvn_force(sv,lp);
7740 sv_utf8_downgrade(sv,0);
7746 =for apidoc sv_pvutf8n_force
7748 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
7754 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
7756 sv_pvn_force(sv,lp);
7757 sv_utf8_upgrade(sv);
7763 =for apidoc sv_reftype
7765 Returns a string describing what the SV is a reference to.
7771 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
7773 /* The fact that I don't need to downcast to char * everywhere, only in ?:
7774 inside return suggests a const propagation bug in g++. */
7775 if (ob && SvOBJECT(sv)) {
7776 char * const name = HvNAME_get(SvSTASH(sv));
7777 return name ? name : (char *) "__ANON__";
7780 switch (SvTYPE(sv)) {
7797 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
7798 /* tied lvalues should appear to be
7799 * scalars for backwards compatitbility */
7800 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
7801 ? "SCALAR" : "LVALUE");
7802 case SVt_PVAV: return "ARRAY";
7803 case SVt_PVHV: return "HASH";
7804 case SVt_PVCV: return "CODE";
7805 case SVt_PVGV: return "GLOB";
7806 case SVt_PVFM: return "FORMAT";
7807 case SVt_PVIO: return "IO";
7808 default: return "UNKNOWN";
7814 =for apidoc sv_isobject
7816 Returns a boolean indicating whether the SV is an RV pointing to a blessed
7817 object. If the SV is not an RV, or if the object is not blessed, then this
7824 Perl_sv_isobject(pTHX_ SV *sv)
7840 Returns a boolean indicating whether the SV is blessed into the specified
7841 class. This does not check for subtypes; use C<sv_derived_from> to verify
7842 an inheritance relationship.
7848 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7859 hvname = HvNAME_get(SvSTASH(sv));
7863 return strEQ(hvname, name);
7869 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
7870 it will be upgraded to one. If C<classname> is non-null then the new SV will
7871 be blessed in the specified package. The new SV is returned and its
7872 reference count is 1.
7878 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7884 SV_CHECK_THINKFIRST_COW_DROP(rv);
7887 if (SvTYPE(rv) >= SVt_PVMG) {
7888 const U32 refcnt = SvREFCNT(rv);
7892 SvREFCNT(rv) = refcnt;
7895 if (SvTYPE(rv) < SVt_RV)
7896 sv_upgrade(rv, SVt_RV);
7897 else if (SvTYPE(rv) > SVt_RV) {
7908 HV* const stash = gv_stashpv(classname, TRUE);
7909 (void)sv_bless(rv, stash);
7915 =for apidoc sv_setref_pv
7917 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7918 argument will be upgraded to an RV. That RV will be modified to point to
7919 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7920 into the SV. The C<classname> argument indicates the package for the
7921 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7922 will have a reference count of 1, and the RV will be returned.
7924 Do not use with other Perl types such as HV, AV, SV, CV, because those
7925 objects will become corrupted by the pointer copy process.
7927 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7933 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7936 sv_setsv(rv, &PL_sv_undef);
7940 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7945 =for apidoc sv_setref_iv
7947 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7948 argument will be upgraded to an RV. That RV will be modified to point to
7949 the new SV. The C<classname> argument indicates the package for the
7950 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7951 will have a reference count of 1, and the RV will be returned.
7957 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7959 sv_setiv(newSVrv(rv,classname), iv);
7964 =for apidoc sv_setref_uv
7966 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7967 argument will be upgraded to an RV. That RV will be modified to point to
7968 the new SV. The C<classname> argument indicates the package for the
7969 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7970 will have a reference count of 1, and the RV will be returned.
7976 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7978 sv_setuv(newSVrv(rv,classname), uv);
7983 =for apidoc sv_setref_nv
7985 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7986 argument will be upgraded to an RV. That RV will be modified to point to
7987 the new SV. The C<classname> argument indicates the package for the
7988 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7989 will have a reference count of 1, and the RV will be returned.
7995 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7997 sv_setnv(newSVrv(rv,classname), nv);
8002 =for apidoc sv_setref_pvn
8004 Copies a string into a new SV, optionally blessing the SV. The length of the
8005 string must be specified with C<n>. The C<rv> argument will be upgraded to
8006 an RV. That RV will be modified to point to the new SV. The C<classname>
8007 argument indicates the package for the blessing. Set C<classname> to
8008 C<Nullch> to avoid the blessing. The new SV will have a reference count
8009 of 1, and the RV will be returned.
8011 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8017 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n)
8019 sv_setpvn(newSVrv(rv,classname), pv, n);
8024 =for apidoc sv_bless
8026 Blesses an SV into a specified package. The SV must be an RV. The package
8027 must be designated by its stash (see C<gv_stashpv()>). The reference count
8028 of the SV is unaffected.
8034 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8038 Perl_croak(aTHX_ "Can't bless non-reference value");
8040 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8041 if (SvREADONLY(tmpRef))
8042 Perl_croak(aTHX_ PL_no_modify);
8043 if (SvOBJECT(tmpRef)) {
8044 if (SvTYPE(tmpRef) != SVt_PVIO)
8046 SvREFCNT_dec(SvSTASH(tmpRef));
8049 SvOBJECT_on(tmpRef);
8050 if (SvTYPE(tmpRef) != SVt_PVIO)
8052 SvUPGRADE(tmpRef, SVt_PVMG);
8053 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
8060 if(SvSMAGICAL(tmpRef))
8061 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8069 /* Downgrades a PVGV to a PVMG.
8073 S_sv_unglob(pTHX_ SV *sv)
8077 assert(SvTYPE(sv) == SVt_PVGV);
8082 sv_del_backref((SV*)GvSTASH(sv), sv);
8083 GvSTASH(sv) = Nullhv;
8085 sv_unmagic(sv, PERL_MAGIC_glob);
8086 Safefree(GvNAME(sv));
8089 /* need to keep SvANY(sv) in the right arena */
8090 xpvmg = new_XPVMG();
8091 StructCopy(SvANY(sv), xpvmg, XPVMG);
8092 del_XPVGV(SvANY(sv));
8095 SvFLAGS(sv) &= ~SVTYPEMASK;
8096 SvFLAGS(sv) |= SVt_PVMG;
8100 =for apidoc sv_unref_flags
8102 Unsets the RV status of the SV, and decrements the reference count of
8103 whatever was being referenced by the RV. This can almost be thought of
8104 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8105 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8106 (otherwise the decrementing is conditional on the reference count being
8107 different from one or the reference being a readonly SV).
8114 Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags)
8116 SV* const target = SvRV(ref);
8118 if (SvWEAKREF(ref)) {
8119 sv_del_backref(target, ref);
8121 SvRV_set(ref, NULL);
8124 SvRV_set(ref, NULL);
8126 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
8127 assigned to as BEGIN {$a = \"Foo"} will fail. */
8128 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
8129 SvREFCNT_dec(target);
8130 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8131 sv_2mortal(target); /* Schedule for freeing later */
8135 =for apidoc sv_untaint
8137 Untaint an SV. Use C<SvTAINTED_off> instead.
8142 Perl_sv_untaint(pTHX_ SV *sv)
8144 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8145 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8152 =for apidoc sv_tainted
8154 Test an SV for taintedness. Use C<SvTAINTED> instead.
8159 Perl_sv_tainted(pTHX_ SV *sv)
8161 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8162 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8163 if (mg && (mg->mg_len & 1) )
8170 =for apidoc sv_setpviv
8172 Copies an integer into the given SV, also updating its string value.
8173 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8179 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8181 char buf[TYPE_CHARS(UV)];
8183 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8185 sv_setpvn(sv, ptr, ebuf - ptr);
8189 =for apidoc sv_setpviv_mg
8191 Like C<sv_setpviv>, but also handles 'set' magic.
8197 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8203 #if defined(PERL_IMPLICIT_CONTEXT)
8205 /* pTHX_ magic can't cope with varargs, so this is a no-context
8206 * version of the main function, (which may itself be aliased to us).
8207 * Don't access this version directly.
8211 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8215 va_start(args, pat);
8216 sv_vsetpvf(sv, pat, &args);
8220 /* pTHX_ magic can't cope with varargs, so this is a no-context
8221 * version of the main function, (which may itself be aliased to us).
8222 * Don't access this version directly.
8226 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8230 va_start(args, pat);
8231 sv_vsetpvf_mg(sv, pat, &args);
8237 =for apidoc sv_setpvf
8239 Works like C<sv_catpvf> but copies the text into the SV instead of
8240 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8246 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8249 va_start(args, pat);
8250 sv_vsetpvf(sv, pat, &args);
8255 =for apidoc sv_vsetpvf
8257 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8258 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8260 Usually used via its frontend C<sv_setpvf>.
8266 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8268 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8272 =for apidoc sv_setpvf_mg
8274 Like C<sv_setpvf>, but also handles 'set' magic.
8280 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8283 va_start(args, pat);
8284 sv_vsetpvf_mg(sv, pat, &args);
8289 =for apidoc sv_vsetpvf_mg
8291 Like C<sv_vsetpvf>, but also handles 'set' magic.
8293 Usually used via its frontend C<sv_setpvf_mg>.
8299 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8301 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8305 #if defined(PERL_IMPLICIT_CONTEXT)
8307 /* pTHX_ magic can't cope with varargs, so this is a no-context
8308 * version of the main function, (which may itself be aliased to us).
8309 * Don't access this version directly.
8313 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8317 va_start(args, pat);
8318 sv_vcatpvf(sv, pat, &args);
8322 /* pTHX_ magic can't cope with varargs, so this is a no-context
8323 * version of the main function, (which may itself be aliased to us).
8324 * Don't access this version directly.
8328 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8332 va_start(args, pat);
8333 sv_vcatpvf_mg(sv, pat, &args);
8339 =for apidoc sv_catpvf
8341 Processes its arguments like C<sprintf> and appends the formatted
8342 output to an SV. If the appended data contains "wide" characters
8343 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8344 and characters >255 formatted with %c), the original SV might get
8345 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
8346 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
8347 valid UTF-8; if the original SV was bytes, the pattern should be too.
8352 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8355 va_start(args, pat);
8356 sv_vcatpvf(sv, pat, &args);
8361 =for apidoc sv_vcatpvf
8363 Processes its arguments like C<vsprintf> and appends the formatted output
8364 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
8366 Usually used via its frontend C<sv_catpvf>.
8372 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8374 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8378 =for apidoc sv_catpvf_mg
8380 Like C<sv_catpvf>, but also handles 'set' magic.
8386 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8389 va_start(args, pat);
8390 sv_vcatpvf_mg(sv, pat, &args);
8395 =for apidoc sv_vcatpvf_mg
8397 Like C<sv_vcatpvf>, but also handles 'set' magic.
8399 Usually used via its frontend C<sv_catpvf_mg>.
8405 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8407 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8412 =for apidoc sv_vsetpvfn
8414 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
8417 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
8423 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8425 sv_setpvn(sv, "", 0);
8426 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8429 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
8432 S_expect_number(pTHX_ char** pattern)
8435 switch (**pattern) {
8436 case '1': case '2': case '3':
8437 case '4': case '5': case '6':
8438 case '7': case '8': case '9':
8439 while (isDIGIT(**pattern))
8440 var = var * 10 + (*(*pattern)++ - '0');
8444 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
8447 F0convert(NV nv, char *endbuf, STRLEN *len)
8449 const int neg = nv < 0;
8458 if (uv & 1 && uv == nv)
8459 uv--; /* Round to even */
8461 const unsigned dig = uv % 10;
8474 =for apidoc sv_vcatpvfn
8476 Processes its arguments like C<vsprintf> and appends the formatted output
8477 to an SV. Uses an array of SVs if the C style variable argument list is
8478 missing (NULL). When running with taint checks enabled, indicates via
8479 C<maybe_tainted> if results are untrustworthy (often due to the use of
8482 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
8488 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
8489 vecstr = (U8*)SvPV_const(vecsv,veclen);\
8490 vec_utf8 = DO_UTF8(vecsv);
8492 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
8495 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8502 static const char nullstr[] = "(null)";
8504 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
8505 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
8507 /* Times 4: a decimal digit takes more than 3 binary digits.
8508 * NV_DIG: mantissa takes than many decimal digits.
8509 * Plus 32: Playing safe. */
8510 char ebuf[IV_DIG * 4 + NV_DIG + 32];
8511 /* large enough for "%#.#f" --chip */
8512 /* what about long double NVs? --jhi */
8514 PERL_UNUSED_ARG(maybe_tainted);
8516 /* no matter what, this is a string now */
8517 (void)SvPV_force(sv, origlen);
8519 /* special-case "", "%s", and "%-p" (SVf - see below) */
8522 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
8524 const char * const s = va_arg(*args, char*);
8525 sv_catpv(sv, s ? s : nullstr);
8527 else if (svix < svmax) {
8528 sv_catsv(sv, *svargs);
8529 if (DO_UTF8(*svargs))
8534 if (args && patlen == 3 && pat[0] == '%' &&
8535 pat[1] == '-' && pat[2] == 'p') {
8536 argsv = va_arg(*args, SV*);
8537 sv_catsv(sv, argsv);
8543 #ifndef USE_LONG_DOUBLE
8544 /* special-case "%.<number>[gf]" */
8545 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
8546 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
8547 unsigned digits = 0;
8551 while (*pp >= '0' && *pp <= '9')
8552 digits = 10 * digits + (*pp++ - '0');
8553 if (pp - pat == (int)patlen - 1) {
8561 /* Add check for digits != 0 because it seems that some
8562 gconverts are buggy in this case, and we don't yet have
8563 a Configure test for this. */
8564 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
8565 /* 0, point, slack */
8566 Gconvert(nv, (int)digits, 0, ebuf);
8568 if (*ebuf) /* May return an empty string for digits==0 */
8571 } else if (!digits) {
8574 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
8575 sv_catpvn(sv, p, l);
8581 #endif /* !USE_LONG_DOUBLE */
8583 if (!args && svix < svmax && DO_UTF8(*svargs))
8586 patend = (char*)pat + patlen;
8587 for (p = (char*)pat; p < patend; p = q) {
8590 bool vectorize = FALSE;
8591 bool vectorarg = FALSE;
8592 bool vec_utf8 = FALSE;
8598 bool has_precis = FALSE;
8601 bool is_utf8 = FALSE; /* is this item utf8? */
8602 #ifdef HAS_LDBL_SPRINTF_BUG
8603 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8604 with sfio - Allen <allens@cpan.org> */
8605 bool fix_ldbl_sprintf_bug = FALSE;
8609 U8 utf8buf[UTF8_MAXBYTES+1];
8610 STRLEN esignlen = 0;
8612 const char *eptr = Nullch;
8615 const U8 *vecstr = Null(U8*);
8622 /* we need a long double target in case HAS_LONG_DOUBLE but
8625 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
8633 const char *dotstr = ".";
8634 STRLEN dotstrlen = 1;
8635 I32 efix = 0; /* explicit format parameter index */
8636 I32 ewix = 0; /* explicit width index */
8637 I32 epix = 0; /* explicit precision index */
8638 I32 evix = 0; /* explicit vector index */
8639 bool asterisk = FALSE;
8641 /* echo everything up to the next format specification */
8642 for (q = p; q < patend && *q != '%'; ++q) ;
8644 if (has_utf8 && !pat_utf8)
8645 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
8647 sv_catpvn(sv, p, q - p);
8654 We allow format specification elements in this order:
8655 \d+\$ explicit format parameter index
8657 v|\*(\d+\$)?v vector with optional (optionally specified) arg
8658 0 flag (as above): repeated to allow "v02"
8659 \d+|\*(\d+\$)? width using optional (optionally specified) arg
8660 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8662 [%bcdefginopsuxDFOUX] format (mandatory)
8667 As of perl5.9.3, printf format checking is on by default.
8668 Internally, perl uses %p formats to provide an escape to
8669 some extended formatting. This block deals with those
8670 extensions: if it does not match, (char*)q is reset and
8671 the normal format processing code is used.
8673 Currently defined extensions are:
8674 %p include pointer address (standard)
8675 %-p (SVf) include an SV (previously %_)
8676 %-<num>p include an SV with precision <num>
8677 %1p (VDf) include a v-string (as %vd)
8678 %<num>p reserved for future extensions
8680 Robin Barker 2005-07-14
8687 EXPECT_NUMBER(q, n);
8694 argsv = va_arg(*args, SV*);
8695 eptr = SvPVx_const(argsv, elen);
8701 else if (n == vdNUMBER) { /* VDf */
8708 if (ckWARN_d(WARN_INTERNAL))
8709 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
8710 "internal %%<num>p might conflict with future printf extensions");
8716 if (EXPECT_NUMBER(q, width)) {
8757 if (EXPECT_NUMBER(q, ewix))
8766 if ((vectorarg = asterisk)) {
8779 EXPECT_NUMBER(q, width);
8785 vecsv = va_arg(*args, SV*);
8787 vecsv = (evix ? evix <= svmax : svix < svmax) ?
8788 svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
8789 dotstr = SvPV_const(vecsv, dotstrlen);
8796 else if (efix ? efix <= svmax : svix < svmax) {
8797 vecsv = svargs[efix ? efix-1 : svix++];
8798 vecstr = (U8*)SvPV_const(vecsv,veclen);
8799 vec_utf8 = DO_UTF8(vecsv);
8800 /* if this is a version object, we need to return the
8801 * stringified representation (which the SvPVX_const has
8802 * already done for us), but not vectorize the args
8804 if ( *q == 'd' && sv_derived_from(vecsv,"version") )
8806 q++; /* skip past the rest of the %vd format */
8807 eptr = (const char *) vecstr;
8821 i = va_arg(*args, int);
8823 i = (ewix ? ewix <= svmax : svix < svmax) ?
8824 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8826 width = (i < 0) ? -i : i;
8836 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
8838 /* XXX: todo, support specified precision parameter */
8842 i = va_arg(*args, int);
8844 i = (ewix ? ewix <= svmax : svix < svmax)
8845 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8846 precis = (i < 0) ? 0 : i;
8851 precis = precis * 10 + (*q++ - '0');
8860 case 'I': /* Ix, I32x, and I64x */
8862 if (q[1] == '6' && q[2] == '4') {
8868 if (q[1] == '3' && q[2] == '2') {
8878 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8889 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8890 if (*(q + 1) == 'l') { /* lld, llf */
8915 argsv = (efix ? efix <= svmax : svix < svmax) ?
8916 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
8923 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
8925 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
8927 eptr = (char*)utf8buf;
8928 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
8939 if (args && !vectorize) {
8940 eptr = va_arg(*args, char*);
8942 #ifdef MACOS_TRADITIONAL
8943 /* On MacOS, %#s format is used for Pascal strings */
8948 elen = strlen(eptr);
8950 eptr = (char *)nullstr;
8951 elen = sizeof nullstr - 1;
8955 eptr = SvPVx_const(argsv, elen);
8956 if (DO_UTF8(argsv)) {
8957 if (has_precis && precis < elen) {
8959 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
8962 if (width) { /* fudge width (can't fudge elen) */
8963 width += elen - sv_len_utf8(argsv);
8971 if (has_precis && elen > precis)
8978 if (alt || vectorize)
8980 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9001 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9010 esignbuf[esignlen++] = plus;
9014 case 'h': iv = (short)va_arg(*args, int); break;
9015 case 'l': iv = va_arg(*args, long); break;
9016 case 'V': iv = va_arg(*args, IV); break;
9017 default: iv = va_arg(*args, int); break;
9019 case 'q': iv = va_arg(*args, Quad_t); break;
9024 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
9026 case 'h': iv = (short)tiv; break;
9027 case 'l': iv = (long)tiv; break;
9029 default: iv = tiv; break;
9031 case 'q': iv = (Quad_t)tiv; break;
9035 if ( !vectorize ) /* we already set uv above */
9040 esignbuf[esignlen++] = plus;
9044 esignbuf[esignlen++] = '-';
9087 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9098 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9099 case 'l': uv = va_arg(*args, unsigned long); break;
9100 case 'V': uv = va_arg(*args, UV); break;
9101 default: uv = va_arg(*args, unsigned); break;
9103 case 'q': uv = va_arg(*args, Uquad_t); break;
9108 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9110 case 'h': uv = (unsigned short)tuv; break;
9111 case 'l': uv = (unsigned long)tuv; break;
9113 default: uv = tuv; break;
9115 case 'q': uv = (Uquad_t)tuv; break;
9122 char *ptr = ebuf + sizeof ebuf;
9128 p = (char*)((c == 'X')
9129 ? "0123456789ABCDEF" : "0123456789abcdef");
9135 esignbuf[esignlen++] = '0';
9136 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9144 if (alt && *ptr != '0')
9153 esignbuf[esignlen++] = '0';
9154 esignbuf[esignlen++] = 'b';
9157 default: /* it had better be ten or less */
9161 } while (uv /= base);
9164 elen = (ebuf + sizeof ebuf) - ptr;
9168 zeros = precis - elen;
9169 else if (precis == 0 && elen == 1 && *eptr == '0')
9175 /* FLOATING POINT */
9178 c = 'f'; /* maybe %F isn't supported here */
9184 /* This is evil, but floating point is even more evil */
9186 /* for SV-style calling, we can only get NV
9187 for C-style calling, we assume %f is double;
9188 for simplicity we allow any of %Lf, %llf, %qf for long double
9192 #if defined(USE_LONG_DOUBLE)
9196 /* [perl #20339] - we should accept and ignore %lf rather than die */
9200 #if defined(USE_LONG_DOUBLE)
9201 intsize = args ? 0 : 'q';
9205 #if defined(HAS_LONG_DOUBLE)
9214 /* now we need (long double) if intsize == 'q', else (double) */
9215 nv = (args && !vectorize) ?
9216 #if LONG_DOUBLESIZE > DOUBLESIZE
9218 va_arg(*args, long double) :
9219 va_arg(*args, double)
9221 va_arg(*args, double)
9227 if (c != 'e' && c != 'E') {
9229 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9230 will cast our (long double) to (double) */
9231 (void)Perl_frexp(nv, &i);
9232 if (i == PERL_INT_MIN)
9233 Perl_die(aTHX_ "panic: frexp");
9235 need = BIT_DIGITS(i);
9237 need += has_precis ? precis : 6; /* known default */
9242 #ifdef HAS_LDBL_SPRINTF_BUG
9243 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9244 with sfio - Allen <allens@cpan.org> */
9247 # define MY_DBL_MAX DBL_MAX
9248 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9249 # if DOUBLESIZE >= 8
9250 # define MY_DBL_MAX 1.7976931348623157E+308L
9252 # define MY_DBL_MAX 3.40282347E+38L
9256 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9257 # define MY_DBL_MAX_BUG 1L
9259 # define MY_DBL_MAX_BUG MY_DBL_MAX
9263 # define MY_DBL_MIN DBL_MIN
9264 # else /* XXX guessing! -Allen */
9265 # if DOUBLESIZE >= 8
9266 # define MY_DBL_MIN 2.2250738585072014E-308L
9268 # define MY_DBL_MIN 1.17549435E-38L
9272 if ((intsize == 'q') && (c == 'f') &&
9273 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9275 /* it's going to be short enough that
9276 * long double precision is not needed */
9278 if ((nv <= 0L) && (nv >= -0L))
9279 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9281 /* would use Perl_fp_class as a double-check but not
9282 * functional on IRIX - see perl.h comments */
9284 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9285 /* It's within the range that a double can represent */
9286 #if defined(DBL_MAX) && !defined(DBL_MIN)
9287 if ((nv >= ((long double)1/DBL_MAX)) ||
9288 (nv <= (-(long double)1/DBL_MAX)))
9290 fix_ldbl_sprintf_bug = TRUE;
9293 if (fix_ldbl_sprintf_bug == TRUE) {
9303 # undef MY_DBL_MAX_BUG
9306 #endif /* HAS_LDBL_SPRINTF_BUG */
9308 need += 20; /* fudge factor */
9309 if (PL_efloatsize < need) {
9310 Safefree(PL_efloatbuf);
9311 PL_efloatsize = need + 20; /* more fudge */
9312 Newx(PL_efloatbuf, PL_efloatsize, char);
9313 PL_efloatbuf[0] = '\0';
9316 if ( !(width || left || plus || alt) && fill != '0'
9317 && has_precis && intsize != 'q' ) { /* Shortcuts */
9318 /* See earlier comment about buggy Gconvert when digits,
9320 if ( c == 'g' && precis) {
9321 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9322 /* May return an empty string for digits==0 */
9323 if (*PL_efloatbuf) {
9324 elen = strlen(PL_efloatbuf);
9325 goto float_converted;
9327 } else if ( c == 'f' && !precis) {
9328 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9333 char *ptr = ebuf + sizeof ebuf;
9336 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9337 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9338 if (intsize == 'q') {
9339 /* Copy the one or more characters in a long double
9340 * format before the 'base' ([efgEFG]) character to
9341 * the format string. */
9342 static char const prifldbl[] = PERL_PRIfldbl;
9343 char const *p = prifldbl + sizeof(prifldbl) - 3;
9344 while (p >= prifldbl) { *--ptr = *p--; }
9349 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9354 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9366 /* No taint. Otherwise we are in the strange situation
9367 * where printf() taints but print($float) doesn't.
9369 #if defined(HAS_LONG_DOUBLE)
9370 elen = ((intsize == 'q')
9371 ? my_sprintf(PL_efloatbuf, ptr, nv)
9372 : my_sprintf(PL_efloatbuf, ptr, (double)nv));
9374 elen = my_sprintf(PL_efloatbuf, ptr, nv);
9378 eptr = PL_efloatbuf;
9384 i = SvCUR(sv) - origlen;
9385 if (args && !vectorize) {
9387 case 'h': *(va_arg(*args, short*)) = i; break;
9388 default: *(va_arg(*args, int*)) = i; break;
9389 case 'l': *(va_arg(*args, long*)) = i; break;
9390 case 'V': *(va_arg(*args, IV*)) = i; break;
9392 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
9397 sv_setuv_mg(argsv, (UV)i);
9399 continue; /* not "break" */
9406 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
9407 && ckWARN(WARN_PRINTF))
9409 SV * const msg = sv_newmortal();
9410 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9411 (PL_op->op_type == OP_PRTF) ? "" : "s");
9414 Perl_sv_catpvf(aTHX_ msg,
9415 "\"%%%c\"", c & 0xFF);
9417 Perl_sv_catpvf(aTHX_ msg,
9418 "\"%%\\%03"UVof"\"",
9421 sv_catpv(msg, "end of string");
9422 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
9425 /* output mangled stuff ... */
9431 /* ... right here, because formatting flags should not apply */
9432 SvGROW(sv, SvCUR(sv) + elen + 1);
9434 Copy(eptr, p, elen, char);
9437 SvCUR_set(sv, p - SvPVX_const(sv));
9439 continue; /* not "break" */
9442 /* calculate width before utf8_upgrade changes it */
9443 have = esignlen + zeros + elen;
9445 if (is_utf8 != has_utf8) {
9448 sv_utf8_upgrade(sv);
9451 SV * const nsv = sv_2mortal(newSVpvn(eptr, elen));
9452 sv_utf8_upgrade(nsv);
9453 eptr = SvPVX_const(nsv);
9456 SvGROW(sv, SvCUR(sv) + elen + 1);
9461 need = (have > width ? have : width);
9464 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
9466 if (esignlen && fill == '0') {
9468 for (i = 0; i < (int)esignlen; i++)
9472 memset(p, fill, gap);
9475 if (esignlen && fill != '0') {
9477 for (i = 0; i < (int)esignlen; i++)
9482 for (i = zeros; i; i--)
9486 Copy(eptr, p, elen, char);
9490 memset(p, ' ', gap);
9495 Copy(dotstr, p, dotstrlen, char);
9499 vectorize = FALSE; /* done iterating over vecstr */
9506 SvCUR_set(sv, p - SvPVX_const(sv));
9514 /* =========================================================================
9516 =head1 Cloning an interpreter
9518 All the macros and functions in this section are for the private use of
9519 the main function, perl_clone().
9521 The foo_dup() functions make an exact copy of an existing foo thinngy.
9522 During the course of a cloning, a hash table is used to map old addresses
9523 to new addresses. The table is created and manipulated with the
9524 ptr_table_* functions.
9528 ============================================================================*/
9531 #if defined(USE_ITHREADS)
9533 #ifndef GpREFCNT_inc
9534 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
9538 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
9539 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
9540 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9541 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
9542 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9543 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
9544 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9545 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
9546 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
9547 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
9548 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9549 #define SAVEPV(p) (p ? savepv(p) : Nullch)
9550 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
9553 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
9554 regcomp.c. AMS 20010712 */
9557 Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
9562 struct reg_substr_datum *s;
9565 return (REGEXP *)NULL;
9567 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
9570 len = r->offsets[0];
9571 npar = r->nparens+1;
9573 Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
9574 Copy(r->program, ret->program, len+1, regnode);
9576 Newx(ret->startp, npar, I32);
9577 Copy(r->startp, ret->startp, npar, I32);
9578 Newx(ret->endp, npar, I32);
9579 Copy(r->startp, ret->startp, npar, I32);
9581 Newx(ret->substrs, 1, struct reg_substr_data);
9582 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
9583 s->min_offset = r->substrs->data[i].min_offset;
9584 s->max_offset = r->substrs->data[i].max_offset;
9585 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
9586 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
9589 ret->regstclass = NULL;
9592 const int count = r->data->count;
9595 Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
9596 char, struct reg_data);
9597 Newx(d->what, count, U8);
9600 for (i = 0; i < count; i++) {
9601 d->what[i] = r->data->what[i];
9602 switch (d->what[i]) {
9603 /* legal options are one of: sfpont
9604 see also regcomp.h and pregfree() */
9606 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
9609 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
9612 /* This is cheating. */
9613 Newx(d->data[i], 1, struct regnode_charclass_class);
9614 StructCopy(r->data->data[i], d->data[i],
9615 struct regnode_charclass_class);
9616 ret->regstclass = (regnode*)d->data[i];
9619 /* Compiled op trees are readonly, and can thus be
9620 shared without duplication. */
9622 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
9626 d->data[i] = r->data->data[i];
9629 d->data[i] = r->data->data[i];
9631 ((reg_trie_data*)d->data[i])->refcount++;
9635 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
9644 Newx(ret->offsets, 2*len+1, U32);
9645 Copy(r->offsets, ret->offsets, 2*len+1, U32);
9647 ret->precomp = SAVEPVN(r->precomp, r->prelen);
9648 ret->refcnt = r->refcnt;
9649 ret->minlen = r->minlen;
9650 ret->prelen = r->prelen;
9651 ret->nparens = r->nparens;
9652 ret->lastparen = r->lastparen;
9653 ret->lastcloseparen = r->lastcloseparen;
9654 ret->reganch = r->reganch;
9656 ret->sublen = r->sublen;
9658 if (RX_MATCH_COPIED(ret))
9659 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
9661 ret->subbeg = Nullch;
9662 #ifdef PERL_OLD_COPY_ON_WRITE
9663 ret->saved_copy = Nullsv;
9666 ptr_table_store(PL_ptr_table, r, ret);
9670 /* duplicate a file handle */
9673 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
9677 PERL_UNUSED_ARG(type);
9680 return (PerlIO*)NULL;
9682 /* look for it in the table first */
9683 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
9687 /* create anew and remember what it is */
9688 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
9689 ptr_table_store(PL_ptr_table, fp, ret);
9693 /* duplicate a directory handle */
9696 Perl_dirp_dup(pTHX_ DIR *dp)
9704 /* duplicate a typeglob */
9707 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
9712 /* look for it in the table first */
9713 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
9717 /* create anew and remember what it is */
9719 ptr_table_store(PL_ptr_table, gp, ret);
9722 ret->gp_refcnt = 0; /* must be before any other dups! */
9723 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
9724 ret->gp_io = io_dup_inc(gp->gp_io, param);
9725 ret->gp_form = cv_dup_inc(gp->gp_form, param);
9726 ret->gp_av = av_dup_inc(gp->gp_av, param);
9727 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
9728 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
9729 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
9730 ret->gp_cvgen = gp->gp_cvgen;
9731 ret->gp_line = gp->gp_line;
9732 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
9736 /* duplicate a chain of magic */
9739 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
9741 MAGIC *mgprev = (MAGIC*)NULL;
9744 return (MAGIC*)NULL;
9745 /* look for it in the table first */
9746 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
9750 for (; mg; mg = mg->mg_moremagic) {
9752 Newxz(nmg, 1, MAGIC);
9754 mgprev->mg_moremagic = nmg;
9757 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
9758 nmg->mg_private = mg->mg_private;
9759 nmg->mg_type = mg->mg_type;
9760 nmg->mg_flags = mg->mg_flags;
9761 if (mg->mg_type == PERL_MAGIC_qr) {
9762 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
9764 else if(mg->mg_type == PERL_MAGIC_backref) {
9765 const AV * const av = (AV*) mg->mg_obj;
9768 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
9770 for (i = AvFILLp(av); i >= 0; i--) {
9771 if (!svp[i]) continue;
9772 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
9775 else if (mg->mg_type == PERL_MAGIC_symtab) {
9776 nmg->mg_obj = mg->mg_obj;
9779 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
9780 ? sv_dup_inc(mg->mg_obj, param)
9781 : sv_dup(mg->mg_obj, param);
9783 nmg->mg_len = mg->mg_len;
9784 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
9785 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
9786 if (mg->mg_len > 0) {
9787 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
9788 if (mg->mg_type == PERL_MAGIC_overload_table &&
9789 AMT_AMAGIC((AMT*)mg->mg_ptr))
9791 AMT * const amtp = (AMT*)mg->mg_ptr;
9792 AMT * const namtp = (AMT*)nmg->mg_ptr;
9794 for (i = 1; i < NofAMmeth; i++) {
9795 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
9799 else if (mg->mg_len == HEf_SVKEY)
9800 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
9802 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
9803 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
9810 /* create a new pointer-mapping table */
9813 Perl_ptr_table_new(pTHX)
9816 Newxz(tbl, 1, PTR_TBL_t);
9819 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
9824 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
9826 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
9830 we use the PTE_SVSLOT 'reservation' made above, both here (in the
9831 following define) and at call to new_body_inline made below in
9832 Perl_ptr_table_store()
9835 #define del_pte(p) del_body_type(p, PTE_SVSLOT)
9837 /* map an existing pointer using a table */
9840 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
9842 PTR_TBL_ENT_t *tblent;
9843 const UV hash = PTR_TABLE_HASH(sv);
9845 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
9846 for (; tblent; tblent = tblent->next) {
9847 if (tblent->oldval == sv)
9848 return tblent->newval;
9853 /* add a new entry to a pointer-mapping table */
9856 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
9858 PTR_TBL_ENT_t *tblent, **otblent;
9859 /* XXX this may be pessimal on platforms where pointers aren't good
9860 * hash values e.g. if they grow faster in the most significant
9862 const UV hash = PTR_TABLE_HASH(oldsv);
9866 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
9867 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
9868 if (tblent->oldval == oldsv) {
9869 tblent->newval = newsv;
9873 new_body_inline(tblent, &PL_body_roots[PTE_SVSLOT],
9874 sizeof(struct ptr_tbl_ent), PTE_SVSLOT);
9875 tblent->oldval = oldsv;
9876 tblent->newval = newsv;
9877 tblent->next = *otblent;
9880 if (!empty && tbl->tbl_items > tbl->tbl_max)
9881 ptr_table_split(tbl);
9884 /* double the hash bucket size of an existing ptr table */
9887 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
9889 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
9890 const UV oldsize = tbl->tbl_max + 1;
9891 UV newsize = oldsize * 2;
9894 Renew(ary, newsize, PTR_TBL_ENT_t*);
9895 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
9896 tbl->tbl_max = --newsize;
9898 for (i=0; i < oldsize; i++, ary++) {
9899 PTR_TBL_ENT_t **curentp, **entp, *ent;
9902 curentp = ary + oldsize;
9903 for (entp = ary, ent = *ary; ent; ent = *entp) {
9904 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
9906 ent->next = *curentp;
9916 /* remove all the entries from a ptr table */
9919 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
9921 register PTR_TBL_ENT_t **array;
9922 register PTR_TBL_ENT_t *entry;
9926 if (!tbl || !tbl->tbl_items) {
9930 array = tbl->tbl_ary;
9936 PTR_TBL_ENT_t *oentry = entry;
9937 entry = entry->next;
9941 if (++riter > max) {
9944 entry = array[riter];
9951 /* clear and free a ptr table */
9954 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
9959 ptr_table_clear(tbl);
9960 Safefree(tbl->tbl_ary);
9966 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
9969 SvRV_set(dstr, SvWEAKREF(sstr)
9970 ? sv_dup(SvRV(sstr), param)
9971 : sv_dup_inc(SvRV(sstr), param));
9974 else if (SvPVX_const(sstr)) {
9975 /* Has something there */
9977 /* Normal PV - clone whole allocated space */
9978 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
9979 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9980 /* Not that normal - actually sstr is copy on write.
9981 But we are a true, independant SV, so: */
9982 SvREADONLY_off(dstr);
9987 /* Special case - not normally malloced for some reason */
9988 if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
9989 /* A "shared" PV - clone it as "shared" PV */
9991 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
9995 /* Some other special case - random pointer */
9996 SvPV_set(dstr, SvPVX(sstr));
10001 /* Copy the Null */
10002 if (SvTYPE(dstr) == SVt_RV)
10003 SvRV_set(dstr, NULL);
10009 /* duplicate an SV of any type (including AV, HV etc) */
10012 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
10017 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10019 /* look for it in the table first */
10020 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10024 if(param->flags & CLONEf_JOIN_IN) {
10025 /** We are joining here so we don't want do clone
10026 something that is bad **/
10027 const char *hvname;
10029 if(SvTYPE(sstr) == SVt_PVHV &&
10030 (hvname = HvNAME_get(sstr))) {
10031 /** don't clone stashes if they already exist **/
10032 return (SV*)gv_stashpv(hvname,0);
10036 /* create anew and remember what it is */
10039 #ifdef DEBUG_LEAKING_SCALARS
10040 dstr->sv_debug_optype = sstr->sv_debug_optype;
10041 dstr->sv_debug_line = sstr->sv_debug_line;
10042 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10043 dstr->sv_debug_cloned = 1;
10045 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10047 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
10051 ptr_table_store(PL_ptr_table, sstr, dstr);
10054 SvFLAGS(dstr) = SvFLAGS(sstr);
10055 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10056 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10059 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
10060 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10061 PL_watch_pvx, SvPVX_const(sstr));
10064 /* don't clone objects whose class has asked us not to */
10065 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10066 SvFLAGS(dstr) &= ~SVTYPEMASK;
10067 SvOBJECT_off(dstr);
10071 switch (SvTYPE(sstr)) {
10073 SvANY(dstr) = NULL;
10076 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
10077 SvIV_set(dstr, SvIVX(sstr));
10080 SvANY(dstr) = new_XNV();
10081 SvNV_set(dstr, SvNVX(sstr));
10084 SvANY(dstr) = &(dstr->sv_u.svu_rv);
10085 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10089 /* These are all the types that need complex bodies allocating. */
10090 size_t new_body_length;
10091 size_t new_body_offset = 0;
10092 void **new_body_arena;
10093 void **new_body_arenaroot;
10095 svtype sv_type = SvTYPE(sstr);
10099 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]",
10104 new_body = new_XPVIO();
10105 new_body_length = sizeof(XPVIO);
10108 new_body = new_XPVFM();
10109 new_body_length = sizeof(XPVFM);
10113 new_body_arena = &PL_body_roots[SVt_PVHV];
10114 new_body_arenaroot = &PL_body_arenaroots[SVt_PVHV];
10115 new_body_offset = - offset_by_svtype[SVt_PVHV];
10117 new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash)
10118 + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash)
10122 new_body_arena = &PL_body_roots[SVt_PVAV];
10123 new_body_arenaroot = &PL_body_arenaroots[SVt_PVAV];
10124 new_body_offset = - offset_by_svtype[SVt_PVAV];
10126 new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash)
10127 + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash)
10131 if (GvUNIQUE((GV*)sstr)) {
10132 /* Do sharing here, and fall through */
10139 new_body_length = sizeof_body_by_svtype[sv_type];
10140 new_body_arena = &PL_body_roots[sv_type];
10141 new_body_arenaroot = &PL_body_arenaroots[sv_type];
10145 new_body_offset = - offset_by_svtype[SVt_PVIV];
10146 new_body_length = sizeof(XPVIV) - new_body_offset;
10147 new_body_arena = &PL_body_roots[SVt_PVIV];
10148 new_body_arenaroot = &PL_body_arenaroots[SVt_PVIV];
10151 new_body_offset = - offset_by_svtype[SVt_PV];
10152 new_body_length = sizeof(XPV) - new_body_offset;
10153 new_body_arena = &PL_body_roots[SVt_PV];
10154 new_body_arenaroot = &PL_body_arenaroots[SVt_PV];
10156 assert(new_body_length);
10158 new_body_inline(new_body, new_body_arena,
10159 new_body_length, SvTYPE(sstr));
10161 new_body = (void*)((char*)new_body - new_body_offset);
10163 /* We always allocated the full length item with PURIFY */
10164 new_body_length += new_body_offset;
10165 new_body_offset = 0;
10166 new_body = my_safemalloc(new_body_length);
10170 SvANY(dstr) = new_body;
10172 Copy(((char*)SvANY(sstr)) + new_body_offset,
10173 ((char*)SvANY(dstr)) + new_body_offset,
10174 new_body_length, char);
10176 if (SvTYPE(sstr) != SVt_PVAV && SvTYPE(sstr) != SVt_PVHV)
10177 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10179 /* The Copy above means that all the source (unduplicated) pointers
10180 are now in the destination. We can check the flags and the
10181 pointers in either, but it's possible that there's less cache
10182 missing by always going for the destination.
10183 FIXME - instrument and check that assumption */
10184 if (SvTYPE(sstr) >= SVt_PVMG) {
10186 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
10188 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
10191 switch (SvTYPE(sstr)) {
10203 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
10204 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
10205 LvTARG(dstr) = dstr;
10206 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
10207 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
10209 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
10212 GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr));
10213 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
10214 /* Don't call sv_add_backref here as it's going to be created
10215 as part of the magic cloning of the symbol table. */
10216 GvGP(dstr) = gp_dup(GvGP(dstr), param);
10217 (void)GpREFCNT_inc(GvGP(dstr));
10220 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
10221 if (IoOFP(dstr) == IoIFP(sstr))
10222 IoOFP(dstr) = IoIFP(dstr);
10224 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
10225 /* PL_rsfp_filters entries have fake IoDIRP() */
10226 if (IoDIRP(dstr) && !(IoFLAGS(dstr) & IOf_FAKE_DIRP))
10227 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
10228 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
10229 /* I have no idea why fake dirp (rsfps)
10230 should be treated differently but otherwise
10231 we end up with leaks -- sky*/
10232 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
10233 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
10234 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
10236 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
10237 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
10238 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
10240 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
10241 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
10242 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
10245 if (AvARRAY((AV*)sstr)) {
10246 SV **dst_ary, **src_ary;
10247 SSize_t items = AvFILLp((AV*)sstr) + 1;
10249 src_ary = AvARRAY((AV*)sstr);
10250 Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*);
10251 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10252 SvPV_set(dstr, (char*)dst_ary);
10253 AvALLOC((AV*)dstr) = dst_ary;
10254 if (AvREAL((AV*)sstr)) {
10255 while (items-- > 0)
10256 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10259 while (items-- > 0)
10260 *dst_ary++ = sv_dup(*src_ary++, param);
10262 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10263 while (items-- > 0) {
10264 *dst_ary++ = &PL_sv_undef;
10268 SvPV_set(dstr, Nullch);
10269 AvALLOC((AV*)dstr) = (SV**)NULL;
10276 if (HvARRAY((HV*)sstr)) {
10278 const bool sharekeys = !!HvSHAREKEYS(sstr);
10279 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
10280 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
10282 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
10283 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
10285 HvARRAY(dstr) = (HE**)darray;
10286 while (i <= sxhv->xhv_max) {
10287 const HE *source = HvARRAY(sstr)[i];
10288 HvARRAY(dstr)[i] = source
10289 ? he_dup(source, sharekeys, param) : 0;
10293 struct xpvhv_aux *saux = HvAUX(sstr);
10294 struct xpvhv_aux *daux = HvAUX(dstr);
10295 /* This flag isn't copied. */
10296 /* SvOOK_on(hv) attacks the IV flags. */
10297 SvFLAGS(dstr) |= SVf_OOK;
10299 hvname = saux->xhv_name;
10301 = hvname ? hek_dup(hvname, param) : hvname;
10303 daux->xhv_riter = saux->xhv_riter;
10304 daux->xhv_eiter = saux->xhv_eiter
10305 ? he_dup(saux->xhv_eiter,
10306 (bool)!!HvSHAREKEYS(sstr), param) : 0;
10310 SvPV_set(dstr, Nullch);
10312 /* Record stashes for possible cloning in Perl_clone(). */
10314 av_push(param->stashes, dstr);
10319 /* NOTE: not refcounted */
10320 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
10322 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
10324 if (CvCONST(dstr)) {
10325 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
10326 SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
10327 sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
10329 /* don't dup if copying back - CvGV isn't refcounted, so the
10330 * duped GV may never be freed. A bit of a hack! DAPM */
10331 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
10332 Nullgv : gv_dup(CvGV(dstr), param) ;
10333 if (!(param->flags & CLONEf_COPY_STACKS)) {
10336 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10338 CvWEAKOUTSIDE(sstr)
10339 ? cv_dup( CvOUTSIDE(dstr), param)
10340 : cv_dup_inc(CvOUTSIDE(dstr), param);
10342 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
10348 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10354 /* duplicate a context */
10357 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10359 PERL_CONTEXT *ncxs;
10362 return (PERL_CONTEXT*)NULL;
10364 /* look for it in the table first */
10365 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10369 /* create anew and remember what it is */
10370 Newxz(ncxs, max + 1, PERL_CONTEXT);
10371 ptr_table_store(PL_ptr_table, cxs, ncxs);
10374 PERL_CONTEXT *cx = &cxs[ix];
10375 PERL_CONTEXT *ncx = &ncxs[ix];
10376 ncx->cx_type = cx->cx_type;
10377 if (CxTYPE(cx) == CXt_SUBST) {
10378 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10381 ncx->blk_oldsp = cx->blk_oldsp;
10382 ncx->blk_oldcop = cx->blk_oldcop;
10383 ncx->blk_oldmarksp = cx->blk_oldmarksp;
10384 ncx->blk_oldscopesp = cx->blk_oldscopesp;
10385 ncx->blk_oldpm = cx->blk_oldpm;
10386 ncx->blk_gimme = cx->blk_gimme;
10387 switch (CxTYPE(cx)) {
10389 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
10390 ? cv_dup_inc(cx->blk_sub.cv, param)
10391 : cv_dup(cx->blk_sub.cv,param));
10392 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
10393 ? av_dup_inc(cx->blk_sub.argarray, param)
10395 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
10396 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
10397 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10398 ncx->blk_sub.lval = cx->blk_sub.lval;
10399 ncx->blk_sub.retop = cx->blk_sub.retop;
10402 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
10403 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
10404 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
10405 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
10406 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
10407 ncx->blk_eval.retop = cx->blk_eval.retop;
10410 ncx->blk_loop.label = cx->blk_loop.label;
10411 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
10412 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
10413 ncx->blk_loop.next_op = cx->blk_loop.next_op;
10414 ncx->blk_loop.last_op = cx->blk_loop.last_op;
10415 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
10416 ? cx->blk_loop.iterdata
10417 : gv_dup((GV*)cx->blk_loop.iterdata, param));
10418 ncx->blk_loop.oldcomppad
10419 = (PAD*)ptr_table_fetch(PL_ptr_table,
10420 cx->blk_loop.oldcomppad);
10421 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
10422 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
10423 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
10424 ncx->blk_loop.iterix = cx->blk_loop.iterix;
10425 ncx->blk_loop.itermax = cx->blk_loop.itermax;
10428 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
10429 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
10430 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
10431 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10432 ncx->blk_sub.retop = cx->blk_sub.retop;
10444 /* duplicate a stack info structure */
10447 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10452 return (PERL_SI*)NULL;
10454 /* look for it in the table first */
10455 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10459 /* create anew and remember what it is */
10460 Newxz(nsi, 1, PERL_SI);
10461 ptr_table_store(PL_ptr_table, si, nsi);
10463 nsi->si_stack = av_dup_inc(si->si_stack, param);
10464 nsi->si_cxix = si->si_cxix;
10465 nsi->si_cxmax = si->si_cxmax;
10466 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
10467 nsi->si_type = si->si_type;
10468 nsi->si_prev = si_dup(si->si_prev, param);
10469 nsi->si_next = si_dup(si->si_next, param);
10470 nsi->si_markoff = si->si_markoff;
10475 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
10476 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
10477 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
10478 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
10479 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
10480 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
10481 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
10482 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
10483 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
10484 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
10485 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
10486 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
10487 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
10488 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
10491 #define pv_dup_inc(p) SAVEPV(p)
10492 #define pv_dup(p) SAVEPV(p)
10493 #define svp_dup_inc(p,pp) any_dup(p,pp)
10495 /* map any object to the new equivent - either something in the
10496 * ptr table, or something in the interpreter structure
10500 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
10505 return (void*)NULL;
10507 /* look for it in the table first */
10508 ret = ptr_table_fetch(PL_ptr_table, v);
10512 /* see if it is part of the interpreter structure */
10513 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
10514 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
10522 /* duplicate the save stack */
10525 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
10527 ANY * const ss = proto_perl->Tsavestack;
10528 const I32 max = proto_perl->Tsavestack_max;
10529 I32 ix = proto_perl->Tsavestack_ix;
10541 void (*dptr) (void*);
10542 void (*dxptr) (pTHX_ void*);
10544 Newxz(nss, max, ANY);
10547 I32 i = POPINT(ss,ix);
10548 TOPINT(nss,ix) = i;
10550 case SAVEt_ITEM: /* normal string */
10551 sv = (SV*)POPPTR(ss,ix);
10552 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10553 sv = (SV*)POPPTR(ss,ix);
10554 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10556 case SAVEt_SV: /* scalar reference */
10557 sv = (SV*)POPPTR(ss,ix);
10558 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10559 gv = (GV*)POPPTR(ss,ix);
10560 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10562 case SAVEt_GENERIC_PVREF: /* generic char* */
10563 c = (char*)POPPTR(ss,ix);
10564 TOPPTR(nss,ix) = pv_dup(c);
10565 ptr = POPPTR(ss,ix);
10566 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10568 case SAVEt_SHARED_PVREF: /* char* in shared space */
10569 c = (char*)POPPTR(ss,ix);
10570 TOPPTR(nss,ix) = savesharedpv(c);
10571 ptr = POPPTR(ss,ix);
10572 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10574 case SAVEt_GENERIC_SVREF: /* generic sv */
10575 case SAVEt_SVREF: /* scalar reference */
10576 sv = (SV*)POPPTR(ss,ix);
10577 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10578 ptr = POPPTR(ss,ix);
10579 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
10581 case SAVEt_AV: /* array reference */
10582 av = (AV*)POPPTR(ss,ix);
10583 TOPPTR(nss,ix) = av_dup_inc(av, param);
10584 gv = (GV*)POPPTR(ss,ix);
10585 TOPPTR(nss,ix) = gv_dup(gv, param);
10587 case SAVEt_HV: /* hash reference */
10588 hv = (HV*)POPPTR(ss,ix);
10589 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10590 gv = (GV*)POPPTR(ss,ix);
10591 TOPPTR(nss,ix) = gv_dup(gv, param);
10593 case SAVEt_INT: /* int reference */
10594 ptr = POPPTR(ss,ix);
10595 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10596 intval = (int)POPINT(ss,ix);
10597 TOPINT(nss,ix) = intval;
10599 case SAVEt_LONG: /* long reference */
10600 ptr = POPPTR(ss,ix);
10601 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10602 longval = (long)POPLONG(ss,ix);
10603 TOPLONG(nss,ix) = longval;
10605 case SAVEt_I32: /* I32 reference */
10606 case SAVEt_I16: /* I16 reference */
10607 case SAVEt_I8: /* I8 reference */
10608 ptr = POPPTR(ss,ix);
10609 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10611 TOPINT(nss,ix) = i;
10613 case SAVEt_IV: /* IV reference */
10614 ptr = POPPTR(ss,ix);
10615 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10617 TOPIV(nss,ix) = iv;
10619 case SAVEt_SPTR: /* SV* reference */
10620 ptr = POPPTR(ss,ix);
10621 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10622 sv = (SV*)POPPTR(ss,ix);
10623 TOPPTR(nss,ix) = sv_dup(sv, param);
10625 case SAVEt_VPTR: /* random* reference */
10626 ptr = POPPTR(ss,ix);
10627 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10628 ptr = POPPTR(ss,ix);
10629 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10631 case SAVEt_PPTR: /* char* reference */
10632 ptr = POPPTR(ss,ix);
10633 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10634 c = (char*)POPPTR(ss,ix);
10635 TOPPTR(nss,ix) = pv_dup(c);
10637 case SAVEt_HPTR: /* HV* reference */
10638 ptr = POPPTR(ss,ix);
10639 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10640 hv = (HV*)POPPTR(ss,ix);
10641 TOPPTR(nss,ix) = hv_dup(hv, param);
10643 case SAVEt_APTR: /* AV* reference */
10644 ptr = POPPTR(ss,ix);
10645 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10646 av = (AV*)POPPTR(ss,ix);
10647 TOPPTR(nss,ix) = av_dup(av, param);
10650 gv = (GV*)POPPTR(ss,ix);
10651 TOPPTR(nss,ix) = gv_dup(gv, param);
10653 case SAVEt_GP: /* scalar reference */
10654 gp = (GP*)POPPTR(ss,ix);
10655 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
10656 (void)GpREFCNT_inc(gp);
10657 gv = (GV*)POPPTR(ss,ix);
10658 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10659 c = (char*)POPPTR(ss,ix);
10660 TOPPTR(nss,ix) = pv_dup(c);
10662 TOPIV(nss,ix) = iv;
10664 TOPIV(nss,ix) = iv;
10667 case SAVEt_MORTALIZESV:
10668 sv = (SV*)POPPTR(ss,ix);
10669 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10672 ptr = POPPTR(ss,ix);
10673 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
10674 /* these are assumed to be refcounted properly */
10676 switch (((OP*)ptr)->op_type) {
10678 case OP_LEAVESUBLV:
10682 case OP_LEAVEWRITE:
10683 TOPPTR(nss,ix) = ptr;
10688 TOPPTR(nss,ix) = Nullop;
10693 TOPPTR(nss,ix) = Nullop;
10696 c = (char*)POPPTR(ss,ix);
10697 TOPPTR(nss,ix) = pv_dup_inc(c);
10699 case SAVEt_CLEARSV:
10700 longval = POPLONG(ss,ix);
10701 TOPLONG(nss,ix) = longval;
10704 hv = (HV*)POPPTR(ss,ix);
10705 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10706 c = (char*)POPPTR(ss,ix);
10707 TOPPTR(nss,ix) = pv_dup_inc(c);
10709 TOPINT(nss,ix) = i;
10711 case SAVEt_DESTRUCTOR:
10712 ptr = POPPTR(ss,ix);
10713 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10714 dptr = POPDPTR(ss,ix);
10715 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
10716 any_dup(FPTR2DPTR(void *, dptr),
10719 case SAVEt_DESTRUCTOR_X:
10720 ptr = POPPTR(ss,ix);
10721 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10722 dxptr = POPDXPTR(ss,ix);
10723 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
10724 any_dup(FPTR2DPTR(void *, dxptr),
10727 case SAVEt_REGCONTEXT:
10730 TOPINT(nss,ix) = i;
10733 case SAVEt_STACK_POS: /* Position on Perl stack */
10735 TOPINT(nss,ix) = i;
10737 case SAVEt_AELEM: /* array element */
10738 sv = (SV*)POPPTR(ss,ix);
10739 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10741 TOPINT(nss,ix) = i;
10742 av = (AV*)POPPTR(ss,ix);
10743 TOPPTR(nss,ix) = av_dup_inc(av, param);
10745 case SAVEt_HELEM: /* hash element */
10746 sv = (SV*)POPPTR(ss,ix);
10747 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10748 sv = (SV*)POPPTR(ss,ix);
10749 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10750 hv = (HV*)POPPTR(ss,ix);
10751 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10754 ptr = POPPTR(ss,ix);
10755 TOPPTR(nss,ix) = ptr;
10759 TOPINT(nss,ix) = i;
10761 case SAVEt_COMPPAD:
10762 av = (AV*)POPPTR(ss,ix);
10763 TOPPTR(nss,ix) = av_dup(av, param);
10766 longval = (long)POPLONG(ss,ix);
10767 TOPLONG(nss,ix) = longval;
10768 ptr = POPPTR(ss,ix);
10769 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10770 sv = (SV*)POPPTR(ss,ix);
10771 TOPPTR(nss,ix) = sv_dup(sv, param);
10774 ptr = POPPTR(ss,ix);
10775 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10776 longval = (long)POPBOOL(ss,ix);
10777 TOPBOOL(nss,ix) = (bool)longval;
10779 case SAVEt_SET_SVFLAGS:
10781 TOPINT(nss,ix) = i;
10783 TOPINT(nss,ix) = i;
10784 sv = (SV*)POPPTR(ss,ix);
10785 TOPPTR(nss,ix) = sv_dup(sv, param);
10788 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
10796 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
10797 * flag to the result. This is done for each stash before cloning starts,
10798 * so we know which stashes want their objects cloned */
10801 do_mark_cloneable_stash(pTHX_ SV *sv)
10803 const HEK * const hvname = HvNAME_HEK((HV*)sv);
10805 GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
10806 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
10807 if (cloner && GvCV(cloner)) {
10814 XPUSHs(sv_2mortal(newSVhek(hvname)));
10816 call_sv((SV*)GvCV(cloner), G_SCALAR);
10823 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
10831 =for apidoc perl_clone
10833 Create and return a new interpreter by cloning the current one.
10835 perl_clone takes these flags as parameters:
10837 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
10838 without it we only clone the data and zero the stacks,
10839 with it we copy the stacks and the new perl interpreter is
10840 ready to run at the exact same point as the previous one.
10841 The pseudo-fork code uses COPY_STACKS while the
10842 threads->new doesn't.
10844 CLONEf_KEEP_PTR_TABLE
10845 perl_clone keeps a ptr_table with the pointer of the old
10846 variable as a key and the new variable as a value,
10847 this allows it to check if something has been cloned and not
10848 clone it again but rather just use the value and increase the
10849 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
10850 the ptr_table using the function
10851 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
10852 reason to keep it around is if you want to dup some of your own
10853 variable who are outside the graph perl scans, example of this
10854 code is in threads.xs create
10857 This is a win32 thing, it is ignored on unix, it tells perls
10858 win32host code (which is c++) to clone itself, this is needed on
10859 win32 if you want to run two threads at the same time,
10860 if you just want to do some stuff in a separate perl interpreter
10861 and then throw it away and return to the original one,
10862 you don't need to do anything.
10867 /* XXX the above needs expanding by someone who actually understands it ! */
10868 EXTERN_C PerlInterpreter *
10869 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
10872 perl_clone(PerlInterpreter *proto_perl, UV flags)
10875 #ifdef PERL_IMPLICIT_SYS
10877 /* perlhost.h so we need to call into it
10878 to clone the host, CPerlHost should have a c interface, sky */
10880 if (flags & CLONEf_CLONE_HOST) {
10881 return perl_clone_host(proto_perl,flags);
10883 return perl_clone_using(proto_perl, flags,
10885 proto_perl->IMemShared,
10886 proto_perl->IMemParse,
10888 proto_perl->IStdIO,
10892 proto_perl->IProc);
10896 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
10897 struct IPerlMem* ipM, struct IPerlMem* ipMS,
10898 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
10899 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
10900 struct IPerlDir* ipD, struct IPerlSock* ipS,
10901 struct IPerlProc* ipP)
10903 /* XXX many of the string copies here can be optimized if they're
10904 * constants; they need to be allocated as common memory and just
10905 * their pointers copied. */
10908 CLONE_PARAMS clone_params;
10909 CLONE_PARAMS* param = &clone_params;
10911 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
10912 /* for each stash, determine whether its objects should be cloned */
10913 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10914 PERL_SET_THX(my_perl);
10917 Poison(my_perl, 1, PerlInterpreter);
10919 PL_curcop = (COP *)Nullop;
10923 PL_savestack_ix = 0;
10924 PL_savestack_max = -1;
10925 PL_sig_pending = 0;
10926 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10927 # else /* !DEBUGGING */
10928 Zero(my_perl, 1, PerlInterpreter);
10929 # endif /* DEBUGGING */
10931 /* host pointers */
10933 PL_MemShared = ipMS;
10934 PL_MemParse = ipMP;
10941 #else /* !PERL_IMPLICIT_SYS */
10943 CLONE_PARAMS clone_params;
10944 CLONE_PARAMS* param = &clone_params;
10945 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
10946 /* for each stash, determine whether its objects should be cloned */
10947 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10948 PERL_SET_THX(my_perl);
10951 Poison(my_perl, 1, PerlInterpreter);
10953 PL_curcop = (COP *)Nullop;
10957 PL_savestack_ix = 0;
10958 PL_savestack_max = -1;
10959 PL_sig_pending = 0;
10960 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10961 # else /* !DEBUGGING */
10962 Zero(my_perl, 1, PerlInterpreter);
10963 # endif /* DEBUGGING */
10964 #endif /* PERL_IMPLICIT_SYS */
10965 param->flags = flags;
10966 param->proto_perl = proto_perl;
10968 Zero(&PL_body_arenaroots, 1, PL_body_arenaroots);
10969 Zero(&PL_body_roots, 1, PL_body_roots);
10971 PL_he_arenaroot = NULL;
10974 PL_nice_chunk = NULL;
10975 PL_nice_chunk_size = 0;
10977 PL_sv_objcount = 0;
10978 PL_sv_root = Nullsv;
10979 PL_sv_arenaroot = Nullsv;
10981 PL_debug = proto_perl->Idebug;
10983 PL_hash_seed = proto_perl->Ihash_seed;
10984 PL_rehash_seed = proto_perl->Irehash_seed;
10986 #ifdef USE_REENTRANT_API
10987 /* XXX: things like -Dm will segfault here in perlio, but doing
10988 * PERL_SET_CONTEXT(proto_perl);
10989 * breaks too many other things
10991 Perl_reentrant_init(aTHX);
10994 /* create SV map for pointer relocation */
10995 PL_ptr_table = ptr_table_new();
10997 /* initialize these special pointers as early as possible */
10998 SvANY(&PL_sv_undef) = NULL;
10999 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11000 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11001 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11003 SvANY(&PL_sv_no) = new_XPVNV();
11004 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11005 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11006 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11007 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
11008 SvCUR_set(&PL_sv_no, 0);
11009 SvLEN_set(&PL_sv_no, 1);
11010 SvIV_set(&PL_sv_no, 0);
11011 SvNV_set(&PL_sv_no, 0);
11012 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11014 SvANY(&PL_sv_yes) = new_XPVNV();
11015 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11016 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11017 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11018 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
11019 SvCUR_set(&PL_sv_yes, 1);
11020 SvLEN_set(&PL_sv_yes, 2);
11021 SvIV_set(&PL_sv_yes, 1);
11022 SvNV_set(&PL_sv_yes, 1);
11023 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11025 /* create (a non-shared!) shared string table */
11026 PL_strtab = newHV();
11027 HvSHAREKEYS_off(PL_strtab);
11028 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
11029 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11031 PL_compiling = proto_perl->Icompiling;
11033 /* These two PVs will be free'd special way so must set them same way op.c does */
11034 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11035 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11037 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11038 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11040 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11041 if (!specialWARN(PL_compiling.cop_warnings))
11042 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
11043 if (!specialCopIO(PL_compiling.cop_io))
11044 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
11045 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
11047 /* pseudo environmental stuff */
11048 PL_origargc = proto_perl->Iorigargc;
11049 PL_origargv = proto_perl->Iorigargv;
11051 param->stashes = newAV(); /* Setup array of objects to call clone on */
11053 /* Set tainting stuff before PerlIO_debug can possibly get called */
11054 PL_tainting = proto_perl->Itainting;
11055 PL_taint_warn = proto_perl->Itaint_warn;
11057 #ifdef PERLIO_LAYERS
11058 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11059 PerlIO_clone(aTHX_ proto_perl, param);
11062 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11063 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11064 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11065 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11066 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11067 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11070 PL_minus_c = proto_perl->Iminus_c;
11071 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11072 PL_localpatches = proto_perl->Ilocalpatches;
11073 PL_splitstr = proto_perl->Isplitstr;
11074 PL_preprocess = proto_perl->Ipreprocess;
11075 PL_minus_n = proto_perl->Iminus_n;
11076 PL_minus_p = proto_perl->Iminus_p;
11077 PL_minus_l = proto_perl->Iminus_l;
11078 PL_minus_a = proto_perl->Iminus_a;
11079 PL_minus_F = proto_perl->Iminus_F;
11080 PL_doswitches = proto_perl->Idoswitches;
11081 PL_dowarn = proto_perl->Idowarn;
11082 PL_doextract = proto_perl->Idoextract;
11083 PL_sawampersand = proto_perl->Isawampersand;
11084 PL_unsafe = proto_perl->Iunsafe;
11085 PL_inplace = SAVEPV(proto_perl->Iinplace);
11086 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11087 PL_perldb = proto_perl->Iperldb;
11088 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11089 PL_exit_flags = proto_perl->Iexit_flags;
11091 /* magical thingies */
11092 /* XXX time(&PL_basetime) when asked for? */
11093 PL_basetime = proto_perl->Ibasetime;
11094 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11096 PL_maxsysfd = proto_perl->Imaxsysfd;
11097 PL_multiline = proto_perl->Imultiline;
11098 PL_statusvalue = proto_perl->Istatusvalue;
11100 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11102 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
11104 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11106 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11107 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11108 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11110 /* Clone the regex array */
11111 PL_regex_padav = newAV();
11113 const I32 len = av_len((AV*)proto_perl->Iregex_padav);
11114 SV** const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11116 av_push(PL_regex_padav,
11117 sv_dup_inc(regexen[0],param));
11118 for(i = 1; i <= len; i++) {
11119 if(SvREPADTMP(regexen[i])) {
11120 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11122 av_push(PL_regex_padav,
11124 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11125 SvIVX(regexen[i])), param)))
11130 PL_regex_pad = AvARRAY(PL_regex_padav);
11132 /* shortcuts to various I/O objects */
11133 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11134 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11135 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11136 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11137 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11138 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11140 /* shortcuts to regexp stuff */
11141 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11143 /* shortcuts to misc objects */
11144 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11146 /* shortcuts to debugging objects */
11147 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11148 PL_DBline = gv_dup(proto_perl->IDBline, param);
11149 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11150 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11151 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11152 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11153 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11154 PL_lineary = av_dup(proto_perl->Ilineary, param);
11155 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11157 /* symbol tables */
11158 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11159 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11160 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11161 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11162 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11164 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11165 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11166 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11167 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11168 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11169 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11171 PL_sub_generation = proto_perl->Isub_generation;
11173 /* funky return mechanisms */
11174 PL_forkprocess = proto_perl->Iforkprocess;
11176 /* subprocess state */
11177 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11179 /* internal state */
11180 PL_maxo = proto_perl->Imaxo;
11181 if (proto_perl->Iop_mask)
11182 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11184 PL_op_mask = Nullch;
11185 /* PL_asserting = proto_perl->Iasserting; */
11187 /* current interpreter roots */
11188 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11189 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11190 PL_main_start = proto_perl->Imain_start;
11191 PL_eval_root = proto_perl->Ieval_root;
11192 PL_eval_start = proto_perl->Ieval_start;
11194 /* runtime control stuff */
11195 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11196 PL_copline = proto_perl->Icopline;
11198 PL_filemode = proto_perl->Ifilemode;
11199 PL_lastfd = proto_perl->Ilastfd;
11200 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11203 PL_gensym = proto_perl->Igensym;
11204 PL_preambled = proto_perl->Ipreambled;
11205 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11206 PL_laststatval = proto_perl->Ilaststatval;
11207 PL_laststype = proto_perl->Ilaststype;
11208 PL_mess_sv = Nullsv;
11210 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11212 /* interpreter atexit processing */
11213 PL_exitlistlen = proto_perl->Iexitlistlen;
11214 if (PL_exitlistlen) {
11215 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11216 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11219 PL_exitlist = (PerlExitListEntry*)NULL;
11220 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11221 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11222 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11224 PL_profiledata = NULL;
11225 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
11226 /* PL_rsfp_filters entries have fake IoDIRP() */
11227 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
11229 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11231 PAD_CLONE_VARS(proto_perl, param);
11233 #ifdef HAVE_INTERP_INTERN
11234 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11237 /* more statics moved here */
11238 PL_generation = proto_perl->Igeneration;
11239 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11241 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11242 PL_in_clean_all = proto_perl->Iin_clean_all;
11244 PL_uid = proto_perl->Iuid;
11245 PL_euid = proto_perl->Ieuid;
11246 PL_gid = proto_perl->Igid;
11247 PL_egid = proto_perl->Iegid;
11248 PL_nomemok = proto_perl->Inomemok;
11249 PL_an = proto_perl->Ian;
11250 PL_evalseq = proto_perl->Ievalseq;
11251 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11252 PL_origalen = proto_perl->Iorigalen;
11253 #ifdef PERL_USES_PL_PIDSTATUS
11254 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11256 PL_osname = SAVEPV(proto_perl->Iosname);
11257 PL_sighandlerp = proto_perl->Isighandlerp;
11259 PL_runops = proto_perl->Irunops;
11261 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11264 PL_cshlen = proto_perl->Icshlen;
11265 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
11268 PL_lex_state = proto_perl->Ilex_state;
11269 PL_lex_defer = proto_perl->Ilex_defer;
11270 PL_lex_expect = proto_perl->Ilex_expect;
11271 PL_lex_formbrack = proto_perl->Ilex_formbrack;
11272 PL_lex_dojoin = proto_perl->Ilex_dojoin;
11273 PL_lex_starts = proto_perl->Ilex_starts;
11274 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
11275 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
11276 PL_lex_op = proto_perl->Ilex_op;
11277 PL_lex_inpat = proto_perl->Ilex_inpat;
11278 PL_lex_inwhat = proto_perl->Ilex_inwhat;
11279 PL_lex_brackets = proto_perl->Ilex_brackets;
11280 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11281 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
11282 PL_lex_casemods = proto_perl->Ilex_casemods;
11283 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11284 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
11286 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11287 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
11288 PL_nexttoke = proto_perl->Inexttoke;
11290 /* XXX This is probably masking the deeper issue of why
11291 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11292 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11293 * (A little debugging with a watchpoint on it may help.)
11295 if (SvANY(proto_perl->Ilinestr)) {
11296 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
11297 i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
11298 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11299 i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
11300 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11301 i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
11302 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11303 i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
11304 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11307 PL_linestr = NEWSV(65,79);
11308 sv_upgrade(PL_linestr,SVt_PVIV);
11309 sv_setpvn(PL_linestr,"",0);
11310 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
11312 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11313 PL_pending_ident = proto_perl->Ipending_ident;
11314 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
11316 PL_expect = proto_perl->Iexpect;
11318 PL_multi_start = proto_perl->Imulti_start;
11319 PL_multi_end = proto_perl->Imulti_end;
11320 PL_multi_open = proto_perl->Imulti_open;
11321 PL_multi_close = proto_perl->Imulti_close;
11323 PL_error_count = proto_perl->Ierror_count;
11324 PL_subline = proto_perl->Isubline;
11325 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
11327 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
11328 if (SvANY(proto_perl->Ilinestr)) {
11329 i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
11330 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11331 i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
11332 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11333 PL_last_lop_op = proto_perl->Ilast_lop_op;
11336 PL_last_uni = SvPVX(PL_linestr);
11337 PL_last_lop = SvPVX(PL_linestr);
11338 PL_last_lop_op = 0;
11340 PL_in_my = proto_perl->Iin_my;
11341 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
11343 PL_cryptseen = proto_perl->Icryptseen;
11346 PL_hints = proto_perl->Ihints;
11348 PL_amagic_generation = proto_perl->Iamagic_generation;
11350 #ifdef USE_LOCALE_COLLATE
11351 PL_collation_ix = proto_perl->Icollation_ix;
11352 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
11353 PL_collation_standard = proto_perl->Icollation_standard;
11354 PL_collxfrm_base = proto_perl->Icollxfrm_base;
11355 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
11356 #endif /* USE_LOCALE_COLLATE */
11358 #ifdef USE_LOCALE_NUMERIC
11359 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
11360 PL_numeric_standard = proto_perl->Inumeric_standard;
11361 PL_numeric_local = proto_perl->Inumeric_local;
11362 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11363 #endif /* !USE_LOCALE_NUMERIC */
11365 /* utf8 character classes */
11366 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11367 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11368 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11369 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11370 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
11371 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11372 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
11373 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
11374 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
11375 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
11376 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
11377 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
11378 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11379 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
11380 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11381 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11382 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11383 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11384 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11385 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11387 /* Did the locale setup indicate UTF-8? */
11388 PL_utf8locale = proto_perl->Iutf8locale;
11389 /* Unicode features (see perlrun/-C) */
11390 PL_unicode = proto_perl->Iunicode;
11392 /* Pre-5.8 signals control */
11393 PL_signals = proto_perl->Isignals;
11395 /* times() ticks per second */
11396 PL_clocktick = proto_perl->Iclocktick;
11398 /* Recursion stopper for PerlIO_find_layer */
11399 PL_in_load_module = proto_perl->Iin_load_module;
11401 /* sort() routine */
11402 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
11404 /* Not really needed/useful since the reenrant_retint is "volatile",
11405 * but do it for consistency's sake. */
11406 PL_reentrant_retint = proto_perl->Ireentrant_retint;
11408 /* Hooks to shared SVs and locks. */
11409 PL_sharehook = proto_perl->Isharehook;
11410 PL_lockhook = proto_perl->Ilockhook;
11411 PL_unlockhook = proto_perl->Iunlockhook;
11412 PL_threadhook = proto_perl->Ithreadhook;
11414 PL_runops_std = proto_perl->Irunops_std;
11415 PL_runops_dbg = proto_perl->Irunops_dbg;
11417 #ifdef THREADS_HAVE_PIDS
11418 PL_ppid = proto_perl->Ippid;
11422 PL_last_swash_hv = Nullhv; /* reinits on demand */
11423 PL_last_swash_klen = 0;
11424 PL_last_swash_key[0]= '\0';
11425 PL_last_swash_tmps = (U8*)NULL;
11426 PL_last_swash_slen = 0;
11428 PL_glob_index = proto_perl->Iglob_index;
11429 PL_srand_called = proto_perl->Isrand_called;
11430 PL_uudmap['M'] = 0; /* reinits on demand */
11431 PL_bitcount = Nullch; /* reinits on demand */
11433 if (proto_perl->Ipsig_pend) {
11434 Newxz(PL_psig_pend, SIG_SIZE, int);
11437 PL_psig_pend = (int*)NULL;
11440 if (proto_perl->Ipsig_ptr) {
11441 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
11442 Newxz(PL_psig_name, SIG_SIZE, SV*);
11443 for (i = 1; i < SIG_SIZE; i++) {
11444 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11445 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11449 PL_psig_ptr = (SV**)NULL;
11450 PL_psig_name = (SV**)NULL;
11453 /* thrdvar.h stuff */
11455 if (flags & CLONEf_COPY_STACKS) {
11456 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11457 PL_tmps_ix = proto_perl->Ttmps_ix;
11458 PL_tmps_max = proto_perl->Ttmps_max;
11459 PL_tmps_floor = proto_perl->Ttmps_floor;
11460 Newxz(PL_tmps_stack, PL_tmps_max, SV*);
11462 while (i <= PL_tmps_ix) {
11463 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
11467 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11468 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
11469 Newxz(PL_markstack, i, I32);
11470 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
11471 - proto_perl->Tmarkstack);
11472 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
11473 - proto_perl->Tmarkstack);
11474 Copy(proto_perl->Tmarkstack, PL_markstack,
11475 PL_markstack_ptr - PL_markstack + 1, I32);
11477 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
11478 * NOTE: unlike the others! */
11479 PL_scopestack_ix = proto_perl->Tscopestack_ix;
11480 PL_scopestack_max = proto_perl->Tscopestack_max;
11481 Newxz(PL_scopestack, PL_scopestack_max, I32);
11482 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
11484 /* NOTE: si_dup() looks at PL_markstack */
11485 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
11487 /* PL_curstack = PL_curstackinfo->si_stack; */
11488 PL_curstack = av_dup(proto_perl->Tcurstack, param);
11489 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
11491 /* next PUSHs() etc. set *(PL_stack_sp+1) */
11492 PL_stack_base = AvARRAY(PL_curstack);
11493 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
11494 - proto_perl->Tstack_base);
11495 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
11497 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
11498 * NOTE: unlike the others! */
11499 PL_savestack_ix = proto_perl->Tsavestack_ix;
11500 PL_savestack_max = proto_perl->Tsavestack_max;
11501 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
11502 PL_savestack = ss_dup(proto_perl, param);
11506 ENTER; /* perl_destruct() wants to LEAVE; */
11509 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
11510 PL_top_env = &PL_start_env;
11512 PL_op = proto_perl->Top;
11515 PL_Xpv = (XPV*)NULL;
11516 PL_na = proto_perl->Tna;
11518 PL_statbuf = proto_perl->Tstatbuf;
11519 PL_statcache = proto_perl->Tstatcache;
11520 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
11521 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
11523 PL_timesbuf = proto_perl->Ttimesbuf;
11526 PL_tainted = proto_perl->Ttainted;
11527 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
11528 PL_rs = sv_dup_inc(proto_perl->Trs, param);
11529 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
11530 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
11531 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
11532 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
11533 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
11534 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
11535 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
11537 PL_restartop = proto_perl->Trestartop;
11538 PL_in_eval = proto_perl->Tin_eval;
11539 PL_delaymagic = proto_perl->Tdelaymagic;
11540 PL_dirty = proto_perl->Tdirty;
11541 PL_localizing = proto_perl->Tlocalizing;
11543 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
11544 PL_hv_fetch_ent_mh = Nullhe;
11545 PL_modcount = proto_perl->Tmodcount;
11546 PL_lastgotoprobe = Nullop;
11547 PL_dumpindent = proto_perl->Tdumpindent;
11549 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
11550 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
11551 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
11552 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
11553 PL_efloatbuf = Nullch; /* reinits on demand */
11554 PL_efloatsize = 0; /* reinits on demand */
11558 PL_screamfirst = NULL;
11559 PL_screamnext = NULL;
11560 PL_maxscream = -1; /* reinits on demand */
11561 PL_lastscream = Nullsv;
11563 PL_watchaddr = NULL;
11564 PL_watchok = Nullch;
11566 PL_regdummy = proto_perl->Tregdummy;
11567 PL_regprecomp = Nullch;
11570 PL_colorset = 0; /* reinits PL_colors[] */
11571 /*PL_colors[6] = {0,0,0,0,0,0};*/
11572 PL_reginput = Nullch;
11573 PL_regbol = Nullch;
11574 PL_regeol = Nullch;
11575 PL_regstartp = (I32*)NULL;
11576 PL_regendp = (I32*)NULL;
11577 PL_reglastparen = (U32*)NULL;
11578 PL_reglastcloseparen = (U32*)NULL;
11579 PL_regtill = Nullch;
11580 PL_reg_start_tmp = (char**)NULL;
11581 PL_reg_start_tmpl = 0;
11582 PL_regdata = (struct reg_data*)NULL;
11585 PL_reg_eval_set = 0;
11587 PL_regprogram = (regnode*)NULL;
11589 PL_regcc = (CURCUR*)NULL;
11590 PL_reg_call_cc = (struct re_cc_state*)NULL;
11591 PL_reg_re = (regexp*)NULL;
11592 PL_reg_ganch = Nullch;
11593 PL_reg_sv = Nullsv;
11594 PL_reg_match_utf8 = FALSE;
11595 PL_reg_magic = (MAGIC*)NULL;
11597 PL_reg_oldcurpm = (PMOP*)NULL;
11598 PL_reg_curpm = (PMOP*)NULL;
11599 PL_reg_oldsaved = Nullch;
11600 PL_reg_oldsavedlen = 0;
11601 #ifdef PERL_OLD_COPY_ON_WRITE
11604 PL_reg_maxiter = 0;
11605 PL_reg_leftiter = 0;
11606 PL_reg_poscache = Nullch;
11607 PL_reg_poscache_size= 0;
11609 /* RE engine - function pointers */
11610 PL_regcompp = proto_perl->Tregcompp;
11611 PL_regexecp = proto_perl->Tregexecp;
11612 PL_regint_start = proto_perl->Tregint_start;
11613 PL_regint_string = proto_perl->Tregint_string;
11614 PL_regfree = proto_perl->Tregfree;
11616 PL_reginterp_cnt = 0;
11617 PL_reg_starttry = 0;
11619 /* Pluggable optimizer */
11620 PL_peepp = proto_perl->Tpeepp;
11622 PL_stashcache = newHV();
11624 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
11625 ptr_table_free(PL_ptr_table);
11626 PL_ptr_table = NULL;
11629 /* Call the ->CLONE method, if it exists, for each of the stashes
11630 identified by sv_dup() above.
11632 while(av_len(param->stashes) != -1) {
11633 HV* const stash = (HV*) av_shift(param->stashes);
11634 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
11635 if (cloner && GvCV(cloner)) {
11640 XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
11642 call_sv((SV*)GvCV(cloner), G_DISCARD);
11648 SvREFCNT_dec(param->stashes);
11650 /* orphaned? eg threads->new inside BEGIN or use */
11651 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
11652 (void)SvREFCNT_inc(PL_compcv);
11653 SAVEFREESV(PL_compcv);
11659 #endif /* USE_ITHREADS */
11662 =head1 Unicode Support
11664 =for apidoc sv_recode_to_utf8
11666 The encoding is assumed to be an Encode object, on entry the PV
11667 of the sv is assumed to be octets in that encoding, and the sv
11668 will be converted into Unicode (and UTF-8).
11670 If the sv already is UTF-8 (or if it is not POK), or if the encoding
11671 is not a reference, nothing is done to the sv. If the encoding is not
11672 an C<Encode::XS> Encoding object, bad things will happen.
11673 (See F<lib/encoding.pm> and L<Encode>).
11675 The PV of the sv is returned.
11680 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
11683 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
11697 Passing sv_yes is wrong - it needs to be or'ed set of constants
11698 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
11699 remove converted chars from source.
11701 Both will default the value - let them.
11703 XPUSHs(&PL_sv_yes);
11706 call_method("decode", G_SCALAR);
11710 s = SvPV_const(uni, len);
11711 if (s != SvPVX_const(sv)) {
11712 SvGROW(sv, len + 1);
11713 Move(s, SvPVX(sv), len + 1, char);
11714 SvCUR_set(sv, len);
11721 return SvPOKp(sv) ? SvPVX(sv) : NULL;
11725 =for apidoc sv_cat_decode
11727 The encoding is assumed to be an Encode object, the PV of the ssv is
11728 assumed to be octets in that encoding and decoding the input starts
11729 from the position which (PV + *offset) pointed to. The dsv will be
11730 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
11731 when the string tstr appears in decoding output or the input ends on
11732 the PV of the ssv. The value which the offset points will be modified
11733 to the last input position on the ssv.
11735 Returns TRUE if the terminator was found, else returns FALSE.
11740 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
11741 SV *ssv, int *offset, char *tstr, int tlen)
11745 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
11756 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
11757 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
11759 call_method("cat_decode", G_SCALAR);
11761 ret = SvTRUE(TOPs);
11762 *offset = SvIV(offsv);
11768 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
11774 * c-indentation-style: bsd
11775 * c-basic-offset: 4
11776 * indent-tabs-mode: t
11779 * ex: set ts=8 sts=4 sw=4 noet: