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_untaint
8324 Untaint an SV. Use C<SvTAINTED_off> instead.
8329 Perl_sv_untaint(pTHX_ SV *sv)
8331 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8332 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8339 =for apidoc sv_tainted
8341 Test an SV for taintedness. Use C<SvTAINTED> instead.
8346 Perl_sv_tainted(pTHX_ SV *sv)
8348 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8349 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8350 if (mg && (mg->mg_len & 1) )
8357 =for apidoc sv_setpviv
8359 Copies an integer into the given SV, also updating its string value.
8360 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8366 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8368 char buf[TYPE_CHARS(UV)];
8370 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8372 sv_setpvn(sv, ptr, ebuf - ptr);
8376 =for apidoc sv_setpviv_mg
8378 Like C<sv_setpviv>, but also handles 'set' magic.
8384 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8386 char buf[TYPE_CHARS(UV)];
8388 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8390 sv_setpvn(sv, ptr, ebuf - ptr);
8394 #if defined(PERL_IMPLICIT_CONTEXT)
8396 /* pTHX_ magic can't cope with varargs, so this is a no-context
8397 * version of the main function, (which may itself be aliased to us).
8398 * Don't access this version directly.
8402 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8406 va_start(args, pat);
8407 sv_vsetpvf(sv, pat, &args);
8411 /* pTHX_ magic can't cope with varargs, so this is a no-context
8412 * version of the main function, (which may itself be aliased to us).
8413 * Don't access this version directly.
8417 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8421 va_start(args, pat);
8422 sv_vsetpvf_mg(sv, pat, &args);
8428 =for apidoc sv_setpvf
8430 Works like C<sv_catpvf> but copies the text into the SV instead of
8431 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8437 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8440 va_start(args, pat);
8441 sv_vsetpvf(sv, pat, &args);
8446 =for apidoc sv_vsetpvf
8448 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8449 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8451 Usually used via its frontend C<sv_setpvf>.
8457 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8459 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8463 =for apidoc sv_setpvf_mg
8465 Like C<sv_setpvf>, but also handles 'set' magic.
8471 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8474 va_start(args, pat);
8475 sv_vsetpvf_mg(sv, pat, &args);
8480 =for apidoc sv_vsetpvf_mg
8482 Like C<sv_vsetpvf>, but also handles 'set' magic.
8484 Usually used via its frontend C<sv_setpvf_mg>.
8490 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8492 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8496 #if defined(PERL_IMPLICIT_CONTEXT)
8498 /* pTHX_ magic can't cope with varargs, so this is a no-context
8499 * version of the main function, (which may itself be aliased to us).
8500 * Don't access this version directly.
8504 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8508 va_start(args, pat);
8509 sv_vcatpvf(sv, pat, &args);
8513 /* pTHX_ magic can't cope with varargs, so this is a no-context
8514 * version of the main function, (which may itself be aliased to us).
8515 * Don't access this version directly.
8519 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8523 va_start(args, pat);
8524 sv_vcatpvf_mg(sv, pat, &args);
8530 =for apidoc sv_catpvf
8532 Processes its arguments like C<sprintf> and appends the formatted
8533 output to an SV. If the appended data contains "wide" characters
8534 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8535 and characters >255 formatted with %c), the original SV might get
8536 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
8537 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
8538 valid UTF-8; if the original SV was bytes, the pattern should be too.
8543 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8546 va_start(args, pat);
8547 sv_vcatpvf(sv, pat, &args);
8552 =for apidoc sv_vcatpvf
8554 Processes its arguments like C<vsprintf> and appends the formatted output
8555 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
8557 Usually used via its frontend C<sv_catpvf>.
8563 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8565 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8569 =for apidoc sv_catpvf_mg
8571 Like C<sv_catpvf>, but also handles 'set' magic.
8577 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8580 va_start(args, pat);
8581 sv_vcatpvf_mg(sv, pat, &args);
8586 =for apidoc sv_vcatpvf_mg
8588 Like C<sv_vcatpvf>, but also handles 'set' magic.
8590 Usually used via its frontend C<sv_catpvf_mg>.
8596 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8598 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8603 =for apidoc sv_vsetpvfn
8605 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
8608 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
8614 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8616 sv_setpvn(sv, "", 0);
8617 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8620 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
8623 S_expect_number(pTHX_ char** pattern)
8626 switch (**pattern) {
8627 case '1': case '2': case '3':
8628 case '4': case '5': case '6':
8629 case '7': case '8': case '9':
8630 while (isDIGIT(**pattern))
8631 var = var * 10 + (*(*pattern)++ - '0');
8635 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
8638 F0convert(NV nv, char *endbuf, STRLEN *len)
8640 const int neg = nv < 0;
8649 if (uv & 1 && uv == nv)
8650 uv--; /* Round to even */
8652 const unsigned dig = uv % 10;
8665 =for apidoc sv_vcatpvfn
8667 Processes its arguments like C<vsprintf> and appends the formatted output
8668 to an SV. Uses an array of SVs if the C style variable argument list is
8669 missing (NULL). When running with taint checks enabled, indicates via
8670 C<maybe_tainted> if results are untrustworthy (often due to the use of
8673 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
8679 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
8680 vecstr = (U8*)SvPV_const(vecsv,veclen);\
8681 vec_utf8 = DO_UTF8(vecsv);
8683 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
8686 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8693 static const char nullstr[] = "(null)";
8695 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
8696 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
8698 /* Times 4: a decimal digit takes more than 3 binary digits.
8699 * NV_DIG: mantissa takes than many decimal digits.
8700 * Plus 32: Playing safe. */
8701 char ebuf[IV_DIG * 4 + NV_DIG + 32];
8702 /* large enough for "%#.#f" --chip */
8703 /* what about long double NVs? --jhi */
8705 PERL_UNUSED_ARG(maybe_tainted);
8707 /* no matter what, this is a string now */
8708 (void)SvPV_force(sv, origlen);
8710 /* special-case "", "%s", and "%-p" (SVf - see below) */
8713 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
8715 const char * const s = va_arg(*args, char*);
8716 sv_catpv(sv, s ? s : nullstr);
8718 else if (svix < svmax) {
8719 sv_catsv(sv, *svargs);
8720 if (DO_UTF8(*svargs))
8725 if (args && patlen == 3 && pat[0] == '%' &&
8726 pat[1] == '-' && pat[2] == 'p') {
8727 argsv = va_arg(*args, SV*);
8728 sv_catsv(sv, argsv);
8734 #ifndef USE_LONG_DOUBLE
8735 /* special-case "%.<number>[gf]" */
8736 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
8737 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
8738 unsigned digits = 0;
8742 while (*pp >= '0' && *pp <= '9')
8743 digits = 10 * digits + (*pp++ - '0');
8744 if (pp - pat == (int)patlen - 1) {
8752 /* Add check for digits != 0 because it seems that some
8753 gconverts are buggy in this case, and we don't yet have
8754 a Configure test for this. */
8755 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
8756 /* 0, point, slack */
8757 Gconvert(nv, (int)digits, 0, ebuf);
8759 if (*ebuf) /* May return an empty string for digits==0 */
8762 } else if (!digits) {
8765 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
8766 sv_catpvn(sv, p, l);
8772 #endif /* !USE_LONG_DOUBLE */
8774 if (!args && svix < svmax && DO_UTF8(*svargs))
8777 patend = (char*)pat + patlen;
8778 for (p = (char*)pat; p < patend; p = q) {
8781 bool vectorize = FALSE;
8782 bool vectorarg = FALSE;
8783 bool vec_utf8 = FALSE;
8789 bool has_precis = FALSE;
8792 bool is_utf8 = FALSE; /* is this item utf8? */
8793 #ifdef HAS_LDBL_SPRINTF_BUG
8794 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8795 with sfio - Allen <allens@cpan.org> */
8796 bool fix_ldbl_sprintf_bug = FALSE;
8800 U8 utf8buf[UTF8_MAXBYTES+1];
8801 STRLEN esignlen = 0;
8803 const char *eptr = Nullch;
8806 const U8 *vecstr = Null(U8*);
8813 /* we need a long double target in case HAS_LONG_DOUBLE but
8816 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
8824 const char *dotstr = ".";
8825 STRLEN dotstrlen = 1;
8826 I32 efix = 0; /* explicit format parameter index */
8827 I32 ewix = 0; /* explicit width index */
8828 I32 epix = 0; /* explicit precision index */
8829 I32 evix = 0; /* explicit vector index */
8830 bool asterisk = FALSE;
8832 /* echo everything up to the next format specification */
8833 for (q = p; q < patend && *q != '%'; ++q) ;
8835 if (has_utf8 && !pat_utf8)
8836 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
8838 sv_catpvn(sv, p, q - p);
8845 We allow format specification elements in this order:
8846 \d+\$ explicit format parameter index
8848 v|\*(\d+\$)?v vector with optional (optionally specified) arg
8849 0 flag (as above): repeated to allow "v02"
8850 \d+|\*(\d+\$)? width using optional (optionally specified) arg
8851 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8853 [%bcdefginopsuxDFOUX] format (mandatory)
8858 As of perl5.9.3, printf format checking is on by default.
8859 Internally, perl uses %p formats to provide an escape to
8860 some extended formatting. This block deals with those
8861 extensions: if it does not match, (char*)q is reset and
8862 the normal format processing code is used.
8864 Currently defined extensions are:
8865 %p include pointer address (standard)
8866 %-p (SVf) include an SV (previously %_)
8867 %-<num>p include an SV with precision <num>
8868 %1p (VDf) include a v-string (as %vd)
8869 %<num>p reserved for future extensions
8871 Robin Barker 2005-07-14
8878 EXPECT_NUMBER(q, n);
8885 argsv = va_arg(*args, SV*);
8886 eptr = SvPVx_const(argsv, elen);
8892 else if (n == vdNUMBER) { /* VDf */
8899 if (ckWARN_d(WARN_INTERNAL))
8900 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
8901 "internal %%<num>p might conflict with future printf extensions");
8907 if (EXPECT_NUMBER(q, width)) {
8948 if (EXPECT_NUMBER(q, ewix))
8957 if ((vectorarg = asterisk)) {
8970 EXPECT_NUMBER(q, width);
8976 vecsv = va_arg(*args, SV*);
8978 vecsv = (evix ? evix <= svmax : svix < svmax) ?
8979 svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
8980 dotstr = SvPV_const(vecsv, dotstrlen);
8987 else if (efix ? efix <= svmax : svix < svmax) {
8988 vecsv = svargs[efix ? efix-1 : svix++];
8989 vecstr = (U8*)SvPV_const(vecsv,veclen);
8990 vec_utf8 = DO_UTF8(vecsv);
8991 /* if this is a version object, we need to return the
8992 * stringified representation (which the SvPVX_const has
8993 * already done for us), but not vectorize the args
8995 if ( *q == 'd' && sv_derived_from(vecsv,"version") )
8997 q++; /* skip past the rest of the %vd format */
8998 eptr = (const char *) vecstr;
8999 elen = strlen(eptr);
9012 i = va_arg(*args, int);
9014 i = (ewix ? ewix <= svmax : svix < svmax) ?
9015 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9017 width = (i < 0) ? -i : i;
9027 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
9029 /* XXX: todo, support specified precision parameter */
9033 i = va_arg(*args, int);
9035 i = (ewix ? ewix <= svmax : svix < svmax)
9036 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9037 precis = (i < 0) ? 0 : i;
9042 precis = precis * 10 + (*q++ - '0');
9051 case 'I': /* Ix, I32x, and I64x */
9053 if (q[1] == '6' && q[2] == '4') {
9059 if (q[1] == '3' && q[2] == '2') {
9069 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9080 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9081 if (*(q + 1) == 'l') { /* lld, llf */
9106 argsv = (efix ? efix <= svmax : svix < svmax) ?
9107 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
9114 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
9116 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9118 eptr = (char*)utf8buf;
9119 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9130 if (args && !vectorize) {
9131 eptr = va_arg(*args, char*);
9133 #ifdef MACOS_TRADITIONAL
9134 /* On MacOS, %#s format is used for Pascal strings */
9139 elen = strlen(eptr);
9141 eptr = (char *)nullstr;
9142 elen = sizeof nullstr - 1;
9146 eptr = SvPVx_const(argsv, elen);
9147 if (DO_UTF8(argsv)) {
9148 if (has_precis && precis < elen) {
9150 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9153 if (width) { /* fudge width (can't fudge elen) */
9154 width += elen - sv_len_utf8(argsv);
9162 if (has_precis && elen > precis)
9169 if (alt || vectorize)
9171 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9192 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9201 esignbuf[esignlen++] = plus;
9205 case 'h': iv = (short)va_arg(*args, int); break;
9206 case 'l': iv = va_arg(*args, long); break;
9207 case 'V': iv = va_arg(*args, IV); break;
9208 default: iv = va_arg(*args, int); break;
9210 case 'q': iv = va_arg(*args, Quad_t); break;
9215 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
9217 case 'h': iv = (short)tiv; break;
9218 case 'l': iv = (long)tiv; break;
9220 default: iv = tiv; break;
9222 case 'q': iv = (Quad_t)tiv; break;
9226 if ( !vectorize ) /* we already set uv above */
9231 esignbuf[esignlen++] = plus;
9235 esignbuf[esignlen++] = '-';
9278 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9289 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9290 case 'l': uv = va_arg(*args, unsigned long); break;
9291 case 'V': uv = va_arg(*args, UV); break;
9292 default: uv = va_arg(*args, unsigned); break;
9294 case 'q': uv = va_arg(*args, Uquad_t); break;
9299 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9301 case 'h': uv = (unsigned short)tuv; break;
9302 case 'l': uv = (unsigned long)tuv; break;
9304 default: uv = tuv; break;
9306 case 'q': uv = (Uquad_t)tuv; break;
9313 char *ptr = ebuf + sizeof ebuf;
9319 p = (char*)((c == 'X')
9320 ? "0123456789ABCDEF" : "0123456789abcdef");
9326 esignbuf[esignlen++] = '0';
9327 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9335 if (alt && *ptr != '0')
9344 esignbuf[esignlen++] = '0';
9345 esignbuf[esignlen++] = 'b';
9348 default: /* it had better be ten or less */
9352 } while (uv /= base);
9355 elen = (ebuf + sizeof ebuf) - ptr;
9359 zeros = precis - elen;
9360 else if (precis == 0 && elen == 1 && *eptr == '0')
9366 /* FLOATING POINT */
9369 c = 'f'; /* maybe %F isn't supported here */
9375 /* This is evil, but floating point is even more evil */
9377 /* for SV-style calling, we can only get NV
9378 for C-style calling, we assume %f is double;
9379 for simplicity we allow any of %Lf, %llf, %qf for long double
9383 #if defined(USE_LONG_DOUBLE)
9387 /* [perl #20339] - we should accept and ignore %lf rather than die */
9391 #if defined(USE_LONG_DOUBLE)
9392 intsize = args ? 0 : 'q';
9396 #if defined(HAS_LONG_DOUBLE)
9405 /* now we need (long double) if intsize == 'q', else (double) */
9406 nv = (args && !vectorize) ?
9407 #if LONG_DOUBLESIZE > DOUBLESIZE
9409 va_arg(*args, long double) :
9410 va_arg(*args, double)
9412 va_arg(*args, double)
9418 if (c != 'e' && c != 'E') {
9420 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9421 will cast our (long double) to (double) */
9422 (void)Perl_frexp(nv, &i);
9423 if (i == PERL_INT_MIN)
9424 Perl_die(aTHX_ "panic: frexp");
9426 need = BIT_DIGITS(i);
9428 need += has_precis ? precis : 6; /* known default */
9433 #ifdef HAS_LDBL_SPRINTF_BUG
9434 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9435 with sfio - Allen <allens@cpan.org> */
9438 # define MY_DBL_MAX DBL_MAX
9439 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9440 # if DOUBLESIZE >= 8
9441 # define MY_DBL_MAX 1.7976931348623157E+308L
9443 # define MY_DBL_MAX 3.40282347E+38L
9447 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9448 # define MY_DBL_MAX_BUG 1L
9450 # define MY_DBL_MAX_BUG MY_DBL_MAX
9454 # define MY_DBL_MIN DBL_MIN
9455 # else /* XXX guessing! -Allen */
9456 # if DOUBLESIZE >= 8
9457 # define MY_DBL_MIN 2.2250738585072014E-308L
9459 # define MY_DBL_MIN 1.17549435E-38L
9463 if ((intsize == 'q') && (c == 'f') &&
9464 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9466 /* it's going to be short enough that
9467 * long double precision is not needed */
9469 if ((nv <= 0L) && (nv >= -0L))
9470 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9472 /* would use Perl_fp_class as a double-check but not
9473 * functional on IRIX - see perl.h comments */
9475 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9476 /* It's within the range that a double can represent */
9477 #if defined(DBL_MAX) && !defined(DBL_MIN)
9478 if ((nv >= ((long double)1/DBL_MAX)) ||
9479 (nv <= (-(long double)1/DBL_MAX)))
9481 fix_ldbl_sprintf_bug = TRUE;
9484 if (fix_ldbl_sprintf_bug == TRUE) {
9494 # undef MY_DBL_MAX_BUG
9497 #endif /* HAS_LDBL_SPRINTF_BUG */
9499 need += 20; /* fudge factor */
9500 if (PL_efloatsize < need) {
9501 Safefree(PL_efloatbuf);
9502 PL_efloatsize = need + 20; /* more fudge */
9503 Newx(PL_efloatbuf, PL_efloatsize, char);
9504 PL_efloatbuf[0] = '\0';
9507 if ( !(width || left || plus || alt) && fill != '0'
9508 && has_precis && intsize != 'q' ) { /* Shortcuts */
9509 /* See earlier comment about buggy Gconvert when digits,
9511 if ( c == 'g' && precis) {
9512 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9513 /* May return an empty string for digits==0 */
9514 if (*PL_efloatbuf) {
9515 elen = strlen(PL_efloatbuf);
9516 goto float_converted;
9518 } else if ( c == 'f' && !precis) {
9519 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9524 char *ptr = ebuf + sizeof ebuf;
9527 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9528 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9529 if (intsize == 'q') {
9530 /* Copy the one or more characters in a long double
9531 * format before the 'base' ([efgEFG]) character to
9532 * the format string. */
9533 static char const prifldbl[] = PERL_PRIfldbl;
9534 char const *p = prifldbl + sizeof(prifldbl) - 3;
9535 while (p >= prifldbl) { *--ptr = *p--; }
9540 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9545 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9557 /* No taint. Otherwise we are in the strange situation
9558 * where printf() taints but print($float) doesn't.
9560 #if defined(HAS_LONG_DOUBLE)
9561 elen = ((intsize == 'q')
9562 ? my_sprintf(PL_efloatbuf, ptr, nv)
9563 : my_sprintf(PL_efloatbuf, ptr, (double)nv));
9565 elen = my_sprintf(PL_efloatbuf, ptr, nv);
9569 eptr = PL_efloatbuf;
9575 i = SvCUR(sv) - origlen;
9576 if (args && !vectorize) {
9578 case 'h': *(va_arg(*args, short*)) = i; break;
9579 default: *(va_arg(*args, int*)) = i; break;
9580 case 'l': *(va_arg(*args, long*)) = i; break;
9581 case 'V': *(va_arg(*args, IV*)) = i; break;
9583 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
9588 sv_setuv_mg(argsv, (UV)i);
9590 continue; /* not "break" */
9597 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
9598 && ckWARN(WARN_PRINTF))
9600 SV *msg = sv_newmortal();
9601 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9602 (PL_op->op_type == OP_PRTF) ? "" : "s");
9605 Perl_sv_catpvf(aTHX_ msg,
9606 "\"%%%c\"", c & 0xFF);
9608 Perl_sv_catpvf(aTHX_ msg,
9609 "\"%%\\%03"UVof"\"",
9612 sv_catpv(msg, "end of string");
9613 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
9616 /* output mangled stuff ... */
9622 /* ... right here, because formatting flags should not apply */
9623 SvGROW(sv, SvCUR(sv) + elen + 1);
9625 Copy(eptr, p, elen, char);
9628 SvCUR_set(sv, p - SvPVX_const(sv));
9630 continue; /* not "break" */
9633 /* calculate width before utf8_upgrade changes it */
9634 have = esignlen + zeros + elen;
9636 if (is_utf8 != has_utf8) {
9639 sv_utf8_upgrade(sv);
9642 SV * const nsv = sv_2mortal(newSVpvn(eptr, elen));
9643 sv_utf8_upgrade(nsv);
9644 eptr = SvPVX_const(nsv);
9647 SvGROW(sv, SvCUR(sv) + elen + 1);
9652 need = (have > width ? have : width);
9655 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
9657 if (esignlen && fill == '0') {
9659 for (i = 0; i < (int)esignlen; i++)
9663 memset(p, fill, gap);
9666 if (esignlen && fill != '0') {
9668 for (i = 0; i < (int)esignlen; i++)
9673 for (i = zeros; i; i--)
9677 Copy(eptr, p, elen, char);
9681 memset(p, ' ', gap);
9686 Copy(dotstr, p, dotstrlen, char);
9690 vectorize = FALSE; /* done iterating over vecstr */
9697 SvCUR_set(sv, p - SvPVX_const(sv));
9705 /* =========================================================================
9707 =head1 Cloning an interpreter
9709 All the macros and functions in this section are for the private use of
9710 the main function, perl_clone().
9712 The foo_dup() functions make an exact copy of an existing foo thinngy.
9713 During the course of a cloning, a hash table is used to map old addresses
9714 to new addresses. The table is created and manipulated with the
9715 ptr_table_* functions.
9719 ============================================================================*/
9722 #if defined(USE_ITHREADS)
9724 #ifndef GpREFCNT_inc
9725 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
9729 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
9730 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
9731 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9732 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
9733 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9734 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
9735 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9736 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
9737 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
9738 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
9739 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9740 #define SAVEPV(p) (p ? savepv(p) : Nullch)
9741 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
9744 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
9745 regcomp.c. AMS 20010712 */
9748 Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
9753 struct reg_substr_datum *s;
9756 return (REGEXP *)NULL;
9758 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
9761 len = r->offsets[0];
9762 npar = r->nparens+1;
9764 Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
9765 Copy(r->program, ret->program, len+1, regnode);
9767 Newx(ret->startp, npar, I32);
9768 Copy(r->startp, ret->startp, npar, I32);
9769 Newx(ret->endp, npar, I32);
9770 Copy(r->startp, ret->startp, npar, I32);
9772 Newx(ret->substrs, 1, struct reg_substr_data);
9773 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
9774 s->min_offset = r->substrs->data[i].min_offset;
9775 s->max_offset = r->substrs->data[i].max_offset;
9776 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
9777 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
9780 ret->regstclass = NULL;
9783 const int count = r->data->count;
9786 Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
9787 char, struct reg_data);
9788 Newx(d->what, count, U8);
9791 for (i = 0; i < count; i++) {
9792 d->what[i] = r->data->what[i];
9793 switch (d->what[i]) {
9794 /* legal options are one of: sfpont
9795 see also regcomp.h and pregfree() */
9797 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
9800 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
9803 /* This is cheating. */
9804 Newx(d->data[i], 1, struct regnode_charclass_class);
9805 StructCopy(r->data->data[i], d->data[i],
9806 struct regnode_charclass_class);
9807 ret->regstclass = (regnode*)d->data[i];
9810 /* Compiled op trees are readonly, and can thus be
9811 shared without duplication. */
9813 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
9817 d->data[i] = r->data->data[i];
9820 d->data[i] = r->data->data[i];
9822 ((reg_trie_data*)d->data[i])->refcount++;
9826 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
9835 Newx(ret->offsets, 2*len+1, U32);
9836 Copy(r->offsets, ret->offsets, 2*len+1, U32);
9838 ret->precomp = SAVEPVN(r->precomp, r->prelen);
9839 ret->refcnt = r->refcnt;
9840 ret->minlen = r->minlen;
9841 ret->prelen = r->prelen;
9842 ret->nparens = r->nparens;
9843 ret->lastparen = r->lastparen;
9844 ret->lastcloseparen = r->lastcloseparen;
9845 ret->reganch = r->reganch;
9847 ret->sublen = r->sublen;
9849 if (RX_MATCH_COPIED(ret))
9850 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
9852 ret->subbeg = Nullch;
9853 #ifdef PERL_OLD_COPY_ON_WRITE
9854 ret->saved_copy = Nullsv;
9857 ptr_table_store(PL_ptr_table, r, ret);
9861 /* duplicate a file handle */
9864 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
9868 PERL_UNUSED_ARG(type);
9871 return (PerlIO*)NULL;
9873 /* look for it in the table first */
9874 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
9878 /* create anew and remember what it is */
9879 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
9880 ptr_table_store(PL_ptr_table, fp, ret);
9884 /* duplicate a directory handle */
9887 Perl_dirp_dup(pTHX_ DIR *dp)
9895 /* duplicate a typeglob */
9898 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
9903 /* look for it in the table first */
9904 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
9908 /* create anew and remember what it is */
9910 ptr_table_store(PL_ptr_table, gp, ret);
9913 ret->gp_refcnt = 0; /* must be before any other dups! */
9914 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
9915 ret->gp_io = io_dup_inc(gp->gp_io, param);
9916 ret->gp_form = cv_dup_inc(gp->gp_form, param);
9917 ret->gp_av = av_dup_inc(gp->gp_av, param);
9918 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
9919 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
9920 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
9921 ret->gp_cvgen = gp->gp_cvgen;
9922 ret->gp_line = gp->gp_line;
9923 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
9927 /* duplicate a chain of magic */
9930 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
9932 MAGIC *mgprev = (MAGIC*)NULL;
9935 return (MAGIC*)NULL;
9936 /* look for it in the table first */
9937 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
9941 for (; mg; mg = mg->mg_moremagic) {
9943 Newxz(nmg, 1, MAGIC);
9945 mgprev->mg_moremagic = nmg;
9948 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
9949 nmg->mg_private = mg->mg_private;
9950 nmg->mg_type = mg->mg_type;
9951 nmg->mg_flags = mg->mg_flags;
9952 if (mg->mg_type == PERL_MAGIC_qr) {
9953 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
9955 else if(mg->mg_type == PERL_MAGIC_backref) {
9956 const AV * const av = (AV*) mg->mg_obj;
9959 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
9961 for (i = AvFILLp(av); i >= 0; i--) {
9962 if (!svp[i]) continue;
9963 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
9966 else if (mg->mg_type == PERL_MAGIC_symtab) {
9967 nmg->mg_obj = mg->mg_obj;
9970 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
9971 ? sv_dup_inc(mg->mg_obj, param)
9972 : sv_dup(mg->mg_obj, param);
9974 nmg->mg_len = mg->mg_len;
9975 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
9976 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
9977 if (mg->mg_len > 0) {
9978 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
9979 if (mg->mg_type == PERL_MAGIC_overload_table &&
9980 AMT_AMAGIC((AMT*)mg->mg_ptr))
9982 AMT *amtp = (AMT*)mg->mg_ptr;
9983 AMT *namtp = (AMT*)nmg->mg_ptr;
9985 for (i = 1; i < NofAMmeth; i++) {
9986 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
9990 else if (mg->mg_len == HEf_SVKEY)
9991 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
9993 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
9994 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10001 /* create a new pointer-mapping table */
10004 Perl_ptr_table_new(pTHX)
10007 Newxz(tbl, 1, PTR_TBL_t);
10008 tbl->tbl_max = 511;
10009 tbl->tbl_items = 0;
10010 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10015 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
10017 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
10020 #define del_pte(p) del_body_type(p, struct ptr_tbl_ent, pte)
10022 /* map an existing pointer using a table */
10025 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
10027 PTR_TBL_ENT_t *tblent;
10028 const UV hash = PTR_TABLE_HASH(sv);
10030 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10031 for (; tblent; tblent = tblent->next) {
10032 if (tblent->oldval == sv)
10033 return tblent->newval;
10035 return (void*)NULL;
10038 /* add a new entry to a pointer-mapping table */
10041 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
10043 PTR_TBL_ENT_t *tblent, **otblent;
10044 /* XXX this may be pessimal on platforms where pointers aren't good
10045 * hash values e.g. if they grow faster in the most significant
10047 const UV hash = PTR_TABLE_HASH(oldsv);
10051 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
10052 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
10053 if (tblent->oldval == oldsv) {
10054 tblent->newval = newsv;
10058 new_body_inline(tblent, (void**)&PL_pte_arenaroot, (void**)&PL_pte_root,
10059 sizeof(struct ptr_tbl_ent));
10060 tblent->oldval = oldsv;
10061 tblent->newval = newsv;
10062 tblent->next = *otblent;
10065 if (!empty && tbl->tbl_items > tbl->tbl_max)
10066 ptr_table_split(tbl);
10069 /* double the hash bucket size of an existing ptr table */
10072 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
10074 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10075 const UV oldsize = tbl->tbl_max + 1;
10076 UV newsize = oldsize * 2;
10079 Renew(ary, newsize, PTR_TBL_ENT_t*);
10080 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10081 tbl->tbl_max = --newsize;
10082 tbl->tbl_ary = ary;
10083 for (i=0; i < oldsize; i++, ary++) {
10084 PTR_TBL_ENT_t **curentp, **entp, *ent;
10087 curentp = ary + oldsize;
10088 for (entp = ary, ent = *ary; ent; ent = *entp) {
10089 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10091 ent->next = *curentp;
10101 /* remove all the entries from a ptr table */
10104 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
10106 register PTR_TBL_ENT_t **array;
10107 register PTR_TBL_ENT_t *entry;
10111 if (!tbl || !tbl->tbl_items) {
10115 array = tbl->tbl_ary;
10117 max = tbl->tbl_max;
10121 PTR_TBL_ENT_t *oentry = entry;
10122 entry = entry->next;
10126 if (++riter > max) {
10129 entry = array[riter];
10133 tbl->tbl_items = 0;
10136 /* clear and free a ptr table */
10139 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
10144 ptr_table_clear(tbl);
10145 Safefree(tbl->tbl_ary);
10151 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
10154 SvRV_set(dstr, SvWEAKREF(sstr)
10155 ? sv_dup(SvRV(sstr), param)
10156 : sv_dup_inc(SvRV(sstr), param));
10159 else if (SvPVX_const(sstr)) {
10160 /* Has something there */
10162 /* Normal PV - clone whole allocated space */
10163 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
10164 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10165 /* Not that normal - actually sstr is copy on write.
10166 But we are a true, independant SV, so: */
10167 SvREADONLY_off(dstr);
10172 /* Special case - not normally malloced for some reason */
10173 if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
10174 /* A "shared" PV - clone it as "shared" PV */
10176 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
10180 /* Some other special case - random pointer */
10181 SvPV_set(dstr, SvPVX(sstr));
10186 /* Copy the Null */
10187 if (SvTYPE(dstr) == SVt_RV)
10188 SvRV_set(dstr, NULL);
10194 /* duplicate an SV of any type (including AV, HV etc) */
10197 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
10202 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10204 /* look for it in the table first */
10205 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10209 if(param->flags & CLONEf_JOIN_IN) {
10210 /** We are joining here so we don't want do clone
10211 something that is bad **/
10212 const char *hvname;
10214 if(SvTYPE(sstr) == SVt_PVHV &&
10215 (hvname = HvNAME_get(sstr))) {
10216 /** don't clone stashes if they already exist **/
10217 return (SV*)gv_stashpv(hvname,0);
10221 /* create anew and remember what it is */
10224 #ifdef DEBUG_LEAKING_SCALARS
10225 dstr->sv_debug_optype = sstr->sv_debug_optype;
10226 dstr->sv_debug_line = sstr->sv_debug_line;
10227 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10228 dstr->sv_debug_cloned = 1;
10230 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10232 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
10236 ptr_table_store(PL_ptr_table, sstr, dstr);
10239 SvFLAGS(dstr) = SvFLAGS(sstr);
10240 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10241 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10244 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
10245 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10246 PL_watch_pvx, SvPVX_const(sstr));
10249 /* don't clone objects whose class has asked us not to */
10250 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10251 SvFLAGS(dstr) &= ~SVTYPEMASK;
10252 SvOBJECT_off(dstr);
10256 switch (SvTYPE(sstr)) {
10258 SvANY(dstr) = NULL;
10261 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
10262 SvIV_set(dstr, SvIVX(sstr));
10265 SvANY(dstr) = new_XNV();
10266 SvNV_set(dstr, SvNVX(sstr));
10269 SvANY(dstr) = &(dstr->sv_u.svu_rv);
10270 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10274 /* These are all the types that need complex bodies allocating. */
10275 size_t new_body_length;
10276 size_t new_body_offset = 0;
10277 void **new_body_arena;
10278 void **new_body_arenaroot;
10281 switch (SvTYPE(sstr)) {
10283 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]",
10288 new_body = new_XPVIO();
10289 new_body_length = sizeof(XPVIO);
10292 new_body = new_XPVFM();
10293 new_body_length = sizeof(XPVFM);
10297 new_body_arena = (void **) &PL_xpvhv_root;
10298 new_body_arenaroot = (void **) &PL_xpvhv_arenaroot;
10299 new_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill)
10300 - STRUCT_OFFSET(xpvhv_allocated, xhv_fill);
10301 new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash)
10302 + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash)
10306 new_body_arena = (void **) &PL_xpvav_root;
10307 new_body_arenaroot = (void **) &PL_xpvav_arenaroot;
10308 new_body_offset = STRUCT_OFFSET(XPVAV, xav_fill)
10309 - STRUCT_OFFSET(xpvav_allocated, xav_fill);
10310 new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash)
10311 + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash)
10315 new_body_length = sizeof(XPVBM);
10316 new_body_arena = (void **) &PL_xpvbm_root;
10317 new_body_arenaroot = (void **) &PL_xpvbm_arenaroot;
10320 if (GvUNIQUE((GV*)sstr)) {
10321 /* Do sharing here. */
10323 new_body_length = sizeof(XPVGV);
10324 new_body_arena = (void **) &PL_xpvgv_root;
10325 new_body_arenaroot = (void **) &PL_xpvgv_arenaroot;
10328 new_body_length = sizeof(XPVCV);
10329 new_body_arena = (void **) &PL_xpvcv_root;
10330 new_body_arenaroot = (void **) &PL_xpvcv_arenaroot;
10333 new_body_length = sizeof(XPVLV);
10334 new_body_arena = (void **) &PL_xpvlv_root;
10335 new_body_arenaroot = (void **) &PL_xpvlv_arenaroot;
10338 new_body_length = sizeof(XPVMG);
10339 new_body_arena = (void **) &PL_xpvmg_root;
10340 new_body_arenaroot = (void **) &PL_xpvmg_arenaroot;
10343 new_body_length = sizeof(XPVNV);
10344 new_body_arena = (void **) &PL_xpvnv_root;
10345 new_body_arenaroot = (void **) &PL_xpvnv_arenaroot;
10348 new_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
10349 - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
10350 new_body_length = sizeof(XPVIV) - new_body_offset;
10351 new_body_arena = (void **) &PL_xpviv_root;
10352 new_body_arenaroot = (void **) &PL_xpviv_arenaroot;
10355 new_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
10356 - STRUCT_OFFSET(xpv_allocated, xpv_cur);
10357 new_body_length = sizeof(XPV) - new_body_offset;
10358 new_body_arena = (void **) &PL_xpv_root;
10359 new_body_arenaroot = (void **) &PL_xpv_arenaroot;
10361 assert(new_body_length);
10363 new_body_inline(new_body, new_body_arenaroot, new_body_arena,
10365 new_body = (void*)((char*)new_body - new_body_offset);
10367 /* We always allocated the full length item with PURIFY */
10368 new_body_length += new_body_offset;
10369 new_body_offset = 0;
10370 new_body = my_safemalloc(new_body_length);
10374 SvANY(dstr) = new_body;
10376 Copy(((char*)SvANY(sstr)) + new_body_offset,
10377 ((char*)SvANY(dstr)) + new_body_offset,
10378 new_body_length, char);
10380 if (SvTYPE(sstr) != SVt_PVAV && SvTYPE(sstr) != SVt_PVHV)
10381 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10383 /* The Copy above means that all the source (unduplicated) pointers
10384 are now in the destination. We can check the flags and the
10385 pointers in either, but it's possible that there's less cache
10386 missing by always going for the destination.
10387 FIXME - instrument and check that assumption */
10388 if (SvTYPE(sstr) >= SVt_PVMG) {
10390 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
10392 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
10395 switch (SvTYPE(sstr)) {
10407 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
10408 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
10409 LvTARG(dstr) = dstr;
10410 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
10411 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
10413 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
10416 GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr));
10417 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
10418 /* Don't call sv_add_backref here as it's going to be created
10419 as part of the magic cloning of the symbol table. */
10420 GvGP(dstr) = gp_dup(GvGP(dstr), param);
10421 (void)GpREFCNT_inc(GvGP(dstr));
10424 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
10425 if (IoOFP(dstr) == IoIFP(sstr))
10426 IoOFP(dstr) = IoIFP(dstr);
10428 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
10429 /* PL_rsfp_filters entries have fake IoDIRP() */
10430 if (IoDIRP(dstr) && !(IoFLAGS(dstr) & IOf_FAKE_DIRP))
10431 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
10432 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
10433 /* I have no idea why fake dirp (rsfps)
10434 should be treated differently but otherwise
10435 we end up with leaks -- sky*/
10436 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
10437 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
10438 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
10440 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
10441 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
10442 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
10444 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
10445 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
10446 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
10449 if (AvARRAY((AV*)sstr)) {
10450 SV **dst_ary, **src_ary;
10451 SSize_t items = AvFILLp((AV*)sstr) + 1;
10453 src_ary = AvARRAY((AV*)sstr);
10454 Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*);
10455 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10456 SvPV_set(dstr, (char*)dst_ary);
10457 AvALLOC((AV*)dstr) = dst_ary;
10458 if (AvREAL((AV*)sstr)) {
10459 while (items-- > 0)
10460 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10463 while (items-- > 0)
10464 *dst_ary++ = sv_dup(*src_ary++, param);
10466 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10467 while (items-- > 0) {
10468 *dst_ary++ = &PL_sv_undef;
10472 SvPV_set(dstr, Nullch);
10473 AvALLOC((AV*)dstr) = (SV**)NULL;
10480 if (HvARRAY((HV*)sstr)) {
10482 const bool sharekeys = !!HvSHAREKEYS(sstr);
10483 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
10484 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
10486 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
10487 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
10489 HvARRAY(dstr) = (HE**)darray;
10490 while (i <= sxhv->xhv_max) {
10491 const HE *source = HvARRAY(sstr)[i];
10492 HvARRAY(dstr)[i] = source
10493 ? he_dup(source, sharekeys, param) : 0;
10497 struct xpvhv_aux *saux = HvAUX(sstr);
10498 struct xpvhv_aux *daux = HvAUX(dstr);
10499 /* This flag isn't copied. */
10500 /* SvOOK_on(hv) attacks the IV flags. */
10501 SvFLAGS(dstr) |= SVf_OOK;
10503 hvname = saux->xhv_name;
10505 = hvname ? hek_dup(hvname, param) : hvname;
10507 daux->xhv_riter = saux->xhv_riter;
10508 daux->xhv_eiter = saux->xhv_eiter
10509 ? he_dup(saux->xhv_eiter,
10510 (bool)!!HvSHAREKEYS(sstr), param) : 0;
10514 SvPV_set(dstr, Nullch);
10516 /* Record stashes for possible cloning in Perl_clone(). */
10518 av_push(param->stashes, dstr);
10523 /* NOTE: not refcounted */
10524 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
10526 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
10528 if (CvCONST(dstr)) {
10529 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
10530 SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
10531 sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
10533 /* don't dup if copying back - CvGV isn't refcounted, so the
10534 * duped GV may never be freed. A bit of a hack! DAPM */
10535 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
10536 Nullgv : gv_dup(CvGV(dstr), param) ;
10537 if (!(param->flags & CLONEf_COPY_STACKS)) {
10540 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10542 CvWEAKOUTSIDE(sstr)
10543 ? cv_dup( CvOUTSIDE(dstr), param)
10544 : cv_dup_inc(CvOUTSIDE(dstr), param);
10546 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
10552 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10558 /* duplicate a context */
10561 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10563 PERL_CONTEXT *ncxs;
10566 return (PERL_CONTEXT*)NULL;
10568 /* look for it in the table first */
10569 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10573 /* create anew and remember what it is */
10574 Newxz(ncxs, max + 1, PERL_CONTEXT);
10575 ptr_table_store(PL_ptr_table, cxs, ncxs);
10578 PERL_CONTEXT *cx = &cxs[ix];
10579 PERL_CONTEXT *ncx = &ncxs[ix];
10580 ncx->cx_type = cx->cx_type;
10581 if (CxTYPE(cx) == CXt_SUBST) {
10582 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10585 ncx->blk_oldsp = cx->blk_oldsp;
10586 ncx->blk_oldcop = cx->blk_oldcop;
10587 ncx->blk_oldmarksp = cx->blk_oldmarksp;
10588 ncx->blk_oldscopesp = cx->blk_oldscopesp;
10589 ncx->blk_oldpm = cx->blk_oldpm;
10590 ncx->blk_gimme = cx->blk_gimme;
10591 switch (CxTYPE(cx)) {
10593 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
10594 ? cv_dup_inc(cx->blk_sub.cv, param)
10595 : cv_dup(cx->blk_sub.cv,param));
10596 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
10597 ? av_dup_inc(cx->blk_sub.argarray, param)
10599 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
10600 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
10601 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10602 ncx->blk_sub.lval = cx->blk_sub.lval;
10603 ncx->blk_sub.retop = cx->blk_sub.retop;
10606 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
10607 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
10608 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
10609 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
10610 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
10611 ncx->blk_eval.retop = cx->blk_eval.retop;
10614 ncx->blk_loop.label = cx->blk_loop.label;
10615 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
10616 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
10617 ncx->blk_loop.next_op = cx->blk_loop.next_op;
10618 ncx->blk_loop.last_op = cx->blk_loop.last_op;
10619 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
10620 ? cx->blk_loop.iterdata
10621 : gv_dup((GV*)cx->blk_loop.iterdata, param));
10622 ncx->blk_loop.oldcomppad
10623 = (PAD*)ptr_table_fetch(PL_ptr_table,
10624 cx->blk_loop.oldcomppad);
10625 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
10626 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
10627 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
10628 ncx->blk_loop.iterix = cx->blk_loop.iterix;
10629 ncx->blk_loop.itermax = cx->blk_loop.itermax;
10632 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
10633 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
10634 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
10635 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10636 ncx->blk_sub.retop = cx->blk_sub.retop;
10648 /* duplicate a stack info structure */
10651 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10656 return (PERL_SI*)NULL;
10658 /* look for it in the table first */
10659 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10663 /* create anew and remember what it is */
10664 Newxz(nsi, 1, PERL_SI);
10665 ptr_table_store(PL_ptr_table, si, nsi);
10667 nsi->si_stack = av_dup_inc(si->si_stack, param);
10668 nsi->si_cxix = si->si_cxix;
10669 nsi->si_cxmax = si->si_cxmax;
10670 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
10671 nsi->si_type = si->si_type;
10672 nsi->si_prev = si_dup(si->si_prev, param);
10673 nsi->si_next = si_dup(si->si_next, param);
10674 nsi->si_markoff = si->si_markoff;
10679 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
10680 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
10681 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
10682 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
10683 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
10684 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
10685 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
10686 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
10687 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
10688 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
10689 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
10690 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
10691 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
10692 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
10695 #define pv_dup_inc(p) SAVEPV(p)
10696 #define pv_dup(p) SAVEPV(p)
10697 #define svp_dup_inc(p,pp) any_dup(p,pp)
10699 /* map any object to the new equivent - either something in the
10700 * ptr table, or something in the interpreter structure
10704 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
10709 return (void*)NULL;
10711 /* look for it in the table first */
10712 ret = ptr_table_fetch(PL_ptr_table, v);
10716 /* see if it is part of the interpreter structure */
10717 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
10718 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
10726 /* duplicate the save stack */
10729 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
10731 ANY * const ss = proto_perl->Tsavestack;
10732 const I32 max = proto_perl->Tsavestack_max;
10733 I32 ix = proto_perl->Tsavestack_ix;
10745 void (*dptr) (void*);
10746 void (*dxptr) (pTHX_ void*);
10748 Newxz(nss, max, ANY);
10751 I32 i = POPINT(ss,ix);
10752 TOPINT(nss,ix) = i;
10754 case SAVEt_ITEM: /* normal string */
10755 sv = (SV*)POPPTR(ss,ix);
10756 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10757 sv = (SV*)POPPTR(ss,ix);
10758 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10760 case SAVEt_SV: /* scalar reference */
10761 sv = (SV*)POPPTR(ss,ix);
10762 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10763 gv = (GV*)POPPTR(ss,ix);
10764 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10766 case SAVEt_GENERIC_PVREF: /* generic char* */
10767 c = (char*)POPPTR(ss,ix);
10768 TOPPTR(nss,ix) = pv_dup(c);
10769 ptr = POPPTR(ss,ix);
10770 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10772 case SAVEt_SHARED_PVREF: /* char* in shared space */
10773 c = (char*)POPPTR(ss,ix);
10774 TOPPTR(nss,ix) = savesharedpv(c);
10775 ptr = POPPTR(ss,ix);
10776 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10778 case SAVEt_GENERIC_SVREF: /* generic sv */
10779 case SAVEt_SVREF: /* scalar reference */
10780 sv = (SV*)POPPTR(ss,ix);
10781 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10782 ptr = POPPTR(ss,ix);
10783 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
10785 case SAVEt_AV: /* array reference */
10786 av = (AV*)POPPTR(ss,ix);
10787 TOPPTR(nss,ix) = av_dup_inc(av, param);
10788 gv = (GV*)POPPTR(ss,ix);
10789 TOPPTR(nss,ix) = gv_dup(gv, param);
10791 case SAVEt_HV: /* hash reference */
10792 hv = (HV*)POPPTR(ss,ix);
10793 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10794 gv = (GV*)POPPTR(ss,ix);
10795 TOPPTR(nss,ix) = gv_dup(gv, param);
10797 case SAVEt_INT: /* int reference */
10798 ptr = POPPTR(ss,ix);
10799 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10800 intval = (int)POPINT(ss,ix);
10801 TOPINT(nss,ix) = intval;
10803 case SAVEt_LONG: /* long reference */
10804 ptr = POPPTR(ss,ix);
10805 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10806 longval = (long)POPLONG(ss,ix);
10807 TOPLONG(nss,ix) = longval;
10809 case SAVEt_I32: /* I32 reference */
10810 case SAVEt_I16: /* I16 reference */
10811 case SAVEt_I8: /* I8 reference */
10812 ptr = POPPTR(ss,ix);
10813 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10815 TOPINT(nss,ix) = i;
10817 case SAVEt_IV: /* IV reference */
10818 ptr = POPPTR(ss,ix);
10819 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10821 TOPIV(nss,ix) = iv;
10823 case SAVEt_SPTR: /* SV* reference */
10824 ptr = POPPTR(ss,ix);
10825 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10826 sv = (SV*)POPPTR(ss,ix);
10827 TOPPTR(nss,ix) = sv_dup(sv, param);
10829 case SAVEt_VPTR: /* random* reference */
10830 ptr = POPPTR(ss,ix);
10831 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10832 ptr = POPPTR(ss,ix);
10833 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10835 case SAVEt_PPTR: /* char* reference */
10836 ptr = POPPTR(ss,ix);
10837 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10838 c = (char*)POPPTR(ss,ix);
10839 TOPPTR(nss,ix) = pv_dup(c);
10841 case SAVEt_HPTR: /* HV* reference */
10842 ptr = POPPTR(ss,ix);
10843 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10844 hv = (HV*)POPPTR(ss,ix);
10845 TOPPTR(nss,ix) = hv_dup(hv, param);
10847 case SAVEt_APTR: /* AV* reference */
10848 ptr = POPPTR(ss,ix);
10849 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10850 av = (AV*)POPPTR(ss,ix);
10851 TOPPTR(nss,ix) = av_dup(av, param);
10854 gv = (GV*)POPPTR(ss,ix);
10855 TOPPTR(nss,ix) = gv_dup(gv, param);
10857 case SAVEt_GP: /* scalar reference */
10858 gp = (GP*)POPPTR(ss,ix);
10859 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
10860 (void)GpREFCNT_inc(gp);
10861 gv = (GV*)POPPTR(ss,ix);
10862 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10863 c = (char*)POPPTR(ss,ix);
10864 TOPPTR(nss,ix) = pv_dup(c);
10866 TOPIV(nss,ix) = iv;
10868 TOPIV(nss,ix) = iv;
10871 case SAVEt_MORTALIZESV:
10872 sv = (SV*)POPPTR(ss,ix);
10873 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10876 ptr = POPPTR(ss,ix);
10877 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
10878 /* these are assumed to be refcounted properly */
10880 switch (((OP*)ptr)->op_type) {
10882 case OP_LEAVESUBLV:
10886 case OP_LEAVEWRITE:
10887 TOPPTR(nss,ix) = ptr;
10892 TOPPTR(nss,ix) = Nullop;
10897 TOPPTR(nss,ix) = Nullop;
10900 c = (char*)POPPTR(ss,ix);
10901 TOPPTR(nss,ix) = pv_dup_inc(c);
10903 case SAVEt_CLEARSV:
10904 longval = POPLONG(ss,ix);
10905 TOPLONG(nss,ix) = longval;
10908 hv = (HV*)POPPTR(ss,ix);
10909 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10910 c = (char*)POPPTR(ss,ix);
10911 TOPPTR(nss,ix) = pv_dup_inc(c);
10913 TOPINT(nss,ix) = i;
10915 case SAVEt_DESTRUCTOR:
10916 ptr = POPPTR(ss,ix);
10917 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10918 dptr = POPDPTR(ss,ix);
10919 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
10920 any_dup(FPTR2DPTR(void *, dptr),
10923 case SAVEt_DESTRUCTOR_X:
10924 ptr = POPPTR(ss,ix);
10925 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10926 dxptr = POPDXPTR(ss,ix);
10927 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
10928 any_dup(FPTR2DPTR(void *, dxptr),
10931 case SAVEt_REGCONTEXT:
10934 TOPINT(nss,ix) = i;
10937 case SAVEt_STACK_POS: /* Position on Perl stack */
10939 TOPINT(nss,ix) = i;
10941 case SAVEt_AELEM: /* array element */
10942 sv = (SV*)POPPTR(ss,ix);
10943 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10945 TOPINT(nss,ix) = i;
10946 av = (AV*)POPPTR(ss,ix);
10947 TOPPTR(nss,ix) = av_dup_inc(av, param);
10949 case SAVEt_HELEM: /* hash element */
10950 sv = (SV*)POPPTR(ss,ix);
10951 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10952 sv = (SV*)POPPTR(ss,ix);
10953 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10954 hv = (HV*)POPPTR(ss,ix);
10955 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10958 ptr = POPPTR(ss,ix);
10959 TOPPTR(nss,ix) = ptr;
10963 TOPINT(nss,ix) = i;
10965 case SAVEt_COMPPAD:
10966 av = (AV*)POPPTR(ss,ix);
10967 TOPPTR(nss,ix) = av_dup(av, param);
10970 longval = (long)POPLONG(ss,ix);
10971 TOPLONG(nss,ix) = longval;
10972 ptr = POPPTR(ss,ix);
10973 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10974 sv = (SV*)POPPTR(ss,ix);
10975 TOPPTR(nss,ix) = sv_dup(sv, param);
10978 ptr = POPPTR(ss,ix);
10979 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10980 longval = (long)POPBOOL(ss,ix);
10981 TOPBOOL(nss,ix) = (bool)longval;
10983 case SAVEt_SET_SVFLAGS:
10985 TOPINT(nss,ix) = i;
10987 TOPINT(nss,ix) = i;
10988 sv = (SV*)POPPTR(ss,ix);
10989 TOPPTR(nss,ix) = sv_dup(sv, param);
10992 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
11000 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11001 * flag to the result. This is done for each stash before cloning starts,
11002 * so we know which stashes want their objects cloned */
11005 do_mark_cloneable_stash(pTHX_ SV *sv)
11007 const HEK * const hvname = HvNAME_HEK((HV*)sv);
11009 GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
11010 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11011 if (cloner && GvCV(cloner)) {
11018 XPUSHs(sv_2mortal(newSVhek(hvname)));
11020 call_sv((SV*)GvCV(cloner), G_SCALAR);
11027 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11035 =for apidoc perl_clone
11037 Create and return a new interpreter by cloning the current one.
11039 perl_clone takes these flags as parameters:
11041 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11042 without it we only clone the data and zero the stacks,
11043 with it we copy the stacks and the new perl interpreter is
11044 ready to run at the exact same point as the previous one.
11045 The pseudo-fork code uses COPY_STACKS while the
11046 threads->new doesn't.
11048 CLONEf_KEEP_PTR_TABLE
11049 perl_clone keeps a ptr_table with the pointer of the old
11050 variable as a key and the new variable as a value,
11051 this allows it to check if something has been cloned and not
11052 clone it again but rather just use the value and increase the
11053 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11054 the ptr_table using the function
11055 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11056 reason to keep it around is if you want to dup some of your own
11057 variable who are outside the graph perl scans, example of this
11058 code is in threads.xs create
11061 This is a win32 thing, it is ignored on unix, it tells perls
11062 win32host code (which is c++) to clone itself, this is needed on
11063 win32 if you want to run two threads at the same time,
11064 if you just want to do some stuff in a separate perl interpreter
11065 and then throw it away and return to the original one,
11066 you don't need to do anything.
11071 /* XXX the above needs expanding by someone who actually understands it ! */
11072 EXTERN_C PerlInterpreter *
11073 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11076 perl_clone(PerlInterpreter *proto_perl, UV flags)
11079 #ifdef PERL_IMPLICIT_SYS
11081 /* perlhost.h so we need to call into it
11082 to clone the host, CPerlHost should have a c interface, sky */
11084 if (flags & CLONEf_CLONE_HOST) {
11085 return perl_clone_host(proto_perl,flags);
11087 return perl_clone_using(proto_perl, flags,
11089 proto_perl->IMemShared,
11090 proto_perl->IMemParse,
11092 proto_perl->IStdIO,
11096 proto_perl->IProc);
11100 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11101 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11102 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11103 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11104 struct IPerlDir* ipD, struct IPerlSock* ipS,
11105 struct IPerlProc* ipP)
11107 /* XXX many of the string copies here can be optimized if they're
11108 * constants; they need to be allocated as common memory and just
11109 * their pointers copied. */
11112 CLONE_PARAMS clone_params;
11113 CLONE_PARAMS* param = &clone_params;
11115 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11116 /* for each stash, determine whether its objects should be cloned */
11117 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11118 PERL_SET_THX(my_perl);
11121 Poison(my_perl, 1, PerlInterpreter);
11123 PL_curcop = (COP *)Nullop;
11127 PL_savestack_ix = 0;
11128 PL_savestack_max = -1;
11129 PL_sig_pending = 0;
11130 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11131 # else /* !DEBUGGING */
11132 Zero(my_perl, 1, PerlInterpreter);
11133 # endif /* DEBUGGING */
11135 /* host pointers */
11137 PL_MemShared = ipMS;
11138 PL_MemParse = ipMP;
11145 #else /* !PERL_IMPLICIT_SYS */
11147 CLONE_PARAMS clone_params;
11148 CLONE_PARAMS* param = &clone_params;
11149 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11150 /* for each stash, determine whether its objects should be cloned */
11151 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11152 PERL_SET_THX(my_perl);
11155 Poison(my_perl, 1, PerlInterpreter);
11157 PL_curcop = (COP *)Nullop;
11161 PL_savestack_ix = 0;
11162 PL_savestack_max = -1;
11163 PL_sig_pending = 0;
11164 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11165 # else /* !DEBUGGING */
11166 Zero(my_perl, 1, PerlInterpreter);
11167 # endif /* DEBUGGING */
11168 #endif /* PERL_IMPLICIT_SYS */
11169 param->flags = flags;
11170 param->proto_perl = proto_perl;
11173 PL_xnv_arenaroot = NULL;
11174 PL_xnv_root = NULL;
11175 PL_xpv_arenaroot = NULL;
11176 PL_xpv_root = NULL;
11177 PL_xpviv_arenaroot = NULL;
11178 PL_xpviv_root = NULL;
11179 PL_xpvnv_arenaroot = NULL;
11180 PL_xpvnv_root = NULL;
11181 PL_xpvcv_arenaroot = NULL;
11182 PL_xpvcv_root = NULL;
11183 PL_xpvav_arenaroot = NULL;
11184 PL_xpvav_root = NULL;
11185 PL_xpvhv_arenaroot = NULL;
11186 PL_xpvhv_root = NULL;
11187 PL_xpvmg_arenaroot = NULL;
11188 PL_xpvmg_root = NULL;
11189 PL_xpvgv_arenaroot = NULL;
11190 PL_xpvgv_root = NULL;
11191 PL_xpvlv_arenaroot = NULL;
11192 PL_xpvlv_root = NULL;
11193 PL_xpvbm_arenaroot = NULL;
11194 PL_xpvbm_root = NULL;
11195 PL_he_arenaroot = NULL;
11197 #if defined(USE_ITHREADS)
11198 PL_pte_arenaroot = NULL;
11199 PL_pte_root = NULL;
11201 PL_nice_chunk = NULL;
11202 PL_nice_chunk_size = 0;
11204 PL_sv_objcount = 0;
11205 PL_sv_root = Nullsv;
11206 PL_sv_arenaroot = Nullsv;
11208 PL_debug = proto_perl->Idebug;
11210 PL_hash_seed = proto_perl->Ihash_seed;
11211 PL_rehash_seed = proto_perl->Irehash_seed;
11213 #ifdef USE_REENTRANT_API
11214 /* XXX: things like -Dm will segfault here in perlio, but doing
11215 * PERL_SET_CONTEXT(proto_perl);
11216 * breaks too many other things
11218 Perl_reentrant_init(aTHX);
11221 /* create SV map for pointer relocation */
11222 PL_ptr_table = ptr_table_new();
11224 /* initialize these special pointers as early as possible */
11225 SvANY(&PL_sv_undef) = NULL;
11226 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11227 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11228 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11230 SvANY(&PL_sv_no) = new_XPVNV();
11231 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11232 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11233 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11234 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
11235 SvCUR_set(&PL_sv_no, 0);
11236 SvLEN_set(&PL_sv_no, 1);
11237 SvIV_set(&PL_sv_no, 0);
11238 SvNV_set(&PL_sv_no, 0);
11239 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11241 SvANY(&PL_sv_yes) = new_XPVNV();
11242 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11243 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11244 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11245 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
11246 SvCUR_set(&PL_sv_yes, 1);
11247 SvLEN_set(&PL_sv_yes, 2);
11248 SvIV_set(&PL_sv_yes, 1);
11249 SvNV_set(&PL_sv_yes, 1);
11250 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11252 /* create (a non-shared!) shared string table */
11253 PL_strtab = newHV();
11254 HvSHAREKEYS_off(PL_strtab);
11255 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
11256 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11258 PL_compiling = proto_perl->Icompiling;
11260 /* These two PVs will be free'd special way so must set them same way op.c does */
11261 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11262 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11264 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11265 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11267 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11268 if (!specialWARN(PL_compiling.cop_warnings))
11269 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
11270 if (!specialCopIO(PL_compiling.cop_io))
11271 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
11272 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
11274 /* pseudo environmental stuff */
11275 PL_origargc = proto_perl->Iorigargc;
11276 PL_origargv = proto_perl->Iorigargv;
11278 param->stashes = newAV(); /* Setup array of objects to call clone on */
11280 /* Set tainting stuff before PerlIO_debug can possibly get called */
11281 PL_tainting = proto_perl->Itainting;
11282 PL_taint_warn = proto_perl->Itaint_warn;
11284 #ifdef PERLIO_LAYERS
11285 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11286 PerlIO_clone(aTHX_ proto_perl, param);
11289 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11290 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11291 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11292 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11293 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11294 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11297 PL_minus_c = proto_perl->Iminus_c;
11298 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11299 PL_localpatches = proto_perl->Ilocalpatches;
11300 PL_splitstr = proto_perl->Isplitstr;
11301 PL_preprocess = proto_perl->Ipreprocess;
11302 PL_minus_n = proto_perl->Iminus_n;
11303 PL_minus_p = proto_perl->Iminus_p;
11304 PL_minus_l = proto_perl->Iminus_l;
11305 PL_minus_a = proto_perl->Iminus_a;
11306 PL_minus_F = proto_perl->Iminus_F;
11307 PL_doswitches = proto_perl->Idoswitches;
11308 PL_dowarn = proto_perl->Idowarn;
11309 PL_doextract = proto_perl->Idoextract;
11310 PL_sawampersand = proto_perl->Isawampersand;
11311 PL_unsafe = proto_perl->Iunsafe;
11312 PL_inplace = SAVEPV(proto_perl->Iinplace);
11313 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11314 PL_perldb = proto_perl->Iperldb;
11315 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11316 PL_exit_flags = proto_perl->Iexit_flags;
11318 /* magical thingies */
11319 /* XXX time(&PL_basetime) when asked for? */
11320 PL_basetime = proto_perl->Ibasetime;
11321 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11323 PL_maxsysfd = proto_perl->Imaxsysfd;
11324 PL_multiline = proto_perl->Imultiline;
11325 PL_statusvalue = proto_perl->Istatusvalue;
11327 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11329 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
11331 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11333 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11334 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11335 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11337 /* Clone the regex array */
11338 PL_regex_padav = newAV();
11340 const I32 len = av_len((AV*)proto_perl->Iregex_padav);
11341 SV** const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11343 av_push(PL_regex_padav,
11344 sv_dup_inc(regexen[0],param));
11345 for(i = 1; i <= len; i++) {
11346 if(SvREPADTMP(regexen[i])) {
11347 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11349 av_push(PL_regex_padav,
11351 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11352 SvIVX(regexen[i])), param)))
11357 PL_regex_pad = AvARRAY(PL_regex_padav);
11359 /* shortcuts to various I/O objects */
11360 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11361 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11362 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11363 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11364 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11365 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11367 /* shortcuts to regexp stuff */
11368 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11370 /* shortcuts to misc objects */
11371 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11373 /* shortcuts to debugging objects */
11374 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11375 PL_DBline = gv_dup(proto_perl->IDBline, param);
11376 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11377 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11378 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11379 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11380 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11381 PL_lineary = av_dup(proto_perl->Ilineary, param);
11382 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11384 /* symbol tables */
11385 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11386 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11387 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11388 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11389 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11391 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11392 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11393 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11394 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11395 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11396 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11398 PL_sub_generation = proto_perl->Isub_generation;
11400 /* funky return mechanisms */
11401 PL_forkprocess = proto_perl->Iforkprocess;
11403 /* subprocess state */
11404 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11406 /* internal state */
11407 PL_maxo = proto_perl->Imaxo;
11408 if (proto_perl->Iop_mask)
11409 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11411 PL_op_mask = Nullch;
11412 /* PL_asserting = proto_perl->Iasserting; */
11414 /* current interpreter roots */
11415 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11416 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11417 PL_main_start = proto_perl->Imain_start;
11418 PL_eval_root = proto_perl->Ieval_root;
11419 PL_eval_start = proto_perl->Ieval_start;
11421 /* runtime control stuff */
11422 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11423 PL_copline = proto_perl->Icopline;
11425 PL_filemode = proto_perl->Ifilemode;
11426 PL_lastfd = proto_perl->Ilastfd;
11427 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11430 PL_gensym = proto_perl->Igensym;
11431 PL_preambled = proto_perl->Ipreambled;
11432 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11433 PL_laststatval = proto_perl->Ilaststatval;
11434 PL_laststype = proto_perl->Ilaststype;
11435 PL_mess_sv = Nullsv;
11437 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11439 /* interpreter atexit processing */
11440 PL_exitlistlen = proto_perl->Iexitlistlen;
11441 if (PL_exitlistlen) {
11442 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11443 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11446 PL_exitlist = (PerlExitListEntry*)NULL;
11447 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11448 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11449 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11451 PL_profiledata = NULL;
11452 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
11453 /* PL_rsfp_filters entries have fake IoDIRP() */
11454 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
11456 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11458 PAD_CLONE_VARS(proto_perl, param);
11460 #ifdef HAVE_INTERP_INTERN
11461 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11464 /* more statics moved here */
11465 PL_generation = proto_perl->Igeneration;
11466 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11468 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11469 PL_in_clean_all = proto_perl->Iin_clean_all;
11471 PL_uid = proto_perl->Iuid;
11472 PL_euid = proto_perl->Ieuid;
11473 PL_gid = proto_perl->Igid;
11474 PL_egid = proto_perl->Iegid;
11475 PL_nomemok = proto_perl->Inomemok;
11476 PL_an = proto_perl->Ian;
11477 PL_evalseq = proto_perl->Ievalseq;
11478 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11479 PL_origalen = proto_perl->Iorigalen;
11480 #ifdef PERL_USES_PL_PIDSTATUS
11481 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11483 PL_osname = SAVEPV(proto_perl->Iosname);
11484 PL_sighandlerp = proto_perl->Isighandlerp;
11486 PL_runops = proto_perl->Irunops;
11488 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11491 PL_cshlen = proto_perl->Icshlen;
11492 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
11495 PL_lex_state = proto_perl->Ilex_state;
11496 PL_lex_defer = proto_perl->Ilex_defer;
11497 PL_lex_expect = proto_perl->Ilex_expect;
11498 PL_lex_formbrack = proto_perl->Ilex_formbrack;
11499 PL_lex_dojoin = proto_perl->Ilex_dojoin;
11500 PL_lex_starts = proto_perl->Ilex_starts;
11501 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
11502 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
11503 PL_lex_op = proto_perl->Ilex_op;
11504 PL_lex_inpat = proto_perl->Ilex_inpat;
11505 PL_lex_inwhat = proto_perl->Ilex_inwhat;
11506 PL_lex_brackets = proto_perl->Ilex_brackets;
11507 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11508 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
11509 PL_lex_casemods = proto_perl->Ilex_casemods;
11510 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11511 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
11513 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11514 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
11515 PL_nexttoke = proto_perl->Inexttoke;
11517 /* XXX This is probably masking the deeper issue of why
11518 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11519 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11520 * (A little debugging with a watchpoint on it may help.)
11522 if (SvANY(proto_perl->Ilinestr)) {
11523 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
11524 i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
11525 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11526 i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
11527 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11528 i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
11529 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11530 i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
11531 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11534 PL_linestr = NEWSV(65,79);
11535 sv_upgrade(PL_linestr,SVt_PVIV);
11536 sv_setpvn(PL_linestr,"",0);
11537 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
11539 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11540 PL_pending_ident = proto_perl->Ipending_ident;
11541 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
11543 PL_expect = proto_perl->Iexpect;
11545 PL_multi_start = proto_perl->Imulti_start;
11546 PL_multi_end = proto_perl->Imulti_end;
11547 PL_multi_open = proto_perl->Imulti_open;
11548 PL_multi_close = proto_perl->Imulti_close;
11550 PL_error_count = proto_perl->Ierror_count;
11551 PL_subline = proto_perl->Isubline;
11552 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
11554 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
11555 if (SvANY(proto_perl->Ilinestr)) {
11556 i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
11557 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11558 i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
11559 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11560 PL_last_lop_op = proto_perl->Ilast_lop_op;
11563 PL_last_uni = SvPVX(PL_linestr);
11564 PL_last_lop = SvPVX(PL_linestr);
11565 PL_last_lop_op = 0;
11567 PL_in_my = proto_perl->Iin_my;
11568 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
11570 PL_cryptseen = proto_perl->Icryptseen;
11573 PL_hints = proto_perl->Ihints;
11575 PL_amagic_generation = proto_perl->Iamagic_generation;
11577 #ifdef USE_LOCALE_COLLATE
11578 PL_collation_ix = proto_perl->Icollation_ix;
11579 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
11580 PL_collation_standard = proto_perl->Icollation_standard;
11581 PL_collxfrm_base = proto_perl->Icollxfrm_base;
11582 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
11583 #endif /* USE_LOCALE_COLLATE */
11585 #ifdef USE_LOCALE_NUMERIC
11586 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
11587 PL_numeric_standard = proto_perl->Inumeric_standard;
11588 PL_numeric_local = proto_perl->Inumeric_local;
11589 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11590 #endif /* !USE_LOCALE_NUMERIC */
11592 /* utf8 character classes */
11593 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11594 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11595 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11596 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11597 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
11598 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11599 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
11600 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
11601 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
11602 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
11603 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
11604 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
11605 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11606 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
11607 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11608 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11609 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11610 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11611 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11612 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11614 /* Did the locale setup indicate UTF-8? */
11615 PL_utf8locale = proto_perl->Iutf8locale;
11616 /* Unicode features (see perlrun/-C) */
11617 PL_unicode = proto_perl->Iunicode;
11619 /* Pre-5.8 signals control */
11620 PL_signals = proto_perl->Isignals;
11622 /* times() ticks per second */
11623 PL_clocktick = proto_perl->Iclocktick;
11625 /* Recursion stopper for PerlIO_find_layer */
11626 PL_in_load_module = proto_perl->Iin_load_module;
11628 /* sort() routine */
11629 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
11631 /* Not really needed/useful since the reenrant_retint is "volatile",
11632 * but do it for consistency's sake. */
11633 PL_reentrant_retint = proto_perl->Ireentrant_retint;
11635 /* Hooks to shared SVs and locks. */
11636 PL_sharehook = proto_perl->Isharehook;
11637 PL_lockhook = proto_perl->Ilockhook;
11638 PL_unlockhook = proto_perl->Iunlockhook;
11639 PL_threadhook = proto_perl->Ithreadhook;
11641 PL_runops_std = proto_perl->Irunops_std;
11642 PL_runops_dbg = proto_perl->Irunops_dbg;
11644 #ifdef THREADS_HAVE_PIDS
11645 PL_ppid = proto_perl->Ippid;
11649 PL_last_swash_hv = Nullhv; /* reinits on demand */
11650 PL_last_swash_klen = 0;
11651 PL_last_swash_key[0]= '\0';
11652 PL_last_swash_tmps = (U8*)NULL;
11653 PL_last_swash_slen = 0;
11655 PL_glob_index = proto_perl->Iglob_index;
11656 PL_srand_called = proto_perl->Isrand_called;
11657 PL_uudmap['M'] = 0; /* reinits on demand */
11658 PL_bitcount = Nullch; /* reinits on demand */
11660 if (proto_perl->Ipsig_pend) {
11661 Newxz(PL_psig_pend, SIG_SIZE, int);
11664 PL_psig_pend = (int*)NULL;
11667 if (proto_perl->Ipsig_ptr) {
11668 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
11669 Newxz(PL_psig_name, SIG_SIZE, SV*);
11670 for (i = 1; i < SIG_SIZE; i++) {
11671 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11672 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11676 PL_psig_ptr = (SV**)NULL;
11677 PL_psig_name = (SV**)NULL;
11680 /* thrdvar.h stuff */
11682 if (flags & CLONEf_COPY_STACKS) {
11683 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11684 PL_tmps_ix = proto_perl->Ttmps_ix;
11685 PL_tmps_max = proto_perl->Ttmps_max;
11686 PL_tmps_floor = proto_perl->Ttmps_floor;
11687 Newxz(PL_tmps_stack, PL_tmps_max, SV*);
11689 while (i <= PL_tmps_ix) {
11690 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
11694 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11695 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
11696 Newxz(PL_markstack, i, I32);
11697 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
11698 - proto_perl->Tmarkstack);
11699 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
11700 - proto_perl->Tmarkstack);
11701 Copy(proto_perl->Tmarkstack, PL_markstack,
11702 PL_markstack_ptr - PL_markstack + 1, I32);
11704 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
11705 * NOTE: unlike the others! */
11706 PL_scopestack_ix = proto_perl->Tscopestack_ix;
11707 PL_scopestack_max = proto_perl->Tscopestack_max;
11708 Newxz(PL_scopestack, PL_scopestack_max, I32);
11709 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
11711 /* NOTE: si_dup() looks at PL_markstack */
11712 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
11714 /* PL_curstack = PL_curstackinfo->si_stack; */
11715 PL_curstack = av_dup(proto_perl->Tcurstack, param);
11716 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
11718 /* next PUSHs() etc. set *(PL_stack_sp+1) */
11719 PL_stack_base = AvARRAY(PL_curstack);
11720 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
11721 - proto_perl->Tstack_base);
11722 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
11724 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
11725 * NOTE: unlike the others! */
11726 PL_savestack_ix = proto_perl->Tsavestack_ix;
11727 PL_savestack_max = proto_perl->Tsavestack_max;
11728 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
11729 PL_savestack = ss_dup(proto_perl, param);
11733 ENTER; /* perl_destruct() wants to LEAVE; */
11736 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
11737 PL_top_env = &PL_start_env;
11739 PL_op = proto_perl->Top;
11742 PL_Xpv = (XPV*)NULL;
11743 PL_na = proto_perl->Tna;
11745 PL_statbuf = proto_perl->Tstatbuf;
11746 PL_statcache = proto_perl->Tstatcache;
11747 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
11748 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
11750 PL_timesbuf = proto_perl->Ttimesbuf;
11753 PL_tainted = proto_perl->Ttainted;
11754 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
11755 PL_rs = sv_dup_inc(proto_perl->Trs, param);
11756 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
11757 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
11758 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
11759 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
11760 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
11761 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
11762 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
11764 PL_restartop = proto_perl->Trestartop;
11765 PL_in_eval = proto_perl->Tin_eval;
11766 PL_delaymagic = proto_perl->Tdelaymagic;
11767 PL_dirty = proto_perl->Tdirty;
11768 PL_localizing = proto_perl->Tlocalizing;
11770 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
11771 PL_hv_fetch_ent_mh = Nullhe;
11772 PL_modcount = proto_perl->Tmodcount;
11773 PL_lastgotoprobe = Nullop;
11774 PL_dumpindent = proto_perl->Tdumpindent;
11776 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
11777 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
11778 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
11779 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
11780 PL_sortcxix = proto_perl->Tsortcxix;
11781 PL_efloatbuf = Nullch; /* reinits on demand */
11782 PL_efloatsize = 0; /* reinits on demand */
11786 PL_screamfirst = NULL;
11787 PL_screamnext = NULL;
11788 PL_maxscream = -1; /* reinits on demand */
11789 PL_lastscream = Nullsv;
11791 PL_watchaddr = NULL;
11792 PL_watchok = Nullch;
11794 PL_regdummy = proto_perl->Tregdummy;
11795 PL_regprecomp = Nullch;
11798 PL_colorset = 0; /* reinits PL_colors[] */
11799 /*PL_colors[6] = {0,0,0,0,0,0};*/
11800 PL_reginput = Nullch;
11801 PL_regbol = Nullch;
11802 PL_regeol = Nullch;
11803 PL_regstartp = (I32*)NULL;
11804 PL_regendp = (I32*)NULL;
11805 PL_reglastparen = (U32*)NULL;
11806 PL_reglastcloseparen = (U32*)NULL;
11807 PL_regtill = Nullch;
11808 PL_reg_start_tmp = (char**)NULL;
11809 PL_reg_start_tmpl = 0;
11810 PL_regdata = (struct reg_data*)NULL;
11813 PL_reg_eval_set = 0;
11815 PL_regprogram = (regnode*)NULL;
11817 PL_regcc = (CURCUR*)NULL;
11818 PL_reg_call_cc = (struct re_cc_state*)NULL;
11819 PL_reg_re = (regexp*)NULL;
11820 PL_reg_ganch = Nullch;
11821 PL_reg_sv = Nullsv;
11822 PL_reg_match_utf8 = FALSE;
11823 PL_reg_magic = (MAGIC*)NULL;
11825 PL_reg_oldcurpm = (PMOP*)NULL;
11826 PL_reg_curpm = (PMOP*)NULL;
11827 PL_reg_oldsaved = Nullch;
11828 PL_reg_oldsavedlen = 0;
11829 #ifdef PERL_OLD_COPY_ON_WRITE
11832 PL_reg_maxiter = 0;
11833 PL_reg_leftiter = 0;
11834 PL_reg_poscache = Nullch;
11835 PL_reg_poscache_size= 0;
11837 /* RE engine - function pointers */
11838 PL_regcompp = proto_perl->Tregcompp;
11839 PL_regexecp = proto_perl->Tregexecp;
11840 PL_regint_start = proto_perl->Tregint_start;
11841 PL_regint_string = proto_perl->Tregint_string;
11842 PL_regfree = proto_perl->Tregfree;
11844 PL_reginterp_cnt = 0;
11845 PL_reg_starttry = 0;
11847 /* Pluggable optimizer */
11848 PL_peepp = proto_perl->Tpeepp;
11850 PL_stashcache = newHV();
11852 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
11853 ptr_table_free(PL_ptr_table);
11854 PL_ptr_table = NULL;
11857 /* Call the ->CLONE method, if it exists, for each of the stashes
11858 identified by sv_dup() above.
11860 while(av_len(param->stashes) != -1) {
11861 HV* const stash = (HV*) av_shift(param->stashes);
11862 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
11863 if (cloner && GvCV(cloner)) {
11868 XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
11870 call_sv((SV*)GvCV(cloner), G_DISCARD);
11876 SvREFCNT_dec(param->stashes);
11878 /* orphaned? eg threads->new inside BEGIN or use */
11879 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
11880 (void)SvREFCNT_inc(PL_compcv);
11881 SAVEFREESV(PL_compcv);
11887 #endif /* USE_ITHREADS */
11890 =head1 Unicode Support
11892 =for apidoc sv_recode_to_utf8
11894 The encoding is assumed to be an Encode object, on entry the PV
11895 of the sv is assumed to be octets in that encoding, and the sv
11896 will be converted into Unicode (and UTF-8).
11898 If the sv already is UTF-8 (or if it is not POK), or if the encoding
11899 is not a reference, nothing is done to the sv. If the encoding is not
11900 an C<Encode::XS> Encoding object, bad things will happen.
11901 (See F<lib/encoding.pm> and L<Encode>).
11903 The PV of the sv is returned.
11908 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
11911 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
11925 Passing sv_yes is wrong - it needs to be or'ed set of constants
11926 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
11927 remove converted chars from source.
11929 Both will default the value - let them.
11931 XPUSHs(&PL_sv_yes);
11934 call_method("decode", G_SCALAR);
11938 s = SvPV_const(uni, len);
11939 if (s != SvPVX_const(sv)) {
11940 SvGROW(sv, len + 1);
11941 Move(s, SvPVX(sv), len + 1, char);
11942 SvCUR_set(sv, len);
11949 return SvPOKp(sv) ? SvPVX(sv) : NULL;
11953 =for apidoc sv_cat_decode
11955 The encoding is assumed to be an Encode object, the PV of the ssv is
11956 assumed to be octets in that encoding and decoding the input starts
11957 from the position which (PV + *offset) pointed to. The dsv will be
11958 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
11959 when the string tstr appears in decoding output or the input ends on
11960 the PV of the ssv. The value which the offset points will be modified
11961 to the last input position on the ssv.
11963 Returns TRUE if the terminator was found, else returns FALSE.
11968 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
11969 SV *ssv, int *offset, char *tstr, int tlen)
11973 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
11984 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
11985 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
11987 call_method("cat_decode", G_SCALAR);
11989 ret = SvTRUE(TOPs);
11990 *offset = SvIV(offsv);
11996 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12002 * c-indentation-style: bsd
12003 * c-basic-offset: 4
12004 * indent-tabs-mode: t
12007 * ex: set ts=8 sts=4 sw=4 noet: