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