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 Normally, this allocation is done using arenas, which by default are
67 approximately 4K chunks of memory parcelled up into N heads or bodies. The
68 first slot in each arena is reserved, and is used to hold a link to the next
69 arena. In the case of heads, the unused first slot also contains some flags
70 and a note of the number of slots. Snaked through each arena chain is a
71 linked list of free items; when this becomes empty, an extra arena is
72 allocated and divided up into N items which are threaded into the free list.
74 The following global variables are associated with arenas:
76 PL_sv_arenaroot pointer to list of SV arenas
77 PL_sv_root pointer to list of free SV structures
79 PL_foo_arenaroot pointer to list of foo arenas,
80 PL_foo_root pointer to list of free foo bodies
81 ... for foo in xiv, xnv, xrv, xpv etc.
83 Note that some of the larger and more rarely used body types (eg xpvio)
84 are not allocated using arenas, but are instead just malloc()/free()ed as
85 required. Also, if PURIFY is defined, arenas are abandoned altogether,
86 with all items individually malloc()ed. In addition, a few SV heads are
87 not allocated from an arena, but are instead directly created as static
88 or auto variables, eg PL_sv_undef. The size of arenas can be changed from
89 the default by setting PERL_ARENA_SIZE appropriately at compile time.
91 The SV arena serves the secondary purpose of allowing still-live SVs
92 to be located and destroyed during final cleanup.
94 At the lowest level, the macros new_SV() and del_SV() grab and free
95 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
96 to return the SV to the free list with error checking.) new_SV() calls
97 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
98 SVs in the free list have their SvTYPE field set to all ones.
100 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
101 that allocate and return individual body types. Normally these are mapped
102 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
103 instead mapped directly to malloc()/free() if PURIFY is defined. The
104 new/del functions remove from, or add to, the appropriate PL_foo_root
105 list, and call more_xiv() etc to add a new arena if the list is empty.
107 At the time of very final cleanup, sv_free_arenas() is called from
108 perl_destruct() to physically free all the arenas allocated since the
109 start of the interpreter. Note that this also clears PL_he_arenaroot,
110 which is otherwise dealt with in hv.c.
112 Manipulation of any of the PL_*root pointers is protected by enclosing
113 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
114 if threads are enabled.
116 The function visit() scans the SV arenas list, and calls a specified
117 function for each SV it finds which is still live - ie which has an SvTYPE
118 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
119 following functions (specified as [function that calls visit()] / [function
120 called by visit() for each SV]):
122 sv_report_used() / do_report_used()
123 dump all remaining SVs (debugging aid)
125 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
126 Attempt to free all objects pointed to by RVs,
127 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
128 try to do the same for all objects indirectly
129 referenced by typeglobs too. Called once from
130 perl_destruct(), prior to calling sv_clean_all()
133 sv_clean_all() / do_clean_all()
134 SvREFCNT_dec(sv) each remaining SV, possibly
135 triggering an sv_free(). It also sets the
136 SVf_BREAK flag on the SV to indicate that the
137 refcnt has been artificially lowered, and thus
138 stopping sv_free() from giving spurious warnings
139 about SVs which unexpectedly have a refcnt
140 of zero. called repeatedly from perl_destruct()
141 until there are no SVs left.
145 Private API to rest of sv.c
149 new_XIV(), del_XIV(),
150 new_XNV(), del_XNV(),
155 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
160 ============================================================================ */
165 * "A time to plant, and a time to uproot what was planted..."
169 * nice_chunk and nice_chunk size need to be set
170 * and queried under the protection of sv_mutex
173 Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
178 new_chunk = (void *)(chunk);
179 new_chunk_size = (chunk_size);
180 if (new_chunk_size > PL_nice_chunk_size) {
181 Safefree(PL_nice_chunk);
182 PL_nice_chunk = (char *) new_chunk;
183 PL_nice_chunk_size = new_chunk_size;
190 #ifdef DEBUG_LEAKING_SCALARS
191 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
193 # define FREE_SV_DEBUG_FILE(sv)
196 #define plant_SV(p) \
198 FREE_SV_DEBUG_FILE(p); \
199 SvANY(p) = (void *)PL_sv_root; \
200 SvFLAGS(p) = SVTYPEMASK; \
205 /* sv_mutex must be held while calling uproot_SV() */
206 #define uproot_SV(p) \
209 PL_sv_root = (SV*)SvANY(p); \
214 /* make some more SVs by adding another arena */
216 /* sv_mutex must be held while calling more_sv() */
223 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
224 PL_nice_chunk = Nullch;
225 PL_nice_chunk_size = 0;
228 char *chunk; /* must use New here to match call to */
229 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
230 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
236 /* new_SV(): return a new, empty SV head */
238 #ifdef DEBUG_LEAKING_SCALARS
239 /* provide a real function for a debugger to play with */
249 sv = S_more_sv(aTHX);
254 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
255 sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
256 (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
257 sv->sv_debug_inpad = 0;
258 sv->sv_debug_cloned = 0;
259 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
263 # define new_SV(p) (p)=S_new_SV(aTHX)
272 (p) = S_more_sv(aTHX); \
281 /* del_SV(): return an empty SV head to the free list */
296 S_del_sv(pTHX_ SV *p)
301 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
302 const SV * const sv = sva + 1;
303 const SV * const svend = &sva[SvREFCNT(sva)];
304 if (p >= sv && p < svend) {
310 if (ckWARN_d(WARN_INTERNAL))
311 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
312 "Attempt to free non-arena SV: 0x%"UVxf
313 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
320 #else /* ! DEBUGGING */
322 #define del_SV(p) plant_SV(p)
324 #endif /* DEBUGGING */
328 =head1 SV Manipulation Functions
330 =for apidoc sv_add_arena
332 Given a chunk of memory, link it to the head of the list of arenas,
333 and split it into a list of free SVs.
339 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
345 /* The first SV in an arena isn't an SV. */
346 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
347 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
348 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
350 PL_sv_arenaroot = sva;
351 PL_sv_root = sva + 1;
353 svend = &sva[SvREFCNT(sva) - 1];
356 SvANY(sv) = (void *)(SV*)(sv + 1);
360 /* Must always set typemask because it's awlays checked in on cleanup
361 when the arenas are walked looking for objects. */
362 SvFLAGS(sv) = SVTYPEMASK;
369 SvFLAGS(sv) = SVTYPEMASK;
372 /* visit(): call the named function for each non-free SV in the arenas
373 * whose flags field matches the flags/mask args. */
376 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
381 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
382 register const SV * const svend = &sva[SvREFCNT(sva)];
384 for (sv = sva + 1; sv < svend; ++sv) {
385 if (SvTYPE(sv) != SVTYPEMASK
386 && (sv->sv_flags & mask) == flags
399 /* called by sv_report_used() for each live SV */
402 do_report_used(pTHX_ SV *sv)
404 if (SvTYPE(sv) != SVTYPEMASK) {
405 PerlIO_printf(Perl_debug_log, "****\n");
412 =for apidoc sv_report_used
414 Dump the contents of all SVs not yet freed. (Debugging aid).
420 Perl_sv_report_used(pTHX)
423 visit(do_report_used, 0, 0);
427 /* called by sv_clean_objs() for each live SV */
430 do_clean_objs(pTHX_ SV *ref)
433 SV * const target = SvRV(ref);
434 if (SvOBJECT(target)) {
435 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
436 if (SvWEAKREF(ref)) {
437 sv_del_backref(target, ref);
443 SvREFCNT_dec(target);
448 /* XXX Might want to check arrays, etc. */
451 /* called by sv_clean_objs() for each live SV */
453 #ifndef DISABLE_DESTRUCTOR_KLUDGE
455 do_clean_named_objs(pTHX_ SV *sv)
457 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
459 #ifdef PERL_DONT_CREATE_GVSV
462 SvOBJECT(GvSV(sv))) ||
463 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
464 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
465 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
466 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
468 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
469 SvFLAGS(sv) |= SVf_BREAK;
477 =for apidoc sv_clean_objs
479 Attempt to destroy all objects not yet freed
485 Perl_sv_clean_objs(pTHX)
487 PL_in_clean_objs = TRUE;
488 visit(do_clean_objs, SVf_ROK, SVf_ROK);
489 #ifndef DISABLE_DESTRUCTOR_KLUDGE
490 /* some barnacles may yet remain, clinging to typeglobs */
491 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
493 PL_in_clean_objs = FALSE;
496 /* called by sv_clean_all() for each live SV */
499 do_clean_all(pTHX_ SV *sv)
501 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
502 SvFLAGS(sv) |= SVf_BREAK;
503 if (PL_comppad == (AV*)sv) {
505 PL_curpad = Null(SV**);
511 =for apidoc sv_clean_all
513 Decrement the refcnt of each remaining SV, possibly triggering a
514 cleanup. This function may have to be called multiple times to free
515 SVs which are in complex self-referential hierarchies.
521 Perl_sv_clean_all(pTHX)
524 PL_in_clean_all = TRUE;
525 cleaned = visit(do_clean_all, 0,0);
526 PL_in_clean_all = FALSE;
531 S_free_arena(pTHX_ void **root) {
533 void ** const next = *(void **)root;
540 =for apidoc sv_free_arenas
542 Deallocate the memory used by all arenas. Note that all the individual SV
543 heads and bodies within the arenas must already have been freed.
548 #define free_arena(name) \
550 S_free_arena(aTHX_ (void**) PL_ ## name ## _arenaroot); \
551 PL_ ## name ## _arenaroot = 0; \
552 PL_ ## name ## _root = 0; \
556 Perl_sv_free_arenas(pTHX)
561 /* Free arenas here, but be careful about fake ones. (We assume
562 contiguity of the fake ones with the corresponding real ones.) */
564 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
565 svanext = (SV*) SvANY(sva);
566 while (svanext && SvFAKE(svanext))
567 svanext = (SV*) SvANY(svanext);
585 #if defined(USE_ITHREADS)
589 Safefree(PL_nice_chunk);
590 PL_nice_chunk = Nullch;
591 PL_nice_chunk_size = 0;
596 /* ---------------------------------------------------------------------
598 * support functions for report_uninit()
601 /* the maxiumum size of array or hash where we will scan looking
602 * for the undefined element that triggered the warning */
604 #define FUV_MAX_SEARCH_SIZE 1000
606 /* Look for an entry in the hash whose value has the same SV as val;
607 * If so, return a mortal copy of the key. */
610 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
616 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
617 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
622 for (i=HvMAX(hv); i>0; i--) {
624 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
625 if (HeVAL(entry) != val)
627 if ( HeVAL(entry) == &PL_sv_undef ||
628 HeVAL(entry) == &PL_sv_placeholder)
632 if (HeKLEN(entry) == HEf_SVKEY)
633 return sv_mortalcopy(HeKEY_sv(entry));
634 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
640 /* Look for an entry in the array whose value has the same SV as val;
641 * If so, return the index, otherwise return -1. */
644 S_find_array_subscript(pTHX_ AV *av, SV* val)
648 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
649 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
653 for (i=AvFILLp(av); i>=0; i--) {
654 if (svp[i] == val && svp[i] != &PL_sv_undef)
660 /* S_varname(): return the name of a variable, optionally with a subscript.
661 * If gv is non-zero, use the name of that global, along with gvtype (one
662 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
663 * targ. Depending on the value of the subscript_type flag, return:
666 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
667 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
668 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
669 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
672 S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
673 SV* keyname, I32 aindex, int subscript_type)
676 SV * const name = sv_newmortal();
682 /* as gv_fullname4(), but add literal '^' for $^FOO names */
684 gv_fullname4(name, gv, buffer, 0);
686 if ((unsigned int)SvPVX(name)[1] <= 26) {
688 buffer[1] = SvPVX(name)[1] + 'A' - 1;
690 /* Swap the 1 unprintable control character for the 2 byte pretty
691 version - ie substr($name, 1, 1) = $buffer; */
692 sv_insert(name, 1, 1, buffer, 2);
697 CV * const cv = find_runcv(&unused);
701 if (!cv || !CvPADLIST(cv))
703 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
704 sv = *av_fetch(av, targ, FALSE);
705 /* SvLEN in a pad name is not to be trusted */
706 sv_setpv(name, SvPV_nolen_const(sv));
709 if (subscript_type == FUV_SUBSCRIPT_HASH) {
710 SV * const sv = NEWSV(0,0);
712 Perl_sv_catpvf(aTHX_ name, "{%s}",
713 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
716 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
718 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
720 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
721 sv_insert(name, 0, 0, "within ", 7);
728 =for apidoc find_uninit_var
730 Find the name of the undefined variable (if any) that caused the operator o
731 to issue a "Use of uninitialized value" warning.
732 If match is true, only return a name if it's value matches uninit_sv.
733 So roughly speaking, if a unary operator (such as OP_COS) generates a
734 warning, then following the direct child of the op may yield an
735 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
736 other hand, with OP_ADD there are two branches to follow, so we only print
737 the variable name if we get an exact match.
739 The name is returned as a mortal SV.
741 Assumes that PL_op is the op that originally triggered the error, and that
742 PL_comppad/PL_curpad points to the currently executing pad.
748 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
756 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
757 uninit_sv == &PL_sv_placeholder)))
760 switch (obase->op_type) {
767 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
768 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
771 int subscript_type = FUV_SUBSCRIPT_WITHIN;
773 if (pad) { /* @lex, %lex */
774 sv = PAD_SVl(obase->op_targ);
778 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
779 /* @global, %global */
780 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
783 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
785 else /* @{expr}, %{expr} */
786 return find_uninit_var(cUNOPx(obase)->op_first,
790 /* attempt to find a match within the aggregate */
792 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
794 subscript_type = FUV_SUBSCRIPT_HASH;
797 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
799 subscript_type = FUV_SUBSCRIPT_ARRAY;
802 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
805 return varname(gv, hash ? '%' : '@', obase->op_targ,
806 keysv, index, subscript_type);
810 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
812 return varname(Nullgv, '$', obase->op_targ,
813 Nullsv, 0, FUV_SUBSCRIPT_NONE);
816 gv = cGVOPx_gv(obase);
817 if (!gv || (match && GvSV(gv) != uninit_sv))
819 return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
822 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
825 av = (AV*)PAD_SV(obase->op_targ);
826 if (!av || SvRMAGICAL(av))
828 svp = av_fetch(av, (I32)obase->op_private, FALSE);
829 if (!svp || *svp != uninit_sv)
832 return varname(Nullgv, '$', obase->op_targ,
833 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
836 gv = cGVOPx_gv(obase);
842 if (!av || SvRMAGICAL(av))
844 svp = av_fetch(av, (I32)obase->op_private, FALSE);
845 if (!svp || *svp != uninit_sv)
848 return varname(gv, '$', 0,
849 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
854 o = cUNOPx(obase)->op_first;
855 if (!o || o->op_type != OP_NULL ||
856 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
858 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
863 /* $a[uninit_expr] or $h{uninit_expr} */
864 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
867 o = cBINOPx(obase)->op_first;
868 kid = cBINOPx(obase)->op_last;
870 /* get the av or hv, and optionally the gv */
872 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
873 sv = PAD_SV(o->op_targ);
875 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
876 && cUNOPo->op_first->op_type == OP_GV)
878 gv = cGVOPx_gv(cUNOPo->op_first);
881 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
886 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
887 /* index is constant */
891 if (obase->op_type == OP_HELEM) {
892 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
893 if (!he || HeVAL(he) != uninit_sv)
897 SV ** const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
898 if (!svp || *svp != uninit_sv)
902 if (obase->op_type == OP_HELEM)
903 return varname(gv, '%', o->op_targ,
904 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
906 return varname(gv, '@', o->op_targ, Nullsv,
907 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
911 /* index is an expression;
912 * attempt to find a match within the aggregate */
913 if (obase->op_type == OP_HELEM) {
914 SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
916 return varname(gv, '%', o->op_targ,
917 keysv, 0, FUV_SUBSCRIPT_HASH);
920 const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
922 return varname(gv, '@', o->op_targ,
923 Nullsv, index, FUV_SUBSCRIPT_ARRAY);
928 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
930 o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
936 /* only examine RHS */
937 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
940 o = cUNOPx(obase)->op_first;
941 if (o->op_type == OP_PUSHMARK)
944 if (!o->op_sibling) {
945 /* one-arg version of open is highly magical */
947 if (o->op_type == OP_GV) { /* open FOO; */
949 if (match && GvSV(gv) != uninit_sv)
951 return varname(gv, '$', 0,
952 Nullsv, 0, FUV_SUBSCRIPT_NONE);
954 /* other possibilities not handled are:
955 * open $x; or open my $x; should return '${*$x}'
956 * open expr; should return '$'.expr ideally
962 /* ops where $_ may be an implicit arg */
966 if ( !(obase->op_flags & OPf_STACKED)) {
967 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
968 ? PAD_SVl(obase->op_targ)
972 sv_setpvn(sv, "$_", 2);
980 /* skip filehandle as it can't produce 'undef' warning */
981 o = cUNOPx(obase)->op_first;
982 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
983 o = o->op_sibling->op_sibling;
990 match = 1; /* XS or custom code could trigger random warnings */
995 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
996 return sv_2mortal(newSVpvn("${$/}", 5));
1001 if (!(obase->op_flags & OPf_KIDS))
1003 o = cUNOPx(obase)->op_first;
1009 /* if all except one arg are constant, or have no side-effects,
1010 * or are optimized away, then it's unambiguous */
1012 for (kid=o; kid; kid = kid->op_sibling) {
1014 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
1015 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
1016 || (kid->op_type == OP_PUSHMARK)
1020 if (o2) { /* more than one found */
1027 return find_uninit_var(o2, uninit_sv, match);
1031 sv = find_uninit_var(o, uninit_sv, 1);
1043 =for apidoc report_uninit
1045 Print appropriate "Use of uninitialized variable" warning
1051 Perl_report_uninit(pTHX_ SV* uninit_sv)
1054 SV* varname = Nullsv;
1056 varname = find_uninit_var(PL_op, uninit_sv,0);
1058 sv_insert(varname, 0, 0, " ", 1);
1060 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1061 varname ? SvPV_nolen_const(varname) : "",
1062 " in ", OP_DESC(PL_op));
1065 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1070 S_more_bodies (pTHX_ void **arena_root, void **root, size_t size)
1074 const size_t count = PERL_ARENA_SIZE/size;
1075 Newx(start, count*size, char);
1076 *((void **) start) = *arena_root;
1077 *arena_root = (void *)start;
1079 end = start + (count-1) * size;
1081 /* The initial slot is used to link the arenas together, so it isn't to be
1082 linked into the list of ready-to-use bodies. */
1086 *root = (void *)start;
1088 while (start < end) {
1089 char * const next = start + size;
1090 *(void**) start = (void *)next;
1093 *(void **)start = 0;
1098 /* grab a new thing from the free list, allocating more if necessary */
1100 /* 1st, the inline version */
1102 #define new_body_inline(xpv, arena_root, root, size) \
1105 xpv = *((void **)(root)) \
1106 ? *((void **)(root)) : S_more_bodies(aTHX_ arena_root, root, size); \
1107 *(root) = *(void**)(xpv); \
1111 /* now use the inline version in the proper function */
1114 S_new_body(pTHX_ void **arena_root, void **root, size_t size)
1117 new_body_inline(xpv, arena_root, root, size);
1121 /* return a thing to the free list */
1123 #define del_body(thing, root) \
1125 void **thing_copy = (void **)thing; \
1127 *thing_copy = *root; \
1128 *root = (void*)thing_copy; \
1132 /* Conventionally we simply malloc() a big block of memory, then divide it
1133 up into lots of the thing that we're allocating.
1135 This macro will expand to call to S_new_body. So for XPVBM (with ithreads),
1138 S_new_body(my_perl, (void**)&(my_perl->Ixpvbm_arenaroot),
1139 (void**)&(my_perl->Ixpvbm_root), sizeof(XPVBM), 0)
1142 #define new_body_type(TYPE,lctype) \
1143 S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \
1144 (void**)&PL_ ## lctype ## _root, \
1147 #define del_body_type(p,TYPE,lctype) \
1148 del_body((void*)p, (void**)&PL_ ## lctype ## _root)
1150 /* But for some types, we cheat. The type starts with some members that are
1151 never accessed. So we allocate the substructure, starting at the first used
1152 member, then adjust the pointer back in memory by the size of the bit not
1153 allocated, so it's as if we allocated the full structure.
1154 (But things will all go boom if you write to the part that is "not there",
1155 because you'll be overwriting the last members of the preceding structure
1158 We calculate the correction using the STRUCT_OFFSET macro. For example, if
1159 xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
1160 and the pointer is unchanged. If the allocated structure is smaller (no
1161 initial NV actually allocated) then the net effect is to subtract the size
1162 of the NV from the pointer, to return a new pointer as if an initial NV were
1165 This is the same trick as was used for NV and IV bodies. Ironically it
1166 doesn't need to be used for NV bodies any more, because NV is now at the
1167 start of the structure. IV bodies don't need it either, because they are
1168 no longer allocated. */
1170 #define new_body_allocated(TYPE,lctype,member) \
1171 (void*)((char*)S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \
1172 (void**)&PL_ ## lctype ## _root, \
1173 sizeof(lctype ## _allocated)) - \
1174 STRUCT_OFFSET(TYPE, member) \
1175 + STRUCT_OFFSET(lctype ## _allocated, member))
1178 #define del_body_allocated(p,TYPE,lctype,member) \
1179 del_body((void*)((char*)p + STRUCT_OFFSET(TYPE, member) \
1180 - STRUCT_OFFSET(lctype ## _allocated, member)), \
1181 (void**)&PL_ ## lctype ## _root)
1183 #define my_safemalloc(s) (void*)safemalloc(s)
1184 #define my_safefree(p) safefree((char*)p)
1188 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1189 #define del_XNV(p) my_safefree(p)
1191 #define new_XPV() my_safemalloc(sizeof(XPV))
1192 #define del_XPV(p) my_safefree(p)
1194 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1195 #define del_XPVIV(p) my_safefree(p)
1197 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1198 #define del_XPVNV(p) my_safefree(p)
1200 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1201 #define del_XPVCV(p) my_safefree(p)
1203 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1204 #define del_XPVAV(p) my_safefree(p)
1206 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1207 #define del_XPVHV(p) my_safefree(p)
1209 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1210 #define del_XPVMG(p) my_safefree(p)
1212 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1213 #define del_XPVGV(p) my_safefree(p)
1215 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1216 #define del_XPVLV(p) my_safefree(p)
1218 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1219 #define del_XPVBM(p) my_safefree(p)
1223 #define new_XNV() new_body_type(NV, xnv)
1224 #define del_XNV(p) del_body_type(p, NV, xnv)
1226 #define new_XPV() new_body_allocated(XPV, xpv, xpv_cur)
1227 #define del_XPV(p) del_body_allocated(p, XPV, xpv, xpv_cur)
1229 #define new_XPVIV() new_body_allocated(XPVIV, xpviv, xpv_cur)
1230 #define del_XPVIV(p) del_body_allocated(p, XPVIV, xpviv, xpv_cur)
1232 #define new_XPVNV() new_body_type(XPVNV, xpvnv)
1233 #define del_XPVNV(p) del_body_type(p, XPVNV, xpvnv)
1235 #define new_XPVCV() new_body_type(XPVCV, xpvcv)
1236 #define del_XPVCV(p) del_body_type(p, XPVCV, xpvcv)
1238 #define new_XPVAV() new_body_allocated(XPVAV, xpvav, xav_fill)
1239 #define del_XPVAV(p) del_body_allocated(p, XPVAV, xpvav, xav_fill)
1241 #define new_XPVHV() new_body_allocated(XPVHV, xpvhv, xhv_fill)
1242 #define del_XPVHV(p) del_body_allocated(p, XPVHV, xpvhv, xhv_fill)
1244 #define new_XPVMG() new_body_type(XPVMG, xpvmg)
1245 #define del_XPVMG(p) del_body_type(p, XPVMG, xpvmg)
1247 #define new_XPVGV() new_body_type(XPVGV, xpvgv)
1248 #define del_XPVGV(p) del_body_type(p, XPVGV, xpvgv)
1250 #define new_XPVLV() new_body_type(XPVLV, xpvlv)
1251 #define del_XPVLV(p) del_body_type(p, XPVLV, xpvlv)
1253 #define new_XPVBM() new_body_type(XPVBM, xpvbm)
1254 #define del_XPVBM(p) del_body_type(p, XPVBM, xpvbm)
1258 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1259 #define del_XPVFM(p) my_safefree(p)
1261 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1262 #define del_XPVIO(p) my_safefree(p)
1265 =for apidoc sv_upgrade
1267 Upgrade an SV to a more complex form. Generally adds a new body type to the
1268 SV, then copies across as much information as possible from the old body.
1269 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1275 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1277 void** old_body_arena;
1278 size_t old_body_offset;
1279 size_t old_body_length; /* Well, the length to copy. */
1281 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1282 /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct
1284 bool zero_nv = TRUE;
1287 size_t new_body_length;
1288 size_t new_body_offset;
1289 void** new_body_arena;
1290 void** new_body_arenaroot;
1291 const U32 old_type = SvTYPE(sv);
1293 if (mt != SVt_PV && SvIsCOW(sv)) {
1294 sv_force_normal_flags(sv, 0);
1297 if (SvTYPE(sv) == mt)
1300 if (SvTYPE(sv) > mt)
1301 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1302 (int)SvTYPE(sv), (int)mt);
1305 old_body = SvANY(sv);
1307 old_body_offset = 0;
1308 old_body_length = 0;
1309 new_body_offset = 0;
1310 new_body_length = ~0;
1312 /* Copying structures onto other structures that have been neatly zeroed
1313 has a subtle gotcha. Consider XPVMG
1315 +------+------+------+------+------+-------+-------+
1316 | NV | CUR | LEN | IV | MAGIC | STASH |
1317 +------+------+------+------+------+-------+-------+
1318 0 4 8 12 16 20 24 28
1320 where NVs are aligned to 8 bytes, so that sizeof that structure is
1321 actually 32 bytes long, with 4 bytes of padding at the end:
1323 +------+------+------+------+------+-------+-------+------+
1324 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1325 +------+------+------+------+------+-------+-------+------+
1326 0 4 8 12 16 20 24 28 32
1328 so what happens if you allocate memory for this structure:
1330 +------+------+------+------+------+-------+-------+------+------+...
1331 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1332 +------+------+------+------+------+-------+-------+------+------+...
1333 0 4 8 12 16 20 24 28 32 36
1335 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1336 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1337 started out as zero once, but it's quite possible that it isn't. So now,
1338 rather than a nicely zeroed GP, you have it pointing somewhere random.
1341 (In fact, GP ends up pointing at a previous GP structure, because the
1342 principle cause of the padding in XPVMG getting garbage is a copy of
1343 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob)
1345 So we are careful and work out the size of used parts of all the
1348 switch (SvTYPE(sv)) {
1354 else if (mt < SVt_PVIV)
1356 old_body_offset = STRUCT_OFFSET(XPVIV, xiv_iv);
1357 old_body_length = sizeof(IV);
1360 old_body_arena = (void **) &PL_xnv_root;
1361 old_body_length = sizeof(NV);
1362 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1371 old_body_arena = (void **) &PL_xpv_root;
1372 old_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
1373 - STRUCT_OFFSET(xpv_allocated, xpv_cur);
1374 old_body_length = STRUCT_OFFSET(XPV, xpv_len)
1375 + sizeof (((XPV*)SvANY(sv))->xpv_len)
1379 else if (mt == SVt_NV)
1383 old_body_arena = (void **) &PL_xpviv_root;
1384 old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
1385 - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
1386 old_body_length = STRUCT_OFFSET(XPVIV, xiv_u)
1387 + sizeof (((XPVIV*)SvANY(sv))->xiv_u)
1391 old_body_arena = (void **) &PL_xpvnv_root;
1392 old_body_length = STRUCT_OFFSET(XPVNV, xiv_u)
1393 + sizeof (((XPVNV*)SvANY(sv))->xiv_u);
1394 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1399 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1400 there's no way that it can be safely upgraded, because perl.c
1401 expects to Safefree(SvANY(PL_mess_sv)) */
1402 assert(sv != PL_mess_sv);
1403 /* This flag bit is used to mean other things in other scalar types.
1404 Given that it only has meaning inside the pad, it shouldn't be set
1405 on anything that can get upgraded. */
1406 assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
1407 old_body_arena = (void **) &PL_xpvmg_root;
1408 old_body_length = STRUCT_OFFSET(XPVMG, xmg_stash)
1409 + sizeof (((XPVMG*)SvANY(sv))->xmg_stash);
1410 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1415 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1418 SvFLAGS(sv) &= ~SVTYPEMASK;
1423 Perl_croak(aTHX_ "Can't upgrade to undef");
1425 assert(old_type == SVt_NULL);
1426 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1430 assert(old_type == SVt_NULL);
1431 SvANY(sv) = new_XNV();
1435 assert(old_type == SVt_NULL);
1436 SvANY(sv) = &sv->sv_u.svu_rv;
1440 SvANY(sv) = new_XPVHV();
1443 HvTOTALKEYS(sv) = 0;
1448 SvANY(sv) = new_XPVAV();
1455 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1456 The target created by newSVrv also is, and it can have magic.
1457 However, it never has SvPVX set.
1459 if (old_type >= SVt_RV) {
1460 assert(SvPVX_const(sv) == 0);
1463 /* Could put this in the else clause below, as PVMG must have SvPVX
1464 0 already (the assertion above) */
1465 SvPV_set(sv, (char*)0);
1467 if (old_type >= SVt_PVMG) {
1468 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic);
1469 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1477 new_body = new_XPVIO();
1478 new_body_length = sizeof(XPVIO);
1481 new_body = new_XPVFM();
1482 new_body_length = sizeof(XPVFM);
1486 new_body_length = sizeof(XPVBM);
1487 new_body_arena = (void **) &PL_xpvbm_root;
1488 new_body_arenaroot = (void **) &PL_xpvbm_arenaroot;
1491 new_body_length = sizeof(XPVGV);
1492 new_body_arena = (void **) &PL_xpvgv_root;
1493 new_body_arenaroot = (void **) &PL_xpvgv_arenaroot;
1496 new_body_length = sizeof(XPVCV);
1497 new_body_arena = (void **) &PL_xpvcv_root;
1498 new_body_arenaroot = (void **) &PL_xpvcv_arenaroot;
1501 new_body_length = sizeof(XPVLV);
1502 new_body_arena = (void **) &PL_xpvlv_root;
1503 new_body_arenaroot = (void **) &PL_xpvlv_arenaroot;
1506 new_body_length = sizeof(XPVMG);
1507 new_body_arena = (void **) &PL_xpvmg_root;
1508 new_body_arenaroot = (void **) &PL_xpvmg_arenaroot;
1511 new_body_length = sizeof(XPVNV);
1512 new_body_arena = (void **) &PL_xpvnv_root;
1513 new_body_arenaroot = (void **) &PL_xpvnv_arenaroot;
1516 new_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
1517 - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
1518 new_body_length = sizeof(XPVIV) - new_body_offset;
1519 new_body_arena = (void **) &PL_xpviv_root;
1520 new_body_arenaroot = (void **) &PL_xpviv_arenaroot;
1521 /* XXX Is this still needed? Was it ever needed? Surely as there is
1522 no route from NV to PVIV, NOK can never be true */
1526 goto new_body_no_NV;
1528 new_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
1529 - STRUCT_OFFSET(xpv_allocated, xpv_cur);
1530 new_body_length = sizeof(XPV) - new_body_offset;
1531 new_body_arena = (void **) &PL_xpv_root;
1532 new_body_arenaroot = (void **) &PL_xpv_arenaroot;
1534 /* PV and PVIV don't have an NV slot. */
1535 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1540 assert(new_body_length);
1542 /* This points to the start of the allocated area. */
1543 new_body_inline(new_body, new_body_arenaroot, new_body_arena,
1546 /* We always allocated the full length item with PURIFY */
1547 new_body_length += new_body_offset;
1548 new_body_offset = 0;
1549 new_body = my_safemalloc(new_body_length);
1553 Zero(new_body, new_body_length, char);
1554 new_body = ((char *)new_body) - new_body_offset;
1555 SvANY(sv) = new_body;
1557 if (old_body_length) {
1558 Copy((char *)old_body + old_body_offset,
1559 (char *)new_body + old_body_offset,
1560 old_body_length, char);
1563 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1569 IoPAGE_LEN(sv) = 60;
1570 if (old_type < SVt_RV)
1574 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", mt);
1578 if (old_body_arena) {
1580 my_safefree(old_body);
1582 del_body((void*)((char*)old_body + old_body_offset),
1589 =for apidoc sv_backoff
1591 Remove any string offset. You should normally use the C<SvOOK_off> macro
1598 Perl_sv_backoff(pTHX_ register SV *sv)
1601 assert(SvTYPE(sv) != SVt_PVHV);
1602 assert(SvTYPE(sv) != SVt_PVAV);
1604 const char * const s = SvPVX_const(sv);
1605 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1606 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1608 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1610 SvFLAGS(sv) &= ~SVf_OOK;
1617 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1618 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1619 Use the C<SvGROW> wrapper instead.
1625 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1629 #ifdef HAS_64K_LIMIT
1630 if (newlen >= 0x10000) {
1631 PerlIO_printf(Perl_debug_log,
1632 "Allocation too large: %"UVxf"\n", (UV)newlen);
1635 #endif /* HAS_64K_LIMIT */
1638 if (SvTYPE(sv) < SVt_PV) {
1639 sv_upgrade(sv, SVt_PV);
1640 s = SvPVX_mutable(sv);
1642 else if (SvOOK(sv)) { /* pv is offset? */
1644 s = SvPVX_mutable(sv);
1645 if (newlen > SvLEN(sv))
1646 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1647 #ifdef HAS_64K_LIMIT
1648 if (newlen >= 0x10000)
1653 s = SvPVX_mutable(sv);
1655 if (newlen > SvLEN(sv)) { /* need more room? */
1656 newlen = PERL_STRLEN_ROUNDUP(newlen);
1657 if (SvLEN(sv) && s) {
1659 const STRLEN l = malloced_size((void*)SvPVX_const(sv));
1665 s = saferealloc(s, newlen);
1668 s = safemalloc(newlen);
1669 if (SvPVX_const(sv) && SvCUR(sv)) {
1670 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1674 SvLEN_set(sv, newlen);
1680 =for apidoc sv_setiv
1682 Copies an integer into the given SV, upgrading first if necessary.
1683 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1689 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1691 SV_CHECK_THINKFIRST_COW_DROP(sv);
1692 switch (SvTYPE(sv)) {
1694 sv_upgrade(sv, SVt_IV);
1697 sv_upgrade(sv, SVt_PVNV);
1701 sv_upgrade(sv, SVt_PVIV);
1710 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1713 (void)SvIOK_only(sv); /* validate number */
1719 =for apidoc sv_setiv_mg
1721 Like C<sv_setiv>, but also handles 'set' magic.
1727 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1734 =for apidoc sv_setuv
1736 Copies an unsigned integer into the given SV, upgrading first if necessary.
1737 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1743 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1745 /* With these two if statements:
1746 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1749 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1751 If you wish to remove them, please benchmark to see what the effect is
1753 if (u <= (UV)IV_MAX) {
1754 sv_setiv(sv, (IV)u);
1763 =for apidoc sv_setuv_mg
1765 Like C<sv_setuv>, but also handles 'set' magic.
1771 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1780 =for apidoc sv_setnv
1782 Copies a double into the given SV, upgrading first if necessary.
1783 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1789 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1791 SV_CHECK_THINKFIRST_COW_DROP(sv);
1792 switch (SvTYPE(sv)) {
1795 sv_upgrade(sv, SVt_NV);
1800 sv_upgrade(sv, SVt_PVNV);
1809 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1813 (void)SvNOK_only(sv); /* validate number */
1818 =for apidoc sv_setnv_mg
1820 Like C<sv_setnv>, but also handles 'set' magic.
1826 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1832 /* Print an "isn't numeric" warning, using a cleaned-up,
1833 * printable version of the offending string
1837 S_not_a_number(pTHX_ SV *sv)
1844 dsv = sv_2mortal(newSVpvn("", 0));
1845 pv = sv_uni_display(dsv, sv, 10, 0);
1848 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1849 /* each *s can expand to 4 chars + "...\0",
1850 i.e. need room for 8 chars */
1852 const char *s, *end;
1853 for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit;
1856 if (ch & 128 && !isPRINT_LC(ch)) {
1865 else if (ch == '\r') {
1869 else if (ch == '\f') {
1873 else if (ch == '\\') {
1877 else if (ch == '\0') {
1881 else if (isPRINT_LC(ch))
1898 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1899 "Argument \"%s\" isn't numeric in %s", pv,
1902 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1903 "Argument \"%s\" isn't numeric", pv);
1907 =for apidoc looks_like_number
1909 Test if the content of an SV looks like a number (or is a number).
1910 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1911 non-numeric warning), even if your atof() doesn't grok them.
1917 Perl_looks_like_number(pTHX_ SV *sv)
1919 register const char *sbegin;
1923 sbegin = SvPVX_const(sv);
1926 else if (SvPOKp(sv))
1927 sbegin = SvPV_const(sv, len);
1929 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1930 return grok_number(sbegin, len, NULL);
1933 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1934 until proven guilty, assume that things are not that bad... */
1939 As 64 bit platforms often have an NV that doesn't preserve all bits of
1940 an IV (an assumption perl has been based on to date) it becomes necessary
1941 to remove the assumption that the NV always carries enough precision to
1942 recreate the IV whenever needed, and that the NV is the canonical form.
1943 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1944 precision as a side effect of conversion (which would lead to insanity
1945 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1946 1) to distinguish between IV/UV/NV slots that have cached a valid
1947 conversion where precision was lost and IV/UV/NV slots that have a
1948 valid conversion which has lost no precision
1949 2) to ensure that if a numeric conversion to one form is requested that
1950 would lose precision, the precise conversion (or differently
1951 imprecise conversion) is also performed and cached, to prevent
1952 requests for different numeric formats on the same SV causing
1953 lossy conversion chains. (lossless conversion chains are perfectly
1958 SvIOKp is true if the IV slot contains a valid value
1959 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1960 SvNOKp is true if the NV slot contains a valid value
1961 SvNOK is true only if the NV value is accurate
1964 while converting from PV to NV, check to see if converting that NV to an
1965 IV(or UV) would lose accuracy over a direct conversion from PV to
1966 IV(or UV). If it would, cache both conversions, return NV, but mark
1967 SV as IOK NOKp (ie not NOK).
1969 While converting from PV to IV, check to see if converting that IV to an
1970 NV would lose accuracy over a direct conversion from PV to NV. If it
1971 would, cache both conversions, flag similarly.
1973 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1974 correctly because if IV & NV were set NV *always* overruled.
1975 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1976 changes - now IV and NV together means that the two are interchangeable:
1977 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1979 The benefit of this is that operations such as pp_add know that if
1980 SvIOK is true for both left and right operands, then integer addition
1981 can be used instead of floating point (for cases where the result won't
1982 overflow). Before, floating point was always used, which could lead to
1983 loss of precision compared with integer addition.
1985 * making IV and NV equal status should make maths accurate on 64 bit
1987 * may speed up maths somewhat if pp_add and friends start to use
1988 integers when possible instead of fp. (Hopefully the overhead in
1989 looking for SvIOK and checking for overflow will not outweigh the
1990 fp to integer speedup)
1991 * will slow down integer operations (callers of SvIV) on "inaccurate"
1992 values, as the change from SvIOK to SvIOKp will cause a call into
1993 sv_2iv each time rather than a macro access direct to the IV slot
1994 * should speed up number->string conversion on integers as IV is
1995 favoured when IV and NV are equally accurate
1997 ####################################################################
1998 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1999 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2000 On the other hand, SvUOK is true iff UV.
2001 ####################################################################
2003 Your mileage will vary depending your CPU's relative fp to integer
2007 #ifndef NV_PRESERVES_UV
2008 # define IS_NUMBER_UNDERFLOW_IV 1
2009 # define IS_NUMBER_UNDERFLOW_UV 2
2010 # define IS_NUMBER_IV_AND_UV 2
2011 # define IS_NUMBER_OVERFLOW_IV 4
2012 # define IS_NUMBER_OVERFLOW_UV 5
2014 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2016 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2018 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2020 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));
2021 if (SvNVX(sv) < (NV)IV_MIN) {
2022 (void)SvIOKp_on(sv);
2024 SvIV_set(sv, IV_MIN);
2025 return IS_NUMBER_UNDERFLOW_IV;
2027 if (SvNVX(sv) > (NV)UV_MAX) {
2028 (void)SvIOKp_on(sv);
2031 SvUV_set(sv, UV_MAX);
2032 return IS_NUMBER_OVERFLOW_UV;
2034 (void)SvIOKp_on(sv);
2036 /* Can't use strtol etc to convert this string. (See truth table in
2038 if (SvNVX(sv) <= (UV)IV_MAX) {
2039 SvIV_set(sv, I_V(SvNVX(sv)));
2040 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2041 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2043 /* Integer is imprecise. NOK, IOKp */
2045 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2048 SvUV_set(sv, U_V(SvNVX(sv)));
2049 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2050 if (SvUVX(sv) == UV_MAX) {
2051 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2052 possibly be preserved by NV. Hence, it must be overflow.
2054 return IS_NUMBER_OVERFLOW_UV;
2056 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2058 /* Integer is imprecise. NOK, IOKp */
2060 return IS_NUMBER_OVERFLOW_IV;
2062 #endif /* !NV_PRESERVES_UV*/
2065 =for apidoc sv_2iv_flags
2067 Return the integer value of an SV, doing any necessary string
2068 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2069 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2075 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2079 if (SvGMAGICAL(sv)) {
2080 if (flags & SV_GMAGIC)
2085 return I_V(SvNVX(sv));
2087 if (SvPOKp(sv) && SvLEN(sv))
2090 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2091 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2097 if (SvTHINKFIRST(sv)) {
2100 SV * const tmpstr=AMG_CALLun(sv,numer);
2101 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2102 return SvIV(tmpstr);
2105 return PTR2IV(SvRV(sv));
2108 sv_force_normal_flags(sv, 0);
2110 if (SvREADONLY(sv) && !SvOK(sv)) {
2111 if (ckWARN(WARN_UNINITIALIZED))
2118 return (IV)(SvUVX(sv));
2125 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2126 * without also getting a cached IV/UV from it at the same time
2127 * (ie PV->NV conversion should detect loss of accuracy and cache
2128 * IV or UV at same time to avoid this. NWC */
2130 if (SvTYPE(sv) == SVt_NV)
2131 sv_upgrade(sv, SVt_PVNV);
2133 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2134 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2135 certainly cast into the IV range at IV_MAX, whereas the correct
2136 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2138 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2139 SvIV_set(sv, I_V(SvNVX(sv)));
2140 if (SvNVX(sv) == (NV) SvIVX(sv)
2141 #ifndef NV_PRESERVES_UV
2142 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2143 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2144 /* Don't flag it as "accurately an integer" if the number
2145 came from a (by definition imprecise) NV operation, and
2146 we're outside the range of NV integer precision */
2149 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2150 DEBUG_c(PerlIO_printf(Perl_debug_log,
2151 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2157 /* IV not precise. No need to convert from PV, as NV
2158 conversion would already have cached IV if it detected
2159 that PV->IV would be better than PV->NV->IV
2160 flags already correct - don't set public IOK. */
2161 DEBUG_c(PerlIO_printf(Perl_debug_log,
2162 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2167 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2168 but the cast (NV)IV_MIN rounds to a the value less (more
2169 negative) than IV_MIN which happens to be equal to SvNVX ??
2170 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2171 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2172 (NV)UVX == NVX are both true, but the values differ. :-(
2173 Hopefully for 2s complement IV_MIN is something like
2174 0x8000000000000000 which will be exact. NWC */
2177 SvUV_set(sv, U_V(SvNVX(sv)));
2179 (SvNVX(sv) == (NV) SvUVX(sv))
2180 #ifndef NV_PRESERVES_UV
2181 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2182 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2183 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2184 /* Don't flag it as "accurately an integer" if the number
2185 came from a (by definition imprecise) NV operation, and
2186 we're outside the range of NV integer precision */
2192 DEBUG_c(PerlIO_printf(Perl_debug_log,
2193 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2197 return (IV)SvUVX(sv);
2200 else if (SvPOKp(sv) && SvLEN(sv)) {
2202 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2203 /* We want to avoid a possible problem when we cache an IV which
2204 may be later translated to an NV, and the resulting NV is not
2205 the same as the direct translation of the initial string
2206 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2207 be careful to ensure that the value with the .456 is around if the
2208 NV value is requested in the future).
2210 This means that if we cache such an IV, we need to cache the
2211 NV as well. Moreover, we trade speed for space, and do not
2212 cache the NV if we are sure it's not needed.
2215 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2216 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2217 == IS_NUMBER_IN_UV) {
2218 /* It's definitely an integer, only upgrade to PVIV */
2219 if (SvTYPE(sv) < SVt_PVIV)
2220 sv_upgrade(sv, SVt_PVIV);
2222 } else if (SvTYPE(sv) < SVt_PVNV)
2223 sv_upgrade(sv, SVt_PVNV);
2225 /* If NV preserves UV then we only use the UV value if we know that
2226 we aren't going to call atof() below. If NVs don't preserve UVs
2227 then the value returned may have more precision than atof() will
2228 return, even though value isn't perfectly accurate. */
2229 if ((numtype & (IS_NUMBER_IN_UV
2230 #ifdef NV_PRESERVES_UV
2233 )) == IS_NUMBER_IN_UV) {
2234 /* This won't turn off the public IOK flag if it was set above */
2235 (void)SvIOKp_on(sv);
2237 if (!(numtype & IS_NUMBER_NEG)) {
2239 if (value <= (UV)IV_MAX) {
2240 SvIV_set(sv, (IV)value);
2242 SvUV_set(sv, value);
2246 /* 2s complement assumption */
2247 if (value <= (UV)IV_MIN) {
2248 SvIV_set(sv, -(IV)value);
2250 /* Too negative for an IV. This is a double upgrade, but
2251 I'm assuming it will be rare. */
2252 if (SvTYPE(sv) < SVt_PVNV)
2253 sv_upgrade(sv, SVt_PVNV);
2257 SvNV_set(sv, -(NV)value);
2258 SvIV_set(sv, IV_MIN);
2262 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2263 will be in the previous block to set the IV slot, and the next
2264 block to set the NV slot. So no else here. */
2266 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2267 != IS_NUMBER_IN_UV) {
2268 /* It wasn't an (integer that doesn't overflow the UV). */
2269 SvNV_set(sv, Atof(SvPVX_const(sv)));
2271 if (! numtype && ckWARN(WARN_NUMERIC))
2274 #if defined(USE_LONG_DOUBLE)
2275 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2276 PTR2UV(sv), SvNVX(sv)));
2278 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2279 PTR2UV(sv), SvNVX(sv)));
2283 #ifdef NV_PRESERVES_UV
2284 (void)SvIOKp_on(sv);
2286 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2287 SvIV_set(sv, I_V(SvNVX(sv)));
2288 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2291 /* Integer is imprecise. NOK, IOKp */
2293 /* UV will not work better than IV */
2295 if (SvNVX(sv) > (NV)UV_MAX) {
2297 /* Integer is inaccurate. NOK, IOKp, is UV */
2298 SvUV_set(sv, UV_MAX);
2301 SvUV_set(sv, U_V(SvNVX(sv)));
2302 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2303 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2307 /* Integer is imprecise. NOK, IOKp, is UV */
2313 #else /* NV_PRESERVES_UV */
2314 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2315 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2316 /* The IV slot will have been set from value returned by
2317 grok_number above. The NV slot has just been set using
2320 assert (SvIOKp(sv));
2322 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2323 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2324 /* Small enough to preserve all bits. */
2325 (void)SvIOKp_on(sv);
2327 SvIV_set(sv, I_V(SvNVX(sv)));
2328 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2330 /* Assumption: first non-preserved integer is < IV_MAX,
2331 this NV is in the preserved range, therefore: */
2332 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2334 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);
2338 0 0 already failed to read UV.
2339 0 1 already failed to read UV.
2340 1 0 you won't get here in this case. IV/UV
2341 slot set, public IOK, Atof() unneeded.
2342 1 1 already read UV.
2343 so there's no point in sv_2iuv_non_preserve() attempting
2344 to use atol, strtol, strtoul etc. */
2345 if (sv_2iuv_non_preserve (sv, numtype)
2346 >= IS_NUMBER_OVERFLOW_IV)
2350 #endif /* NV_PRESERVES_UV */
2353 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2355 if (SvTYPE(sv) < SVt_IV)
2356 /* Typically the caller expects that sv_any is not NULL now. */
2357 sv_upgrade(sv, SVt_IV);
2360 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2361 PTR2UV(sv),SvIVX(sv)));
2362 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2365 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2366 * this function provided for binary compatibility only
2370 Perl_sv_2uv(pTHX_ register SV *sv)
2372 return sv_2uv_flags(sv, SV_GMAGIC);
2376 =for apidoc sv_2uv_flags
2378 Return the unsigned integer value of an SV, doing any necessary string
2379 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2380 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2386 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2390 if (SvGMAGICAL(sv)) {
2391 if (flags & SV_GMAGIC)
2396 return U_V(SvNVX(sv));
2397 if (SvPOKp(sv) && SvLEN(sv))
2400 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2401 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2407 if (SvTHINKFIRST(sv)) {
2410 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2411 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2412 return SvUV(tmpstr);
2413 return PTR2UV(SvRV(sv));
2416 sv_force_normal_flags(sv, 0);
2418 if (SvREADONLY(sv) && !SvOK(sv)) {
2419 if (ckWARN(WARN_UNINITIALIZED))
2429 return (UV)SvIVX(sv);
2433 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2434 * without also getting a cached IV/UV from it at the same time
2435 * (ie PV->NV conversion should detect loss of accuracy and cache
2436 * IV or UV at same time to avoid this. */
2437 /* IV-over-UV optimisation - choose to cache IV if possible */
2439 if (SvTYPE(sv) == SVt_NV)
2440 sv_upgrade(sv, SVt_PVNV);
2442 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2443 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2444 SvIV_set(sv, I_V(SvNVX(sv)));
2445 if (SvNVX(sv) == (NV) SvIVX(sv)
2446 #ifndef NV_PRESERVES_UV
2447 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2448 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2449 /* Don't flag it as "accurately an integer" if the number
2450 came from a (by definition imprecise) NV operation, and
2451 we're outside the range of NV integer precision */
2454 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2455 DEBUG_c(PerlIO_printf(Perl_debug_log,
2456 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2462 /* IV not precise. No need to convert from PV, as NV
2463 conversion would already have cached IV if it detected
2464 that PV->IV would be better than PV->NV->IV
2465 flags already correct - don't set public IOK. */
2466 DEBUG_c(PerlIO_printf(Perl_debug_log,
2467 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2472 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2473 but the cast (NV)IV_MIN rounds to a the value less (more
2474 negative) than IV_MIN which happens to be equal to SvNVX ??
2475 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2476 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2477 (NV)UVX == NVX are both true, but the values differ. :-(
2478 Hopefully for 2s complement IV_MIN is something like
2479 0x8000000000000000 which will be exact. NWC */
2482 SvUV_set(sv, U_V(SvNVX(sv)));
2484 (SvNVX(sv) == (NV) SvUVX(sv))
2485 #ifndef NV_PRESERVES_UV
2486 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2487 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2488 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2489 /* Don't flag it as "accurately an integer" if the number
2490 came from a (by definition imprecise) NV operation, and
2491 we're outside the range of NV integer precision */
2496 DEBUG_c(PerlIO_printf(Perl_debug_log,
2497 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2503 else if (SvPOKp(sv) && SvLEN(sv)) {
2505 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2507 /* We want to avoid a possible problem when we cache a UV which
2508 may be later translated to an NV, and the resulting NV is not
2509 the translation of the initial data.
2511 This means that if we cache such a UV, we need to cache the
2512 NV as well. Moreover, we trade speed for space, and do not
2513 cache the NV if not needed.
2516 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2517 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2518 == IS_NUMBER_IN_UV) {
2519 /* It's definitely an integer, only upgrade to PVIV */
2520 if (SvTYPE(sv) < SVt_PVIV)
2521 sv_upgrade(sv, SVt_PVIV);
2523 } else if (SvTYPE(sv) < SVt_PVNV)
2524 sv_upgrade(sv, SVt_PVNV);
2526 /* If NV preserves UV then we only use the UV value if we know that
2527 we aren't going to call atof() below. If NVs don't preserve UVs
2528 then the value returned may have more precision than atof() will
2529 return, even though it isn't accurate. */
2530 if ((numtype & (IS_NUMBER_IN_UV
2531 #ifdef NV_PRESERVES_UV
2534 )) == IS_NUMBER_IN_UV) {
2535 /* This won't turn off the public IOK flag if it was set above */
2536 (void)SvIOKp_on(sv);
2538 if (!(numtype & IS_NUMBER_NEG)) {
2540 if (value <= (UV)IV_MAX) {
2541 SvIV_set(sv, (IV)value);
2543 /* it didn't overflow, and it was positive. */
2544 SvUV_set(sv, value);
2548 /* 2s complement assumption */
2549 if (value <= (UV)IV_MIN) {
2550 SvIV_set(sv, -(IV)value);
2552 /* Too negative for an IV. This is a double upgrade, but
2553 I'm assuming it will be rare. */
2554 if (SvTYPE(sv) < SVt_PVNV)
2555 sv_upgrade(sv, SVt_PVNV);
2559 SvNV_set(sv, -(NV)value);
2560 SvIV_set(sv, IV_MIN);
2565 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2566 != IS_NUMBER_IN_UV) {
2567 /* It wasn't an integer, or it overflowed the UV. */
2568 SvNV_set(sv, Atof(SvPVX_const(sv)));
2570 if (! numtype && ckWARN(WARN_NUMERIC))
2573 #if defined(USE_LONG_DOUBLE)
2574 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2575 PTR2UV(sv), SvNVX(sv)));
2577 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2578 PTR2UV(sv), SvNVX(sv)));
2581 #ifdef NV_PRESERVES_UV
2582 (void)SvIOKp_on(sv);
2584 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2585 SvIV_set(sv, I_V(SvNVX(sv)));
2586 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2589 /* Integer is imprecise. NOK, IOKp */
2591 /* UV will not work better than IV */
2593 if (SvNVX(sv) > (NV)UV_MAX) {
2595 /* Integer is inaccurate. NOK, IOKp, is UV */
2596 SvUV_set(sv, UV_MAX);
2599 SvUV_set(sv, U_V(SvNVX(sv)));
2600 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2601 NV preservse UV so can do correct comparison. */
2602 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2606 /* Integer is imprecise. NOK, IOKp, is UV */
2611 #else /* NV_PRESERVES_UV */
2612 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2613 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2614 /* The UV slot will have been set from value returned by
2615 grok_number above. The NV slot has just been set using
2618 assert (SvIOKp(sv));
2620 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2621 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2622 /* Small enough to preserve all bits. */
2623 (void)SvIOKp_on(sv);
2625 SvIV_set(sv, I_V(SvNVX(sv)));
2626 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2628 /* Assumption: first non-preserved integer is < IV_MAX,
2629 this NV is in the preserved range, therefore: */
2630 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2632 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);
2635 sv_2iuv_non_preserve (sv, numtype);
2637 #endif /* NV_PRESERVES_UV */
2641 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2642 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2645 if (SvTYPE(sv) < SVt_IV)
2646 /* Typically the caller expects that sv_any is not NULL now. */
2647 sv_upgrade(sv, SVt_IV);
2651 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2652 PTR2UV(sv),SvUVX(sv)));
2653 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2659 Return the num value of an SV, doing any necessary string or integer
2660 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2667 Perl_sv_2nv(pTHX_ register SV *sv)
2671 if (SvGMAGICAL(sv)) {
2675 if (SvPOKp(sv) && SvLEN(sv)) {
2676 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2677 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2679 return Atof(SvPVX_const(sv));
2683 return (NV)SvUVX(sv);
2685 return (NV)SvIVX(sv);
2688 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2689 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2695 if (SvTHINKFIRST(sv)) {
2698 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2699 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2700 return SvNV(tmpstr);
2701 return PTR2NV(SvRV(sv));
2704 sv_force_normal_flags(sv, 0);
2706 if (SvREADONLY(sv) && !SvOK(sv)) {
2707 if (ckWARN(WARN_UNINITIALIZED))
2712 if (SvTYPE(sv) < SVt_NV) {
2713 if (SvTYPE(sv) == SVt_IV)
2714 sv_upgrade(sv, SVt_PVNV);
2716 sv_upgrade(sv, SVt_NV);
2717 #ifdef USE_LONG_DOUBLE
2719 STORE_NUMERIC_LOCAL_SET_STANDARD();
2720 PerlIO_printf(Perl_debug_log,
2721 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2722 PTR2UV(sv), SvNVX(sv));
2723 RESTORE_NUMERIC_LOCAL();
2727 STORE_NUMERIC_LOCAL_SET_STANDARD();
2728 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2729 PTR2UV(sv), SvNVX(sv));
2730 RESTORE_NUMERIC_LOCAL();
2734 else if (SvTYPE(sv) < SVt_PVNV)
2735 sv_upgrade(sv, SVt_PVNV);
2740 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2741 #ifdef NV_PRESERVES_UV
2744 /* Only set the public NV OK flag if this NV preserves the IV */
2745 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2746 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2747 : (SvIVX(sv) == I_V(SvNVX(sv))))
2753 else if (SvPOKp(sv) && SvLEN(sv)) {
2755 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2756 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2758 #ifdef NV_PRESERVES_UV
2759 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2760 == IS_NUMBER_IN_UV) {
2761 /* It's definitely an integer */
2762 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2764 SvNV_set(sv, Atof(SvPVX_const(sv)));
2767 SvNV_set(sv, Atof(SvPVX_const(sv)));
2768 /* Only set the public NV OK flag if this NV preserves the value in
2769 the PV at least as well as an IV/UV would.
2770 Not sure how to do this 100% reliably. */
2771 /* if that shift count is out of range then Configure's test is
2772 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2774 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2775 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2776 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2777 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2778 /* Can't use strtol etc to convert this string, so don't try.
2779 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2782 /* value has been set. It may not be precise. */
2783 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2784 /* 2s complement assumption for (UV)IV_MIN */
2785 SvNOK_on(sv); /* Integer is too negative. */
2790 if (numtype & IS_NUMBER_NEG) {
2791 SvIV_set(sv, -(IV)value);
2792 } else if (value <= (UV)IV_MAX) {
2793 SvIV_set(sv, (IV)value);
2795 SvUV_set(sv, value);
2799 if (numtype & IS_NUMBER_NOT_INT) {
2800 /* I believe that even if the original PV had decimals,
2801 they are lost beyond the limit of the FP precision.
2802 However, neither is canonical, so both only get p
2803 flags. NWC, 2000/11/25 */
2804 /* Both already have p flags, so do nothing */
2806 const NV nv = SvNVX(sv);
2807 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2808 if (SvIVX(sv) == I_V(nv)) {
2813 /* It had no "." so it must be integer. */
2816 /* between IV_MAX and NV(UV_MAX).
2817 Could be slightly > UV_MAX */
2819 if (numtype & IS_NUMBER_NOT_INT) {
2820 /* UV and NV both imprecise. */
2822 const UV nv_as_uv = U_V(nv);
2824 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2835 #endif /* NV_PRESERVES_UV */
2838 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2840 if (SvTYPE(sv) < SVt_NV)
2841 /* Typically the caller expects that sv_any is not NULL now. */
2842 /* XXX Ilya implies that this is a bug in callers that assume this
2843 and ideally should be fixed. */
2844 sv_upgrade(sv, SVt_NV);
2847 #if defined(USE_LONG_DOUBLE)
2849 STORE_NUMERIC_LOCAL_SET_STANDARD();
2850 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2851 PTR2UV(sv), SvNVX(sv));
2852 RESTORE_NUMERIC_LOCAL();
2856 STORE_NUMERIC_LOCAL_SET_STANDARD();
2857 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2858 PTR2UV(sv), SvNVX(sv));
2859 RESTORE_NUMERIC_LOCAL();
2865 /* asIV(): extract an integer from the string value of an SV.
2866 * Caller must validate PVX */
2869 S_asIV(pTHX_ SV *sv)
2872 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2874 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2875 == IS_NUMBER_IN_UV) {
2876 /* It's definitely an integer */
2877 if (numtype & IS_NUMBER_NEG) {
2878 if (value < (UV)IV_MIN)
2881 if (value < (UV)IV_MAX)
2886 if (ckWARN(WARN_NUMERIC))
2889 return I_V(Atof(SvPVX_const(sv)));
2892 /* asUV(): extract an unsigned integer from the string value of an SV
2893 * Caller must validate PVX */
2896 S_asUV(pTHX_ SV *sv)
2899 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2901 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2902 == IS_NUMBER_IN_UV) {
2903 /* It's definitely an integer */
2904 if (!(numtype & IS_NUMBER_NEG))
2908 if (ckWARN(WARN_NUMERIC))
2911 return U_V(Atof(SvPVX_const(sv)));
2915 =for apidoc sv_2pv_nolen
2917 Like C<sv_2pv()>, but doesn't return the length too. You should usually
2918 use the macro wrapper C<SvPV_nolen(sv)> instead.
2923 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2925 return sv_2pv(sv, 0);
2928 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2929 * UV as a string towards the end of buf, and return pointers to start and
2932 * We assume that buf is at least TYPE_CHARS(UV) long.
2936 S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2938 char *ptr = buf + TYPE_CHARS(UV);
2939 char * const ebuf = ptr;
2952 *--ptr = '0' + (char)(uv % 10);
2961 =for apidoc sv_2pv_flags
2963 Returns a pointer to the string value of an SV, and sets *lp to its length.
2964 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2966 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2967 usually end up here too.
2973 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2978 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2979 char *tmpbuf = tbuf;
2986 if (SvGMAGICAL(sv)) {
2987 if (flags & SV_GMAGIC)
2992 if (flags & SV_MUTABLE_RETURN)
2993 return SvPVX_mutable(sv);
2994 if (flags & SV_CONST_RETURN)
2995 return (char *)SvPVX_const(sv);
3000 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
3002 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3007 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3012 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3013 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3021 if (SvTHINKFIRST(sv)) {
3024 register const char *typestr;
3025 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3026 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3028 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
3031 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
3032 if (flags & SV_CONST_RETURN) {
3033 pv = (char *) SvPVX_const(tmpstr);
3035 pv = (flags & SV_MUTABLE_RETURN)
3036 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
3039 *lp = SvCUR(tmpstr);
3041 pv = sv_2pv_flags(tmpstr, lp, flags);
3052 typestr = "NULLREF";
3056 switch (SvTYPE(sv)) {
3058 if ( ((SvFLAGS(sv) &
3059 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3060 == (SVs_OBJECT|SVs_SMG))
3061 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3062 const regexp *re = (regexp *)mg->mg_obj;
3065 const char *fptr = "msix";
3070 char need_newline = 0;
3071 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3073 while((ch = *fptr++)) {
3075 reflags[left++] = ch;
3078 reflags[right--] = ch;
3083 reflags[left] = '-';
3087 mg->mg_len = re->prelen + 4 + left;
3089 * If /x was used, we have to worry about a regex
3090 * ending with a comment later being embedded
3091 * within another regex. If so, we don't want this
3092 * regex's "commentization" to leak out to the
3093 * right part of the enclosing regex, we must cap
3094 * it with a newline.
3096 * So, if /x was used, we scan backwards from the
3097 * end of the regex. If we find a '#' before we
3098 * find a newline, we need to add a newline
3099 * ourself. If we find a '\n' first (or if we
3100 * don't find '#' or '\n'), we don't need to add
3101 * anything. -jfriedl
3103 if (PMf_EXTENDED & re->reganch)
3105 const char *endptr = re->precomp + re->prelen;
3106 while (endptr >= re->precomp)
3108 const char c = *(endptr--);
3110 break; /* don't need another */
3112 /* we end while in a comment, so we
3114 mg->mg_len++; /* save space for it */
3115 need_newline = 1; /* note to add it */
3121 Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
3122 Copy("(?", mg->mg_ptr, 2, char);
3123 Copy(reflags, mg->mg_ptr+2, left, char);
3124 Copy(":", mg->mg_ptr+left+2, 1, char);
3125 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3127 mg->mg_ptr[mg->mg_len - 2] = '\n';
3128 mg->mg_ptr[mg->mg_len - 1] = ')';
3129 mg->mg_ptr[mg->mg_len] = 0;
3131 PL_reginterp_cnt += re->program[0].next_off;
3133 if (re->reganch & ROPT_UTF8)
3149 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3150 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3151 /* tied lvalues should appear to be
3152 * scalars for backwards compatitbility */
3153 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3154 ? "SCALAR" : "LVALUE"; break;
3155 case SVt_PVAV: typestr = "ARRAY"; break;
3156 case SVt_PVHV: typestr = "HASH"; break;
3157 case SVt_PVCV: typestr = "CODE"; break;
3158 case SVt_PVGV: typestr = "GLOB"; break;
3159 case SVt_PVFM: typestr = "FORMAT"; break;
3160 case SVt_PVIO: typestr = "IO"; break;
3161 default: typestr = "UNKNOWN"; break;
3165 const char *name = HvNAME_get(SvSTASH(sv));
3166 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3167 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3170 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3174 *lp = strlen(typestr);
3175 return (char *)typestr;
3177 if (SvREADONLY(sv) && !SvOK(sv)) {
3178 if (ckWARN(WARN_UNINITIALIZED))
3185 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3186 /* I'm assuming that if both IV and NV are equally valid then
3187 converting the IV is going to be more efficient */
3188 const U32 isIOK = SvIOK(sv);
3189 const U32 isUIOK = SvIsUV(sv);
3190 char buf[TYPE_CHARS(UV)];
3193 if (SvTYPE(sv) < SVt_PVIV)
3194 sv_upgrade(sv, SVt_PVIV);
3196 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3198 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3199 /* inlined from sv_setpvn */
3200 SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
3201 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
3202 SvCUR_set(sv, ebuf - ptr);
3212 else if (SvNOKp(sv)) {
3213 if (SvTYPE(sv) < SVt_PVNV)
3214 sv_upgrade(sv, SVt_PVNV);
3215 /* The +20 is pure guesswork. Configure test needed. --jhi */
3216 s = SvGROW_mutable(sv, NV_DIG + 20);
3217 olderrno = errno; /* some Xenix systems wipe out errno here */
3219 if (SvNVX(sv) == 0.0)
3220 (void)strcpy(s,"0");
3224 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3227 #ifdef FIXNEGATIVEZERO
3228 if (*s == '-' && s[1] == '0' && !s[2])
3238 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
3242 if (SvTYPE(sv) < SVt_PV)
3243 /* Typically the caller expects that sv_any is not NULL now. */
3244 sv_upgrade(sv, SVt_PV);
3248 const STRLEN len = s - SvPVX_const(sv);
3254 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3255 PTR2UV(sv),SvPVX_const(sv)));
3256 if (flags & SV_CONST_RETURN)
3257 return (char *)SvPVX_const(sv);
3258 if (flags & SV_MUTABLE_RETURN)
3259 return SvPVX_mutable(sv);
3263 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3264 /* Sneaky stuff here */
3268 tsv = newSVpv(tmpbuf, 0);
3281 t = SvPVX_const(tsv);
3286 len = strlen(tmpbuf);
3288 #ifdef FIXNEGATIVEZERO
3289 if (len == 2 && t[0] == '-' && t[1] == '0') {
3294 SvUPGRADE(sv, SVt_PV);
3297 s = SvGROW_mutable(sv, len + 1);
3300 return memcpy(s, t, len + 1);
3305 =for apidoc sv_copypv
3307 Copies a stringified representation of the source SV into the
3308 destination SV. Automatically performs any necessary mg_get and
3309 coercion of numeric values into strings. Guaranteed to preserve
3310 UTF-8 flag even from overloaded objects. Similar in nature to
3311 sv_2pv[_flags] but operates directly on an SV instead of just the
3312 string. Mostly uses sv_2pv_flags to do its work, except when that
3313 would lose the UTF-8'ness of the PV.
3319 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3322 const char * const s = SvPV_const(ssv,len);
3323 sv_setpvn(dsv,s,len);
3331 =for apidoc sv_2pvbyte_nolen
3333 Return a pointer to the byte-encoded representation of the SV.
3334 May cause the SV to be downgraded from UTF-8 as a side-effect.
3336 Usually accessed via the C<SvPVbyte_nolen> macro.
3342 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3344 return sv_2pvbyte(sv, 0);
3348 =for apidoc sv_2pvbyte
3350 Return a pointer to the byte-encoded representation of the SV, and set *lp
3351 to its length. May cause the SV to be downgraded from UTF-8 as a
3354 Usually accessed via the C<SvPVbyte> macro.
3360 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3362 sv_utf8_downgrade(sv,0);
3363 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3367 =for apidoc sv_2pvutf8_nolen
3369 Return a pointer to the UTF-8-encoded representation of the SV.
3370 May cause the SV to be upgraded to UTF-8 as a side-effect.
3372 Usually accessed via the C<SvPVutf8_nolen> macro.
3378 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3380 return sv_2pvutf8(sv, 0);
3384 * =for apidoc sv_2pvutf8
3386 * Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3387 * to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3389 * Usually accessed via the C<SvPVutf8> macro.
3395 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3397 sv_utf8_upgrade(sv);
3398 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3403 =for apidoc sv_2bool
3405 This function is only called on magical items, and is only used by
3406 sv_true() or its macro equivalent.
3412 Perl_sv_2bool(pTHX_ register SV *sv)
3420 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3421 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3422 return (bool)SvTRUE(tmpsv);
3423 return SvRV(sv) != 0;
3426 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3428 (*sv->sv_u.svu_pv > '0' ||
3429 Xpvtmp->xpv_cur > 1 ||
3430 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3437 return SvIVX(sv) != 0;
3440 return SvNVX(sv) != 0.0;
3447 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3448 * this function provided for binary compatibility only
3453 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3455 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3459 =for apidoc sv_utf8_upgrade
3461 Converts the PV of an SV to its UTF-8-encoded form.
3462 Forces the SV to string form if it is not already.
3463 Always sets the SvUTF8 flag to avoid future validity checks even
3464 if all the bytes have hibit clear.
3466 This is not as a general purpose byte encoding to Unicode interface:
3467 use the Encode extension for that.
3469 =for apidoc sv_utf8_upgrade_flags
3471 Converts the PV of an SV to its UTF-8-encoded form.
3472 Forces the SV to string form if it is not already.
3473 Always sets the SvUTF8 flag to avoid future validity checks even
3474 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3475 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3476 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3478 This is not as a general purpose byte encoding to Unicode interface:
3479 use the Encode extension for that.
3485 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3487 if (sv == &PL_sv_undef)
3491 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3492 (void) sv_2pv_flags(sv,&len, flags);
3496 (void) SvPV_force(sv,len);
3505 sv_force_normal_flags(sv, 0);
3508 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3509 sv_recode_to_utf8(sv, PL_encoding);
3510 else { /* Assume Latin-1/EBCDIC */
3511 /* This function could be much more efficient if we
3512 * had a FLAG in SVs to signal if there are any hibit
3513 * chars in the PV. Given that there isn't such a flag
3514 * make the loop as fast as possible. */
3515 const U8 *s = (U8 *) SvPVX_const(sv);
3516 const U8 *e = (U8 *) SvEND(sv);
3522 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3526 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3527 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
3529 SvPV_free(sv); /* No longer using what was there before. */
3531 SvPV_set(sv, (char*)recoded);
3532 SvCUR_set(sv, len - 1);
3533 SvLEN_set(sv, len); /* No longer know the real size. */
3535 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3542 =for apidoc sv_utf8_downgrade
3544 Attempts to convert the PV of an SV from characters to bytes.
3545 If the PV contains a character beyond byte, this conversion will fail;
3546 in this case, either returns false or, if C<fail_ok> is not
3549 This is not as a general purpose Unicode to byte encoding interface:
3550 use the Encode extension for that.
3556 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3558 if (SvPOKp(sv) && SvUTF8(sv)) {
3564 sv_force_normal_flags(sv, 0);
3566 s = (U8 *) SvPV(sv, len);
3567 if (!utf8_to_bytes(s, &len)) {
3572 Perl_croak(aTHX_ "Wide character in %s",
3575 Perl_croak(aTHX_ "Wide character");
3586 =for apidoc sv_utf8_encode
3588 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3589 flag off so that it looks like octets again.
3595 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3597 (void) sv_utf8_upgrade(sv);
3599 sv_force_normal_flags(sv, 0);
3601 if (SvREADONLY(sv)) {
3602 Perl_croak(aTHX_ PL_no_modify);
3608 =for apidoc sv_utf8_decode
3610 If the PV of the SV is an octet sequence in UTF-8
3611 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3612 so that it looks like a character. If the PV contains only single-byte
3613 characters, the C<SvUTF8> flag stays being off.
3614 Scans PV for validity and returns false if the PV is invalid UTF-8.
3620 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3626 /* The octets may have got themselves encoded - get them back as
3629 if (!sv_utf8_downgrade(sv, TRUE))
3632 /* it is actually just a matter of turning the utf8 flag on, but
3633 * we want to make sure everything inside is valid utf8 first.
3635 c = (const U8 *) SvPVX_const(sv);
3636 if (!is_utf8_string(c, SvCUR(sv)+1))
3638 e = (const U8 *) SvEND(sv);
3641 if (!UTF8_IS_INVARIANT(ch)) {
3651 =for apidoc sv_setsv
3653 Copies the contents of the source SV C<ssv> into the destination SV
3654 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3655 function if the source SV needs to be reused. Does not handle 'set' magic.
3656 Loosely speaking, it performs a copy-by-value, obliterating any previous
3657 content of the destination.
3659 You probably want to use one of the assortment of wrappers, such as
3660 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3661 C<SvSetMagicSV_nosteal>.
3663 =for apidoc sv_setsv_flags
3665 Copies the contents of the source SV C<ssv> into the destination SV
3666 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3667 function if the source SV needs to be reused. Does not handle 'set' magic.
3668 Loosely speaking, it performs a copy-by-value, obliterating any previous
3669 content of the destination.
3670 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3671 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3672 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3673 and C<sv_setsv_nomg> are implemented in terms of this function.
3675 You probably want to use one of the assortment of wrappers, such as
3676 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3677 C<SvSetMagicSV_nosteal>.
3679 This is the primary function for copying scalars, and most other
3680 copy-ish functions and macros use this underneath.
3686 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3688 register U32 sflags;
3694 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3696 sstr = &PL_sv_undef;
3697 stype = SvTYPE(sstr);
3698 dtype = SvTYPE(dstr);
3703 /* need to nuke the magic */
3705 SvRMAGICAL_off(dstr);
3708 /* There's a lot of redundancy below but we're going for speed here */
3713 if (dtype != SVt_PVGV) {
3714 (void)SvOK_off(dstr);
3722 sv_upgrade(dstr, SVt_IV);
3725 sv_upgrade(dstr, SVt_PVNV);
3729 sv_upgrade(dstr, SVt_PVIV);
3732 (void)SvIOK_only(dstr);
3733 SvIV_set(dstr, SvIVX(sstr));
3736 if (SvTAINTED(sstr))
3747 sv_upgrade(dstr, SVt_NV);
3752 sv_upgrade(dstr, SVt_PVNV);
3755 SvNV_set(dstr, SvNVX(sstr));
3756 (void)SvNOK_only(dstr);
3757 if (SvTAINTED(sstr))
3765 sv_upgrade(dstr, SVt_RV);
3766 else if (dtype == SVt_PVGV &&
3767 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3770 if (GvIMPORTED(dstr) != GVf_IMPORTED
3771 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3773 GvIMPORTED_on(dstr);
3782 #ifdef PERL_OLD_COPY_ON_WRITE
3783 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3784 if (dtype < SVt_PVIV)
3785 sv_upgrade(dstr, SVt_PVIV);
3792 sv_upgrade(dstr, SVt_PV);
3795 if (dtype < SVt_PVIV)
3796 sv_upgrade(dstr, SVt_PVIV);
3799 if (dtype < SVt_PVNV)
3800 sv_upgrade(dstr, SVt_PVNV);
3807 const char * const type = sv_reftype(sstr,0);
3809 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3811 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3816 if (dtype <= SVt_PVGV) {
3818 if (dtype != SVt_PVGV) {
3819 const char * const name = GvNAME(sstr);
3820 const STRLEN len = GvNAMELEN(sstr);
3821 /* don't upgrade SVt_PVLV: it can hold a glob */
3822 if (dtype != SVt_PVLV)
3823 sv_upgrade(dstr, SVt_PVGV);
3824 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3825 GvSTASH(dstr) = GvSTASH(sstr);
3827 Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3828 GvNAME(dstr) = savepvn(name, len);
3829 GvNAMELEN(dstr) = len;
3830 SvFAKE_on(dstr); /* can coerce to non-glob */
3832 /* ahem, death to those who redefine active sort subs */
3833 else if (PL_curstackinfo->si_type == PERLSI_SORT
3834 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3835 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3838 #ifdef GV_UNIQUE_CHECK
3839 if (GvUNIQUE((GV*)dstr)) {
3840 Perl_croak(aTHX_ PL_no_modify);
3844 (void)SvOK_off(dstr);
3845 GvINTRO_off(dstr); /* one-shot flag */
3847 GvGP(dstr) = gp_ref(GvGP(sstr));
3848 if (SvTAINTED(sstr))
3850 if (GvIMPORTED(dstr) != GVf_IMPORTED
3851 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3853 GvIMPORTED_on(dstr);
3861 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3863 if ((int)SvTYPE(sstr) != stype) {
3864 stype = SvTYPE(sstr);
3865 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3869 if (stype == SVt_PVLV)
3870 SvUPGRADE(dstr, SVt_PVNV);
3872 SvUPGRADE(dstr, (U32)stype);
3875 sflags = SvFLAGS(sstr);
3877 if (sflags & SVf_ROK) {
3878 if (dtype >= SVt_PV) {
3879 if (dtype == SVt_PVGV) {
3880 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3882 const int intro = GvINTRO(dstr);
3884 #ifdef GV_UNIQUE_CHECK
3885 if (GvUNIQUE((GV*)dstr)) {
3886 Perl_croak(aTHX_ PL_no_modify);
3891 GvINTRO_off(dstr); /* one-shot flag */
3892 GvLINE(dstr) = CopLINE(PL_curcop);
3893 GvEGV(dstr) = (GV*)dstr;
3896 switch (SvTYPE(sref)) {
3899 SAVEGENERICSV(GvAV(dstr));
3901 dref = (SV*)GvAV(dstr);
3902 GvAV(dstr) = (AV*)sref;
3903 if (!GvIMPORTED_AV(dstr)
3904 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3906 GvIMPORTED_AV_on(dstr);
3911 SAVEGENERICSV(GvHV(dstr));
3913 dref = (SV*)GvHV(dstr);
3914 GvHV(dstr) = (HV*)sref;
3915 if (!GvIMPORTED_HV(dstr)
3916 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3918 GvIMPORTED_HV_on(dstr);
3923 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3924 SvREFCNT_dec(GvCV(dstr));
3925 GvCV(dstr) = Nullcv;
3926 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3927 PL_sub_generation++;
3929 SAVEGENERICSV(GvCV(dstr));
3932 dref = (SV*)GvCV(dstr);
3933 if (GvCV(dstr) != (CV*)sref) {
3934 CV* const cv = GvCV(dstr);
3936 if (!GvCVGEN((GV*)dstr) &&
3937 (CvROOT(cv) || CvXSUB(cv)))
3939 /* ahem, death to those who redefine
3940 * active sort subs */
3941 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3942 PL_sortcop == CvSTART(cv))
3944 "Can't redefine active sort subroutine %s",
3945 GvENAME((GV*)dstr));
3946 /* Redefining a sub - warning is mandatory if
3947 it was a const and its value changed. */
3948 if (ckWARN(WARN_REDEFINE)
3950 && (!CvCONST((CV*)sref)
3951 || sv_cmp(cv_const_sv(cv),
3952 cv_const_sv((CV*)sref)))))
3954 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3956 ? "Constant subroutine %s::%s redefined"
3957 : "Subroutine %s::%s redefined",
3958 HvNAME_get(GvSTASH((GV*)dstr)),
3959 GvENAME((GV*)dstr));
3963 cv_ckproto(cv, (GV*)dstr,
3965 ? SvPVX_const(sref) : Nullch);
3967 GvCV(dstr) = (CV*)sref;
3968 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3969 GvASSUMECV_on(dstr);
3970 PL_sub_generation++;
3972 if (!GvIMPORTED_CV(dstr)
3973 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3975 GvIMPORTED_CV_on(dstr);
3980 SAVEGENERICSV(GvIOp(dstr));
3982 dref = (SV*)GvIOp(dstr);
3983 GvIOp(dstr) = (IO*)sref;
3987 SAVEGENERICSV(GvFORM(dstr));
3989 dref = (SV*)GvFORM(dstr);
3990 GvFORM(dstr) = (CV*)sref;
3994 SAVEGENERICSV(GvSV(dstr));
3996 dref = (SV*)GvSV(dstr);
3998 if (!GvIMPORTED_SV(dstr)
3999 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4001 GvIMPORTED_SV_on(dstr);
4007 if (SvTAINTED(sstr))
4011 if (SvPVX_const(dstr)) {
4017 (void)SvOK_off(dstr);
4018 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4020 if (sflags & SVp_NOK) {
4022 /* Only set the public OK flag if the source has public OK. */
4023 if (sflags & SVf_NOK)
4024 SvFLAGS(dstr) |= SVf_NOK;
4025 SvNV_set(dstr, SvNVX(sstr));
4027 if (sflags & SVp_IOK) {
4028 (void)SvIOKp_on(dstr);
4029 if (sflags & SVf_IOK)
4030 SvFLAGS(dstr) |= SVf_IOK;
4031 if (sflags & SVf_IVisUV)
4033 SvIV_set(dstr, SvIVX(sstr));
4035 if (SvAMAGIC(sstr)) {
4039 else if (sflags & SVp_POK) {
4043 * Check to see if we can just swipe the string. If so, it's a
4044 * possible small lose on short strings, but a big win on long ones.
4045 * It might even be a win on short strings if SvPVX_const(dstr)
4046 * has to be allocated and SvPVX_const(sstr) has to be freed.
4049 /* Whichever path we take through the next code, we want this true,
4050 and doing it now facilitates the COW check. */
4051 (void)SvPOK_only(dstr);
4054 /* We're not already COW */
4055 ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4056 #ifndef PERL_OLD_COPY_ON_WRITE
4057 /* or we are, but dstr isn't a suitable target. */
4058 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4063 (sflags & SVs_TEMP) && /* slated for free anyway? */
4064 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4065 (!(flags & SV_NOSTEAL)) &&
4066 /* and we're allowed to steal temps */
4067 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4068 SvLEN(sstr) && /* and really is a string */
4069 /* and won't be needed again, potentially */
4070 !(PL_op && PL_op->op_type == OP_AASSIGN))
4071 #ifdef PERL_OLD_COPY_ON_WRITE
4072 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4073 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4074 && SvTYPE(sstr) >= SVt_PVIV)
4077 /* Failed the swipe test, and it's not a shared hash key either.
4078 Have to copy the string. */
4079 STRLEN len = SvCUR(sstr);
4080 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4081 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4082 SvCUR_set(dstr, len);
4083 *SvEND(dstr) = '\0';
4085 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4087 /* Either it's a shared hash key, or it's suitable for
4088 copy-on-write or we can swipe the string. */
4090 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4094 #ifdef PERL_OLD_COPY_ON_WRITE
4096 /* I believe I should acquire a global SV mutex if
4097 it's a COW sv (not a shared hash key) to stop
4098 it going un copy-on-write.
4099 If the source SV has gone un copy on write between up there
4100 and down here, then (assert() that) it is of the correct
4101 form to make it copy on write again */
4102 if ((sflags & (SVf_FAKE | SVf_READONLY))
4103 != (SVf_FAKE | SVf_READONLY)) {
4104 SvREADONLY_on(sstr);
4106 /* Make the source SV into a loop of 1.
4107 (about to become 2) */
4108 SV_COW_NEXT_SV_SET(sstr, sstr);
4112 /* Initial code is common. */
4113 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4118 /* making another shared SV. */
4119 STRLEN cur = SvCUR(sstr);
4120 STRLEN len = SvLEN(sstr);
4121 #ifdef PERL_OLD_COPY_ON_WRITE
4123 assert (SvTYPE(dstr) >= SVt_PVIV);
4124 /* SvIsCOW_normal */
4125 /* splice us in between source and next-after-source. */
4126 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4127 SV_COW_NEXT_SV_SET(sstr, dstr);
4128 SvPV_set(dstr, SvPVX_mutable(sstr));
4132 /* SvIsCOW_shared_hash */
4133 DEBUG_C(PerlIO_printf(Perl_debug_log,
4134 "Copy on write: Sharing hash\n"));
4136 assert (SvTYPE(dstr) >= SVt_PV);
4138 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4140 SvLEN_set(dstr, len);
4141 SvCUR_set(dstr, cur);
4142 SvREADONLY_on(dstr);
4144 /* Relesase a global SV mutex. */
4147 { /* Passes the swipe test. */
4148 SvPV_set(dstr, SvPVX_mutable(sstr));
4149 SvLEN_set(dstr, SvLEN(sstr));
4150 SvCUR_set(dstr, SvCUR(sstr));
4153 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4154 SvPV_set(sstr, Nullch);
4160 if (sflags & SVf_UTF8)
4162 if (sflags & SVp_NOK) {
4164 if (sflags & SVf_NOK)
4165 SvFLAGS(dstr) |= SVf_NOK;
4166 SvNV_set(dstr, SvNVX(sstr));
4168 if (sflags & SVp_IOK) {
4169 (void)SvIOKp_on(dstr);
4170 if (sflags & SVf_IOK)
4171 SvFLAGS(dstr) |= SVf_IOK;
4172 if (sflags & SVf_IVisUV)
4174 SvIV_set(dstr, SvIVX(sstr));
4177 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4178 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4179 smg->mg_ptr, smg->mg_len);
4180 SvRMAGICAL_on(dstr);
4183 else if (sflags & SVp_IOK) {
4184 if (sflags & SVf_IOK)
4185 (void)SvIOK_only(dstr);
4187 (void)SvOK_off(dstr);
4188 (void)SvIOKp_on(dstr);
4190 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4191 if (sflags & SVf_IVisUV)
4193 SvIV_set(dstr, SvIVX(sstr));
4194 if (sflags & SVp_NOK) {
4195 if (sflags & SVf_NOK)
4196 (void)SvNOK_on(dstr);
4198 (void)SvNOKp_on(dstr);
4199 SvNV_set(dstr, SvNVX(sstr));
4202 else if (sflags & SVp_NOK) {
4203 if (sflags & SVf_NOK)
4204 (void)SvNOK_only(dstr);
4206 (void)SvOK_off(dstr);
4209 SvNV_set(dstr, SvNVX(sstr));
4212 if (dtype == SVt_PVGV) {
4213 if (ckWARN(WARN_MISC))
4214 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4217 (void)SvOK_off(dstr);
4219 if (SvTAINTED(sstr))
4224 =for apidoc sv_setsv_mg
4226 Like C<sv_setsv>, but also handles 'set' magic.
4232 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4234 sv_setsv(dstr,sstr);
4238 #ifdef PERL_OLD_COPY_ON_WRITE
4240 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4242 STRLEN cur = SvCUR(sstr);
4243 STRLEN len = SvLEN(sstr);
4244 register char *new_pv;
4247 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4255 if (SvTHINKFIRST(dstr))
4256 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4257 else if (SvPVX_const(dstr))
4258 Safefree(SvPVX_const(dstr));
4262 SvUPGRADE(dstr, SVt_PVIV);
4264 assert (SvPOK(sstr));
4265 assert (SvPOKp(sstr));
4266 assert (!SvIOK(sstr));
4267 assert (!SvIOKp(sstr));
4268 assert (!SvNOK(sstr));
4269 assert (!SvNOKp(sstr));
4271 if (SvIsCOW(sstr)) {
4273 if (SvLEN(sstr) == 0) {
4274 /* source is a COW shared hash key. */
4275 DEBUG_C(PerlIO_printf(Perl_debug_log,
4276 "Fast copy on write: Sharing hash\n"));
4277 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4280 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4282 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4283 SvUPGRADE(sstr, SVt_PVIV);
4284 SvREADONLY_on(sstr);
4286 DEBUG_C(PerlIO_printf(Perl_debug_log,
4287 "Fast copy on write: Converting sstr to COW\n"));
4288 SV_COW_NEXT_SV_SET(dstr, sstr);
4290 SV_COW_NEXT_SV_SET(sstr, dstr);
4291 new_pv = SvPVX_mutable(sstr);
4294 SvPV_set(dstr, new_pv);
4295 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4298 SvLEN_set(dstr, len);
4299 SvCUR_set(dstr, cur);
4308 =for apidoc sv_setpvn
4310 Copies a string into an SV. The C<len> parameter indicates the number of
4311 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4312 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4318 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4320 register char *dptr;
4322 SV_CHECK_THINKFIRST_COW_DROP(sv);
4328 /* len is STRLEN which is unsigned, need to copy to signed */
4331 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4333 SvUPGRADE(sv, SVt_PV);
4335 dptr = SvGROW(sv, len + 1);
4336 Move(ptr,dptr,len,char);
4339 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4344 =for apidoc sv_setpvn_mg
4346 Like C<sv_setpvn>, but also handles 'set' magic.
4352 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4354 sv_setpvn(sv,ptr,len);
4359 =for apidoc sv_setpv
4361 Copies a string into an SV. The string must be null-terminated. Does not
4362 handle 'set' magic. See C<sv_setpv_mg>.
4368 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4370 register STRLEN len;
4372 SV_CHECK_THINKFIRST_COW_DROP(sv);
4378 SvUPGRADE(sv, SVt_PV);
4380 SvGROW(sv, len + 1);
4381 Move(ptr,SvPVX(sv),len+1,char);
4383 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4388 =for apidoc sv_setpv_mg
4390 Like C<sv_setpv>, but also handles 'set' magic.
4396 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4403 =for apidoc sv_usepvn
4405 Tells an SV to use C<ptr> to find its string value. Normally the string is
4406 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4407 The C<ptr> should point to memory that was allocated by C<malloc>. The
4408 string length, C<len>, must be supplied. This function will realloc the
4409 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4410 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4411 See C<sv_usepvn_mg>.
4417 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4420 SV_CHECK_THINKFIRST_COW_DROP(sv);
4421 SvUPGRADE(sv, SVt_PV);
4426 if (SvPVX_const(sv))
4429 allocate = PERL_STRLEN_ROUNDUP(len + 1);
4430 ptr = saferealloc (ptr, allocate);
4433 SvLEN_set(sv, allocate);
4435 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4440 =for apidoc sv_usepvn_mg
4442 Like C<sv_usepvn>, but also handles 'set' magic.
4448 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4450 sv_usepvn(sv,ptr,len);
4454 #ifdef PERL_OLD_COPY_ON_WRITE
4455 /* Need to do this *after* making the SV normal, as we need the buffer
4456 pointer to remain valid until after we've copied it. If we let go too early,
4457 another thread could invalidate it by unsharing last of the same hash key
4458 (which it can do by means other than releasing copy-on-write Svs)
4459 or by changing the other copy-on-write SVs in the loop. */
4461 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
4463 if (len) { /* this SV was SvIsCOW_normal(sv) */
4464 /* we need to find the SV pointing to us. */
4465 SV * const current = SV_COW_NEXT_SV(after);
4467 if (current == sv) {
4468 /* The SV we point to points back to us (there were only two of us
4470 Hence other SV is no longer copy on write either. */
4472 SvREADONLY_off(after);
4474 /* We need to follow the pointers around the loop. */
4476 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4479 /* don't loop forever if the structure is bust, and we have
4480 a pointer into a closed loop. */
4481 assert (current != after);
4482 assert (SvPVX_const(current) == pvx);
4484 /* Make the SV before us point to the SV after us. */
4485 SV_COW_NEXT_SV_SET(current, after);
4488 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4493 Perl_sv_release_IVX(pTHX_ register SV *sv)
4496 sv_force_normal_flags(sv, 0);
4502 =for apidoc sv_force_normal_flags
4504 Undo various types of fakery on an SV: if the PV is a shared string, make
4505 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4506 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4507 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4508 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4509 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4510 set to some other value.) In addition, the C<flags> parameter gets passed to
4511 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4512 with flags set to 0.
4518 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4520 #ifdef PERL_OLD_COPY_ON_WRITE
4521 if (SvREADONLY(sv)) {
4522 /* At this point I believe I should acquire a global SV mutex. */
4524 const char * const pvx = SvPVX_const(sv);
4525 const STRLEN len = SvLEN(sv);
4526 const STRLEN cur = SvCUR(sv);
4527 SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
4529 PerlIO_printf(Perl_debug_log,
4530 "Copy on write: Force normal %ld\n",
4536 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4537 SvPV_set(sv, (char*)0);
4539 if (flags & SV_COW_DROP_PV) {
4540 /* OK, so we don't need to copy our buffer. */
4543 SvGROW(sv, cur + 1);
4544 Move(pvx,SvPVX(sv),cur,char);
4548 sv_release_COW(sv, pvx, len, next);
4553 else if (IN_PERL_RUNTIME)
4554 Perl_croak(aTHX_ PL_no_modify);
4555 /* At this point I believe that I can drop the global SV mutex. */
4558 if (SvREADONLY(sv)) {
4560 const char * const pvx = SvPVX_const(sv);
4561 const STRLEN len = SvCUR(sv);
4564 SvPV_set(sv, Nullch);
4566 SvGROW(sv, len + 1);
4567 Move(pvx,SvPVX(sv),len,char);
4569 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4571 else if (IN_PERL_RUNTIME)
4572 Perl_croak(aTHX_ PL_no_modify);
4576 sv_unref_flags(sv, flags);
4577 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4582 =for apidoc sv_force_normal
4584 Undo various types of fakery on an SV: if the PV is a shared string, make
4585 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4586 an xpvmg. See also C<sv_force_normal_flags>.
4592 Perl_sv_force_normal(pTHX_ register SV *sv)
4594 sv_force_normal_flags(sv, 0);
4600 Efficient removal of characters from the beginning of the string buffer.
4601 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4602 the string buffer. The C<ptr> becomes the first character of the adjusted
4603 string. Uses the "OOK hack".
4604 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4605 refer to the same chunk of data.
4611 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
4613 register STRLEN delta;
4614 if (!ptr || !SvPOKp(sv))
4616 delta = ptr - SvPVX_const(sv);
4617 SV_CHECK_THINKFIRST(sv);
4618 if (SvTYPE(sv) < SVt_PVIV)
4619 sv_upgrade(sv,SVt_PVIV);
4622 if (!SvLEN(sv)) { /* make copy of shared string */
4623 const char *pvx = SvPVX_const(sv);
4624 const STRLEN len = SvCUR(sv);
4625 SvGROW(sv, len + 1);
4626 Move(pvx,SvPVX(sv),len,char);
4630 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
4631 and we do that anyway inside the SvNIOK_off
4633 SvFLAGS(sv) |= SVf_OOK;
4636 SvLEN_set(sv, SvLEN(sv) - delta);
4637 SvCUR_set(sv, SvCUR(sv) - delta);
4638 SvPV_set(sv, SvPVX(sv) + delta);
4639 SvIV_set(sv, SvIVX(sv) + delta);
4643 =for apidoc sv_catpvn
4645 Concatenates the string onto the end of the string which is in the SV. The
4646 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4647 status set, then the bytes appended should be valid UTF-8.
4648 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4650 =for apidoc sv_catpvn_flags
4652 Concatenates the string onto the end of the string which is in the SV. The
4653 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4654 status set, then the bytes appended should be valid UTF-8.
4655 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4656 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4657 in terms of this function.
4663 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4666 const char *dstr = SvPV_force_flags(dsv, dlen, flags);
4668 SvGROW(dsv, dlen + slen + 1);
4670 sstr = SvPVX_const(dsv);
4671 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4672 SvCUR_set(dsv, SvCUR(dsv) + slen);
4674 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4679 =for apidoc sv_catpvn_mg
4681 Like C<sv_catpvn>, but also handles 'set' magic.
4687 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4689 sv_catpvn(sv,ptr,len);
4694 =for apidoc sv_catsv
4696 Concatenates the string from SV C<ssv> onto the end of the string in
4697 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4698 not 'set' magic. See C<sv_catsv_mg>.
4700 =for apidoc sv_catsv_flags
4702 Concatenates the string from SV C<ssv> onto the end of the string in
4703 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4704 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4705 and C<sv_catsv_nomg> are implemented in terms of this function.
4710 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4716 if ((spv = SvPV_const(ssv, slen))) {
4717 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4718 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4719 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4720 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4721 dsv->sv_flags doesn't have that bit set.
4722 Andy Dougherty 12 Oct 2001
4724 const I32 sutf8 = DO_UTF8(ssv);
4727 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4729 dutf8 = DO_UTF8(dsv);
4731 if (dutf8 != sutf8) {
4733 /* Not modifying source SV, so taking a temporary copy. */
4734 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4736 sv_utf8_upgrade(csv);
4737 spv = SvPV_const(csv, slen);
4740 sv_utf8_upgrade_nomg(dsv);
4742 sv_catpvn_nomg(dsv, spv, slen);
4747 =for apidoc sv_catsv_mg
4749 Like C<sv_catsv>, but also handles 'set' magic.
4755 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4762 =for apidoc sv_catpv
4764 Concatenates the string onto the end of the string which is in the SV.
4765 If the SV has the UTF-8 status set, then the bytes appended should be
4766 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4771 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4773 register STRLEN len;
4779 junk = SvPV_force(sv, tlen);
4781 SvGROW(sv, tlen + len + 1);
4783 ptr = SvPVX_const(sv);
4784 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4785 SvCUR_set(sv, SvCUR(sv) + len);
4786 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4791 =for apidoc sv_catpv_mg
4793 Like C<sv_catpv>, but also handles 'set' magic.
4799 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4808 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4809 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4816 Perl_newSV(pTHX_ STRLEN len)
4822 sv_upgrade(sv, SVt_PV);
4823 SvGROW(sv, len + 1);
4828 =for apidoc sv_magicext
4830 Adds magic to an SV, upgrading it if necessary. Applies the
4831 supplied vtable and returns a pointer to the magic added.
4833 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4834 In particular, you can add magic to SvREADONLY SVs, and add more than
4835 one instance of the same 'how'.
4837 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4838 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4839 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4840 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4842 (This is now used as a subroutine by C<sv_magic>.)
4847 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
4848 const char* name, I32 namlen)
4852 if (SvTYPE(sv) < SVt_PVMG) {
4853 SvUPGRADE(sv, SVt_PVMG);
4855 Newxz(mg, 1, MAGIC);
4856 mg->mg_moremagic = SvMAGIC(sv);
4857 SvMAGIC_set(sv, mg);
4859 /* Sometimes a magic contains a reference loop, where the sv and
4860 object refer to each other. To prevent a reference loop that
4861 would prevent such objects being freed, we look for such loops
4862 and if we find one we avoid incrementing the object refcount.
4864 Note we cannot do this to avoid self-tie loops as intervening RV must
4865 have its REFCNT incremented to keep it in existence.
4868 if (!obj || obj == sv ||
4869 how == PERL_MAGIC_arylen ||
4870 how == PERL_MAGIC_qr ||
4871 how == PERL_MAGIC_symtab ||
4872 (SvTYPE(obj) == SVt_PVGV &&
4873 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4874 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4875 GvFORM(obj) == (CV*)sv)))
4880 mg->mg_obj = SvREFCNT_inc(obj);
4881 mg->mg_flags |= MGf_REFCOUNTED;
4884 /* Normal self-ties simply pass a null object, and instead of
4885 using mg_obj directly, use the SvTIED_obj macro to produce a
4886 new RV as needed. For glob "self-ties", we are tieing the PVIO
4887 with an RV obj pointing to the glob containing the PVIO. In
4888 this case, to avoid a reference loop, we need to weaken the
4892 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4893 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4899 mg->mg_len = namlen;
4902 mg->mg_ptr = savepvn(name, namlen);
4903 else if (namlen == HEf_SVKEY)
4904 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4906 mg->mg_ptr = (char *) name;
4908 mg->mg_virtual = vtable;
4912 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4917 =for apidoc sv_magic
4919 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4920 then adds a new magic item of type C<how> to the head of the magic list.
4922 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4923 handling of the C<name> and C<namlen> arguments.
4925 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4926 to add more than one instance of the same 'how'.
4932 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4934 const MGVTBL *vtable;
4937 #ifdef PERL_OLD_COPY_ON_WRITE
4939 sv_force_normal_flags(sv, 0);
4941 if (SvREADONLY(sv)) {
4943 /* its okay to attach magic to shared strings; the subsequent
4944 * upgrade to PVMG will unshare the string */
4945 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4948 && how != PERL_MAGIC_regex_global
4949 && how != PERL_MAGIC_bm
4950 && how != PERL_MAGIC_fm
4951 && how != PERL_MAGIC_sv
4952 && how != PERL_MAGIC_backref
4955 Perl_croak(aTHX_ PL_no_modify);
4958 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4959 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4960 /* sv_magic() refuses to add a magic of the same 'how' as an
4963 if (how == PERL_MAGIC_taint)
4971 vtable = &PL_vtbl_sv;
4973 case PERL_MAGIC_overload:
4974 vtable = &PL_vtbl_amagic;
4976 case PERL_MAGIC_overload_elem:
4977 vtable = &PL_vtbl_amagicelem;
4979 case PERL_MAGIC_overload_table:
4980 vtable = &PL_vtbl_ovrld;
4983 vtable = &PL_vtbl_bm;
4985 case PERL_MAGIC_regdata:
4986 vtable = &PL_vtbl_regdata;
4988 case PERL_MAGIC_regdatum:
4989 vtable = &PL_vtbl_regdatum;
4991 case PERL_MAGIC_env:
4992 vtable = &PL_vtbl_env;
4995 vtable = &PL_vtbl_fm;
4997 case PERL_MAGIC_envelem:
4998 vtable = &PL_vtbl_envelem;
5000 case PERL_MAGIC_regex_global:
5001 vtable = &PL_vtbl_mglob;
5003 case PERL_MAGIC_isa:
5004 vtable = &PL_vtbl_isa;
5006 case PERL_MAGIC_isaelem:
5007 vtable = &PL_vtbl_isaelem;
5009 case PERL_MAGIC_nkeys:
5010 vtable = &PL_vtbl_nkeys;
5012 case PERL_MAGIC_dbfile:
5015 case PERL_MAGIC_dbline:
5016 vtable = &PL_vtbl_dbline;
5018 #ifdef USE_LOCALE_COLLATE
5019 case PERL_MAGIC_collxfrm:
5020 vtable = &PL_vtbl_collxfrm;
5022 #endif /* USE_LOCALE_COLLATE */
5023 case PERL_MAGIC_tied:
5024 vtable = &PL_vtbl_pack;
5026 case PERL_MAGIC_tiedelem:
5027 case PERL_MAGIC_tiedscalar:
5028 vtable = &PL_vtbl_packelem;
5031 vtable = &PL_vtbl_regexp;
5033 case PERL_MAGIC_sig:
5034 vtable = &PL_vtbl_sig;
5036 case PERL_MAGIC_sigelem:
5037 vtable = &PL_vtbl_sigelem;
5039 case PERL_MAGIC_taint:
5040 vtable = &PL_vtbl_taint;
5042 case PERL_MAGIC_uvar:
5043 vtable = &PL_vtbl_uvar;
5045 case PERL_MAGIC_vec:
5046 vtable = &PL_vtbl_vec;
5048 case PERL_MAGIC_arylen_p:
5049 case PERL_MAGIC_rhash:
5050 case PERL_MAGIC_symtab:
5051 case PERL_MAGIC_vstring:
5054 case PERL_MAGIC_utf8:
5055 vtable = &PL_vtbl_utf8;
5057 case PERL_MAGIC_substr:
5058 vtable = &PL_vtbl_substr;
5060 case PERL_MAGIC_defelem:
5061 vtable = &PL_vtbl_defelem;
5063 case PERL_MAGIC_glob:
5064 vtable = &PL_vtbl_glob;
5066 case PERL_MAGIC_arylen:
5067 vtable = &PL_vtbl_arylen;
5069 case PERL_MAGIC_pos:
5070 vtable = &PL_vtbl_pos;
5072 case PERL_MAGIC_backref:
5073 vtable = &PL_vtbl_backref;
5075 case PERL_MAGIC_ext:
5076 /* Reserved for use by extensions not perl internals. */
5077 /* Useful for attaching extension internal data to perl vars. */
5078 /* Note that multiple extensions may clash if magical scalars */
5079 /* etc holding private data from one are passed to another. */
5083 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5086 /* Rest of work is done else where */
5087 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5090 case PERL_MAGIC_taint:
5093 case PERL_MAGIC_ext:
5094 case PERL_MAGIC_dbfile:
5101 =for apidoc sv_unmagic
5103 Removes all magic of type C<type> from an SV.
5109 Perl_sv_unmagic(pTHX_ SV *sv, int type)
5113 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5116 for (mg = *mgp; mg; mg = *mgp) {
5117 if (mg->mg_type == type) {
5118 const MGVTBL* const vtbl = mg->mg_virtual;
5119 *mgp = mg->mg_moremagic;
5120 if (vtbl && vtbl->svt_free)
5121 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5122 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5124 Safefree(mg->mg_ptr);
5125 else if (mg->mg_len == HEf_SVKEY)
5126 SvREFCNT_dec((SV*)mg->mg_ptr);
5127 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
5128 Safefree(mg->mg_ptr);
5130 if (mg->mg_flags & MGf_REFCOUNTED)
5131 SvREFCNT_dec(mg->mg_obj);
5135 mgp = &mg->mg_moremagic;
5139 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5146 =for apidoc sv_rvweaken
5148 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5149 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5150 push a back-reference to this RV onto the array of backreferences
5151 associated with that magic.
5157 Perl_sv_rvweaken(pTHX_ SV *sv)
5160 if (!SvOK(sv)) /* let undefs pass */
5163 Perl_croak(aTHX_ "Can't weaken a nonreference");
5164 else if (SvWEAKREF(sv)) {
5165 if (ckWARN(WARN_MISC))
5166 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5170 Perl_sv_add_backref(aTHX_ tsv, sv);
5176 /* Give tsv backref magic if it hasn't already got it, then push a
5177 * back-reference to sv onto the array associated with the backref magic.
5181 Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
5185 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
5186 av = (AV*)mg->mg_obj;
5189 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5190 /* av now has a refcnt of 2, which avoids it getting freed
5191 * before us during global cleanup. The extra ref is removed
5192 * by magic_killbackrefs() when tsv is being freed */
5194 if (AvFILLp(av) >= AvMAX(av)) {
5195 av_extend(av, AvFILLp(av)+1);
5197 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5200 /* delete a back-reference to ourselves from the backref magic associated
5201 * with the SV we point to.
5205 S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
5211 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) {
5212 if (PL_in_clean_all)
5215 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
5216 Perl_croak(aTHX_ "panic: del_backref");
5217 av = (AV *)mg->mg_obj;
5219 /* We shouldn't be in here more than once, but for paranoia reasons lets
5221 for (i = AvFILLp(av); i >= 0; i--) {
5223 const SSize_t fill = AvFILLp(av);
5225 /* We weren't the last entry.
5226 An unordered list has this property that you can take the
5227 last element off the end to fill the hole, and it's still
5228 an unordered list :-)
5233 AvFILLp(av) = fill - 1;
5239 =for apidoc sv_insert
5241 Inserts a string at the specified offset/length within the SV. Similar to
5242 the Perl substr() function.
5248 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
5252 register char *midend;
5253 register char *bigend;
5259 Perl_croak(aTHX_ "Can't modify non-existent substring");
5260 SvPV_force(bigstr, curlen);
5261 (void)SvPOK_only_UTF8(bigstr);
5262 if (offset + len > curlen) {
5263 SvGROW(bigstr, offset+len+1);
5264 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5265 SvCUR_set(bigstr, offset+len);
5269 i = littlelen - len;
5270 if (i > 0) { /* string might grow */
5271 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5272 mid = big + offset + len;
5273 midend = bigend = big + SvCUR(bigstr);
5276 while (midend > mid) /* shove everything down */
5277 *--bigend = *--midend;
5278 Move(little,big+offset,littlelen,char);
5279 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5284 Move(little,SvPVX(bigstr)+offset,len,char);
5289 big = SvPVX(bigstr);
5292 bigend = big + SvCUR(bigstr);
5294 if (midend > bigend)
5295 Perl_croak(aTHX_ "panic: sv_insert");
5297 if (mid - big > bigend - midend) { /* faster to shorten from end */
5299 Move(little, mid, littlelen,char);
5302 i = bigend - midend;
5304 Move(midend, mid, i,char);
5308 SvCUR_set(bigstr, mid - big);
5310 else if ((i = mid - big)) { /* faster from front */
5311 midend -= littlelen;
5313 sv_chop(bigstr,midend-i);
5318 Move(little, mid, littlelen,char);
5320 else if (littlelen) {
5321 midend -= littlelen;
5322 sv_chop(bigstr,midend);
5323 Move(little,midend,littlelen,char);
5326 sv_chop(bigstr,midend);
5332 =for apidoc sv_replace
5334 Make the first argument a copy of the second, then delete the original.
5335 The target SV physically takes over ownership of the body of the source SV
5336 and inherits its flags; however, the target keeps any magic it owns,
5337 and any magic in the source is discarded.
5338 Note that this is a rather specialist SV copying operation; most of the
5339 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5345 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5347 const U32 refcnt = SvREFCNT(sv);
5348 SV_CHECK_THINKFIRST_COW_DROP(sv);
5349 if (SvREFCNT(nsv) != 1) {
5350 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
5351 UVuf " != 1)", (UV) SvREFCNT(nsv));
5353 if (SvMAGICAL(sv)) {
5357 sv_upgrade(nsv, SVt_PVMG);
5358 SvMAGIC_set(nsv, SvMAGIC(sv));
5359 SvFLAGS(nsv) |= SvMAGICAL(sv);
5361 SvMAGIC_set(sv, NULL);
5365 assert(!SvREFCNT(sv));
5366 #ifdef DEBUG_LEAKING_SCALARS
5367 sv->sv_flags = nsv->sv_flags;
5368 sv->sv_any = nsv->sv_any;
5369 sv->sv_refcnt = nsv->sv_refcnt;
5370 sv->sv_u = nsv->sv_u;
5372 StructCopy(nsv,sv,SV);
5374 /* Currently could join these into one piece of pointer arithmetic, but
5375 it would be unclear. */
5376 if(SvTYPE(sv) == SVt_IV)
5378 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5379 else if (SvTYPE(sv) == SVt_RV) {
5380 SvANY(sv) = &sv->sv_u.svu_rv;
5384 #ifdef PERL_OLD_COPY_ON_WRITE
5385 if (SvIsCOW_normal(nsv)) {
5386 /* We need to follow the pointers around the loop to make the
5387 previous SV point to sv, rather than nsv. */
5390 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5393 assert(SvPVX_const(current) == SvPVX_const(nsv));
5395 /* Make the SV before us point to the SV after us. */
5397 PerlIO_printf(Perl_debug_log, "previous is\n");
5399 PerlIO_printf(Perl_debug_log,
5400 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5401 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5403 SV_COW_NEXT_SV_SET(current, sv);
5406 SvREFCNT(sv) = refcnt;
5407 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5413 =for apidoc sv_clear
5415 Clear an SV: call any destructors, free up any memory used by the body,
5416 and free the body itself. The SV's head is I<not> freed, although
5417 its type is set to all 1's so that it won't inadvertently be assumed
5418 to be live during global destruction etc.
5419 This function should only be called when REFCNT is zero. Most of the time
5420 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5427 Perl_sv_clear(pTHX_ register SV *sv)
5430 void** old_body_arena;
5431 size_t old_body_offset;
5432 const U32 type = SvTYPE(sv);
5435 assert(SvREFCNT(sv) == 0);
5441 old_body_offset = 0;
5444 if (PL_defstash) { /* Still have a symbol table? */
5449 stash = SvSTASH(sv);
5450 destructor = StashHANDLER(stash,DESTROY);
5452 SV* const tmpref = newRV(sv);
5453 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5455 PUSHSTACKi(PERLSI_DESTROY);
5460 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5466 if(SvREFCNT(tmpref) < 2) {
5467 /* tmpref is not kept alive! */
5469 SvRV_set(tmpref, NULL);
5472 SvREFCNT_dec(tmpref);
5474 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5478 if (PL_in_clean_objs)
5479 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5481 /* DESTROY gave object new lease on life */
5487 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5488 SvOBJECT_off(sv); /* Curse the object. */
5489 if (type != SVt_PVIO)
5490 --PL_sv_objcount; /* XXX Might want something more general */
5493 if (type >= SVt_PVMG) {
5496 if (type == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
5497 SvREFCNT_dec(SvSTASH(sv));
5502 IoIFP(sv) != PerlIO_stdin() &&
5503 IoIFP(sv) != PerlIO_stdout() &&
5504 IoIFP(sv) != PerlIO_stderr())
5506 io_close((IO*)sv, FALSE);
5508 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5509 PerlDir_close(IoDIRP(sv));
5510 IoDIRP(sv) = (DIR*)NULL;
5511 Safefree(IoTOP_NAME(sv));
5512 Safefree(IoFMT_NAME(sv));
5513 Safefree(IoBOTTOM_NAME(sv));
5514 /* PVIOs aren't from arenas */
5517 old_body_arena = (void **) &PL_xpvbm_root;
5520 old_body_arena = (void **) &PL_xpvcv_root;
5522 /* PVFMs aren't from arenas */
5527 old_body_arena = (void **) &PL_xpvhv_root;
5528 old_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill);
5532 old_body_arena = (void **) &PL_xpvav_root;
5533 old_body_offset = STRUCT_OFFSET(XPVAV, xav_fill);
5536 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5537 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5538 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5539 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5541 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5542 SvREFCNT_dec(LvTARG(sv));
5543 old_body_arena = (void **) &PL_xpvlv_root;
5547 Safefree(GvNAME(sv));
5548 /* If we're in a stash, we don't own a reference to it. However it does
5549 have a back reference to us, which needs to be cleared. */
5551 sv_del_backref((SV*)GvSTASH(sv), sv);
5552 old_body_arena = (void **) &PL_xpvgv_root;
5555 old_body_arena = (void **) &PL_xpvmg_root;
5558 old_body_arena = (void **) &PL_xpvnv_root;
5561 old_body_arena = (void **) &PL_xpviv_root;
5562 old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur);
5564 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5566 SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
5567 /* Don't even bother with turning off the OOK flag. */
5571 old_body_arena = (void **) &PL_xpv_root;
5572 old_body_offset = STRUCT_OFFSET(XPV, xpv_cur);
5576 SV *target = SvRV(sv);
5578 sv_del_backref(target, sv);
5580 SvREFCNT_dec(target);
5582 #ifdef PERL_OLD_COPY_ON_WRITE
5583 else if (SvPVX_const(sv)) {
5585 /* I believe I need to grab the global SV mutex here and
5586 then recheck the COW status. */
5588 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5591 sv_release_COW(sv, SvPVX_const(sv), SvLEN(sv),
5592 SV_COW_NEXT_SV(sv));
5593 /* And drop it here. */
5595 } else if (SvLEN(sv)) {
5596 Safefree(SvPVX_const(sv));
5600 else if (SvPVX_const(sv) && SvLEN(sv))
5601 Safefree(SvPVX_mutable(sv));
5602 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5603 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5609 old_body_arena = (void **) &PL_xnv_root;
5613 SvFLAGS(sv) &= SVf_BREAK;
5614 SvFLAGS(sv) |= SVTYPEMASK;
5617 if (old_body_arena) {
5618 del_body(((char *)SvANY(sv) + old_body_offset), old_body_arena);
5622 if (type > SVt_RV) {
5623 my_safefree(SvANY(sv));
5628 =for apidoc sv_newref
5630 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5637 Perl_sv_newref(pTHX_ SV *sv)
5647 Decrement an SV's reference count, and if it drops to zero, call
5648 C<sv_clear> to invoke destructors and free up any memory used by
5649 the body; finally, deallocate the SV's head itself.
5650 Normally called via a wrapper macro C<SvREFCNT_dec>.
5656 Perl_sv_free(pTHX_ SV *sv)
5661 if (SvREFCNT(sv) == 0) {
5662 if (SvFLAGS(sv) & SVf_BREAK)
5663 /* this SV's refcnt has been artificially decremented to
5664 * trigger cleanup */
5666 if (PL_in_clean_all) /* All is fair */
5668 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5669 /* make sure SvREFCNT(sv)==0 happens very seldom */
5670 SvREFCNT(sv) = (~(U32)0)/2;
5673 if (ckWARN_d(WARN_INTERNAL)) {
5674 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5675 "Attempt to free unreferenced scalar: SV 0x%"UVxf
5676 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5677 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5678 Perl_dump_sv_child(aTHX_ sv);
5683 if (--(SvREFCNT(sv)) > 0)
5685 Perl_sv_free2(aTHX_ sv);
5689 Perl_sv_free2(pTHX_ SV *sv)
5694 if (ckWARN_d(WARN_DEBUGGING))
5695 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5696 "Attempt to free temp prematurely: SV 0x%"UVxf
5697 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5701 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5702 /* make sure SvREFCNT(sv)==0 happens very seldom */
5703 SvREFCNT(sv) = (~(U32)0)/2;
5714 Returns the length of the string in the SV. Handles magic and type
5715 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5721 Perl_sv_len(pTHX_ register SV *sv)
5729 len = mg_length(sv);
5731 (void)SvPV_const(sv, len);
5736 =for apidoc sv_len_utf8
5738 Returns the number of characters in the string in an SV, counting wide
5739 UTF-8 bytes as a single character. Handles magic and type coercion.
5745 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
5746 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
5747 * (Note that the mg_len is not the length of the mg_ptr field.)
5752 Perl_sv_len_utf8(pTHX_ register SV *sv)
5758 return mg_length(sv);
5762 const U8 *s = (U8*)SvPV_const(sv, len);
5763 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
5765 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
5767 #ifdef PERL_UTF8_CACHE_ASSERT
5768 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
5772 ulen = Perl_utf8_length(aTHX_ s, s + len);
5773 if (!mg && !SvREADONLY(sv)) {
5774 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5775 mg = mg_find(sv, PERL_MAGIC_utf8);
5785 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
5786 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5787 * between UTF-8 and byte offsets. There are two (substr offset and substr
5788 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
5789 * and byte offset) cache positions.
5791 * The mg_len field is used by sv_len_utf8(), see its comments.
5792 * Note that the mg_len is not the length of the mg_ptr field.
5796 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i,
5797 I32 offsetp, const U8 *s, const U8 *start)
5801 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5803 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
5807 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5809 Newxz(*cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5810 (*mgp)->mg_ptr = (char *) *cachep;
5814 (*cachep)[i] = offsetp;
5815 (*cachep)[i+1] = s - start;
5823 * S_utf8_mg_pos() is used to query and update mg_ptr field of
5824 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5825 * between UTF-8 and byte offsets. See also the comments of
5826 * S_utf8_mg_pos_init().
5830 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)
5834 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5836 *mgp = mg_find(sv, PERL_MAGIC_utf8);
5837 if (*mgp && (*mgp)->mg_ptr) {
5838 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5839 ASSERT_UTF8_CACHE(*cachep);
5840 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
5842 else { /* We will skip to the right spot. */
5847 /* The assumption is that going backward is half
5848 * the speed of going forward (that's where the
5849 * 2 * backw in the below comes from). (The real
5850 * figure of course depends on the UTF-8 data.) */
5852 if ((*cachep)[i] > (STRLEN)uoff) {
5854 backw = (*cachep)[i] - (STRLEN)uoff;
5856 if (forw < 2 * backw)
5859 p = start + (*cachep)[i+1];
5861 /* Try this only for the substr offset (i == 0),
5862 * not for the substr length (i == 2). */
5863 else if (i == 0) { /* (*cachep)[i] < uoff */
5864 const STRLEN ulen = sv_len_utf8(sv);
5866 if ((STRLEN)uoff < ulen) {
5867 forw = (STRLEN)uoff - (*cachep)[i];
5868 backw = ulen - (STRLEN)uoff;
5870 if (forw < 2 * backw)
5871 p = start + (*cachep)[i+1];
5876 /* If the string is not long enough for uoff,
5877 * we could extend it, but not at this low a level. */
5881 if (forw < 2 * backw) {
5888 while (UTF8_IS_CONTINUATION(*p))
5893 /* Update the cache. */
5894 (*cachep)[i] = (STRLEN)uoff;
5895 (*cachep)[i+1] = p - start;
5897 /* Drop the stale "length" cache */
5906 if (found) { /* Setup the return values. */
5907 *offsetp = (*cachep)[i+1];
5908 *sp = start + *offsetp;
5911 *offsetp = send - start;
5913 else if (*sp < start) {
5919 #ifdef PERL_UTF8_CACHE_ASSERT
5924 while (n-- && s < send)
5928 assert(*offsetp == s - start);
5929 assert((*cachep)[0] == (STRLEN)uoff);
5930 assert((*cachep)[1] == *offsetp);
5932 ASSERT_UTF8_CACHE(*cachep);
5941 =for apidoc sv_pos_u2b
5943 Converts the value pointed to by offsetp from a count of UTF-8 chars from
5944 the start of the string, to a count of the equivalent number of bytes; if
5945 lenp is non-zero, it does the same to lenp, but this time starting from
5946 the offset, rather than from the start of the string. Handles magic and
5953 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
5954 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5955 * byte offsets. See also the comments of S_utf8_mg_pos().
5960 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5968 start = (U8*)SvPV_const(sv, len);
5972 const U8 *s = start;
5973 I32 uoffset = *offsetp;
5974 const U8 * const send = s + len;
5978 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
5980 if (!found && uoffset > 0) {
5981 while (s < send && uoffset--)
5985 if (utf8_mg_pos_init(sv, &mg, &cache, 0, *offsetp, s, start))
5987 *offsetp = s - start;
5992 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) {
5996 if (!found && *lenp > 0) {
5999 while (s < send && ulen--)
6003 utf8_mg_pos_init(sv, &mg, &cache, 2, *lenp, s, start);
6007 ASSERT_UTF8_CACHE(cache);
6019 =for apidoc sv_pos_b2u
6021 Converts the value pointed to by offsetp from a count of bytes from the
6022 start of the string, to a count of the equivalent number of UTF-8 chars.
6023 Handles magic and type coercion.
6029 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6030 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6031 * byte offsets. See also the comments of S_utf8_mg_pos().
6036 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
6044 s = (const U8*)SvPV_const(sv, len);
6045 if ((I32)len < *offsetp)
6046 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6048 const U8* send = s + *offsetp;
6050 STRLEN *cache = NULL;
6054 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6055 mg = mg_find(sv, PERL_MAGIC_utf8);
6056 if (mg && mg->mg_ptr) {
6057 cache = (STRLEN *) mg->mg_ptr;
6058 if (cache[1] == (STRLEN)*offsetp) {
6059 /* An exact match. */
6060 *offsetp = cache[0];
6064 else if (cache[1] < (STRLEN)*offsetp) {
6065 /* We already know part of the way. */
6068 /* Let the below loop do the rest. */
6070 else { /* cache[1] > *offsetp */
6071 /* We already know all of the way, now we may
6072 * be able to walk back. The same assumption
6073 * is made as in S_utf8_mg_pos(), namely that
6074 * walking backward is twice slower than
6075 * walking forward. */
6076 const STRLEN forw = *offsetp;
6077 STRLEN backw = cache[1] - *offsetp;
6079 if (!(forw < 2 * backw)) {
6080 const U8 *p = s + cache[1];
6087 while (UTF8_IS_CONTINUATION(*p)) {
6095 *offsetp = cache[0];
6097 /* Drop the stale "length" cache */
6105 ASSERT_UTF8_CACHE(cache);
6111 /* Call utf8n_to_uvchr() to validate the sequence
6112 * (unless a simple non-UTF character) */
6113 if (!UTF8_IS_INVARIANT(*s))
6114 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
6123 if (!SvREADONLY(sv)) {
6125 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6126 mg = mg_find(sv, PERL_MAGIC_utf8);
6131 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6132 mg->mg_ptr = (char *) cache;
6137 cache[1] = *offsetp;
6138 /* Drop the stale "length" cache */
6151 Returns a boolean indicating whether the strings in the two SVs are
6152 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6153 coerce its args to strings if necessary.
6159 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6167 SV* svrecode = Nullsv;
6174 pv1 = SvPV_const(sv1, cur1);
6181 pv2 = SvPV_const(sv2, cur2);
6183 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6184 /* Differing utf8ness.
6185 * Do not UTF8size the comparands as a side-effect. */
6188 svrecode = newSVpvn(pv2, cur2);
6189 sv_recode_to_utf8(svrecode, PL_encoding);
6190 pv2 = SvPV_const(svrecode, cur2);
6193 svrecode = newSVpvn(pv1, cur1);
6194 sv_recode_to_utf8(svrecode, PL_encoding);
6195 pv1 = SvPV_const(svrecode, cur1);
6197 /* Now both are in UTF-8. */
6199 SvREFCNT_dec(svrecode);
6204 bool is_utf8 = TRUE;
6207 /* sv1 is the UTF-8 one,
6208 * if is equal it must be downgrade-able */
6209 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6215 /* sv2 is the UTF-8 one,
6216 * if is equal it must be downgrade-able */
6217 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6223 /* Downgrade not possible - cannot be eq */
6231 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6234 SvREFCNT_dec(svrecode);
6245 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6246 string in C<sv1> is less than, equal to, or greater than the string in
6247 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6248 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6254 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6257 const char *pv1, *pv2;
6260 SV *svrecode = Nullsv;
6267 pv1 = SvPV_const(sv1, cur1);
6274 pv2 = SvPV_const(sv2, cur2);
6276 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6277 /* Differing utf8ness.
6278 * Do not UTF8size the comparands as a side-effect. */
6281 svrecode = newSVpvn(pv2, cur2);
6282 sv_recode_to_utf8(svrecode, PL_encoding);
6283 pv2 = SvPV_const(svrecode, cur2);
6286 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6291 svrecode = newSVpvn(pv1, cur1);
6292 sv_recode_to_utf8(svrecode, PL_encoding);
6293 pv1 = SvPV_const(svrecode, cur1);
6296 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6302 cmp = cur2 ? -1 : 0;
6306 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6309 cmp = retval < 0 ? -1 : 1;
6310 } else if (cur1 == cur2) {
6313 cmp = cur1 < cur2 ? -1 : 1;
6318 SvREFCNT_dec(svrecode);
6327 =for apidoc sv_cmp_locale
6329 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6330 'use bytes' aware, handles get magic, and will coerce its args to strings
6331 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6337 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6339 #ifdef USE_LOCALE_COLLATE
6345 if (PL_collation_standard)
6349 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6351 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6353 if (!pv1 || !len1) {
6364 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6367 return retval < 0 ? -1 : 1;
6370 * When the result of collation is equality, that doesn't mean
6371 * that there are no differences -- some locales exclude some
6372 * characters from consideration. So to avoid false equalities,
6373 * we use the raw string as a tiebreaker.
6379 #endif /* USE_LOCALE_COLLATE */
6381 return sv_cmp(sv1, sv2);
6385 #ifdef USE_LOCALE_COLLATE
6388 =for apidoc sv_collxfrm
6390 Add Collate Transform magic to an SV if it doesn't already have it.
6392 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6393 scalar data of the variable, but transformed to such a format that a normal
6394 memory comparison can be used to compare the data according to the locale
6401 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6405 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6406 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6412 Safefree(mg->mg_ptr);
6413 s = SvPV_const(sv, len);
6414 if ((xf = mem_collxfrm(s, len, &xlen))) {
6415 if (SvREADONLY(sv)) {
6418 return xf + sizeof(PL_collation_ix);
6421 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6422 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6435 if (mg && mg->mg_ptr) {
6437 return mg->mg_ptr + sizeof(PL_collation_ix);
6445 #endif /* USE_LOCALE_COLLATE */
6450 Get a line from the filehandle and store it into the SV, optionally
6451 appending to the currently-stored string.
6457 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6461 register STDCHAR rslast;
6462 register STDCHAR *bp;
6468 if (SvTHINKFIRST(sv))
6469 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6470 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6472 However, perlbench says it's slower, because the existing swipe code
6473 is faster than copy on write.
6474 Swings and roundabouts. */
6475 SvUPGRADE(sv, SVt_PV);
6480 if (PerlIO_isutf8(fp)) {
6482 sv_utf8_upgrade_nomg(sv);
6483 sv_pos_u2b(sv,&append,0);
6485 } else if (SvUTF8(sv)) {
6486 SV * const tsv = NEWSV(0,0);
6487 sv_gets(tsv, fp, 0);
6488 sv_utf8_upgrade_nomg(tsv);
6489 SvCUR_set(sv,append);
6492 goto return_string_or_null;
6497 if (PerlIO_isutf8(fp))
6500 if (IN_PERL_COMPILETIME) {
6501 /* we always read code in line mode */
6505 else if (RsSNARF(PL_rs)) {
6506 /* If it is a regular disk file use size from stat() as estimate
6507 of amount we are going to read - may result in malloc-ing
6508 more memory than we realy need if layers bellow reduce
6509 size we read (e.g. CRLF or a gzip layer)
6512 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6513 const Off_t offset = PerlIO_tell(fp);
6514 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6515 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6521 else if (RsRECORD(PL_rs)) {
6525 /* Grab the size of the record we're getting */
6526 recsize = SvIV(SvRV(PL_rs));
6527 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6530 /* VMS wants read instead of fread, because fread doesn't respect */
6531 /* RMS record boundaries. This is not necessarily a good thing to be */
6532 /* doing, but we've got no other real choice - except avoid stdio
6533 as implementation - perhaps write a :vms layer ?
6535 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6537 bytesread = PerlIO_read(fp, buffer, recsize);
6541 SvCUR_set(sv, bytesread += append);
6542 buffer[bytesread] = '\0';
6543 goto return_string_or_null;
6545 else if (RsPARA(PL_rs)) {
6551 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6552 if (PerlIO_isutf8(fp)) {
6553 rsptr = SvPVutf8(PL_rs, rslen);
6556 if (SvUTF8(PL_rs)) {
6557 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6558 Perl_croak(aTHX_ "Wide character in $/");
6561 rsptr = SvPV_const(PL_rs, rslen);
6565 rslast = rslen ? rsptr[rslen - 1] : '\0';
6567 if (rspara) { /* have to do this both before and after */
6568 do { /* to make sure file boundaries work right */
6571 i = PerlIO_getc(fp);
6575 PerlIO_ungetc(fp,i);
6581 /* See if we know enough about I/O mechanism to cheat it ! */
6583 /* This used to be #ifdef test - it is made run-time test for ease
6584 of abstracting out stdio interface. One call should be cheap
6585 enough here - and may even be a macro allowing compile
6589 if (PerlIO_fast_gets(fp)) {
6592 * We're going to steal some values from the stdio struct
6593 * and put EVERYTHING in the innermost loop into registers.
6595 register STDCHAR *ptr;
6599 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6600 /* An ungetc()d char is handled separately from the regular
6601 * buffer, so we getc() it back out and stuff it in the buffer.
6603 i = PerlIO_getc(fp);
6604 if (i == EOF) return 0;
6605 *(--((*fp)->_ptr)) = (unsigned char) i;
6609 /* Here is some breathtakingly efficient cheating */
6611 cnt = PerlIO_get_cnt(fp); /* get count into register */
6612 /* make sure we have the room */
6613 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
6614 /* Not room for all of it
6615 if we are looking for a separator and room for some
6617 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
6618 /* just process what we have room for */
6619 shortbuffered = cnt - SvLEN(sv) + append + 1;
6620 cnt -= shortbuffered;
6624 /* remember that cnt can be negative */
6625 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
6630 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
6631 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
6632 DEBUG_P(PerlIO_printf(Perl_debug_log,
6633 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6634 DEBUG_P(PerlIO_printf(Perl_debug_log,
6635 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6636 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6637 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6642 while (cnt > 0) { /* this | eat */
6644 if ((*bp++ = *ptr++) == rslast) /* really | dust */
6645 goto thats_all_folks; /* screams | sed :-) */
6649 Copy(ptr, bp, cnt, char); /* this | eat */
6650 bp += cnt; /* screams | dust */
6651 ptr += cnt; /* louder | sed :-) */
6656 if (shortbuffered) { /* oh well, must extend */
6657 cnt = shortbuffered;
6659 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6661 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6662 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6666 DEBUG_P(PerlIO_printf(Perl_debug_log,
6667 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6668 PTR2UV(ptr),(long)cnt));
6669 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6671 DEBUG_P(PerlIO_printf(Perl_debug_log,
6672 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6673 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6674 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6676 /* This used to call 'filbuf' in stdio form, but as that behaves like
6677 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6678 another abstraction. */
6679 i = PerlIO_getc(fp); /* get more characters */
6681 DEBUG_P(PerlIO_printf(Perl_debug_log,
6682 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6683 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6684 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6686 cnt = PerlIO_get_cnt(fp);
6687 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
6688 DEBUG_P(PerlIO_printf(Perl_debug_log,
6689 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6691 if (i == EOF) /* all done for ever? */
6692 goto thats_really_all_folks;
6694 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6696 SvGROW(sv, bpx + cnt + 2);
6697 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6699 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
6701 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
6702 goto thats_all_folks;
6706 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
6707 memNE((char*)bp - rslen, rsptr, rslen))
6708 goto screamer; /* go back to the fray */
6709 thats_really_all_folks:
6711 cnt += shortbuffered;
6712 DEBUG_P(PerlIO_printf(Perl_debug_log,
6713 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6714 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
6715 DEBUG_P(PerlIO_printf(Perl_debug_log,
6716 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6717 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6718 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6720 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
6721 DEBUG_P(PerlIO_printf(Perl_debug_log,
6722 "Screamer: done, len=%ld, string=|%.*s|\n",
6723 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
6727 /*The big, slow, and stupid way. */
6728 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
6730 Newx(buf, 8192, STDCHAR);
6738 register const STDCHAR *bpe = buf + sizeof(buf);
6740 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6741 ; /* keep reading */
6745 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6746 /* Accomodate broken VAXC compiler, which applies U8 cast to
6747 * both args of ?: operator, causing EOF to change into 255
6750 i = (U8)buf[cnt - 1];
6756 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
6758 sv_catpvn(sv, (char *) buf, cnt);
6760 sv_setpvn(sv, (char *) buf, cnt);
6762 if (i != EOF && /* joy */
6764 SvCUR(sv) < rslen ||
6765 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6769 * If we're reading from a TTY and we get a short read,
6770 * indicating that the user hit his EOF character, we need
6771 * to notice it now, because if we try to read from the TTY
6772 * again, the EOF condition will disappear.
6774 * The comparison of cnt to sizeof(buf) is an optimization
6775 * that prevents unnecessary calls to feof().
6779 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
6783 #ifdef USE_HEAP_INSTEAD_OF_STACK
6788 if (rspara) { /* have to do this both before and after */
6789 while (i != EOF) { /* to make sure file boundaries work right */
6790 i = PerlIO_getc(fp);
6792 PerlIO_ungetc(fp,i);
6798 return_string_or_null:
6799 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
6805 Auto-increment of the value in the SV, doing string to numeric conversion
6806 if necessary. Handles 'get' magic.
6812 Perl_sv_inc(pTHX_ register SV *sv)
6820 if (SvTHINKFIRST(sv)) {
6822 sv_force_normal_flags(sv, 0);
6823 if (SvREADONLY(sv)) {
6824 if (IN_PERL_RUNTIME)
6825 Perl_croak(aTHX_ PL_no_modify);
6829 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6831 i = PTR2IV(SvRV(sv));
6836 flags = SvFLAGS(sv);
6837 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6838 /* It's (privately or publicly) a float, but not tested as an
6839 integer, so test it to see. */
6841 flags = SvFLAGS(sv);
6843 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6844 /* It's publicly an integer, or privately an integer-not-float */
6845 #ifdef PERL_PRESERVE_IVUV
6849 if (SvUVX(sv) == UV_MAX)
6850 sv_setnv(sv, UV_MAX_P1);
6852 (void)SvIOK_only_UV(sv);
6853 SvUV_set(sv, SvUVX(sv) + 1);
6855 if (SvIVX(sv) == IV_MAX)
6856 sv_setuv(sv, (UV)IV_MAX + 1);
6858 (void)SvIOK_only(sv);
6859 SvIV_set(sv, SvIVX(sv) + 1);
6864 if (flags & SVp_NOK) {
6865 (void)SvNOK_only(sv);
6866 SvNV_set(sv, SvNVX(sv) + 1.0);
6870 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
6871 if ((flags & SVTYPEMASK) < SVt_PVIV)
6872 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
6873 (void)SvIOK_only(sv);
6878 while (isALPHA(*d)) d++;
6879 while (isDIGIT(*d)) d++;
6881 #ifdef PERL_PRESERVE_IVUV
6882 /* Got to punt this as an integer if needs be, but we don't issue
6883 warnings. Probably ought to make the sv_iv_please() that does
6884 the conversion if possible, and silently. */
6885 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6886 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6887 /* Need to try really hard to see if it's an integer.
6888 9.22337203685478e+18 is an integer.
6889 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6890 so $a="9.22337203685478e+18"; $a+0; $a++
6891 needs to be the same as $a="9.22337203685478e+18"; $a++
6898 /* sv_2iv *should* have made this an NV */
6899 if (flags & SVp_NOK) {
6900 (void)SvNOK_only(sv);
6901 SvNV_set(sv, SvNVX(sv) + 1.0);
6904 /* I don't think we can get here. Maybe I should assert this
6905 And if we do get here I suspect that sv_setnv will croak. NWC
6907 #if defined(USE_LONG_DOUBLE)
6908 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",
6909 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6911 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6912 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6915 #endif /* PERL_PRESERVE_IVUV */
6916 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
6920 while (d >= SvPVX_const(sv)) {
6928 /* MKS: The original code here died if letters weren't consecutive.
6929 * at least it didn't have to worry about non-C locales. The
6930 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6931 * arranged in order (although not consecutively) and that only
6932 * [A-Za-z] are accepted by isALPHA in the C locale.
6934 if (*d != 'z' && *d != 'Z') {
6935 do { ++*d; } while (!isALPHA(*d));
6938 *(d--) -= 'z' - 'a';
6943 *(d--) -= 'z' - 'a' + 1;
6947 /* oh,oh, the number grew */
6948 SvGROW(sv, SvCUR(sv) + 2);
6949 SvCUR_set(sv, SvCUR(sv) + 1);
6950 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
6961 Auto-decrement of the value in the SV, doing string to numeric conversion
6962 if necessary. Handles 'get' magic.
6968 Perl_sv_dec(pTHX_ register SV *sv)
6975 if (SvTHINKFIRST(sv)) {
6977 sv_force_normal_flags(sv, 0);
6978 if (SvREADONLY(sv)) {
6979 if (IN_PERL_RUNTIME)
6980 Perl_croak(aTHX_ PL_no_modify);
6984 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6986 i = PTR2IV(SvRV(sv));
6991 /* Unlike sv_inc we don't have to worry about string-never-numbers
6992 and keeping them magic. But we mustn't warn on punting */
6993 flags = SvFLAGS(sv);
6994 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6995 /* It's publicly an integer, or privately an integer-not-float */
6996 #ifdef PERL_PRESERVE_IVUV
7000 if (SvUVX(sv) == 0) {
7001 (void)SvIOK_only(sv);
7005 (void)SvIOK_only_UV(sv);
7006 SvUV_set(sv, SvUVX(sv) - 1);
7009 if (SvIVX(sv) == IV_MIN)
7010 sv_setnv(sv, (NV)IV_MIN - 1.0);
7012 (void)SvIOK_only(sv);
7013 SvIV_set(sv, SvIVX(sv) - 1);
7018 if (flags & SVp_NOK) {
7019 SvNV_set(sv, SvNVX(sv) - 1.0);
7020 (void)SvNOK_only(sv);
7023 if (!(flags & SVp_POK)) {
7024 if ((flags & SVTYPEMASK) < SVt_PVIV)
7025 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
7027 (void)SvIOK_only(sv);
7030 #ifdef PERL_PRESERVE_IVUV
7032 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7033 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7034 /* Need to try really hard to see if it's an integer.
7035 9.22337203685478e+18 is an integer.
7036 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7037 so $a="9.22337203685478e+18"; $a+0; $a--
7038 needs to be the same as $a="9.22337203685478e+18"; $a--
7045 /* sv_2iv *should* have made this an NV */
7046 if (flags & SVp_NOK) {
7047 (void)SvNOK_only(sv);
7048 SvNV_set(sv, SvNVX(sv) - 1.0);
7051 /* I don't think we can get here. Maybe I should assert this
7052 And if we do get here I suspect that sv_setnv will croak. NWC
7054 #if defined(USE_LONG_DOUBLE)
7055 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",
7056 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7058 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7059 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7063 #endif /* PERL_PRESERVE_IVUV */
7064 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
7068 =for apidoc sv_mortalcopy
7070 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7071 The new SV is marked as mortal. It will be destroyed "soon", either by an
7072 explicit call to FREETMPS, or by an implicit call at places such as
7073 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7078 /* Make a string that will exist for the duration of the expression
7079 * evaluation. Actually, it may have to last longer than that, but
7080 * hopefully we won't free it until it has been assigned to a
7081 * permanent location. */
7084 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
7089 sv_setsv(sv,oldstr);
7091 PL_tmps_stack[++PL_tmps_ix] = sv;
7097 =for apidoc sv_newmortal
7099 Creates a new null SV which is mortal. The reference count of the SV is
7100 set to 1. It will be destroyed "soon", either by an explicit call to
7101 FREETMPS, or by an implicit call at places such as statement boundaries.
7102 See also C<sv_mortalcopy> and C<sv_2mortal>.
7108 Perl_sv_newmortal(pTHX)
7113 SvFLAGS(sv) = SVs_TEMP;
7115 PL_tmps_stack[++PL_tmps_ix] = sv;
7120 =for apidoc sv_2mortal
7122 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7123 by an explicit call to FREETMPS, or by an implicit call at places such as
7124 statement boundaries. SvTEMP() is turned on which means that the SV's
7125 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7126 and C<sv_mortalcopy>.
7132 Perl_sv_2mortal(pTHX_ register SV *sv)
7137 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7140 PL_tmps_stack[++PL_tmps_ix] = sv;
7148 Creates a new SV and copies a string into it. The reference count for the
7149 SV is set to 1. If C<len> is zero, Perl will compute the length using
7150 strlen(). For efficiency, consider using C<newSVpvn> instead.
7156 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
7161 sv_setpvn(sv,s,len ? len : strlen(s));
7166 =for apidoc newSVpvn
7168 Creates a new SV and copies a string into it. The reference count for the
7169 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7170 string. You are responsible for ensuring that the source string is at least
7171 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7177 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7182 sv_setpvn(sv,s,len);
7188 =for apidoc newSVhek
7190 Creates a new SV from the hash key structure. It will generate scalars that
7191 point to the shared string table where possible. Returns a new (undefined)
7192 SV if the hek is NULL.
7198 Perl_newSVhek(pTHX_ const HEK *hek)
7207 if (HEK_LEN(hek) == HEf_SVKEY) {
7208 return newSVsv(*(SV**)HEK_KEY(hek));
7210 const int flags = HEK_FLAGS(hek);
7211 if (flags & HVhek_WASUTF8) {
7213 Andreas would like keys he put in as utf8 to come back as utf8
7215 STRLEN utf8_len = HEK_LEN(hek);
7216 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7217 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
7220 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7222 } else if (flags & HVhek_REHASH) {
7223 /* We don't have a pointer to the hv, so we have to replicate the
7224 flag into every HEK. This hv is using custom a hasing
7225 algorithm. Hence we can't return a shared string scalar, as
7226 that would contain the (wrong) hash value, and might get passed
7227 into an hv routine with a regular hash */
7229 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7234 /* This will be overwhelminly the most common case. */
7235 return newSVpvn_share(HEK_KEY(hek),
7236 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
7242 =for apidoc newSVpvn_share
7244 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7245 table. If the string does not already exist in the table, it is created
7246 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
7247 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
7248 otherwise the hash is computed. The idea here is that as the string table
7249 is used for shared hash keys these strings will have SvPVX_const == HeKEY and
7250 hash lookup will avoid string compare.
7256 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7259 bool is_utf8 = FALSE;
7261 STRLEN tmplen = -len;
7263 /* See the note in hv.c:hv_fetch() --jhi */
7264 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7268 PERL_HASH(hash, src, len);
7270 sv_upgrade(sv, SVt_PV);
7271 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7283 #if defined(PERL_IMPLICIT_CONTEXT)
7285 /* pTHX_ magic can't cope with varargs, so this is a no-context
7286 * version of the main function, (which may itself be aliased to us).
7287 * Don't access this version directly.
7291 Perl_newSVpvf_nocontext(const char* pat, ...)
7296 va_start(args, pat);
7297 sv = vnewSVpvf(pat, &args);
7304 =for apidoc newSVpvf
7306 Creates a new SV and initializes it with the string formatted like
7313 Perl_newSVpvf(pTHX_ const char* pat, ...)
7317 va_start(args, pat);
7318 sv = vnewSVpvf(pat, &args);
7323 /* backend for newSVpvf() and newSVpvf_nocontext() */
7326 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7330 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7337 Creates a new SV and copies a floating point value into it.
7338 The reference count for the SV is set to 1.
7344 Perl_newSVnv(pTHX_ NV n)
7356 Creates a new SV and copies an integer into it. The reference count for the
7363 Perl_newSViv(pTHX_ IV i)
7375 Creates a new SV and copies an unsigned integer into it.
7376 The reference count for the SV is set to 1.
7382 Perl_newSVuv(pTHX_ UV u)
7392 =for apidoc newRV_noinc
7394 Creates an RV wrapper for an SV. The reference count for the original
7395 SV is B<not> incremented.
7401 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7406 sv_upgrade(sv, SVt_RV);
7408 SvRV_set(sv, tmpRef);
7413 /* newRV_inc is the official function name to use now.
7414 * newRV_inc is in fact #defined to newRV in sv.h
7418 Perl_newRV(pTHX_ SV *tmpRef)
7420 return newRV_noinc(SvREFCNT_inc(tmpRef));
7426 Creates a new SV which is an exact duplicate of the original SV.
7433 Perl_newSVsv(pTHX_ register SV *old)
7439 if (SvTYPE(old) == SVTYPEMASK) {
7440 if (ckWARN_d(WARN_INTERNAL))
7441 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7445 /* SV_GMAGIC is the default for sv_setv()
7446 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7447 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7448 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7453 =for apidoc sv_reset
7455 Underlying implementation for the C<reset> Perl function.
7456 Note that the perl-level function is vaguely deprecated.
7462 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
7465 char todo[PERL_UCHAR_MAX+1];
7470 if (!*s) { /* reset ?? searches */
7471 MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
7473 PMOP *pm = (PMOP *) mg->mg_obj;
7475 pm->op_pmdynflags &= ~PMdf_USED;
7482 /* reset variables */
7484 if (!HvARRAY(stash))
7487 Zero(todo, 256, char);
7490 I32 i = (unsigned char)*s;
7494 max = (unsigned char)*s++;
7495 for ( ; i <= max; i++) {
7498 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7500 for (entry = HvARRAY(stash)[i];
7502 entry = HeNEXT(entry))
7507 if (!todo[(U8)*HeKEY(entry)])
7509 gv = (GV*)HeVAL(entry);
7512 if (SvTHINKFIRST(sv)) {
7513 if (!SvREADONLY(sv) && SvROK(sv))
7515 /* XXX Is this continue a bug? Why should THINKFIRST
7516 exempt us from resetting arrays and hashes? */
7520 if (SvTYPE(sv) >= SVt_PV) {
7522 if (SvPVX_const(sv) != Nullch)
7530 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
7533 #ifdef USE_ENVIRON_ARRAY
7535 # ifdef USE_ITHREADS
7536 && PL_curinterp == aTHX
7540 environ[0] = Nullch;
7543 #endif /* !PERL_MICRO */
7553 Using various gambits, try to get an IO from an SV: the IO slot if its a
7554 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7555 named after the PV if we're a string.
7561 Perl_sv_2io(pTHX_ SV *sv)
7566 switch (SvTYPE(sv)) {
7574 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7578 Perl_croak(aTHX_ PL_no_usym, "filehandle");
7580 return sv_2io(SvRV(sv));
7581 gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
7587 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
7596 Using various gambits, try to get a CV from an SV; in addition, try if
7597 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7603 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7610 return *gvp = Nullgv, Nullcv;
7611 switch (SvTYPE(sv)) {
7629 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
7630 tryAMAGICunDEREF(to_cv);
7633 if (SvTYPE(sv) == SVt_PVCV) {
7642 Perl_croak(aTHX_ "Not a subroutine reference");
7647 gv = gv_fetchsv(sv, lref, SVt_PVCV);
7653 if (lref && !GvCVu(gv)) {
7656 tmpsv = NEWSV(704,0);
7657 gv_efullname3(tmpsv, gv, Nullch);
7658 /* XXX this is probably not what they think they're getting.
7659 * It has the same effect as "sub name;", i.e. just a forward
7661 newSUB(start_subparse(FALSE, 0),
7662 newSVOP(OP_CONST, 0, tmpsv),
7667 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
7677 Returns true if the SV has a true value by Perl's rules.
7678 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
7679 instead use an in-line version.
7685 Perl_sv_true(pTHX_ register SV *sv)
7690 register const XPV* const tXpv = (XPV*)SvANY(sv);
7692 (tXpv->xpv_cur > 1 ||
7693 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
7700 return SvIVX(sv) != 0;
7703 return SvNVX(sv) != 0.0;
7705 return sv_2bool(sv);
7713 A private implementation of the C<SvIVx> macro for compilers which can't
7714 cope with complex macro expressions. Always use the macro instead.
7720 Perl_sv_iv(pTHX_ register SV *sv)
7724 return (IV)SvUVX(sv);
7733 A private implementation of the C<SvUVx> macro for compilers which can't
7734 cope with complex macro expressions. Always use the macro instead.
7740 Perl_sv_uv(pTHX_ register SV *sv)
7745 return (UV)SvIVX(sv);
7753 A private implementation of the C<SvNVx> macro for compilers which can't
7754 cope with complex macro expressions. Always use the macro instead.
7760 Perl_sv_nv(pTHX_ register SV *sv)
7770 Use the C<SvPV_nolen> macro instead
7774 A private implementation of the C<SvPV> macro for compilers which can't
7775 cope with complex macro expressions. Always use the macro instead.
7781 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
7787 return sv_2pv(sv, lp);
7792 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
7798 return sv_2pv_flags(sv, lp, 0);
7802 =for apidoc sv_pvn_force
7804 Get a sensible string out of the SV somehow.
7805 A private implementation of the C<SvPV_force> macro for compilers which
7806 can't cope with complex macro expressions. Always use the macro instead.
7808 =for apidoc sv_pvn_force_flags
7810 Get a sensible string out of the SV somehow.
7811 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
7812 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
7813 implemented in terms of this function.
7814 You normally want to use the various wrapper macros instead: see
7815 C<SvPV_force> and C<SvPV_force_nomg>
7821 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
7824 if (SvTHINKFIRST(sv) && !SvROK(sv))
7825 sv_force_normal_flags(sv, 0);
7835 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
7836 const char * const ref = sv_reftype(sv,0);
7838 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
7839 ref, OP_NAME(PL_op));
7841 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
7843 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
7844 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
7846 s = sv_2pv_flags(sv, &len, flags);
7850 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
7853 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
7854 SvGROW(sv, len + 1);
7855 Move(s,SvPVX(sv),len,char);
7860 SvPOK_on(sv); /* validate pointer */
7862 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
7863 PTR2UV(sv),SvPVX_const(sv)));
7866 return SvPVX_mutable(sv);
7870 =for apidoc sv_pvbyte
7872 Use C<SvPVbyte_nolen> instead.
7874 =for apidoc sv_pvbyten
7876 A private implementation of the C<SvPVbyte> macro for compilers
7877 which can't cope with complex macro expressions. Always use the macro
7884 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
7886 sv_utf8_downgrade(sv,0);
7887 return sv_pvn(sv,lp);
7891 =for apidoc sv_pvbyten_force
7893 A private implementation of the C<SvPVbytex_force> macro for compilers
7894 which can't cope with complex macro expressions. Always use the macro
7901 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
7903 sv_pvn_force(sv,lp);
7904 sv_utf8_downgrade(sv,0);
7910 =for apidoc sv_pvutf8
7912 Use the C<SvPVutf8_nolen> macro instead
7914 =for apidoc sv_pvutf8n
7916 A private implementation of the C<SvPVutf8> macro for compilers
7917 which can't cope with complex macro expressions. Always use the macro
7924 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
7926 sv_utf8_upgrade(sv);
7927 return sv_pvn(sv,lp);
7931 =for apidoc sv_pvutf8n_force
7933 A private implementation of the C<SvPVutf8_force> macro for compilers
7934 which can't cope with complex macro expressions. Always use the macro
7941 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
7943 sv_pvn_force(sv,lp);
7944 sv_utf8_upgrade(sv);
7950 =for apidoc sv_reftype
7952 Returns a string describing what the SV is a reference to.
7958 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
7960 /* The fact that I don't need to downcast to char * everywhere, only in ?:
7961 inside return suggests a const propagation bug in g++. */
7962 if (ob && SvOBJECT(sv)) {
7963 char * const name = HvNAME_get(SvSTASH(sv));
7964 return name ? name : (char *) "__ANON__";
7967 switch (SvTYPE(sv)) {
7984 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
7985 /* tied lvalues should appear to be
7986 * scalars for backwards compatitbility */
7987 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
7988 ? "SCALAR" : "LVALUE");
7989 case SVt_PVAV: return "ARRAY";
7990 case SVt_PVHV: return "HASH";
7991 case SVt_PVCV: return "CODE";
7992 case SVt_PVGV: return "GLOB";
7993 case SVt_PVFM: return "FORMAT";
7994 case SVt_PVIO: return "IO";
7995 default: return "UNKNOWN";
8001 =for apidoc sv_isobject
8003 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8004 object. If the SV is not an RV, or if the object is not blessed, then this
8011 Perl_sv_isobject(pTHX_ SV *sv)
8027 Returns a boolean indicating whether the SV is blessed into the specified
8028 class. This does not check for subtypes; use C<sv_derived_from> to verify
8029 an inheritance relationship.
8035 Perl_sv_isa(pTHX_ SV *sv, const char *name)
8046 hvname = HvNAME_get(SvSTASH(sv));
8050 return strEQ(hvname, name);
8056 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
8057 it will be upgraded to one. If C<classname> is non-null then the new SV will
8058 be blessed in the specified package. The new SV is returned and its
8059 reference count is 1.
8065 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
8071 SV_CHECK_THINKFIRST_COW_DROP(rv);
8074 if (SvTYPE(rv) >= SVt_PVMG) {
8075 const U32 refcnt = SvREFCNT(rv);
8079 SvREFCNT(rv) = refcnt;
8082 if (SvTYPE(rv) < SVt_RV)
8083 sv_upgrade(rv, SVt_RV);
8084 else if (SvTYPE(rv) > SVt_RV) {
8095 HV* const stash = gv_stashpv(classname, TRUE);
8096 (void)sv_bless(rv, stash);
8102 =for apidoc sv_setref_pv
8104 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
8105 argument will be upgraded to an RV. That RV will be modified to point to
8106 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8107 into the SV. The C<classname> argument indicates the package for the
8108 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8109 will have a reference count of 1, and the RV will be returned.
8111 Do not use with other Perl types such as HV, AV, SV, CV, because those
8112 objects will become corrupted by the pointer copy process.
8114 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8120 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
8123 sv_setsv(rv, &PL_sv_undef);
8127 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8132 =for apidoc sv_setref_iv
8134 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
8135 argument will be upgraded to an RV. That RV will be modified to point to
8136 the new SV. The C<classname> argument indicates the package for the
8137 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8138 will have a reference count of 1, and the RV will be returned.
8144 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
8146 sv_setiv(newSVrv(rv,classname), iv);
8151 =for apidoc sv_setref_uv
8153 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
8154 argument will be upgraded to an RV. That RV will be modified to point to
8155 the new SV. The C<classname> argument indicates the package for the
8156 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8157 will have a reference count of 1, and the RV will be returned.
8163 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
8165 sv_setuv(newSVrv(rv,classname), uv);
8170 =for apidoc sv_setref_nv
8172 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8173 argument will be upgraded to an RV. That RV will be modified to point to
8174 the new SV. The C<classname> argument indicates the package for the
8175 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8176 will have a reference count of 1, and the RV will be returned.
8182 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
8184 sv_setnv(newSVrv(rv,classname), nv);
8189 =for apidoc sv_setref_pvn
8191 Copies a string into a new SV, optionally blessing the SV. The length of the
8192 string must be specified with C<n>. The C<rv> argument will be upgraded to
8193 an RV. That RV will be modified to point to the new SV. The C<classname>
8194 argument indicates the package for the blessing. Set C<classname> to
8195 C<Nullch> to avoid the blessing. The new SV will have a reference count
8196 of 1, and the RV will be returned.
8198 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8204 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n)
8206 sv_setpvn(newSVrv(rv,classname), pv, n);
8211 =for apidoc sv_bless
8213 Blesses an SV into a specified package. The SV must be an RV. The package
8214 must be designated by its stash (see C<gv_stashpv()>). The reference count
8215 of the SV is unaffected.
8221 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8225 Perl_croak(aTHX_ "Can't bless non-reference value");
8227 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8228 if (SvREADONLY(tmpRef))
8229 Perl_croak(aTHX_ PL_no_modify);
8230 if (SvOBJECT(tmpRef)) {
8231 if (SvTYPE(tmpRef) != SVt_PVIO)
8233 SvREFCNT_dec(SvSTASH(tmpRef));
8236 SvOBJECT_on(tmpRef);
8237 if (SvTYPE(tmpRef) != SVt_PVIO)
8239 SvUPGRADE(tmpRef, SVt_PVMG);
8240 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
8247 if(SvSMAGICAL(tmpRef))
8248 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8256 /* Downgrades a PVGV to a PVMG.
8260 S_sv_unglob(pTHX_ SV *sv)
8264 assert(SvTYPE(sv) == SVt_PVGV);
8269 sv_del_backref((SV*)GvSTASH(sv), sv);
8270 GvSTASH(sv) = Nullhv;
8272 sv_unmagic(sv, PERL_MAGIC_glob);
8273 Safefree(GvNAME(sv));
8276 /* need to keep SvANY(sv) in the right arena */
8277 xpvmg = new_XPVMG();
8278 StructCopy(SvANY(sv), xpvmg, XPVMG);
8279 del_XPVGV(SvANY(sv));
8282 SvFLAGS(sv) &= ~SVTYPEMASK;
8283 SvFLAGS(sv) |= SVt_PVMG;
8287 =for apidoc sv_unref_flags
8289 Unsets the RV status of the SV, and decrements the reference count of
8290 whatever was being referenced by the RV. This can almost be thought of
8291 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8292 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8293 (otherwise the decrementing is conditional on the reference count being
8294 different from one or the reference being a readonly SV).
8301 Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags)
8303 SV* const target = SvRV(ref);
8305 if (SvWEAKREF(ref)) {
8306 sv_del_backref(target, ref);
8308 SvRV_set(ref, NULL);
8311 SvRV_set(ref, NULL);
8313 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
8314 assigned to as BEGIN {$a = \"Foo"} will fail. */
8315 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
8316 SvREFCNT_dec(target);
8317 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8318 sv_2mortal(target); /* Schedule for freeing later */
8322 =for apidoc sv_unref
8324 Unsets the RV status of the SV, and decrements the reference count of
8325 whatever was being referenced by the RV. This can almost be thought of
8326 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
8327 being zero. See C<SvROK_off>.
8333 Perl_sv_unref(pTHX_ SV *sv)
8335 sv_unref_flags(sv, 0);
8339 =for apidoc sv_taint
8341 Taint an SV. Use C<SvTAINTED_on> instead.
8346 Perl_sv_taint(pTHX_ SV *sv)
8348 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
8352 =for apidoc sv_untaint
8354 Untaint an SV. Use C<SvTAINTED_off> instead.
8359 Perl_sv_untaint(pTHX_ SV *sv)
8361 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8362 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8369 =for apidoc sv_tainted
8371 Test an SV for taintedness. Use C<SvTAINTED> instead.
8376 Perl_sv_tainted(pTHX_ SV *sv)
8378 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8379 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8380 if (mg && (mg->mg_len & 1) )
8387 =for apidoc sv_setpviv
8389 Copies an integer into the given SV, also updating its string value.
8390 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8396 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8398 char buf[TYPE_CHARS(UV)];
8400 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8402 sv_setpvn(sv, ptr, ebuf - ptr);
8406 =for apidoc sv_setpviv_mg
8408 Like C<sv_setpviv>, but also handles 'set' magic.
8414 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8416 char buf[TYPE_CHARS(UV)];
8418 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8420 sv_setpvn(sv, ptr, ebuf - ptr);
8424 #if defined(PERL_IMPLICIT_CONTEXT)
8426 /* pTHX_ magic can't cope with varargs, so this is a no-context
8427 * version of the main function, (which may itself be aliased to us).
8428 * Don't access this version directly.
8432 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8436 va_start(args, pat);
8437 sv_vsetpvf(sv, pat, &args);
8441 /* pTHX_ magic can't cope with varargs, so this is a no-context
8442 * version of the main function, (which may itself be aliased to us).
8443 * Don't access this version directly.
8447 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8451 va_start(args, pat);
8452 sv_vsetpvf_mg(sv, pat, &args);
8458 =for apidoc sv_setpvf
8460 Works like C<sv_catpvf> but copies the text into the SV instead of
8461 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8467 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8470 va_start(args, pat);
8471 sv_vsetpvf(sv, pat, &args);
8476 =for apidoc sv_vsetpvf
8478 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8479 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8481 Usually used via its frontend C<sv_setpvf>.
8487 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8489 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8493 =for apidoc sv_setpvf_mg
8495 Like C<sv_setpvf>, but also handles 'set' magic.
8501 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8504 va_start(args, pat);
8505 sv_vsetpvf_mg(sv, pat, &args);
8510 =for apidoc sv_vsetpvf_mg
8512 Like C<sv_vsetpvf>, but also handles 'set' magic.
8514 Usually used via its frontend C<sv_setpvf_mg>.
8520 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8522 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8526 #if defined(PERL_IMPLICIT_CONTEXT)
8528 /* pTHX_ magic can't cope with varargs, so this is a no-context
8529 * version of the main function, (which may itself be aliased to us).
8530 * Don't access this version directly.
8534 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8538 va_start(args, pat);
8539 sv_vcatpvf(sv, pat, &args);
8543 /* pTHX_ magic can't cope with varargs, so this is a no-context
8544 * version of the main function, (which may itself be aliased to us).
8545 * Don't access this version directly.
8549 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8553 va_start(args, pat);
8554 sv_vcatpvf_mg(sv, pat, &args);
8560 =for apidoc sv_catpvf
8562 Processes its arguments like C<sprintf> and appends the formatted
8563 output to an SV. If the appended data contains "wide" characters
8564 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8565 and characters >255 formatted with %c), the original SV might get
8566 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
8567 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
8568 valid UTF-8; if the original SV was bytes, the pattern should be too.
8573 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8576 va_start(args, pat);
8577 sv_vcatpvf(sv, pat, &args);
8582 =for apidoc sv_vcatpvf
8584 Processes its arguments like C<vsprintf> and appends the formatted output
8585 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
8587 Usually used via its frontend C<sv_catpvf>.
8593 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8595 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8599 =for apidoc sv_catpvf_mg
8601 Like C<sv_catpvf>, but also handles 'set' magic.
8607 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8610 va_start(args, pat);
8611 sv_vcatpvf_mg(sv, pat, &args);
8616 =for apidoc sv_vcatpvf_mg
8618 Like C<sv_vcatpvf>, but also handles 'set' magic.
8620 Usually used via its frontend C<sv_catpvf_mg>.
8626 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8628 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8633 =for apidoc sv_vsetpvfn
8635 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
8638 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
8644 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8646 sv_setpvn(sv, "", 0);
8647 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8650 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
8653 S_expect_number(pTHX_ char** pattern)
8656 switch (**pattern) {
8657 case '1': case '2': case '3':
8658 case '4': case '5': case '6':
8659 case '7': case '8': case '9':
8660 while (isDIGIT(**pattern))
8661 var = var * 10 + (*(*pattern)++ - '0');
8665 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
8668 F0convert(NV nv, char *endbuf, STRLEN *len)
8670 const int neg = nv < 0;
8679 if (uv & 1 && uv == nv)
8680 uv--; /* Round to even */
8682 const unsigned dig = uv % 10;
8695 =for apidoc sv_vcatpvfn
8697 Processes its arguments like C<vsprintf> and appends the formatted output
8698 to an SV. Uses an array of SVs if the C style variable argument list is
8699 missing (NULL). When running with taint checks enabled, indicates via
8700 C<maybe_tainted> if results are untrustworthy (often due to the use of
8703 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
8709 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
8710 vecstr = (U8*)SvPV_const(vecsv,veclen);\
8711 vec_utf8 = DO_UTF8(vecsv);
8713 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
8716 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8723 static const char nullstr[] = "(null)";
8725 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
8726 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
8728 /* Times 4: a decimal digit takes more than 3 binary digits.
8729 * NV_DIG: mantissa takes than many decimal digits.
8730 * Plus 32: Playing safe. */
8731 char ebuf[IV_DIG * 4 + NV_DIG + 32];
8732 /* large enough for "%#.#f" --chip */
8733 /* what about long double NVs? --jhi */
8735 PERL_UNUSED_ARG(maybe_tainted);
8737 /* no matter what, this is a string now */
8738 (void)SvPV_force(sv, origlen);
8740 /* special-case "", "%s", and "%-p" (SVf - see below) */
8743 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
8745 const char * const s = va_arg(*args, char*);
8746 sv_catpv(sv, s ? s : nullstr);
8748 else if (svix < svmax) {
8749 sv_catsv(sv, *svargs);
8750 if (DO_UTF8(*svargs))
8755 if (args && patlen == 3 && pat[0] == '%' &&
8756 pat[1] == '-' && pat[2] == 'p') {
8757 argsv = va_arg(*args, SV*);
8758 sv_catsv(sv, argsv);
8764 #ifndef USE_LONG_DOUBLE
8765 /* special-case "%.<number>[gf]" */
8766 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
8767 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
8768 unsigned digits = 0;
8772 while (*pp >= '0' && *pp <= '9')
8773 digits = 10 * digits + (*pp++ - '0');
8774 if (pp - pat == (int)patlen - 1) {
8782 /* Add check for digits != 0 because it seems that some
8783 gconverts are buggy in this case, and we don't yet have
8784 a Configure test for this. */
8785 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
8786 /* 0, point, slack */
8787 Gconvert(nv, (int)digits, 0, ebuf);
8789 if (*ebuf) /* May return an empty string for digits==0 */
8792 } else if (!digits) {
8795 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
8796 sv_catpvn(sv, p, l);
8802 #endif /* !USE_LONG_DOUBLE */
8804 if (!args && svix < svmax && DO_UTF8(*svargs))
8807 patend = (char*)pat + patlen;
8808 for (p = (char*)pat; p < patend; p = q) {
8811 bool vectorize = FALSE;
8812 bool vectorarg = FALSE;
8813 bool vec_utf8 = FALSE;
8819 bool has_precis = FALSE;
8822 bool is_utf8 = FALSE; /* is this item utf8? */
8823 #ifdef HAS_LDBL_SPRINTF_BUG
8824 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8825 with sfio - Allen <allens@cpan.org> */
8826 bool fix_ldbl_sprintf_bug = FALSE;
8830 U8 utf8buf[UTF8_MAXBYTES+1];
8831 STRLEN esignlen = 0;
8833 const char *eptr = Nullch;
8836 const U8 *vecstr = Null(U8*);
8843 /* we need a long double target in case HAS_LONG_DOUBLE but
8846 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
8854 const char *dotstr = ".";
8855 STRLEN dotstrlen = 1;
8856 I32 efix = 0; /* explicit format parameter index */
8857 I32 ewix = 0; /* explicit width index */
8858 I32 epix = 0; /* explicit precision index */
8859 I32 evix = 0; /* explicit vector index */
8860 bool asterisk = FALSE;
8862 /* echo everything up to the next format specification */
8863 for (q = p; q < patend && *q != '%'; ++q) ;
8865 if (has_utf8 && !pat_utf8)
8866 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
8868 sv_catpvn(sv, p, q - p);
8875 We allow format specification elements in this order:
8876 \d+\$ explicit format parameter index
8878 v|\*(\d+\$)?v vector with optional (optionally specified) arg
8879 0 flag (as above): repeated to allow "v02"
8880 \d+|\*(\d+\$)? width using optional (optionally specified) arg
8881 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8883 [%bcdefginopsuxDFOUX] format (mandatory)
8888 As of perl5.9.3, printf format checking is on by default.
8889 Internally, perl uses %p formats to provide an escape to
8890 some extended formatting. This block deals with those
8891 extensions: if it does not match, (char*)q is reset and
8892 the normal format processing code is used.
8894 Currently defined extensions are:
8895 %p include pointer address (standard)
8896 %-p (SVf) include an SV (previously %_)
8897 %-<num>p include an SV with precision <num>
8898 %1p (VDf) include a v-string (as %vd)
8899 %<num>p reserved for future extensions
8901 Robin Barker 2005-07-14
8908 EXPECT_NUMBER(q, n);
8915 argsv = va_arg(*args, SV*);
8916 eptr = SvPVx_const(argsv, elen);
8922 else if (n == vdNUMBER) { /* VDf */
8929 if (ckWARN_d(WARN_INTERNAL))
8930 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
8931 "internal %%<num>p might conflict with future printf extensions");
8937 if (EXPECT_NUMBER(q, width)) {
8978 if (EXPECT_NUMBER(q, ewix))
8987 if ((vectorarg = asterisk)) {
9000 EXPECT_NUMBER(q, width);
9006 vecsv = va_arg(*args, SV*);
9008 vecsv = (evix ? evix <= svmax : svix < svmax) ?
9009 svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
9010 dotstr = SvPV_const(vecsv, dotstrlen);
9017 else if (efix ? efix <= svmax : svix < svmax) {
9018 vecsv = svargs[efix ? efix-1 : svix++];
9019 vecstr = (U8*)SvPV_const(vecsv,veclen);
9020 vec_utf8 = DO_UTF8(vecsv);
9021 /* if this is a version object, we need to return the
9022 * stringified representation (which the SvPVX_const has
9023 * already done for us), but not vectorize the args
9025 if ( *q == 'd' && sv_derived_from(vecsv,"version") )
9027 q++; /* skip past the rest of the %vd format */
9028 eptr = (const char *) vecstr;
9029 elen = strlen(eptr);
9042 i = va_arg(*args, int);
9044 i = (ewix ? ewix <= svmax : svix < svmax) ?
9045 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9047 width = (i < 0) ? -i : i;
9057 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
9059 /* XXX: todo, support specified precision parameter */
9063 i = va_arg(*args, int);
9065 i = (ewix ? ewix <= svmax : svix < svmax)
9066 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9067 precis = (i < 0) ? 0 : i;
9072 precis = precis * 10 + (*q++ - '0');
9081 case 'I': /* Ix, I32x, and I64x */
9083 if (q[1] == '6' && q[2] == '4') {
9089 if (q[1] == '3' && q[2] == '2') {
9099 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9110 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9111 if (*(q + 1) == 'l') { /* lld, llf */
9136 argsv = (efix ? efix <= svmax : svix < svmax) ?
9137 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
9144 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
9146 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9148 eptr = (char*)utf8buf;
9149 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9160 if (args && !vectorize) {
9161 eptr = va_arg(*args, char*);
9163 #ifdef MACOS_TRADITIONAL
9164 /* On MacOS, %#s format is used for Pascal strings */
9169 elen = strlen(eptr);
9171 eptr = (char *)nullstr;
9172 elen = sizeof nullstr - 1;
9176 eptr = SvPVx_const(argsv, elen);
9177 if (DO_UTF8(argsv)) {
9178 if (has_precis && precis < elen) {
9180 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9183 if (width) { /* fudge width (can't fudge elen) */
9184 width += elen - sv_len_utf8(argsv);
9192 if (has_precis && elen > precis)
9199 if (alt || vectorize)
9201 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9222 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9231 esignbuf[esignlen++] = plus;
9235 case 'h': iv = (short)va_arg(*args, int); break;
9236 case 'l': iv = va_arg(*args, long); break;
9237 case 'V': iv = va_arg(*args, IV); break;
9238 default: iv = va_arg(*args, int); break;
9240 case 'q': iv = va_arg(*args, Quad_t); break;
9245 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
9247 case 'h': iv = (short)tiv; break;
9248 case 'l': iv = (long)tiv; break;
9250 default: iv = tiv; break;
9252 case 'q': iv = (Quad_t)tiv; break;
9256 if ( !vectorize ) /* we already set uv above */
9261 esignbuf[esignlen++] = plus;
9265 esignbuf[esignlen++] = '-';
9308 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9319 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9320 case 'l': uv = va_arg(*args, unsigned long); break;
9321 case 'V': uv = va_arg(*args, UV); break;
9322 default: uv = va_arg(*args, unsigned); break;
9324 case 'q': uv = va_arg(*args, Uquad_t); break;
9329 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9331 case 'h': uv = (unsigned short)tuv; break;
9332 case 'l': uv = (unsigned long)tuv; break;
9334 default: uv = tuv; break;
9336 case 'q': uv = (Uquad_t)tuv; break;
9343 char *ptr = ebuf + sizeof ebuf;
9349 p = (char*)((c == 'X')
9350 ? "0123456789ABCDEF" : "0123456789abcdef");
9356 esignbuf[esignlen++] = '0';
9357 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9365 if (alt && *ptr != '0')
9374 esignbuf[esignlen++] = '0';
9375 esignbuf[esignlen++] = 'b';
9378 default: /* it had better be ten or less */
9382 } while (uv /= base);
9385 elen = (ebuf + sizeof ebuf) - ptr;
9389 zeros = precis - elen;
9390 else if (precis == 0 && elen == 1 && *eptr == '0')
9396 /* FLOATING POINT */
9399 c = 'f'; /* maybe %F isn't supported here */
9405 /* This is evil, but floating point is even more evil */
9407 /* for SV-style calling, we can only get NV
9408 for C-style calling, we assume %f is double;
9409 for simplicity we allow any of %Lf, %llf, %qf for long double
9413 #if defined(USE_LONG_DOUBLE)
9417 /* [perl #20339] - we should accept and ignore %lf rather than die */
9421 #if defined(USE_LONG_DOUBLE)
9422 intsize = args ? 0 : 'q';
9426 #if defined(HAS_LONG_DOUBLE)
9435 /* now we need (long double) if intsize == 'q', else (double) */
9436 nv = (args && !vectorize) ?
9437 #if LONG_DOUBLESIZE > DOUBLESIZE
9439 va_arg(*args, long double) :
9440 va_arg(*args, double)
9442 va_arg(*args, double)
9448 if (c != 'e' && c != 'E') {
9450 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9451 will cast our (long double) to (double) */
9452 (void)Perl_frexp(nv, &i);
9453 if (i == PERL_INT_MIN)
9454 Perl_die(aTHX_ "panic: frexp");
9456 need = BIT_DIGITS(i);
9458 need += has_precis ? precis : 6; /* known default */
9463 #ifdef HAS_LDBL_SPRINTF_BUG
9464 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9465 with sfio - Allen <allens@cpan.org> */
9468 # define MY_DBL_MAX DBL_MAX
9469 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9470 # if DOUBLESIZE >= 8
9471 # define MY_DBL_MAX 1.7976931348623157E+308L
9473 # define MY_DBL_MAX 3.40282347E+38L
9477 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9478 # define MY_DBL_MAX_BUG 1L
9480 # define MY_DBL_MAX_BUG MY_DBL_MAX
9484 # define MY_DBL_MIN DBL_MIN
9485 # else /* XXX guessing! -Allen */
9486 # if DOUBLESIZE >= 8
9487 # define MY_DBL_MIN 2.2250738585072014E-308L
9489 # define MY_DBL_MIN 1.17549435E-38L
9493 if ((intsize == 'q') && (c == 'f') &&
9494 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9496 /* it's going to be short enough that
9497 * long double precision is not needed */
9499 if ((nv <= 0L) && (nv >= -0L))
9500 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9502 /* would use Perl_fp_class as a double-check but not
9503 * functional on IRIX - see perl.h comments */
9505 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9506 /* It's within the range that a double can represent */
9507 #if defined(DBL_MAX) && !defined(DBL_MIN)
9508 if ((nv >= ((long double)1/DBL_MAX)) ||
9509 (nv <= (-(long double)1/DBL_MAX)))
9511 fix_ldbl_sprintf_bug = TRUE;
9514 if (fix_ldbl_sprintf_bug == TRUE) {
9524 # undef MY_DBL_MAX_BUG
9527 #endif /* HAS_LDBL_SPRINTF_BUG */
9529 need += 20; /* fudge factor */
9530 if (PL_efloatsize < need) {
9531 Safefree(PL_efloatbuf);
9532 PL_efloatsize = need + 20; /* more fudge */
9533 Newx(PL_efloatbuf, PL_efloatsize, char);
9534 PL_efloatbuf[0] = '\0';
9537 if ( !(width || left || plus || alt) && fill != '0'
9538 && has_precis && intsize != 'q' ) { /* Shortcuts */
9539 /* See earlier comment about buggy Gconvert when digits,
9541 if ( c == 'g' && precis) {
9542 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9543 /* May return an empty string for digits==0 */
9544 if (*PL_efloatbuf) {
9545 elen = strlen(PL_efloatbuf);
9546 goto float_converted;
9548 } else if ( c == 'f' && !precis) {
9549 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9554 char *ptr = ebuf + sizeof ebuf;
9557 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9558 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9559 if (intsize == 'q') {
9560 /* Copy the one or more characters in a long double
9561 * format before the 'base' ([efgEFG]) character to
9562 * the format string. */
9563 static char const prifldbl[] = PERL_PRIfldbl;
9564 char const *p = prifldbl + sizeof(prifldbl) - 3;
9565 while (p >= prifldbl) { *--ptr = *p--; }
9570 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9575 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9587 /* No taint. Otherwise we are in the strange situation
9588 * where printf() taints but print($float) doesn't.
9590 #if defined(HAS_LONG_DOUBLE)
9591 elen = ((intsize == 'q')
9592 ? my_sprintf(PL_efloatbuf, ptr, nv)
9593 : my_sprintf(PL_efloatbuf, ptr, (double)nv));
9595 elen = my_sprintf(PL_efloatbuf, ptr, nv);
9599 eptr = PL_efloatbuf;
9605 i = SvCUR(sv) - origlen;
9606 if (args && !vectorize) {
9608 case 'h': *(va_arg(*args, short*)) = i; break;
9609 default: *(va_arg(*args, int*)) = i; break;
9610 case 'l': *(va_arg(*args, long*)) = i; break;
9611 case 'V': *(va_arg(*args, IV*)) = i; break;
9613 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
9618 sv_setuv_mg(argsv, (UV)i);
9620 continue; /* not "break" */
9627 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
9628 && ckWARN(WARN_PRINTF))
9630 SV *msg = sv_newmortal();
9631 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9632 (PL_op->op_type == OP_PRTF) ? "" : "s");
9635 Perl_sv_catpvf(aTHX_ msg,
9636 "\"%%%c\"", c & 0xFF);
9638 Perl_sv_catpvf(aTHX_ msg,
9639 "\"%%\\%03"UVof"\"",
9642 sv_catpv(msg, "end of string");
9643 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
9646 /* output mangled stuff ... */
9652 /* ... right here, because formatting flags should not apply */
9653 SvGROW(sv, SvCUR(sv) + elen + 1);
9655 Copy(eptr, p, elen, char);
9658 SvCUR_set(sv, p - SvPVX_const(sv));
9660 continue; /* not "break" */
9663 /* calculate width before utf8_upgrade changes it */
9664 have = esignlen + zeros + elen;
9666 if (is_utf8 != has_utf8) {
9669 sv_utf8_upgrade(sv);
9672 SV * const nsv = sv_2mortal(newSVpvn(eptr, elen));
9673 sv_utf8_upgrade(nsv);
9674 eptr = SvPVX_const(nsv);
9677 SvGROW(sv, SvCUR(sv) + elen + 1);
9682 need = (have > width ? have : width);
9685 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
9687 if (esignlen && fill == '0') {
9689 for (i = 0; i < (int)esignlen; i++)
9693 memset(p, fill, gap);
9696 if (esignlen && fill != '0') {
9698 for (i = 0; i < (int)esignlen; i++)
9703 for (i = zeros; i; i--)
9707 Copy(eptr, p, elen, char);
9711 memset(p, ' ', gap);
9716 Copy(dotstr, p, dotstrlen, char);
9720 vectorize = FALSE; /* done iterating over vecstr */
9727 SvCUR_set(sv, p - SvPVX_const(sv));
9735 /* =========================================================================
9737 =head1 Cloning an interpreter
9739 All the macros and functions in this section are for the private use of
9740 the main function, perl_clone().
9742 The foo_dup() functions make an exact copy of an existing foo thinngy.
9743 During the course of a cloning, a hash table is used to map old addresses
9744 to new addresses. The table is created and manipulated with the
9745 ptr_table_* functions.
9749 ============================================================================*/
9752 #if defined(USE_ITHREADS)
9754 #ifndef GpREFCNT_inc
9755 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
9759 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
9760 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
9761 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9762 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
9763 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9764 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
9765 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9766 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
9767 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
9768 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
9769 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9770 #define SAVEPV(p) (p ? savepv(p) : Nullch)
9771 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
9774 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
9775 regcomp.c. AMS 20010712 */
9778 Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
9783 struct reg_substr_datum *s;
9786 return (REGEXP *)NULL;
9788 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
9791 len = r->offsets[0];
9792 npar = r->nparens+1;
9794 Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
9795 Copy(r->program, ret->program, len+1, regnode);
9797 Newx(ret->startp, npar, I32);
9798 Copy(r->startp, ret->startp, npar, I32);
9799 Newx(ret->endp, npar, I32);
9800 Copy(r->startp, ret->startp, npar, I32);
9802 Newx(ret->substrs, 1, struct reg_substr_data);
9803 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
9804 s->min_offset = r->substrs->data[i].min_offset;
9805 s->max_offset = r->substrs->data[i].max_offset;
9806 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
9807 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
9810 ret->regstclass = NULL;
9813 const int count = r->data->count;
9816 Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
9817 char, struct reg_data);
9818 Newx(d->what, count, U8);
9821 for (i = 0; i < count; i++) {
9822 d->what[i] = r->data->what[i];
9823 switch (d->what[i]) {
9824 /* legal options are one of: sfpont
9825 see also regcomp.h and pregfree() */
9827 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
9830 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
9833 /* This is cheating. */
9834 Newx(d->data[i], 1, struct regnode_charclass_class);
9835 StructCopy(r->data->data[i], d->data[i],
9836 struct regnode_charclass_class);
9837 ret->regstclass = (regnode*)d->data[i];
9840 /* Compiled op trees are readonly, and can thus be
9841 shared without duplication. */
9843 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
9847 d->data[i] = r->data->data[i];
9850 d->data[i] = r->data->data[i];
9852 ((reg_trie_data*)d->data[i])->refcount++;
9856 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
9865 Newx(ret->offsets, 2*len+1, U32);
9866 Copy(r->offsets, ret->offsets, 2*len+1, U32);
9868 ret->precomp = SAVEPVN(r->precomp, r->prelen);
9869 ret->refcnt = r->refcnt;
9870 ret->minlen = r->minlen;
9871 ret->prelen = r->prelen;
9872 ret->nparens = r->nparens;
9873 ret->lastparen = r->lastparen;
9874 ret->lastcloseparen = r->lastcloseparen;
9875 ret->reganch = r->reganch;
9877 ret->sublen = r->sublen;
9879 if (RX_MATCH_COPIED(ret))
9880 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
9882 ret->subbeg = Nullch;
9883 #ifdef PERL_OLD_COPY_ON_WRITE
9884 ret->saved_copy = Nullsv;
9887 ptr_table_store(PL_ptr_table, r, ret);
9891 /* duplicate a file handle */
9894 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
9898 PERL_UNUSED_ARG(type);
9901 return (PerlIO*)NULL;
9903 /* look for it in the table first */
9904 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
9908 /* create anew and remember what it is */
9909 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
9910 ptr_table_store(PL_ptr_table, fp, ret);
9914 /* duplicate a directory handle */
9917 Perl_dirp_dup(pTHX_ DIR *dp)
9925 /* duplicate a typeglob */
9928 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
9933 /* look for it in the table first */
9934 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
9938 /* create anew and remember what it is */
9940 ptr_table_store(PL_ptr_table, gp, ret);
9943 ret->gp_refcnt = 0; /* must be before any other dups! */
9944 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
9945 ret->gp_io = io_dup_inc(gp->gp_io, param);
9946 ret->gp_form = cv_dup_inc(gp->gp_form, param);
9947 ret->gp_av = av_dup_inc(gp->gp_av, param);
9948 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
9949 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
9950 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
9951 ret->gp_cvgen = gp->gp_cvgen;
9952 ret->gp_line = gp->gp_line;
9953 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
9957 /* duplicate a chain of magic */
9960 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
9962 MAGIC *mgprev = (MAGIC*)NULL;
9965 return (MAGIC*)NULL;
9966 /* look for it in the table first */
9967 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
9971 for (; mg; mg = mg->mg_moremagic) {
9973 Newxz(nmg, 1, MAGIC);
9975 mgprev->mg_moremagic = nmg;
9978 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
9979 nmg->mg_private = mg->mg_private;
9980 nmg->mg_type = mg->mg_type;
9981 nmg->mg_flags = mg->mg_flags;
9982 if (mg->mg_type == PERL_MAGIC_qr) {
9983 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
9985 else if(mg->mg_type == PERL_MAGIC_backref) {
9986 const AV * const av = (AV*) mg->mg_obj;
9989 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
9991 for (i = AvFILLp(av); i >= 0; i--) {
9992 if (!svp[i]) continue;
9993 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
9996 else if (mg->mg_type == PERL_MAGIC_symtab) {
9997 nmg->mg_obj = mg->mg_obj;
10000 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
10001 ? sv_dup_inc(mg->mg_obj, param)
10002 : sv_dup(mg->mg_obj, param);
10004 nmg->mg_len = mg->mg_len;
10005 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
10006 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
10007 if (mg->mg_len > 0) {
10008 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
10009 if (mg->mg_type == PERL_MAGIC_overload_table &&
10010 AMT_AMAGIC((AMT*)mg->mg_ptr))
10012 AMT *amtp = (AMT*)mg->mg_ptr;
10013 AMT *namtp = (AMT*)nmg->mg_ptr;
10015 for (i = 1; i < NofAMmeth; i++) {
10016 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
10020 else if (mg->mg_len == HEf_SVKEY)
10021 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
10023 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
10024 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10031 /* create a new pointer-mapping table */
10034 Perl_ptr_table_new(pTHX)
10037 Newxz(tbl, 1, PTR_TBL_t);
10038 tbl->tbl_max = 511;
10039 tbl->tbl_items = 0;
10040 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10045 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
10047 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
10050 #define del_pte(p) del_body_type(p, struct ptr_tbl_ent, pte)
10052 /* map an existing pointer using a table */
10055 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
10057 PTR_TBL_ENT_t *tblent;
10058 const UV hash = PTR_TABLE_HASH(sv);
10060 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10061 for (; tblent; tblent = tblent->next) {
10062 if (tblent->oldval == sv)
10063 return tblent->newval;
10065 return (void*)NULL;
10068 /* add a new entry to a pointer-mapping table */
10071 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
10073 PTR_TBL_ENT_t *tblent, **otblent;
10074 /* XXX this may be pessimal on platforms where pointers aren't good
10075 * hash values e.g. if they grow faster in the most significant
10077 const UV hash = PTR_TABLE_HASH(oldsv);
10081 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
10082 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
10083 if (tblent->oldval == oldsv) {
10084 tblent->newval = newsv;
10088 new_body_inline(tblent, (void**)&PL_pte_arenaroot, (void**)&PL_pte_root,
10089 sizeof(struct ptr_tbl_ent));
10090 tblent->oldval = oldsv;
10091 tblent->newval = newsv;
10092 tblent->next = *otblent;
10095 if (!empty && tbl->tbl_items > tbl->tbl_max)
10096 ptr_table_split(tbl);
10099 /* double the hash bucket size of an existing ptr table */
10102 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
10104 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10105 const UV oldsize = tbl->tbl_max + 1;
10106 UV newsize = oldsize * 2;
10109 Renew(ary, newsize, PTR_TBL_ENT_t*);
10110 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10111 tbl->tbl_max = --newsize;
10112 tbl->tbl_ary = ary;
10113 for (i=0; i < oldsize; i++, ary++) {
10114 PTR_TBL_ENT_t **curentp, **entp, *ent;
10117 curentp = ary + oldsize;
10118 for (entp = ary, ent = *ary; ent; ent = *entp) {
10119 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10121 ent->next = *curentp;
10131 /* remove all the entries from a ptr table */
10134 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
10136 register PTR_TBL_ENT_t **array;
10137 register PTR_TBL_ENT_t *entry;
10141 if (!tbl || !tbl->tbl_items) {
10145 array = tbl->tbl_ary;
10147 max = tbl->tbl_max;
10151 PTR_TBL_ENT_t *oentry = entry;
10152 entry = entry->next;
10156 if (++riter > max) {
10159 entry = array[riter];
10163 tbl->tbl_items = 0;
10166 /* clear and free a ptr table */
10169 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
10174 ptr_table_clear(tbl);
10175 Safefree(tbl->tbl_ary);
10181 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
10184 SvRV_set(dstr, SvWEAKREF(sstr)
10185 ? sv_dup(SvRV(sstr), param)
10186 : sv_dup_inc(SvRV(sstr), param));
10189 else if (SvPVX_const(sstr)) {
10190 /* Has something there */
10192 /* Normal PV - clone whole allocated space */
10193 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
10194 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10195 /* Not that normal - actually sstr is copy on write.
10196 But we are a true, independant SV, so: */
10197 SvREADONLY_off(dstr);
10202 /* Special case - not normally malloced for some reason */
10203 if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
10204 /* A "shared" PV - clone it as "shared" PV */
10206 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
10210 /* Some other special case - random pointer */
10211 SvPV_set(dstr, SvPVX(sstr));
10216 /* Copy the Null */
10217 if (SvTYPE(dstr) == SVt_RV)
10218 SvRV_set(dstr, NULL);
10224 /* duplicate an SV of any type (including AV, HV etc) */
10227 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
10232 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10234 /* look for it in the table first */
10235 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10239 if(param->flags & CLONEf_JOIN_IN) {
10240 /** We are joining here so we don't want do clone
10241 something that is bad **/
10242 const char *hvname;
10244 if(SvTYPE(sstr) == SVt_PVHV &&
10245 (hvname = HvNAME_get(sstr))) {
10246 /** don't clone stashes if they already exist **/
10247 return (SV*)gv_stashpv(hvname,0);
10251 /* create anew and remember what it is */
10254 #ifdef DEBUG_LEAKING_SCALARS
10255 dstr->sv_debug_optype = sstr->sv_debug_optype;
10256 dstr->sv_debug_line = sstr->sv_debug_line;
10257 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10258 dstr->sv_debug_cloned = 1;
10260 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10262 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
10266 ptr_table_store(PL_ptr_table, sstr, dstr);
10269 SvFLAGS(dstr) = SvFLAGS(sstr);
10270 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10271 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10274 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
10275 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10276 PL_watch_pvx, SvPVX_const(sstr));
10279 /* don't clone objects whose class has asked us not to */
10280 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10281 SvFLAGS(dstr) &= ~SVTYPEMASK;
10282 SvOBJECT_off(dstr);
10286 switch (SvTYPE(sstr)) {
10288 SvANY(dstr) = NULL;
10291 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
10292 SvIV_set(dstr, SvIVX(sstr));
10295 SvANY(dstr) = new_XNV();
10296 SvNV_set(dstr, SvNVX(sstr));
10299 SvANY(dstr) = &(dstr->sv_u.svu_rv);
10300 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10304 /* These are all the types that need complex bodies allocating. */
10305 size_t new_body_length;
10306 size_t new_body_offset = 0;
10307 void **new_body_arena;
10308 void **new_body_arenaroot;
10311 switch (SvTYPE(sstr)) {
10313 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]",
10318 new_body = new_XPVIO();
10319 new_body_length = sizeof(XPVIO);
10322 new_body = new_XPVFM();
10323 new_body_length = sizeof(XPVFM);
10327 new_body_arena = (void **) &PL_xpvhv_root;
10328 new_body_arenaroot = (void **) &PL_xpvhv_arenaroot;
10329 new_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill)
10330 - STRUCT_OFFSET(xpvhv_allocated, xhv_fill);
10331 new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash)
10332 + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash)
10336 new_body_arena = (void **) &PL_xpvav_root;
10337 new_body_arenaroot = (void **) &PL_xpvav_arenaroot;
10338 new_body_offset = STRUCT_OFFSET(XPVAV, xav_fill)
10339 - STRUCT_OFFSET(xpvav_allocated, xav_fill);
10340 new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash)
10341 + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash)
10345 new_body_length = sizeof(XPVBM);
10346 new_body_arena = (void **) &PL_xpvbm_root;
10347 new_body_arenaroot = (void **) &PL_xpvbm_arenaroot;
10350 if (GvUNIQUE((GV*)sstr)) {
10351 /* Do sharing here. */
10353 new_body_length = sizeof(XPVGV);
10354 new_body_arena = (void **) &PL_xpvgv_root;
10355 new_body_arenaroot = (void **) &PL_xpvgv_arenaroot;
10358 new_body_length = sizeof(XPVCV);
10359 new_body_arena = (void **) &PL_xpvcv_root;
10360 new_body_arenaroot = (void **) &PL_xpvcv_arenaroot;
10363 new_body_length = sizeof(XPVLV);
10364 new_body_arena = (void **) &PL_xpvlv_root;
10365 new_body_arenaroot = (void **) &PL_xpvlv_arenaroot;
10368 new_body_length = sizeof(XPVMG);
10369 new_body_arena = (void **) &PL_xpvmg_root;
10370 new_body_arenaroot = (void **) &PL_xpvmg_arenaroot;
10373 new_body_length = sizeof(XPVNV);
10374 new_body_arena = (void **) &PL_xpvnv_root;
10375 new_body_arenaroot = (void **) &PL_xpvnv_arenaroot;
10378 new_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
10379 - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
10380 new_body_length = sizeof(XPVIV) - new_body_offset;
10381 new_body_arena = (void **) &PL_xpviv_root;
10382 new_body_arenaroot = (void **) &PL_xpviv_arenaroot;
10385 new_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
10386 - STRUCT_OFFSET(xpv_allocated, xpv_cur);
10387 new_body_length = sizeof(XPV) - new_body_offset;
10388 new_body_arena = (void **) &PL_xpv_root;
10389 new_body_arenaroot = (void **) &PL_xpv_arenaroot;
10391 assert(new_body_length);
10393 new_body_inline(new_body, new_body_arenaroot, new_body_arena,
10395 new_body = (void*)((char*)new_body - new_body_offset);
10397 /* We always allocated the full length item with PURIFY */
10398 new_body_length += new_body_offset;
10399 new_body_offset = 0;
10400 new_body = my_safemalloc(new_body_length);
10404 SvANY(dstr) = new_body;
10406 Copy(((char*)SvANY(sstr)) + new_body_offset,
10407 ((char*)SvANY(dstr)) + new_body_offset,
10408 new_body_length, char);
10410 if (SvTYPE(sstr) != SVt_PVAV && SvTYPE(sstr) != SVt_PVHV)
10411 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10413 /* The Copy above means that all the source (unduplicated) pointers
10414 are now in the destination. We can check the flags and the
10415 pointers in either, but it's possible that there's less cache
10416 missing by always going for the destination.
10417 FIXME - instrument and check that assumption */
10418 if (SvTYPE(sstr) >= SVt_PVMG) {
10420 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
10422 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
10425 switch (SvTYPE(sstr)) {
10437 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
10438 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
10439 LvTARG(dstr) = dstr;
10440 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
10441 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
10443 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
10446 GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr));
10447 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
10448 /* Don't call sv_add_backref here as it's going to be created
10449 as part of the magic cloning of the symbol table. */
10450 GvGP(dstr) = gp_dup(GvGP(dstr), param);
10451 (void)GpREFCNT_inc(GvGP(dstr));
10454 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
10455 if (IoOFP(dstr) == IoIFP(sstr))
10456 IoOFP(dstr) = IoIFP(dstr);
10458 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
10459 /* PL_rsfp_filters entries have fake IoDIRP() */
10460 if (IoDIRP(dstr) && !(IoFLAGS(dstr) & IOf_FAKE_DIRP))
10461 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
10462 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
10463 /* I have no idea why fake dirp (rsfps)
10464 should be treated differently but otherwise
10465 we end up with leaks -- sky*/
10466 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
10467 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
10468 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
10470 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
10471 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
10472 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
10474 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
10475 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
10476 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
10479 if (AvARRAY((AV*)sstr)) {
10480 SV **dst_ary, **src_ary;
10481 SSize_t items = AvFILLp((AV*)sstr) + 1;
10483 src_ary = AvARRAY((AV*)sstr);
10484 Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*);
10485 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10486 SvPV_set(dstr, (char*)dst_ary);
10487 AvALLOC((AV*)dstr) = dst_ary;
10488 if (AvREAL((AV*)sstr)) {
10489 while (items-- > 0)
10490 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10493 while (items-- > 0)
10494 *dst_ary++ = sv_dup(*src_ary++, param);
10496 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10497 while (items-- > 0) {
10498 *dst_ary++ = &PL_sv_undef;
10502 SvPV_set(dstr, Nullch);
10503 AvALLOC((AV*)dstr) = (SV**)NULL;
10510 if (HvARRAY((HV*)sstr)) {
10512 const bool sharekeys = !!HvSHAREKEYS(sstr);
10513 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
10514 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
10516 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
10517 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
10519 HvARRAY(dstr) = (HE**)darray;
10520 while (i <= sxhv->xhv_max) {
10521 const HE *source = HvARRAY(sstr)[i];
10522 HvARRAY(dstr)[i] = source
10523 ? he_dup(source, sharekeys, param) : 0;
10527 struct xpvhv_aux *saux = HvAUX(sstr);
10528 struct xpvhv_aux *daux = HvAUX(dstr);
10529 /* This flag isn't copied. */
10530 /* SvOOK_on(hv) attacks the IV flags. */
10531 SvFLAGS(dstr) |= SVf_OOK;
10533 hvname = saux->xhv_name;
10535 = hvname ? hek_dup(hvname, param) : hvname;
10537 daux->xhv_riter = saux->xhv_riter;
10538 daux->xhv_eiter = saux->xhv_eiter
10539 ? he_dup(saux->xhv_eiter,
10540 (bool)!!HvSHAREKEYS(sstr), param) : 0;
10544 SvPV_set(dstr, Nullch);
10546 /* Record stashes for possible cloning in Perl_clone(). */
10548 av_push(param->stashes, dstr);
10553 /* NOTE: not refcounted */
10554 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
10556 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
10558 if (CvCONST(dstr)) {
10559 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
10560 SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
10561 sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
10563 /* don't dup if copying back - CvGV isn't refcounted, so the
10564 * duped GV may never be freed. A bit of a hack! DAPM */
10565 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
10566 Nullgv : gv_dup(CvGV(dstr), param) ;
10567 if (!(param->flags & CLONEf_COPY_STACKS)) {
10570 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10572 CvWEAKOUTSIDE(sstr)
10573 ? cv_dup( CvOUTSIDE(dstr), param)
10574 : cv_dup_inc(CvOUTSIDE(dstr), param);
10576 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
10582 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10588 /* duplicate a context */
10591 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10593 PERL_CONTEXT *ncxs;
10596 return (PERL_CONTEXT*)NULL;
10598 /* look for it in the table first */
10599 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10603 /* create anew and remember what it is */
10604 Newxz(ncxs, max + 1, PERL_CONTEXT);
10605 ptr_table_store(PL_ptr_table, cxs, ncxs);
10608 PERL_CONTEXT *cx = &cxs[ix];
10609 PERL_CONTEXT *ncx = &ncxs[ix];
10610 ncx->cx_type = cx->cx_type;
10611 if (CxTYPE(cx) == CXt_SUBST) {
10612 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10615 ncx->blk_oldsp = cx->blk_oldsp;
10616 ncx->blk_oldcop = cx->blk_oldcop;
10617 ncx->blk_oldmarksp = cx->blk_oldmarksp;
10618 ncx->blk_oldscopesp = cx->blk_oldscopesp;
10619 ncx->blk_oldpm = cx->blk_oldpm;
10620 ncx->blk_gimme = cx->blk_gimme;
10621 switch (CxTYPE(cx)) {
10623 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
10624 ? cv_dup_inc(cx->blk_sub.cv, param)
10625 : cv_dup(cx->blk_sub.cv,param));
10626 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
10627 ? av_dup_inc(cx->blk_sub.argarray, param)
10629 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
10630 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
10631 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10632 ncx->blk_sub.lval = cx->blk_sub.lval;
10633 ncx->blk_sub.retop = cx->blk_sub.retop;
10636 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
10637 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
10638 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
10639 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
10640 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
10641 ncx->blk_eval.retop = cx->blk_eval.retop;
10644 ncx->blk_loop.label = cx->blk_loop.label;
10645 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
10646 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
10647 ncx->blk_loop.next_op = cx->blk_loop.next_op;
10648 ncx->blk_loop.last_op = cx->blk_loop.last_op;
10649 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
10650 ? cx->blk_loop.iterdata
10651 : gv_dup((GV*)cx->blk_loop.iterdata, param));
10652 ncx->blk_loop.oldcomppad
10653 = (PAD*)ptr_table_fetch(PL_ptr_table,
10654 cx->blk_loop.oldcomppad);
10655 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
10656 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
10657 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
10658 ncx->blk_loop.iterix = cx->blk_loop.iterix;
10659 ncx->blk_loop.itermax = cx->blk_loop.itermax;
10662 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
10663 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
10664 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
10665 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10666 ncx->blk_sub.retop = cx->blk_sub.retop;
10678 /* duplicate a stack info structure */
10681 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10686 return (PERL_SI*)NULL;
10688 /* look for it in the table first */
10689 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10693 /* create anew and remember what it is */
10694 Newxz(nsi, 1, PERL_SI);
10695 ptr_table_store(PL_ptr_table, si, nsi);
10697 nsi->si_stack = av_dup_inc(si->si_stack, param);
10698 nsi->si_cxix = si->si_cxix;
10699 nsi->si_cxmax = si->si_cxmax;
10700 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
10701 nsi->si_type = si->si_type;
10702 nsi->si_prev = si_dup(si->si_prev, param);
10703 nsi->si_next = si_dup(si->si_next, param);
10704 nsi->si_markoff = si->si_markoff;
10709 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
10710 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
10711 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
10712 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
10713 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
10714 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
10715 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
10716 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
10717 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
10718 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
10719 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
10720 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
10721 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
10722 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
10725 #define pv_dup_inc(p) SAVEPV(p)
10726 #define pv_dup(p) SAVEPV(p)
10727 #define svp_dup_inc(p,pp) any_dup(p,pp)
10729 /* map any object to the new equivent - either something in the
10730 * ptr table, or something in the interpreter structure
10734 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
10739 return (void*)NULL;
10741 /* look for it in the table first */
10742 ret = ptr_table_fetch(PL_ptr_table, v);
10746 /* see if it is part of the interpreter structure */
10747 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
10748 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
10756 /* duplicate the save stack */
10759 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
10761 ANY * const ss = proto_perl->Tsavestack;
10762 const I32 max = proto_perl->Tsavestack_max;
10763 I32 ix = proto_perl->Tsavestack_ix;
10775 void (*dptr) (void*);
10776 void (*dxptr) (pTHX_ void*);
10778 Newxz(nss, max, ANY);
10781 I32 i = POPINT(ss,ix);
10782 TOPINT(nss,ix) = i;
10784 case SAVEt_ITEM: /* normal string */
10785 sv = (SV*)POPPTR(ss,ix);
10786 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10787 sv = (SV*)POPPTR(ss,ix);
10788 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10790 case SAVEt_SV: /* scalar reference */
10791 sv = (SV*)POPPTR(ss,ix);
10792 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10793 gv = (GV*)POPPTR(ss,ix);
10794 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10796 case SAVEt_GENERIC_PVREF: /* generic char* */
10797 c = (char*)POPPTR(ss,ix);
10798 TOPPTR(nss,ix) = pv_dup(c);
10799 ptr = POPPTR(ss,ix);
10800 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10802 case SAVEt_SHARED_PVREF: /* char* in shared space */
10803 c = (char*)POPPTR(ss,ix);
10804 TOPPTR(nss,ix) = savesharedpv(c);
10805 ptr = POPPTR(ss,ix);
10806 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10808 case SAVEt_GENERIC_SVREF: /* generic sv */
10809 case SAVEt_SVREF: /* scalar reference */
10810 sv = (SV*)POPPTR(ss,ix);
10811 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10812 ptr = POPPTR(ss,ix);
10813 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
10815 case SAVEt_AV: /* array reference */
10816 av = (AV*)POPPTR(ss,ix);
10817 TOPPTR(nss,ix) = av_dup_inc(av, param);
10818 gv = (GV*)POPPTR(ss,ix);
10819 TOPPTR(nss,ix) = gv_dup(gv, param);
10821 case SAVEt_HV: /* hash reference */
10822 hv = (HV*)POPPTR(ss,ix);
10823 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10824 gv = (GV*)POPPTR(ss,ix);
10825 TOPPTR(nss,ix) = gv_dup(gv, param);
10827 case SAVEt_INT: /* int reference */
10828 ptr = POPPTR(ss,ix);
10829 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10830 intval = (int)POPINT(ss,ix);
10831 TOPINT(nss,ix) = intval;
10833 case SAVEt_LONG: /* long reference */
10834 ptr = POPPTR(ss,ix);
10835 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10836 longval = (long)POPLONG(ss,ix);
10837 TOPLONG(nss,ix) = longval;
10839 case SAVEt_I32: /* I32 reference */
10840 case SAVEt_I16: /* I16 reference */
10841 case SAVEt_I8: /* I8 reference */
10842 ptr = POPPTR(ss,ix);
10843 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10845 TOPINT(nss,ix) = i;
10847 case SAVEt_IV: /* IV reference */
10848 ptr = POPPTR(ss,ix);
10849 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10851 TOPIV(nss,ix) = iv;
10853 case SAVEt_SPTR: /* SV* reference */
10854 ptr = POPPTR(ss,ix);
10855 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10856 sv = (SV*)POPPTR(ss,ix);
10857 TOPPTR(nss,ix) = sv_dup(sv, param);
10859 case SAVEt_VPTR: /* random* reference */
10860 ptr = POPPTR(ss,ix);
10861 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10862 ptr = POPPTR(ss,ix);
10863 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10865 case SAVEt_PPTR: /* char* reference */
10866 ptr = POPPTR(ss,ix);
10867 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10868 c = (char*)POPPTR(ss,ix);
10869 TOPPTR(nss,ix) = pv_dup(c);
10871 case SAVEt_HPTR: /* HV* reference */
10872 ptr = POPPTR(ss,ix);
10873 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10874 hv = (HV*)POPPTR(ss,ix);
10875 TOPPTR(nss,ix) = hv_dup(hv, param);
10877 case SAVEt_APTR: /* AV* reference */
10878 ptr = POPPTR(ss,ix);
10879 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10880 av = (AV*)POPPTR(ss,ix);
10881 TOPPTR(nss,ix) = av_dup(av, param);
10884 gv = (GV*)POPPTR(ss,ix);
10885 TOPPTR(nss,ix) = gv_dup(gv, param);
10887 case SAVEt_GP: /* scalar reference */
10888 gp = (GP*)POPPTR(ss,ix);
10889 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
10890 (void)GpREFCNT_inc(gp);
10891 gv = (GV*)POPPTR(ss,ix);
10892 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10893 c = (char*)POPPTR(ss,ix);
10894 TOPPTR(nss,ix) = pv_dup(c);
10896 TOPIV(nss,ix) = iv;
10898 TOPIV(nss,ix) = iv;
10901 case SAVEt_MORTALIZESV:
10902 sv = (SV*)POPPTR(ss,ix);
10903 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10906 ptr = POPPTR(ss,ix);
10907 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
10908 /* these are assumed to be refcounted properly */
10910 switch (((OP*)ptr)->op_type) {
10912 case OP_LEAVESUBLV:
10916 case OP_LEAVEWRITE:
10917 TOPPTR(nss,ix) = ptr;
10922 TOPPTR(nss,ix) = Nullop;
10927 TOPPTR(nss,ix) = Nullop;
10930 c = (char*)POPPTR(ss,ix);
10931 TOPPTR(nss,ix) = pv_dup_inc(c);
10933 case SAVEt_CLEARSV:
10934 longval = POPLONG(ss,ix);
10935 TOPLONG(nss,ix) = longval;
10938 hv = (HV*)POPPTR(ss,ix);
10939 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10940 c = (char*)POPPTR(ss,ix);
10941 TOPPTR(nss,ix) = pv_dup_inc(c);
10943 TOPINT(nss,ix) = i;
10945 case SAVEt_DESTRUCTOR:
10946 ptr = POPPTR(ss,ix);
10947 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10948 dptr = POPDPTR(ss,ix);
10949 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
10950 any_dup(FPTR2DPTR(void *, dptr),
10953 case SAVEt_DESTRUCTOR_X:
10954 ptr = POPPTR(ss,ix);
10955 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10956 dxptr = POPDXPTR(ss,ix);
10957 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
10958 any_dup(FPTR2DPTR(void *, dxptr),
10961 case SAVEt_REGCONTEXT:
10964 TOPINT(nss,ix) = i;
10967 case SAVEt_STACK_POS: /* Position on Perl stack */
10969 TOPINT(nss,ix) = i;
10971 case SAVEt_AELEM: /* array element */
10972 sv = (SV*)POPPTR(ss,ix);
10973 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10975 TOPINT(nss,ix) = i;
10976 av = (AV*)POPPTR(ss,ix);
10977 TOPPTR(nss,ix) = av_dup_inc(av, param);
10979 case SAVEt_HELEM: /* hash element */
10980 sv = (SV*)POPPTR(ss,ix);
10981 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10982 sv = (SV*)POPPTR(ss,ix);
10983 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10984 hv = (HV*)POPPTR(ss,ix);
10985 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10988 ptr = POPPTR(ss,ix);
10989 TOPPTR(nss,ix) = ptr;
10993 TOPINT(nss,ix) = i;
10995 case SAVEt_COMPPAD:
10996 av = (AV*)POPPTR(ss,ix);
10997 TOPPTR(nss,ix) = av_dup(av, param);
11000 longval = (long)POPLONG(ss,ix);
11001 TOPLONG(nss,ix) = longval;
11002 ptr = POPPTR(ss,ix);
11003 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11004 sv = (SV*)POPPTR(ss,ix);
11005 TOPPTR(nss,ix) = sv_dup(sv, param);
11008 ptr = POPPTR(ss,ix);
11009 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11010 longval = (long)POPBOOL(ss,ix);
11011 TOPBOOL(nss,ix) = (bool)longval;
11013 case SAVEt_SET_SVFLAGS:
11015 TOPINT(nss,ix) = i;
11017 TOPINT(nss,ix) = i;
11018 sv = (SV*)POPPTR(ss,ix);
11019 TOPPTR(nss,ix) = sv_dup(sv, param);
11022 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
11030 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11031 * flag to the result. This is done for each stash before cloning starts,
11032 * so we know which stashes want their objects cloned */
11035 do_mark_cloneable_stash(pTHX_ SV *sv)
11037 const HEK * const hvname = HvNAME_HEK((HV*)sv);
11039 GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
11040 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11041 if (cloner && GvCV(cloner)) {
11048 XPUSHs(sv_2mortal(newSVhek(hvname)));
11050 call_sv((SV*)GvCV(cloner), G_SCALAR);
11057 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11065 =for apidoc perl_clone
11067 Create and return a new interpreter by cloning the current one.
11069 perl_clone takes these flags as parameters:
11071 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11072 without it we only clone the data and zero the stacks,
11073 with it we copy the stacks and the new perl interpreter is
11074 ready to run at the exact same point as the previous one.
11075 The pseudo-fork code uses COPY_STACKS while the
11076 threads->new doesn't.
11078 CLONEf_KEEP_PTR_TABLE
11079 perl_clone keeps a ptr_table with the pointer of the old
11080 variable as a key and the new variable as a value,
11081 this allows it to check if something has been cloned and not
11082 clone it again but rather just use the value and increase the
11083 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11084 the ptr_table using the function
11085 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11086 reason to keep it around is if you want to dup some of your own
11087 variable who are outside the graph perl scans, example of this
11088 code is in threads.xs create
11091 This is a win32 thing, it is ignored on unix, it tells perls
11092 win32host code (which is c++) to clone itself, this is needed on
11093 win32 if you want to run two threads at the same time,
11094 if you just want to do some stuff in a separate perl interpreter
11095 and then throw it away and return to the original one,
11096 you don't need to do anything.
11101 /* XXX the above needs expanding by someone who actually understands it ! */
11102 EXTERN_C PerlInterpreter *
11103 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11106 perl_clone(PerlInterpreter *proto_perl, UV flags)
11109 #ifdef PERL_IMPLICIT_SYS
11111 /* perlhost.h so we need to call into it
11112 to clone the host, CPerlHost should have a c interface, sky */
11114 if (flags & CLONEf_CLONE_HOST) {
11115 return perl_clone_host(proto_perl,flags);
11117 return perl_clone_using(proto_perl, flags,
11119 proto_perl->IMemShared,
11120 proto_perl->IMemParse,
11122 proto_perl->IStdIO,
11126 proto_perl->IProc);
11130 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11131 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11132 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11133 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11134 struct IPerlDir* ipD, struct IPerlSock* ipS,
11135 struct IPerlProc* ipP)
11137 /* XXX many of the string copies here can be optimized if they're
11138 * constants; they need to be allocated as common memory and just
11139 * their pointers copied. */
11142 CLONE_PARAMS clone_params;
11143 CLONE_PARAMS* param = &clone_params;
11145 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11146 /* for each stash, determine whether its objects should be cloned */
11147 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11148 PERL_SET_THX(my_perl);
11151 Poison(my_perl, 1, PerlInterpreter);
11153 PL_curcop = (COP *)Nullop;
11157 PL_savestack_ix = 0;
11158 PL_savestack_max = -1;
11159 PL_sig_pending = 0;
11160 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11161 # else /* !DEBUGGING */
11162 Zero(my_perl, 1, PerlInterpreter);
11163 # endif /* DEBUGGING */
11165 /* host pointers */
11167 PL_MemShared = ipMS;
11168 PL_MemParse = ipMP;
11175 #else /* !PERL_IMPLICIT_SYS */
11177 CLONE_PARAMS clone_params;
11178 CLONE_PARAMS* param = &clone_params;
11179 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11180 /* for each stash, determine whether its objects should be cloned */
11181 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11182 PERL_SET_THX(my_perl);
11185 Poison(my_perl, 1, PerlInterpreter);
11187 PL_curcop = (COP *)Nullop;
11191 PL_savestack_ix = 0;
11192 PL_savestack_max = -1;
11193 PL_sig_pending = 0;
11194 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11195 # else /* !DEBUGGING */
11196 Zero(my_perl, 1, PerlInterpreter);
11197 # endif /* DEBUGGING */
11198 #endif /* PERL_IMPLICIT_SYS */
11199 param->flags = flags;
11200 param->proto_perl = proto_perl;
11203 PL_xnv_arenaroot = NULL;
11204 PL_xnv_root = NULL;
11205 PL_xpv_arenaroot = NULL;
11206 PL_xpv_root = NULL;
11207 PL_xpviv_arenaroot = NULL;
11208 PL_xpviv_root = NULL;
11209 PL_xpvnv_arenaroot = NULL;
11210 PL_xpvnv_root = NULL;
11211 PL_xpvcv_arenaroot = NULL;
11212 PL_xpvcv_root = NULL;
11213 PL_xpvav_arenaroot = NULL;
11214 PL_xpvav_root = NULL;
11215 PL_xpvhv_arenaroot = NULL;
11216 PL_xpvhv_root = NULL;
11217 PL_xpvmg_arenaroot = NULL;
11218 PL_xpvmg_root = NULL;
11219 PL_xpvgv_arenaroot = NULL;
11220 PL_xpvgv_root = NULL;
11221 PL_xpvlv_arenaroot = NULL;
11222 PL_xpvlv_root = NULL;
11223 PL_xpvbm_arenaroot = NULL;
11224 PL_xpvbm_root = NULL;
11225 PL_he_arenaroot = NULL;
11227 #if defined(USE_ITHREADS)
11228 PL_pte_arenaroot = NULL;
11229 PL_pte_root = NULL;
11231 PL_nice_chunk = NULL;
11232 PL_nice_chunk_size = 0;
11234 PL_sv_objcount = 0;
11235 PL_sv_root = Nullsv;
11236 PL_sv_arenaroot = Nullsv;
11238 PL_debug = proto_perl->Idebug;
11240 PL_hash_seed = proto_perl->Ihash_seed;
11241 PL_rehash_seed = proto_perl->Irehash_seed;
11243 #ifdef USE_REENTRANT_API
11244 /* XXX: things like -Dm will segfault here in perlio, but doing
11245 * PERL_SET_CONTEXT(proto_perl);
11246 * breaks too many other things
11248 Perl_reentrant_init(aTHX);
11251 /* create SV map for pointer relocation */
11252 PL_ptr_table = ptr_table_new();
11254 /* initialize these special pointers as early as possible */
11255 SvANY(&PL_sv_undef) = NULL;
11256 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11257 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11258 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11260 SvANY(&PL_sv_no) = new_XPVNV();
11261 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11262 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11263 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11264 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
11265 SvCUR_set(&PL_sv_no, 0);
11266 SvLEN_set(&PL_sv_no, 1);
11267 SvIV_set(&PL_sv_no, 0);
11268 SvNV_set(&PL_sv_no, 0);
11269 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11271 SvANY(&PL_sv_yes) = new_XPVNV();
11272 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11273 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11274 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11275 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
11276 SvCUR_set(&PL_sv_yes, 1);
11277 SvLEN_set(&PL_sv_yes, 2);
11278 SvIV_set(&PL_sv_yes, 1);
11279 SvNV_set(&PL_sv_yes, 1);
11280 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11282 /* create (a non-shared!) shared string table */
11283 PL_strtab = newHV();
11284 HvSHAREKEYS_off(PL_strtab);
11285 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
11286 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11288 PL_compiling = proto_perl->Icompiling;
11290 /* These two PVs will be free'd special way so must set them same way op.c does */
11291 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11292 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11294 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11295 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11297 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11298 if (!specialWARN(PL_compiling.cop_warnings))
11299 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
11300 if (!specialCopIO(PL_compiling.cop_io))
11301 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
11302 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
11304 /* pseudo environmental stuff */
11305 PL_origargc = proto_perl->Iorigargc;
11306 PL_origargv = proto_perl->Iorigargv;
11308 param->stashes = newAV(); /* Setup array of objects to call clone on */
11310 /* Set tainting stuff before PerlIO_debug can possibly get called */
11311 PL_tainting = proto_perl->Itainting;
11312 PL_taint_warn = proto_perl->Itaint_warn;
11314 #ifdef PERLIO_LAYERS
11315 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11316 PerlIO_clone(aTHX_ proto_perl, param);
11319 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11320 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11321 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11322 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11323 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11324 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11327 PL_minus_c = proto_perl->Iminus_c;
11328 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11329 PL_localpatches = proto_perl->Ilocalpatches;
11330 PL_splitstr = proto_perl->Isplitstr;
11331 PL_preprocess = proto_perl->Ipreprocess;
11332 PL_minus_n = proto_perl->Iminus_n;
11333 PL_minus_p = proto_perl->Iminus_p;
11334 PL_minus_l = proto_perl->Iminus_l;
11335 PL_minus_a = proto_perl->Iminus_a;
11336 PL_minus_F = proto_perl->Iminus_F;
11337 PL_doswitches = proto_perl->Idoswitches;
11338 PL_dowarn = proto_perl->Idowarn;
11339 PL_doextract = proto_perl->Idoextract;
11340 PL_sawampersand = proto_perl->Isawampersand;
11341 PL_unsafe = proto_perl->Iunsafe;
11342 PL_inplace = SAVEPV(proto_perl->Iinplace);
11343 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11344 PL_perldb = proto_perl->Iperldb;
11345 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11346 PL_exit_flags = proto_perl->Iexit_flags;
11348 /* magical thingies */
11349 /* XXX time(&PL_basetime) when asked for? */
11350 PL_basetime = proto_perl->Ibasetime;
11351 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11353 PL_maxsysfd = proto_perl->Imaxsysfd;
11354 PL_multiline = proto_perl->Imultiline;
11355 PL_statusvalue = proto_perl->Istatusvalue;
11357 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11359 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
11361 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11363 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11364 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11365 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11367 /* Clone the regex array */
11368 PL_regex_padav = newAV();
11370 const I32 len = av_len((AV*)proto_perl->Iregex_padav);
11371 SV** const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11373 av_push(PL_regex_padav,
11374 sv_dup_inc(regexen[0],param));
11375 for(i = 1; i <= len; i++) {
11376 if(SvREPADTMP(regexen[i])) {
11377 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11379 av_push(PL_regex_padav,
11381 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11382 SvIVX(regexen[i])), param)))
11387 PL_regex_pad = AvARRAY(PL_regex_padav);
11389 /* shortcuts to various I/O objects */
11390 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11391 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11392 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11393 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11394 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11395 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11397 /* shortcuts to regexp stuff */
11398 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11400 /* shortcuts to misc objects */
11401 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11403 /* shortcuts to debugging objects */
11404 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11405 PL_DBline = gv_dup(proto_perl->IDBline, param);
11406 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11407 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11408 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11409 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11410 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11411 PL_lineary = av_dup(proto_perl->Ilineary, param);
11412 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11414 /* symbol tables */
11415 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11416 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11417 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11418 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11419 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11421 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11422 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11423 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11424 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11425 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11426 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11428 PL_sub_generation = proto_perl->Isub_generation;
11430 /* funky return mechanisms */
11431 PL_forkprocess = proto_perl->Iforkprocess;
11433 /* subprocess state */
11434 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11436 /* internal state */
11437 PL_maxo = proto_perl->Imaxo;
11438 if (proto_perl->Iop_mask)
11439 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11441 PL_op_mask = Nullch;
11442 /* PL_asserting = proto_perl->Iasserting; */
11444 /* current interpreter roots */
11445 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11446 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11447 PL_main_start = proto_perl->Imain_start;
11448 PL_eval_root = proto_perl->Ieval_root;
11449 PL_eval_start = proto_perl->Ieval_start;
11451 /* runtime control stuff */
11452 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11453 PL_copline = proto_perl->Icopline;
11455 PL_filemode = proto_perl->Ifilemode;
11456 PL_lastfd = proto_perl->Ilastfd;
11457 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11460 PL_gensym = proto_perl->Igensym;
11461 PL_preambled = proto_perl->Ipreambled;
11462 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11463 PL_laststatval = proto_perl->Ilaststatval;
11464 PL_laststype = proto_perl->Ilaststype;
11465 PL_mess_sv = Nullsv;
11467 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11469 /* interpreter atexit processing */
11470 PL_exitlistlen = proto_perl->Iexitlistlen;
11471 if (PL_exitlistlen) {
11472 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11473 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11476 PL_exitlist = (PerlExitListEntry*)NULL;
11477 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11478 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11479 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11481 PL_profiledata = NULL;
11482 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
11483 /* PL_rsfp_filters entries have fake IoDIRP() */
11484 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
11486 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11488 PAD_CLONE_VARS(proto_perl, param);
11490 #ifdef HAVE_INTERP_INTERN
11491 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11494 /* more statics moved here */
11495 PL_generation = proto_perl->Igeneration;
11496 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11498 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11499 PL_in_clean_all = proto_perl->Iin_clean_all;
11501 PL_uid = proto_perl->Iuid;
11502 PL_euid = proto_perl->Ieuid;
11503 PL_gid = proto_perl->Igid;
11504 PL_egid = proto_perl->Iegid;
11505 PL_nomemok = proto_perl->Inomemok;
11506 PL_an = proto_perl->Ian;
11507 PL_evalseq = proto_perl->Ievalseq;
11508 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11509 PL_origalen = proto_perl->Iorigalen;
11510 #ifdef PERL_USES_PL_PIDSTATUS
11511 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11513 PL_osname = SAVEPV(proto_perl->Iosname);
11514 PL_sighandlerp = proto_perl->Isighandlerp;
11516 PL_runops = proto_perl->Irunops;
11518 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11521 PL_cshlen = proto_perl->Icshlen;
11522 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
11525 PL_lex_state = proto_perl->Ilex_state;
11526 PL_lex_defer = proto_perl->Ilex_defer;
11527 PL_lex_expect = proto_perl->Ilex_expect;
11528 PL_lex_formbrack = proto_perl->Ilex_formbrack;
11529 PL_lex_dojoin = proto_perl->Ilex_dojoin;
11530 PL_lex_starts = proto_perl->Ilex_starts;
11531 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
11532 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
11533 PL_lex_op = proto_perl->Ilex_op;
11534 PL_lex_inpat = proto_perl->Ilex_inpat;
11535 PL_lex_inwhat = proto_perl->Ilex_inwhat;
11536 PL_lex_brackets = proto_perl->Ilex_brackets;
11537 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11538 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
11539 PL_lex_casemods = proto_perl->Ilex_casemods;
11540 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11541 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
11543 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11544 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
11545 PL_nexttoke = proto_perl->Inexttoke;
11547 /* XXX This is probably masking the deeper issue of why
11548 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11549 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11550 * (A little debugging with a watchpoint on it may help.)
11552 if (SvANY(proto_perl->Ilinestr)) {
11553 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
11554 i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
11555 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11556 i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
11557 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11558 i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
11559 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11560 i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
11561 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11564 PL_linestr = NEWSV(65,79);
11565 sv_upgrade(PL_linestr,SVt_PVIV);
11566 sv_setpvn(PL_linestr,"",0);
11567 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
11569 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11570 PL_pending_ident = proto_perl->Ipending_ident;
11571 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
11573 PL_expect = proto_perl->Iexpect;
11575 PL_multi_start = proto_perl->Imulti_start;
11576 PL_multi_end = proto_perl->Imulti_end;
11577 PL_multi_open = proto_perl->Imulti_open;
11578 PL_multi_close = proto_perl->Imulti_close;
11580 PL_error_count = proto_perl->Ierror_count;
11581 PL_subline = proto_perl->Isubline;
11582 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
11584 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
11585 if (SvANY(proto_perl->Ilinestr)) {
11586 i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
11587 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11588 i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
11589 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11590 PL_last_lop_op = proto_perl->Ilast_lop_op;
11593 PL_last_uni = SvPVX(PL_linestr);
11594 PL_last_lop = SvPVX(PL_linestr);
11595 PL_last_lop_op = 0;
11597 PL_in_my = proto_perl->Iin_my;
11598 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
11600 PL_cryptseen = proto_perl->Icryptseen;
11603 PL_hints = proto_perl->Ihints;
11605 PL_amagic_generation = proto_perl->Iamagic_generation;
11607 #ifdef USE_LOCALE_COLLATE
11608 PL_collation_ix = proto_perl->Icollation_ix;
11609 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
11610 PL_collation_standard = proto_perl->Icollation_standard;
11611 PL_collxfrm_base = proto_perl->Icollxfrm_base;
11612 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
11613 #endif /* USE_LOCALE_COLLATE */
11615 #ifdef USE_LOCALE_NUMERIC
11616 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
11617 PL_numeric_standard = proto_perl->Inumeric_standard;
11618 PL_numeric_local = proto_perl->Inumeric_local;
11619 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11620 #endif /* !USE_LOCALE_NUMERIC */
11622 /* utf8 character classes */
11623 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11624 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11625 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11626 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11627 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
11628 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11629 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
11630 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
11631 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
11632 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
11633 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
11634 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
11635 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11636 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
11637 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11638 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11639 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11640 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11641 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11642 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11644 /* Did the locale setup indicate UTF-8? */
11645 PL_utf8locale = proto_perl->Iutf8locale;
11646 /* Unicode features (see perlrun/-C) */
11647 PL_unicode = proto_perl->Iunicode;
11649 /* Pre-5.8 signals control */
11650 PL_signals = proto_perl->Isignals;
11652 /* times() ticks per second */
11653 PL_clocktick = proto_perl->Iclocktick;
11655 /* Recursion stopper for PerlIO_find_layer */
11656 PL_in_load_module = proto_perl->Iin_load_module;
11658 /* sort() routine */
11659 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
11661 /* Not really needed/useful since the reenrant_retint is "volatile",
11662 * but do it for consistency's sake. */
11663 PL_reentrant_retint = proto_perl->Ireentrant_retint;
11665 /* Hooks to shared SVs and locks. */
11666 PL_sharehook = proto_perl->Isharehook;
11667 PL_lockhook = proto_perl->Ilockhook;
11668 PL_unlockhook = proto_perl->Iunlockhook;
11669 PL_threadhook = proto_perl->Ithreadhook;
11671 PL_runops_std = proto_perl->Irunops_std;
11672 PL_runops_dbg = proto_perl->Irunops_dbg;
11674 #ifdef THREADS_HAVE_PIDS
11675 PL_ppid = proto_perl->Ippid;
11679 PL_last_swash_hv = Nullhv; /* reinits on demand */
11680 PL_last_swash_klen = 0;
11681 PL_last_swash_key[0]= '\0';
11682 PL_last_swash_tmps = (U8*)NULL;
11683 PL_last_swash_slen = 0;
11685 PL_glob_index = proto_perl->Iglob_index;
11686 PL_srand_called = proto_perl->Isrand_called;
11687 PL_uudmap['M'] = 0; /* reinits on demand */
11688 PL_bitcount = Nullch; /* reinits on demand */
11690 if (proto_perl->Ipsig_pend) {
11691 Newxz(PL_psig_pend, SIG_SIZE, int);
11694 PL_psig_pend = (int*)NULL;
11697 if (proto_perl->Ipsig_ptr) {
11698 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
11699 Newxz(PL_psig_name, SIG_SIZE, SV*);
11700 for (i = 1; i < SIG_SIZE; i++) {
11701 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11702 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11706 PL_psig_ptr = (SV**)NULL;
11707 PL_psig_name = (SV**)NULL;
11710 /* thrdvar.h stuff */
11712 if (flags & CLONEf_COPY_STACKS) {
11713 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11714 PL_tmps_ix = proto_perl->Ttmps_ix;
11715 PL_tmps_max = proto_perl->Ttmps_max;
11716 PL_tmps_floor = proto_perl->Ttmps_floor;
11717 Newxz(PL_tmps_stack, PL_tmps_max, SV*);
11719 while (i <= PL_tmps_ix) {
11720 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
11724 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11725 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
11726 Newxz(PL_markstack, i, I32);
11727 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
11728 - proto_perl->Tmarkstack);
11729 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
11730 - proto_perl->Tmarkstack);
11731 Copy(proto_perl->Tmarkstack, PL_markstack,
11732 PL_markstack_ptr - PL_markstack + 1, I32);
11734 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
11735 * NOTE: unlike the others! */
11736 PL_scopestack_ix = proto_perl->Tscopestack_ix;
11737 PL_scopestack_max = proto_perl->Tscopestack_max;
11738 Newxz(PL_scopestack, PL_scopestack_max, I32);
11739 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
11741 /* NOTE: si_dup() looks at PL_markstack */
11742 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
11744 /* PL_curstack = PL_curstackinfo->si_stack; */
11745 PL_curstack = av_dup(proto_perl->Tcurstack, param);
11746 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
11748 /* next PUSHs() etc. set *(PL_stack_sp+1) */
11749 PL_stack_base = AvARRAY(PL_curstack);
11750 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
11751 - proto_perl->Tstack_base);
11752 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
11754 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
11755 * NOTE: unlike the others! */
11756 PL_savestack_ix = proto_perl->Tsavestack_ix;
11757 PL_savestack_max = proto_perl->Tsavestack_max;
11758 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
11759 PL_savestack = ss_dup(proto_perl, param);
11763 ENTER; /* perl_destruct() wants to LEAVE; */
11766 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
11767 PL_top_env = &PL_start_env;
11769 PL_op = proto_perl->Top;
11772 PL_Xpv = (XPV*)NULL;
11773 PL_na = proto_perl->Tna;
11775 PL_statbuf = proto_perl->Tstatbuf;
11776 PL_statcache = proto_perl->Tstatcache;
11777 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
11778 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
11780 PL_timesbuf = proto_perl->Ttimesbuf;
11783 PL_tainted = proto_perl->Ttainted;
11784 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
11785 PL_rs = sv_dup_inc(proto_perl->Trs, param);
11786 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
11787 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
11788 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
11789 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
11790 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
11791 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
11792 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
11794 PL_restartop = proto_perl->Trestartop;
11795 PL_in_eval = proto_perl->Tin_eval;
11796 PL_delaymagic = proto_perl->Tdelaymagic;
11797 PL_dirty = proto_perl->Tdirty;
11798 PL_localizing = proto_perl->Tlocalizing;
11800 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
11801 PL_hv_fetch_ent_mh = Nullhe;
11802 PL_modcount = proto_perl->Tmodcount;
11803 PL_lastgotoprobe = Nullop;
11804 PL_dumpindent = proto_perl->Tdumpindent;
11806 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
11807 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
11808 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
11809 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
11810 PL_sortcxix = proto_perl->Tsortcxix;
11811 PL_efloatbuf = Nullch; /* reinits on demand */
11812 PL_efloatsize = 0; /* reinits on demand */
11816 PL_screamfirst = NULL;
11817 PL_screamnext = NULL;
11818 PL_maxscream = -1; /* reinits on demand */
11819 PL_lastscream = Nullsv;
11821 PL_watchaddr = NULL;
11822 PL_watchok = Nullch;
11824 PL_regdummy = proto_perl->Tregdummy;
11825 PL_regprecomp = Nullch;
11828 PL_colorset = 0; /* reinits PL_colors[] */
11829 /*PL_colors[6] = {0,0,0,0,0,0};*/
11830 PL_reginput = Nullch;
11831 PL_regbol = Nullch;
11832 PL_regeol = Nullch;
11833 PL_regstartp = (I32*)NULL;
11834 PL_regendp = (I32*)NULL;
11835 PL_reglastparen = (U32*)NULL;
11836 PL_reglastcloseparen = (U32*)NULL;
11837 PL_regtill = Nullch;
11838 PL_reg_start_tmp = (char**)NULL;
11839 PL_reg_start_tmpl = 0;
11840 PL_regdata = (struct reg_data*)NULL;
11843 PL_reg_eval_set = 0;
11845 PL_regprogram = (regnode*)NULL;
11847 PL_regcc = (CURCUR*)NULL;
11848 PL_reg_call_cc = (struct re_cc_state*)NULL;
11849 PL_reg_re = (regexp*)NULL;
11850 PL_reg_ganch = Nullch;
11851 PL_reg_sv = Nullsv;
11852 PL_reg_match_utf8 = FALSE;
11853 PL_reg_magic = (MAGIC*)NULL;
11855 PL_reg_oldcurpm = (PMOP*)NULL;
11856 PL_reg_curpm = (PMOP*)NULL;
11857 PL_reg_oldsaved = Nullch;
11858 PL_reg_oldsavedlen = 0;
11859 #ifdef PERL_OLD_COPY_ON_WRITE
11862 PL_reg_maxiter = 0;
11863 PL_reg_leftiter = 0;
11864 PL_reg_poscache = Nullch;
11865 PL_reg_poscache_size= 0;
11867 /* RE engine - function pointers */
11868 PL_regcompp = proto_perl->Tregcompp;
11869 PL_regexecp = proto_perl->Tregexecp;
11870 PL_regint_start = proto_perl->Tregint_start;
11871 PL_regint_string = proto_perl->Tregint_string;
11872 PL_regfree = proto_perl->Tregfree;
11874 PL_reginterp_cnt = 0;
11875 PL_reg_starttry = 0;
11877 /* Pluggable optimizer */
11878 PL_peepp = proto_perl->Tpeepp;
11880 PL_stashcache = newHV();
11882 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
11883 ptr_table_free(PL_ptr_table);
11884 PL_ptr_table = NULL;
11887 /* Call the ->CLONE method, if it exists, for each of the stashes
11888 identified by sv_dup() above.
11890 while(av_len(param->stashes) != -1) {
11891 HV* const stash = (HV*) av_shift(param->stashes);
11892 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
11893 if (cloner && GvCV(cloner)) {
11898 XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
11900 call_sv((SV*)GvCV(cloner), G_DISCARD);
11906 SvREFCNT_dec(param->stashes);
11908 /* orphaned? eg threads->new inside BEGIN or use */
11909 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
11910 (void)SvREFCNT_inc(PL_compcv);
11911 SAVEFREESV(PL_compcv);
11917 #endif /* USE_ITHREADS */
11920 =head1 Unicode Support
11922 =for apidoc sv_recode_to_utf8
11924 The encoding is assumed to be an Encode object, on entry the PV
11925 of the sv is assumed to be octets in that encoding, and the sv
11926 will be converted into Unicode (and UTF-8).
11928 If the sv already is UTF-8 (or if it is not POK), or if the encoding
11929 is not a reference, nothing is done to the sv. If the encoding is not
11930 an C<Encode::XS> Encoding object, bad things will happen.
11931 (See F<lib/encoding.pm> and L<Encode>).
11933 The PV of the sv is returned.
11938 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
11941 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
11955 Passing sv_yes is wrong - it needs to be or'ed set of constants
11956 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
11957 remove converted chars from source.
11959 Both will default the value - let them.
11961 XPUSHs(&PL_sv_yes);
11964 call_method("decode", G_SCALAR);
11968 s = SvPV_const(uni, len);
11969 if (s != SvPVX_const(sv)) {
11970 SvGROW(sv, len + 1);
11971 Move(s, SvPVX(sv), len + 1, char);
11972 SvCUR_set(sv, len);
11979 return SvPOKp(sv) ? SvPVX(sv) : NULL;
11983 =for apidoc sv_cat_decode
11985 The encoding is assumed to be an Encode object, the PV of the ssv is
11986 assumed to be octets in that encoding and decoding the input starts
11987 from the position which (PV + *offset) pointed to. The dsv will be
11988 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
11989 when the string tstr appears in decoding output or the input ends on
11990 the PV of the ssv. The value which the offset points will be modified
11991 to the last input position on the ssv.
11993 Returns TRUE if the terminator was found, else returns FALSE.
11998 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
11999 SV *ssv, int *offset, char *tstr, int tlen)
12003 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12014 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
12015 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
12017 call_method("cat_decode", G_SCALAR);
12019 ret = SvTRUE(TOPs);
12020 *offset = SvIV(offsv);
12026 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12032 * c-indentation-style: bsd
12033 * c-basic-offset: 4
12034 * indent-tabs-mode: t
12037 * ex: set ts=8 sts=4 sw=4 noet: