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
192 # define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
194 # define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file)
197 # define FREE_SV_DEBUG_FILE(sv)
200 #define plant_SV(p) \
202 FREE_SV_DEBUG_FILE(p); \
203 SvANY(p) = (void *)PL_sv_root; \
204 SvFLAGS(p) = SVTYPEMASK; \
209 /* sv_mutex must be held while calling uproot_SV() */
210 #define uproot_SV(p) \
213 PL_sv_root = (SV*)SvANY(p); \
218 /* make some more SVs by adding another arena */
220 /* sv_mutex must be held while calling more_sv() */
227 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
228 PL_nice_chunk = Nullch;
229 PL_nice_chunk_size = 0;
232 char *chunk; /* must use New here to match call to */
233 New(704,chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
234 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
240 /* new_SV(): return a new, empty SV head */
242 #ifdef DEBUG_LEAKING_SCALARS
243 /* provide a real function for a debugger to play with */
253 sv = S_more_sv(aTHX);
258 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
259 sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
260 (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
261 sv->sv_debug_inpad = 0;
262 sv->sv_debug_cloned = 0;
264 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
266 sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
271 # define new_SV(p) (p)=S_new_SV(aTHX)
280 (p) = S_more_sv(aTHX); \
289 /* del_SV(): return an empty SV head to the free list */
304 S_del_sv(pTHX_ SV *p)
309 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
310 const SV * const sv = sva + 1;
311 const SV * const svend = &sva[SvREFCNT(sva)];
312 if (p >= sv && p < svend) {
318 if (ckWARN_d(WARN_INTERNAL))
319 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
320 "Attempt to free non-arena SV: 0x%"UVxf
321 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
328 #else /* ! DEBUGGING */
330 #define del_SV(p) plant_SV(p)
332 #endif /* DEBUGGING */
336 =head1 SV Manipulation Functions
338 =for apidoc sv_add_arena
340 Given a chunk of memory, link it to the head of the list of arenas,
341 and split it into a list of free SVs.
347 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
353 /* The first SV in an arena isn't an SV. */
354 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
355 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
356 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
358 PL_sv_arenaroot = sva;
359 PL_sv_root = sva + 1;
361 svend = &sva[SvREFCNT(sva) - 1];
364 SvANY(sv) = (void *)(SV*)(sv + 1);
368 /* Must always set typemask because it's awlays checked in on cleanup
369 when the arenas are walked looking for objects. */
370 SvFLAGS(sv) = SVTYPEMASK;
377 SvFLAGS(sv) = SVTYPEMASK;
380 /* visit(): call the named function for each non-free SV in the arenas
381 * whose flags field matches the flags/mask args. */
384 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
389 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
390 register const SV * const svend = &sva[SvREFCNT(sva)];
392 for (sv = sva + 1; sv < svend; ++sv) {
393 if (SvTYPE(sv) != SVTYPEMASK
394 && (sv->sv_flags & mask) == flags
407 /* called by sv_report_used() for each live SV */
410 do_report_used(pTHX_ SV *sv)
412 if (SvTYPE(sv) != SVTYPEMASK) {
413 PerlIO_printf(Perl_debug_log, "****\n");
420 =for apidoc sv_report_used
422 Dump the contents of all SVs not yet freed. (Debugging aid).
428 Perl_sv_report_used(pTHX)
431 visit(do_report_used, 0, 0);
435 /* called by sv_clean_objs() for each live SV */
438 do_clean_objs(pTHX_ SV *ref)
442 if (SvROK(ref) && SvOBJECT(target = SvRV(ref))) {
443 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
444 if (SvWEAKREF(ref)) {
445 sv_del_backref(target, ref);
451 SvREFCNT_dec(target);
455 /* XXX Might want to check arrays, etc. */
458 /* called by sv_clean_objs() for each live SV */
460 #ifndef DISABLE_DESTRUCTOR_KLUDGE
462 do_clean_named_objs(pTHX_ SV *sv)
464 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
466 #ifdef PERL_DONT_CREATE_GVSV
469 SvOBJECT(GvSV(sv))) ||
470 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
471 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
472 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
473 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
475 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
476 SvFLAGS(sv) |= SVf_BREAK;
484 =for apidoc sv_clean_objs
486 Attempt to destroy all objects not yet freed
492 Perl_sv_clean_objs(pTHX)
494 PL_in_clean_objs = TRUE;
495 visit(do_clean_objs, SVf_ROK, SVf_ROK);
496 #ifndef DISABLE_DESTRUCTOR_KLUDGE
497 /* some barnacles may yet remain, clinging to typeglobs */
498 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
500 PL_in_clean_objs = FALSE;
503 /* called by sv_clean_all() for each live SV */
506 do_clean_all(pTHX_ SV *sv)
508 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
509 SvFLAGS(sv) |= SVf_BREAK;
510 if (PL_comppad == (AV*)sv) {
512 PL_curpad = Null(SV**);
518 =for apidoc sv_clean_all
520 Decrement the refcnt of each remaining SV, possibly triggering a
521 cleanup. This function may have to be called multiple times to free
522 SVs which are in complex self-referential hierarchies.
528 Perl_sv_clean_all(pTHX)
531 PL_in_clean_all = TRUE;
532 cleaned = visit(do_clean_all, 0,0);
533 PL_in_clean_all = FALSE;
538 S_free_arena(pTHX_ void **root) {
540 void ** const next = *(void **)root;
547 =for apidoc sv_free_arenas
549 Deallocate the memory used by all arenas. Note that all the individual SV
550 heads and bodies within the arenas must already have been freed.
555 #define free_arena(name) \
557 S_free_arena(aTHX_ (void**) PL_ ## name ## _arenaroot); \
558 PL_ ## name ## _arenaroot = 0; \
559 PL_ ## name ## _root = 0; \
563 Perl_sv_free_arenas(pTHX)
568 /* Free arenas here, but be careful about fake ones. (We assume
569 contiguity of the fake ones with the corresponding real ones.) */
571 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
572 svanext = (SV*) SvANY(sva);
573 while (svanext && SvFAKE(svanext))
574 svanext = (SV*) SvANY(svanext);
592 #if defined(USE_ITHREADS)
596 Safefree(PL_nice_chunk);
597 PL_nice_chunk = Nullch;
598 PL_nice_chunk_size = 0;
603 /* ---------------------------------------------------------------------
605 * support functions for report_uninit()
608 /* the maxiumum size of array or hash where we will scan looking
609 * for the undefined element that triggered the warning */
611 #define FUV_MAX_SEARCH_SIZE 1000
613 /* Look for an entry in the hash whose value has the same SV as val;
614 * If so, return a mortal copy of the key. */
617 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
623 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
624 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
629 for (i=HvMAX(hv); i>0; i--) {
631 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
632 if (HeVAL(entry) != val)
634 if ( HeVAL(entry) == &PL_sv_undef ||
635 HeVAL(entry) == &PL_sv_placeholder)
639 if (HeKLEN(entry) == HEf_SVKEY)
640 return sv_mortalcopy(HeKEY_sv(entry));
641 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
647 /* Look for an entry in the array whose value has the same SV as val;
648 * If so, return the index, otherwise return -1. */
651 S_find_array_subscript(pTHX_ AV *av, SV* val)
655 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
656 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
660 for (i=AvFILLp(av); i>=0; i--) {
661 if (svp[i] == val && svp[i] != &PL_sv_undef)
667 /* S_varname(): return the name of a variable, optionally with a subscript.
668 * If gv is non-zero, use the name of that global, along with gvtype (one
669 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
670 * targ. Depending on the value of the subscript_type flag, return:
673 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
674 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
675 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
676 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
679 S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
680 SV* keyname, I32 aindex, int subscript_type)
683 SV * const name = sv_newmortal();
686 /* simulate gv_fullname4(), but add literal '^' for $^FOO names
687 * XXX get rid of all this if gv_fullnameX() ever supports this
691 HV * const hv = GvSTASH(gv);
694 else if (!(p=HvNAME_get(hv)))
696 if (strEQ(p, "main"))
697 sv_setpvn(name, &gvtype, 1);
699 Perl_sv_setpvf(aTHX_ name, "%c%s::", gvtype, p);
701 if (GvNAMELEN(gv)>= 1 &&
702 ((unsigned int)*GvNAME(gv)) <= 26)
704 Perl_sv_catpvf(aTHX_ name,"^%c", *GvNAME(gv) + 'A' - 1);
705 sv_catpvn(name,GvNAME(gv)+1,GvNAMELEN(gv)-1);
708 sv_catpvn(name,GvNAME(gv),GvNAMELEN(gv));
712 CV * const cv = find_runcv(&unused);
716 if (!cv || !CvPADLIST(cv))
718 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
719 sv = *av_fetch(av, targ, FALSE);
720 /* SvLEN in a pad name is not to be trusted */
721 sv_setpv(name, SvPV_nolen_const(sv));
724 if (subscript_type == FUV_SUBSCRIPT_HASH) {
725 SV * const sv = NEWSV(0,0);
727 Perl_sv_catpvf(aTHX_ name, "{%s}",
728 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
731 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
733 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
735 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
736 sv_insert(name, 0, 0, "within ", 7);
743 =for apidoc find_uninit_var
745 Find the name of the undefined variable (if any) that caused the operator o
746 to issue a "Use of uninitialized value" warning.
747 If match is true, only return a name if it's value matches uninit_sv.
748 So roughly speaking, if a unary operator (such as OP_COS) generates a
749 warning, then following the direct child of the op may yield an
750 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
751 other hand, with OP_ADD there are two branches to follow, so we only print
752 the variable name if we get an exact match.
754 The name is returned as a mortal SV.
756 Assumes that PL_op is the op that originally triggered the error, and that
757 PL_comppad/PL_curpad points to the currently executing pad.
763 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
771 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
772 uninit_sv == &PL_sv_placeholder)))
775 switch (obase->op_type) {
782 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
783 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
786 int subscript_type = FUV_SUBSCRIPT_WITHIN;
788 if (pad) { /* @lex, %lex */
789 sv = PAD_SVl(obase->op_targ);
793 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
794 /* @global, %global */
795 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
798 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
800 else /* @{expr}, %{expr} */
801 return find_uninit_var(cUNOPx(obase)->op_first,
805 /* attempt to find a match within the aggregate */
807 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
809 subscript_type = FUV_SUBSCRIPT_HASH;
812 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
814 subscript_type = FUV_SUBSCRIPT_ARRAY;
817 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
820 return varname(gv, hash ? '%' : '@', obase->op_targ,
821 keysv, index, subscript_type);
825 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
827 return varname(Nullgv, '$', obase->op_targ,
828 Nullsv, 0, FUV_SUBSCRIPT_NONE);
831 gv = cGVOPx_gv(obase);
832 if (!gv || (match && GvSV(gv) != uninit_sv))
834 return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
837 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
840 av = (AV*)PAD_SV(obase->op_targ);
841 if (!av || SvRMAGICAL(av))
843 svp = av_fetch(av, (I32)obase->op_private, FALSE);
844 if (!svp || *svp != uninit_sv)
847 return varname(Nullgv, '$', obase->op_targ,
848 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
851 gv = cGVOPx_gv(obase);
857 if (!av || SvRMAGICAL(av))
859 svp = av_fetch(av, (I32)obase->op_private, FALSE);
860 if (!svp || *svp != uninit_sv)
863 return varname(gv, '$', 0,
864 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
869 o = cUNOPx(obase)->op_first;
870 if (!o || o->op_type != OP_NULL ||
871 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
873 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
878 /* $a[uninit_expr] or $h{uninit_expr} */
879 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
882 o = cBINOPx(obase)->op_first;
883 kid = cBINOPx(obase)->op_last;
885 /* get the av or hv, and optionally the gv */
887 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
888 sv = PAD_SV(o->op_targ);
890 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
891 && cUNOPo->op_first->op_type == OP_GV)
893 gv = cGVOPx_gv(cUNOPo->op_first);
896 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
901 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
902 /* index is constant */
906 if (obase->op_type == OP_HELEM) {
907 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
908 if (!he || HeVAL(he) != uninit_sv)
912 SV ** const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
913 if (!svp || *svp != uninit_sv)
917 if (obase->op_type == OP_HELEM)
918 return varname(gv, '%', o->op_targ,
919 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
921 return varname(gv, '@', o->op_targ, Nullsv,
922 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
926 /* index is an expression;
927 * attempt to find a match within the aggregate */
928 if (obase->op_type == OP_HELEM) {
929 SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
931 return varname(gv, '%', o->op_targ,
932 keysv, 0, FUV_SUBSCRIPT_HASH);
935 const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
937 return varname(gv, '@', o->op_targ,
938 Nullsv, index, FUV_SUBSCRIPT_ARRAY);
943 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
945 o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
951 /* only examine RHS */
952 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
955 o = cUNOPx(obase)->op_first;
956 if (o->op_type == OP_PUSHMARK)
959 if (!o->op_sibling) {
960 /* one-arg version of open is highly magical */
962 if (o->op_type == OP_GV) { /* open FOO; */
964 if (match && GvSV(gv) != uninit_sv)
966 return varname(gv, '$', 0,
967 Nullsv, 0, FUV_SUBSCRIPT_NONE);
969 /* other possibilities not handled are:
970 * open $x; or open my $x; should return '${*$x}'
971 * open expr; should return '$'.expr ideally
977 /* ops where $_ may be an implicit arg */
981 if ( !(obase->op_flags & OPf_STACKED)) {
982 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
983 ? PAD_SVl(obase->op_targ)
987 sv_setpvn(sv, "$_", 2);
995 /* skip filehandle as it can't produce 'undef' warning */
996 o = cUNOPx(obase)->op_first;
997 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
998 o = o->op_sibling->op_sibling;
1005 match = 1; /* XS or custom code could trigger random warnings */
1010 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
1011 return sv_2mortal(newSVpvn("${$/}", 5));
1016 if (!(obase->op_flags & OPf_KIDS))
1018 o = cUNOPx(obase)->op_first;
1024 /* if all except one arg are constant, or have no side-effects,
1025 * or are optimized away, then it's unambiguous */
1027 for (kid=o; kid; kid = kid->op_sibling) {
1029 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
1030 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
1031 || (kid->op_type == OP_PUSHMARK)
1035 if (o2) { /* more than one found */
1042 return find_uninit_var(o2, uninit_sv, match);
1046 sv = find_uninit_var(o, uninit_sv, 1);
1058 =for apidoc report_uninit
1060 Print appropriate "Use of uninitialized variable" warning
1066 Perl_report_uninit(pTHX_ SV* uninit_sv)
1069 SV* varname = Nullsv;
1071 varname = find_uninit_var(PL_op, uninit_sv,0);
1073 sv_insert(varname, 0, 0, " ", 1);
1075 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1076 varname ? SvPV_nolen_const(varname) : "",
1077 " in ", OP_DESC(PL_op));
1080 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1085 S_more_bodies (pTHX_ void **arena_root, void **root, size_t size)
1089 const size_t count = PERL_ARENA_SIZE/size;
1090 New(0, start, count*size, char);
1091 *((void **) start) = *arena_root;
1092 *arena_root = (void *)start;
1094 end = start + (count-1) * size;
1096 /* The initial slot is used to link the arenas together, so it isn't to be
1097 linked into the list of ready-to-use bodies. */
1101 *root = (void *)start;
1103 while (start < end) {
1104 char * const next = start + size;
1105 *(void**) start = (void *)next;
1108 *(void **)start = 0;
1113 /* grab a new thing from the free list, allocating more if necessary */
1116 S_new_body(pTHX_ void **arena_root, void **root, size_t size)
1120 xpv = *root ? *root : S_more_bodies(aTHX_ arena_root, root, size);
1121 *root = *(void**)xpv;
1126 /* return a thing to the free list */
1128 #define del_body(thing, root) \
1130 void **thing_copy = (void **)thing; \
1132 *thing_copy = *root; \
1133 *root = (void*)thing_copy; \
1137 /* Conventionally we simply malloc() a big block of memory, then divide it
1138 up into lots of the thing that we're allocating.
1140 This macro will expand to call to S_new_body. So for XPVBM (with ithreads),
1143 S_new_body(my_perl, (void**)&(my_perl->Ixpvbm_arenaroot),
1144 (void**)&(my_perl->Ixpvbm_root), sizeof(XPVBM), 0)
1147 #define new_body(TYPE,lctype) \
1148 S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \
1149 (void**)&PL_ ## lctype ## _root, \
1152 #define del_body_type(p,TYPE,lctype) \
1153 del_body((void*)p, (void**)&PL_ ## lctype ## _root)
1155 /* But for some types, we cheat. The type starts with some members that are
1156 never accessed. So we allocate the substructure, starting at the first used
1157 member, then adjust the pointer back in memory by the size of the bit not
1158 allocated, so it's as if we allocated the full structure.
1159 (But things will all go boom if you write to the part that is "not there",
1160 because you'll be overwriting the last members of the preceding structure
1163 We calculate the correction using the STRUCT_OFFSET macro. For example, if
1164 xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
1165 and the pointer is unchanged. If the allocated structure is smaller (no
1166 initial NV actually allocated) then the net effect is to subtract the size
1167 of the NV from the pointer, to return a new pointer as if an initial NV were
1170 This is the same trick as was used for NV and IV bodies. Ironically it
1171 doesn't need to be used for NV bodies any more, because NV is now at the
1172 start of the structure. IV bodies don't need it either, because they are
1173 no longer allocated. */
1175 #define new_body_allocated(TYPE,lctype,member) \
1176 (void*)((char*)S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \
1177 (void**)&PL_ ## lctype ## _root, \
1178 sizeof(lctype ## _allocated)) - \
1179 STRUCT_OFFSET(TYPE, member) \
1180 + STRUCT_OFFSET(lctype ## _allocated, member))
1183 #define del_body_allocated(p,TYPE,lctype,member) \
1184 del_body((void*)((char*)p + STRUCT_OFFSET(TYPE, member) \
1185 - STRUCT_OFFSET(lctype ## _allocated, member)), \
1186 (void**)&PL_ ## lctype ## _root)
1188 #define my_safemalloc(s) (void*)safemalloc(s)
1189 #define my_safefree(p) safefree((char*)p)
1193 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1194 #define del_XNV(p) my_safefree(p)
1196 #define new_XPV() my_safemalloc(sizeof(XPV))
1197 #define del_XPV(p) my_safefree(p)
1199 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1200 #define del_XPVIV(p) my_safefree(p)
1202 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1203 #define del_XPVNV(p) my_safefree(p)
1205 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1206 #define del_XPVCV(p) my_safefree(p)
1208 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1209 #define del_XPVAV(p) my_safefree(p)
1211 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1212 #define del_XPVHV(p) my_safefree(p)
1214 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1215 #define del_XPVMG(p) my_safefree(p)
1217 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1218 #define del_XPVGV(p) my_safefree(p)
1220 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1221 #define del_XPVLV(p) my_safefree(p)
1223 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1224 #define del_XPVBM(p) my_safefree(p)
1228 #define new_XNV() new_body(NV, xnv)
1229 #define del_XNV(p) del_body_type(p, NV, xnv)
1231 #define new_XPV() new_body_allocated(XPV, xpv, xpv_cur)
1232 #define del_XPV(p) del_body_allocated(p, XPV, xpv, xpv_cur)
1234 #define new_XPVIV() new_body_allocated(XPVIV, xpviv, xpv_cur)
1235 #define del_XPVIV(p) del_body_allocated(p, XPVIV, xpviv, xpv_cur)
1237 #define new_XPVNV() new_body(XPVNV, xpvnv)
1238 #define del_XPVNV(p) del_body_type(p, XPVNV, xpvnv)
1240 #define new_XPVCV() new_body(XPVCV, xpvcv)
1241 #define del_XPVCV(p) del_body_type(p, XPVCV, xpvcv)
1243 #define new_XPVAV() new_body_allocated(XPVAV, xpvav, xav_fill)
1244 #define del_XPVAV(p) del_body_allocated(p, XPVAV, xpvav, xav_fill)
1246 #define new_XPVHV() new_body_allocated(XPVHV, xpvhv, xhv_fill)
1247 #define del_XPVHV(p) del_body_allocated(p, XPVHV, xpvhv, xhv_fill)
1249 #define new_XPVMG() new_body(XPVMG, xpvmg)
1250 #define del_XPVMG(p) del_body_type(p, XPVMG, xpvmg)
1252 #define new_XPVGV() new_body(XPVGV, xpvgv)
1253 #define del_XPVGV(p) del_body_type(p, XPVGV, xpvgv)
1255 #define new_XPVLV() new_body(XPVLV, xpvlv)
1256 #define del_XPVLV(p) del_body_type(p, XPVLV, xpvlv)
1258 #define new_XPVBM() new_body(XPVBM, xpvbm)
1259 #define del_XPVBM(p) del_body_type(p, XPVBM, xpvbm)
1263 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1264 #define del_XPVFM(p) my_safefree(p)
1266 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1267 #define del_XPVIO(p) my_safefree(p)
1270 =for apidoc sv_upgrade
1272 Upgrade an SV to a more complex form. Generally adds a new body type to the
1273 SV, then copies across as much information as possible from the old body.
1274 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1280 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1282 void** old_body_arena;
1283 size_t old_body_offset;
1284 size_t old_body_length; /* Well, the length to copy. */
1286 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1287 /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct
1289 bool zero_nv = TRUE;
1292 size_t new_body_length;
1293 size_t new_body_offset;
1294 void** new_body_arena;
1295 void** new_body_arenaroot;
1296 const U32 old_type = SvTYPE(sv);
1298 if (mt != SVt_PV && SvIsCOW(sv)) {
1299 sv_force_normal_flags(sv, 0);
1302 if (SvTYPE(sv) == mt)
1305 if (SvTYPE(sv) > mt)
1306 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1307 (int)SvTYPE(sv), (int)mt);
1310 old_body = SvANY(sv);
1312 old_body_offset = 0;
1313 old_body_length = 0;
1314 new_body_offset = 0;
1315 new_body_length = ~0;
1317 /* Copying structures onto other structures that have been neatly zeroed
1318 has a subtle gotcha. Consider XPVMG
1320 +------+------+------+------+------+-------+-------+
1321 | NV | CUR | LEN | IV | MAGIC | STASH |
1322 +------+------+------+------+------+-------+-------+
1323 0 4 8 12 16 20 24 28
1325 where NVs are aligned to 8 bytes, so that sizeof that structure is
1326 actually 32 bytes long, with 4 bytes of padding at the end:
1328 +------+------+------+------+------+-------+-------+------+
1329 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1330 +------+------+------+------+------+-------+-------+------+
1331 0 4 8 12 16 20 24 28 32
1333 so what happens if you allocate memory for this structure:
1335 +------+------+------+------+------+-------+-------+------+------+...
1336 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1337 +------+------+------+------+------+-------+-------+------+------+...
1338 0 4 8 12 16 20 24 28 32 36
1340 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1341 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1342 started out as zero once, but it's quite possible that it isn't. So now,
1343 rather than a nicely zeroed GP, you have it pointing somewhere random.
1346 (In fact, GP ends up pointing at a previous GP structure, because the
1347 principle cause of the padding in XPVMG getting garbage is a copy of
1348 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob)
1350 So we are careful and work out the size of used parts of all the
1353 switch (SvTYPE(sv)) {
1359 else if (mt < SVt_PVIV)
1361 old_body_offset = STRUCT_OFFSET(XPVIV, xiv_iv);
1362 old_body_length = sizeof(IV);
1365 old_body_arena = (void **) &PL_xnv_root;
1366 old_body_length = sizeof(NV);
1367 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1376 old_body_arena = (void **) &PL_xpv_root;
1377 old_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
1378 - STRUCT_OFFSET(xpv_allocated, xpv_cur);
1379 old_body_length = STRUCT_OFFSET(XPV, xpv_len)
1380 + sizeof (((XPV*)SvANY(sv))->xpv_len)
1384 else if (mt == SVt_NV)
1388 old_body_arena = (void **) &PL_xpviv_root;
1389 old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
1390 - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
1391 old_body_length = STRUCT_OFFSET(XPVIV, xiv_u)
1392 + sizeof (((XPVIV*)SvANY(sv))->xiv_u)
1396 old_body_arena = (void **) &PL_xpvnv_root;
1397 old_body_length = STRUCT_OFFSET(XPVNV, xiv_u)
1398 + sizeof (((XPVNV*)SvANY(sv))->xiv_u);
1399 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1404 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1405 there's no way that it can be safely upgraded, because perl.c
1406 expects to Safefree(SvANY(PL_mess_sv)) */
1407 assert(sv != PL_mess_sv);
1408 /* This flag bit is used to mean other things in other scalar types.
1409 Given that it only has meaning inside the pad, it shouldn't be set
1410 on anything that can get upgraded. */
1411 assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
1412 old_body_arena = (void **) &PL_xpvmg_root;
1413 old_body_length = STRUCT_OFFSET(XPVMG, xmg_stash)
1414 + sizeof (((XPVMG*)SvANY(sv))->xmg_stash);
1415 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1420 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1423 SvFLAGS(sv) &= ~SVTYPEMASK;
1428 Perl_croak(aTHX_ "Can't upgrade to undef");
1430 assert(old_type == SVt_NULL);
1431 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1435 assert(old_type == SVt_NULL);
1436 SvANY(sv) = new_XNV();
1440 assert(old_type == SVt_NULL);
1441 SvANY(sv) = &sv->sv_u.svu_rv;
1445 SvANY(sv) = new_XPVHV();
1448 HvTOTALKEYS(sv) = 0;
1453 SvANY(sv) = new_XPVAV();
1460 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1461 The target created by newSVrv also is, and it can have magic.
1462 However, it never has SvPVX set.
1464 if (old_type >= SVt_RV) {
1465 assert(SvPVX_const(sv) == 0);
1468 /* Could put this in the else clause below, as PVMG must have SvPVX
1469 0 already (the assertion above) */
1470 SvPV_set(sv, (char*)0);
1472 if (old_type >= SVt_PVMG) {
1473 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic);
1474 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1482 new_body = new_XPVIO();
1483 new_body_length = sizeof(XPVIO);
1486 new_body = new_XPVFM();
1487 new_body_length = sizeof(XPVFM);
1491 new_body_length = sizeof(XPVBM);
1492 new_body_arena = (void **) &PL_xpvbm_root;
1493 new_body_arenaroot = (void **) &PL_xpvbm_arenaroot;
1496 new_body_length = sizeof(XPVGV);
1497 new_body_arena = (void **) &PL_xpvgv_root;
1498 new_body_arenaroot = (void **) &PL_xpvgv_arenaroot;
1501 new_body_length = sizeof(XPVCV);
1502 new_body_arena = (void **) &PL_xpvcv_root;
1503 new_body_arenaroot = (void **) &PL_xpvcv_arenaroot;
1506 new_body_length = sizeof(XPVLV);
1507 new_body_arena = (void **) &PL_xpvlv_root;
1508 new_body_arenaroot = (void **) &PL_xpvlv_arenaroot;
1511 new_body_length = sizeof(XPVMG);
1512 new_body_arena = (void **) &PL_xpvmg_root;
1513 new_body_arenaroot = (void **) &PL_xpvmg_arenaroot;
1516 new_body_length = sizeof(XPVNV);
1517 new_body_arena = (void **) &PL_xpvnv_root;
1518 new_body_arenaroot = (void **) &PL_xpvnv_arenaroot;
1521 new_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
1522 - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
1523 new_body_length = sizeof(XPVIV) - new_body_offset;
1524 new_body_arena = (void **) &PL_xpviv_root;
1525 new_body_arenaroot = (void **) &PL_xpviv_arenaroot;
1526 /* XXX Is this still needed? Was it ever needed? Surely as there is
1527 no route from NV to PVIV, NOK can never be true */
1531 goto new_body_no_NV;
1533 new_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
1534 - STRUCT_OFFSET(xpv_allocated, xpv_cur);
1535 new_body_length = sizeof(XPV) - new_body_offset;
1536 new_body_arena = (void **) &PL_xpv_root;
1537 new_body_arenaroot = (void **) &PL_xpv_arenaroot;
1539 /* PV and PVIV don't have an NV slot. */
1540 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1545 assert(new_body_length);
1547 /* This points to the start of the allocated area. */
1548 new_body = S_new_body(aTHX_ new_body_arenaroot, new_body_arena,
1551 /* We always allocated the full length item with PURIFY */
1552 new_body_length += new_body_offset;
1553 new_body_offset = 0;
1554 new_body = my_safemalloc(new_body_length);
1558 Zero(new_body, new_body_length, char);
1559 new_body = ((char *)new_body) - new_body_offset;
1560 SvANY(sv) = new_body;
1562 if (old_body_length) {
1563 Copy((char *)old_body + old_body_offset,
1564 (char *)new_body + old_body_offset,
1565 old_body_length, char);
1568 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1574 IoPAGE_LEN(sv) = 60;
1575 if (old_type < SVt_RV)
1579 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", mt);
1583 if (old_body_arena) {
1585 my_safefree(old_body);
1587 del_body((void*)((char*)old_body + old_body_offset),
1594 =for apidoc sv_backoff
1596 Remove any string offset. You should normally use the C<SvOOK_off> macro
1603 Perl_sv_backoff(pTHX_ register SV *sv)
1606 assert(SvTYPE(sv) != SVt_PVHV);
1607 assert(SvTYPE(sv) != SVt_PVAV);
1609 const char * const s = SvPVX_const(sv);
1610 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1611 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1613 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1615 SvFLAGS(sv) &= ~SVf_OOK;
1622 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1623 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1624 Use the C<SvGROW> wrapper instead.
1630 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1634 #ifdef HAS_64K_LIMIT
1635 if (newlen >= 0x10000) {
1636 PerlIO_printf(Perl_debug_log,
1637 "Allocation too large: %"UVxf"\n", (UV)newlen);
1640 #endif /* HAS_64K_LIMIT */
1643 if (SvTYPE(sv) < SVt_PV) {
1644 sv_upgrade(sv, SVt_PV);
1645 s = SvPVX_mutable(sv);
1647 else if (SvOOK(sv)) { /* pv is offset? */
1649 s = SvPVX_mutable(sv);
1650 if (newlen > SvLEN(sv))
1651 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1652 #ifdef HAS_64K_LIMIT
1653 if (newlen >= 0x10000)
1658 s = SvPVX_mutable(sv);
1660 if (newlen > SvLEN(sv)) { /* need more room? */
1661 newlen = PERL_STRLEN_ROUNDUP(newlen);
1662 if (SvLEN(sv) && s) {
1664 const STRLEN l = malloced_size((void*)SvPVX_const(sv));
1670 s = saferealloc(s, newlen);
1673 s = safemalloc(newlen);
1674 if (SvPVX_const(sv) && SvCUR(sv)) {
1675 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1679 SvLEN_set(sv, newlen);
1685 =for apidoc sv_setiv
1687 Copies an integer into the given SV, upgrading first if necessary.
1688 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1694 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1696 SV_CHECK_THINKFIRST_COW_DROP(sv);
1697 switch (SvTYPE(sv)) {
1699 sv_upgrade(sv, SVt_IV);
1702 sv_upgrade(sv, SVt_PVNV);
1706 sv_upgrade(sv, SVt_PVIV);
1715 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1718 (void)SvIOK_only(sv); /* validate number */
1724 =for apidoc sv_setiv_mg
1726 Like C<sv_setiv>, but also handles 'set' magic.
1732 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1739 =for apidoc sv_setuv
1741 Copies an unsigned integer into the given SV, upgrading first if necessary.
1742 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1748 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1750 /* With these two if statements:
1751 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1754 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1756 If you wish to remove them, please benchmark to see what the effect is
1758 if (u <= (UV)IV_MAX) {
1759 sv_setiv(sv, (IV)u);
1768 =for apidoc sv_setuv_mg
1770 Like C<sv_setuv>, but also handles 'set' magic.
1776 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1785 =for apidoc sv_setnv
1787 Copies a double into the given SV, upgrading first if necessary.
1788 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1794 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1796 SV_CHECK_THINKFIRST_COW_DROP(sv);
1797 switch (SvTYPE(sv)) {
1800 sv_upgrade(sv, SVt_NV);
1805 sv_upgrade(sv, SVt_PVNV);
1814 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1818 (void)SvNOK_only(sv); /* validate number */
1823 =for apidoc sv_setnv_mg
1825 Like C<sv_setnv>, but also handles 'set' magic.
1831 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1837 /* Print an "isn't numeric" warning, using a cleaned-up,
1838 * printable version of the offending string
1842 S_not_a_number(pTHX_ SV *sv)
1849 dsv = sv_2mortal(newSVpvn("", 0));
1850 pv = sv_uni_display(dsv, sv, 10, 0);
1853 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1854 /* each *s can expand to 4 chars + "...\0",
1855 i.e. need room for 8 chars */
1857 const char *s, *end;
1858 for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit;
1861 if (ch & 128 && !isPRINT_LC(ch)) {
1870 else if (ch == '\r') {
1874 else if (ch == '\f') {
1878 else if (ch == '\\') {
1882 else if (ch == '\0') {
1886 else if (isPRINT_LC(ch))
1903 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1904 "Argument \"%s\" isn't numeric in %s", pv,
1907 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1908 "Argument \"%s\" isn't numeric", pv);
1912 =for apidoc looks_like_number
1914 Test if the content of an SV looks like a number (or is a number).
1915 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1916 non-numeric warning), even if your atof() doesn't grok them.
1922 Perl_looks_like_number(pTHX_ SV *sv)
1924 register const char *sbegin;
1928 sbegin = SvPVX_const(sv);
1931 else if (SvPOKp(sv))
1932 sbegin = SvPV_const(sv, len);
1934 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1935 return grok_number(sbegin, len, NULL);
1938 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1939 until proven guilty, assume that things are not that bad... */
1944 As 64 bit platforms often have an NV that doesn't preserve all bits of
1945 an IV (an assumption perl has been based on to date) it becomes necessary
1946 to remove the assumption that the NV always carries enough precision to
1947 recreate the IV whenever needed, and that the NV is the canonical form.
1948 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1949 precision as a side effect of conversion (which would lead to insanity
1950 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1951 1) to distinguish between IV/UV/NV slots that have cached a valid
1952 conversion where precision was lost and IV/UV/NV slots that have a
1953 valid conversion which has lost no precision
1954 2) to ensure that if a numeric conversion to one form is requested that
1955 would lose precision, the precise conversion (or differently
1956 imprecise conversion) is also performed and cached, to prevent
1957 requests for different numeric formats on the same SV causing
1958 lossy conversion chains. (lossless conversion chains are perfectly
1963 SvIOKp is true if the IV slot contains a valid value
1964 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1965 SvNOKp is true if the NV slot contains a valid value
1966 SvNOK is true only if the NV value is accurate
1969 while converting from PV to NV, check to see if converting that NV to an
1970 IV(or UV) would lose accuracy over a direct conversion from PV to
1971 IV(or UV). If it would, cache both conversions, return NV, but mark
1972 SV as IOK NOKp (ie not NOK).
1974 While converting from PV to IV, check to see if converting that IV to an
1975 NV would lose accuracy over a direct conversion from PV to NV. If it
1976 would, cache both conversions, flag similarly.
1978 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1979 correctly because if IV & NV were set NV *always* overruled.
1980 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1981 changes - now IV and NV together means that the two are interchangeable:
1982 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1984 The benefit of this is that operations such as pp_add know that if
1985 SvIOK is true for both left and right operands, then integer addition
1986 can be used instead of floating point (for cases where the result won't
1987 overflow). Before, floating point was always used, which could lead to
1988 loss of precision compared with integer addition.
1990 * making IV and NV equal status should make maths accurate on 64 bit
1992 * may speed up maths somewhat if pp_add and friends start to use
1993 integers when possible instead of fp. (Hopefully the overhead in
1994 looking for SvIOK and checking for overflow will not outweigh the
1995 fp to integer speedup)
1996 * will slow down integer operations (callers of SvIV) on "inaccurate"
1997 values, as the change from SvIOK to SvIOKp will cause a call into
1998 sv_2iv each time rather than a macro access direct to the IV slot
1999 * should speed up number->string conversion on integers as IV is
2000 favoured when IV and NV are equally accurate
2002 ####################################################################
2003 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2004 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2005 On the other hand, SvUOK is true iff UV.
2006 ####################################################################
2008 Your mileage will vary depending your CPU's relative fp to integer
2012 #ifndef NV_PRESERVES_UV
2013 # define IS_NUMBER_UNDERFLOW_IV 1
2014 # define IS_NUMBER_UNDERFLOW_UV 2
2015 # define IS_NUMBER_IV_AND_UV 2
2016 # define IS_NUMBER_OVERFLOW_IV 4
2017 # define IS_NUMBER_OVERFLOW_UV 5
2019 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2021 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2023 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2025 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));
2026 if (SvNVX(sv) < (NV)IV_MIN) {
2027 (void)SvIOKp_on(sv);
2029 SvIV_set(sv, IV_MIN);
2030 return IS_NUMBER_UNDERFLOW_IV;
2032 if (SvNVX(sv) > (NV)UV_MAX) {
2033 (void)SvIOKp_on(sv);
2036 SvUV_set(sv, UV_MAX);
2037 return IS_NUMBER_OVERFLOW_UV;
2039 (void)SvIOKp_on(sv);
2041 /* Can't use strtol etc to convert this string. (See truth table in
2043 if (SvNVX(sv) <= (UV)IV_MAX) {
2044 SvIV_set(sv, I_V(SvNVX(sv)));
2045 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2046 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2048 /* Integer is imprecise. NOK, IOKp */
2050 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2053 SvUV_set(sv, U_V(SvNVX(sv)));
2054 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2055 if (SvUVX(sv) == UV_MAX) {
2056 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2057 possibly be preserved by NV. Hence, it must be overflow.
2059 return IS_NUMBER_OVERFLOW_UV;
2061 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2063 /* Integer is imprecise. NOK, IOKp */
2065 return IS_NUMBER_OVERFLOW_IV;
2067 #endif /* !NV_PRESERVES_UV*/
2069 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
2070 * this function provided for binary compatibility only
2074 Perl_sv_2iv(pTHX_ register SV *sv)
2076 return sv_2iv_flags(sv, SV_GMAGIC);
2080 =for apidoc sv_2iv_flags
2082 Return the integer value of an SV, doing any necessary string
2083 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2084 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2090 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2094 if (SvGMAGICAL(sv)) {
2095 if (flags & SV_GMAGIC)
2100 return I_V(SvNVX(sv));
2102 if (SvPOKp(sv) && SvLEN(sv))
2105 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2106 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2112 if (SvTHINKFIRST(sv)) {
2115 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2116 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2117 return SvIV(tmpstr);
2118 return PTR2IV(SvRV(sv));
2121 sv_force_normal_flags(sv, 0);
2123 if (SvREADONLY(sv) && !SvOK(sv)) {
2124 if (ckWARN(WARN_UNINITIALIZED))
2131 return (IV)(SvUVX(sv));
2138 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2139 * without also getting a cached IV/UV from it at the same time
2140 * (ie PV->NV conversion should detect loss of accuracy and cache
2141 * IV or UV at same time to avoid this. NWC */
2143 if (SvTYPE(sv) == SVt_NV)
2144 sv_upgrade(sv, SVt_PVNV);
2146 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2147 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2148 certainly cast into the IV range at IV_MAX, whereas the correct
2149 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2151 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2152 SvIV_set(sv, I_V(SvNVX(sv)));
2153 if (SvNVX(sv) == (NV) SvIVX(sv)
2154 #ifndef NV_PRESERVES_UV
2155 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2156 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2157 /* Don't flag it as "accurately an integer" if the number
2158 came from a (by definition imprecise) NV operation, and
2159 we're outside the range of NV integer precision */
2162 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2163 DEBUG_c(PerlIO_printf(Perl_debug_log,
2164 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2170 /* IV not precise. No need to convert from PV, as NV
2171 conversion would already have cached IV if it detected
2172 that PV->IV would be better than PV->NV->IV
2173 flags already correct - don't set public IOK. */
2174 DEBUG_c(PerlIO_printf(Perl_debug_log,
2175 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2180 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2181 but the cast (NV)IV_MIN rounds to a the value less (more
2182 negative) than IV_MIN which happens to be equal to SvNVX ??
2183 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2184 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2185 (NV)UVX == NVX are both true, but the values differ. :-(
2186 Hopefully for 2s complement IV_MIN is something like
2187 0x8000000000000000 which will be exact. NWC */
2190 SvUV_set(sv, U_V(SvNVX(sv)));
2192 (SvNVX(sv) == (NV) SvUVX(sv))
2193 #ifndef NV_PRESERVES_UV
2194 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2195 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2196 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2197 /* Don't flag it as "accurately an integer" if the number
2198 came from a (by definition imprecise) NV operation, and
2199 we're outside the range of NV integer precision */
2205 DEBUG_c(PerlIO_printf(Perl_debug_log,
2206 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2210 return (IV)SvUVX(sv);
2213 else if (SvPOKp(sv) && SvLEN(sv)) {
2215 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2216 /* We want to avoid a possible problem when we cache an IV which
2217 may be later translated to an NV, and the resulting NV is not
2218 the same as the direct translation of the initial string
2219 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2220 be careful to ensure that the value with the .456 is around if the
2221 NV value is requested in the future).
2223 This means that if we cache such an IV, we need to cache the
2224 NV as well. Moreover, we trade speed for space, and do not
2225 cache the NV if we are sure it's not needed.
2228 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2229 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2230 == IS_NUMBER_IN_UV) {
2231 /* It's definitely an integer, only upgrade to PVIV */
2232 if (SvTYPE(sv) < SVt_PVIV)
2233 sv_upgrade(sv, SVt_PVIV);
2235 } else if (SvTYPE(sv) < SVt_PVNV)
2236 sv_upgrade(sv, SVt_PVNV);
2238 /* If NV preserves UV then we only use the UV value if we know that
2239 we aren't going to call atof() below. If NVs don't preserve UVs
2240 then the value returned may have more precision than atof() will
2241 return, even though value isn't perfectly accurate. */
2242 if ((numtype & (IS_NUMBER_IN_UV
2243 #ifdef NV_PRESERVES_UV
2246 )) == IS_NUMBER_IN_UV) {
2247 /* This won't turn off the public IOK flag if it was set above */
2248 (void)SvIOKp_on(sv);
2250 if (!(numtype & IS_NUMBER_NEG)) {
2252 if (value <= (UV)IV_MAX) {
2253 SvIV_set(sv, (IV)value);
2255 SvUV_set(sv, value);
2259 /* 2s complement assumption */
2260 if (value <= (UV)IV_MIN) {
2261 SvIV_set(sv, -(IV)value);
2263 /* Too negative for an IV. This is a double upgrade, but
2264 I'm assuming it will be rare. */
2265 if (SvTYPE(sv) < SVt_PVNV)
2266 sv_upgrade(sv, SVt_PVNV);
2270 SvNV_set(sv, -(NV)value);
2271 SvIV_set(sv, IV_MIN);
2275 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2276 will be in the previous block to set the IV slot, and the next
2277 block to set the NV slot. So no else here. */
2279 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2280 != IS_NUMBER_IN_UV) {
2281 /* It wasn't an (integer that doesn't overflow the UV). */
2282 SvNV_set(sv, Atof(SvPVX_const(sv)));
2284 if (! numtype && ckWARN(WARN_NUMERIC))
2287 #if defined(USE_LONG_DOUBLE)
2288 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2289 PTR2UV(sv), SvNVX(sv)));
2291 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2292 PTR2UV(sv), SvNVX(sv)));
2296 #ifdef NV_PRESERVES_UV
2297 (void)SvIOKp_on(sv);
2299 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2300 SvIV_set(sv, I_V(SvNVX(sv)));
2301 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2304 /* Integer is imprecise. NOK, IOKp */
2306 /* UV will not work better than IV */
2308 if (SvNVX(sv) > (NV)UV_MAX) {
2310 /* Integer is inaccurate. NOK, IOKp, is UV */
2311 SvUV_set(sv, UV_MAX);
2314 SvUV_set(sv, U_V(SvNVX(sv)));
2315 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2316 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2320 /* Integer is imprecise. NOK, IOKp, is UV */
2326 #else /* NV_PRESERVES_UV */
2327 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2328 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2329 /* The IV slot will have been set from value returned by
2330 grok_number above. The NV slot has just been set using
2333 assert (SvIOKp(sv));
2335 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2336 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2337 /* Small enough to preserve all bits. */
2338 (void)SvIOKp_on(sv);
2340 SvIV_set(sv, I_V(SvNVX(sv)));
2341 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2343 /* Assumption: first non-preserved integer is < IV_MAX,
2344 this NV is in the preserved range, therefore: */
2345 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2347 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);
2351 0 0 already failed to read UV.
2352 0 1 already failed to read UV.
2353 1 0 you won't get here in this case. IV/UV
2354 slot set, public IOK, Atof() unneeded.
2355 1 1 already read UV.
2356 so there's no point in sv_2iuv_non_preserve() attempting
2357 to use atol, strtol, strtoul etc. */
2358 if (sv_2iuv_non_preserve (sv, numtype)
2359 >= IS_NUMBER_OVERFLOW_IV)
2363 #endif /* NV_PRESERVES_UV */
2366 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2368 if (SvTYPE(sv) < SVt_IV)
2369 /* Typically the caller expects that sv_any is not NULL now. */
2370 sv_upgrade(sv, SVt_IV);
2373 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2374 PTR2UV(sv),SvIVX(sv)));
2375 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2378 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2379 * this function provided for binary compatibility only
2383 Perl_sv_2uv(pTHX_ register SV *sv)
2385 return sv_2uv_flags(sv, SV_GMAGIC);
2389 =for apidoc sv_2uv_flags
2391 Return the unsigned integer value of an SV, doing any necessary string
2392 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2393 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2399 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2403 if (SvGMAGICAL(sv)) {
2404 if (flags & SV_GMAGIC)
2409 return U_V(SvNVX(sv));
2410 if (SvPOKp(sv) && SvLEN(sv))
2413 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2414 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2420 if (SvTHINKFIRST(sv)) {
2423 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2424 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2425 return SvUV(tmpstr);
2426 return PTR2UV(SvRV(sv));
2429 sv_force_normal_flags(sv, 0);
2431 if (SvREADONLY(sv) && !SvOK(sv)) {
2432 if (ckWARN(WARN_UNINITIALIZED))
2442 return (UV)SvIVX(sv);
2446 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2447 * without also getting a cached IV/UV from it at the same time
2448 * (ie PV->NV conversion should detect loss of accuracy and cache
2449 * IV or UV at same time to avoid this. */
2450 /* IV-over-UV optimisation - choose to cache IV if possible */
2452 if (SvTYPE(sv) == SVt_NV)
2453 sv_upgrade(sv, SVt_PVNV);
2455 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2456 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2457 SvIV_set(sv, I_V(SvNVX(sv)));
2458 if (SvNVX(sv) == (NV) SvIVX(sv)
2459 #ifndef NV_PRESERVES_UV
2460 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2461 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2462 /* Don't flag it as "accurately an integer" if the number
2463 came from a (by definition imprecise) NV operation, and
2464 we're outside the range of NV integer precision */
2467 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2468 DEBUG_c(PerlIO_printf(Perl_debug_log,
2469 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2475 /* IV not precise. No need to convert from PV, as NV
2476 conversion would already have cached IV if it detected
2477 that PV->IV would be better than PV->NV->IV
2478 flags already correct - don't set public IOK. */
2479 DEBUG_c(PerlIO_printf(Perl_debug_log,
2480 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2485 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2486 but the cast (NV)IV_MIN rounds to a the value less (more
2487 negative) than IV_MIN which happens to be equal to SvNVX ??
2488 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2489 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2490 (NV)UVX == NVX are both true, but the values differ. :-(
2491 Hopefully for 2s complement IV_MIN is something like
2492 0x8000000000000000 which will be exact. NWC */
2495 SvUV_set(sv, U_V(SvNVX(sv)));
2497 (SvNVX(sv) == (NV) SvUVX(sv))
2498 #ifndef NV_PRESERVES_UV
2499 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2500 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2501 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2502 /* Don't flag it as "accurately an integer" if the number
2503 came from a (by definition imprecise) NV operation, and
2504 we're outside the range of NV integer precision */
2509 DEBUG_c(PerlIO_printf(Perl_debug_log,
2510 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2516 else if (SvPOKp(sv) && SvLEN(sv)) {
2518 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2520 /* We want to avoid a possible problem when we cache a UV which
2521 may be later translated to an NV, and the resulting NV is not
2522 the translation of the initial data.
2524 This means that if we cache such a UV, we need to cache the
2525 NV as well. Moreover, we trade speed for space, and do not
2526 cache the NV if not needed.
2529 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2530 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2531 == IS_NUMBER_IN_UV) {
2532 /* It's definitely an integer, only upgrade to PVIV */
2533 if (SvTYPE(sv) < SVt_PVIV)
2534 sv_upgrade(sv, SVt_PVIV);
2536 } else if (SvTYPE(sv) < SVt_PVNV)
2537 sv_upgrade(sv, SVt_PVNV);
2539 /* If NV preserves UV then we only use the UV value if we know that
2540 we aren't going to call atof() below. If NVs don't preserve UVs
2541 then the value returned may have more precision than atof() will
2542 return, even though it isn't accurate. */
2543 if ((numtype & (IS_NUMBER_IN_UV
2544 #ifdef NV_PRESERVES_UV
2547 )) == IS_NUMBER_IN_UV) {
2548 /* This won't turn off the public IOK flag if it was set above */
2549 (void)SvIOKp_on(sv);
2551 if (!(numtype & IS_NUMBER_NEG)) {
2553 if (value <= (UV)IV_MAX) {
2554 SvIV_set(sv, (IV)value);
2556 /* it didn't overflow, and it was positive. */
2557 SvUV_set(sv, value);
2561 /* 2s complement assumption */
2562 if (value <= (UV)IV_MIN) {
2563 SvIV_set(sv, -(IV)value);
2565 /* Too negative for an IV. This is a double upgrade, but
2566 I'm assuming it will be rare. */
2567 if (SvTYPE(sv) < SVt_PVNV)
2568 sv_upgrade(sv, SVt_PVNV);
2572 SvNV_set(sv, -(NV)value);
2573 SvIV_set(sv, IV_MIN);
2578 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2579 != IS_NUMBER_IN_UV) {
2580 /* It wasn't an integer, or it overflowed the UV. */
2581 SvNV_set(sv, Atof(SvPVX_const(sv)));
2583 if (! numtype && ckWARN(WARN_NUMERIC))
2586 #if defined(USE_LONG_DOUBLE)
2587 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2588 PTR2UV(sv), SvNVX(sv)));
2590 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2591 PTR2UV(sv), SvNVX(sv)));
2594 #ifdef NV_PRESERVES_UV
2595 (void)SvIOKp_on(sv);
2597 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2598 SvIV_set(sv, I_V(SvNVX(sv)));
2599 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2602 /* Integer is imprecise. NOK, IOKp */
2604 /* UV will not work better than IV */
2606 if (SvNVX(sv) > (NV)UV_MAX) {
2608 /* Integer is inaccurate. NOK, IOKp, is UV */
2609 SvUV_set(sv, UV_MAX);
2612 SvUV_set(sv, U_V(SvNVX(sv)));
2613 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2614 NV preservse UV so can do correct comparison. */
2615 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2619 /* Integer is imprecise. NOK, IOKp, is UV */
2624 #else /* NV_PRESERVES_UV */
2625 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2626 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2627 /* The UV slot will have been set from value returned by
2628 grok_number above. The NV slot has just been set using
2631 assert (SvIOKp(sv));
2633 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2634 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2635 /* Small enough to preserve all bits. */
2636 (void)SvIOKp_on(sv);
2638 SvIV_set(sv, I_V(SvNVX(sv)));
2639 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2641 /* Assumption: first non-preserved integer is < IV_MAX,
2642 this NV is in the preserved range, therefore: */
2643 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2645 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);
2648 sv_2iuv_non_preserve (sv, numtype);
2650 #endif /* NV_PRESERVES_UV */
2654 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2655 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2658 if (SvTYPE(sv) < SVt_IV)
2659 /* Typically the caller expects that sv_any is not NULL now. */
2660 sv_upgrade(sv, SVt_IV);
2664 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2665 PTR2UV(sv),SvUVX(sv)));
2666 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2672 Return the num value of an SV, doing any necessary string or integer
2673 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2680 Perl_sv_2nv(pTHX_ register SV *sv)
2684 if (SvGMAGICAL(sv)) {
2688 if (SvPOKp(sv) && SvLEN(sv)) {
2689 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2690 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2692 return Atof(SvPVX_const(sv));
2696 return (NV)SvUVX(sv);
2698 return (NV)SvIVX(sv);
2701 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2702 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2708 if (SvTHINKFIRST(sv)) {
2711 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2712 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2713 return SvNV(tmpstr);
2714 return PTR2NV(SvRV(sv));
2717 sv_force_normal_flags(sv, 0);
2719 if (SvREADONLY(sv) && !SvOK(sv)) {
2720 if (ckWARN(WARN_UNINITIALIZED))
2725 if (SvTYPE(sv) < SVt_NV) {
2726 if (SvTYPE(sv) == SVt_IV)
2727 sv_upgrade(sv, SVt_PVNV);
2729 sv_upgrade(sv, SVt_NV);
2730 #ifdef USE_LONG_DOUBLE
2732 STORE_NUMERIC_LOCAL_SET_STANDARD();
2733 PerlIO_printf(Perl_debug_log,
2734 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2735 PTR2UV(sv), SvNVX(sv));
2736 RESTORE_NUMERIC_LOCAL();
2740 STORE_NUMERIC_LOCAL_SET_STANDARD();
2741 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2742 PTR2UV(sv), SvNVX(sv));
2743 RESTORE_NUMERIC_LOCAL();
2747 else if (SvTYPE(sv) < SVt_PVNV)
2748 sv_upgrade(sv, SVt_PVNV);
2753 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2754 #ifdef NV_PRESERVES_UV
2757 /* Only set the public NV OK flag if this NV preserves the IV */
2758 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2759 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2760 : (SvIVX(sv) == I_V(SvNVX(sv))))
2766 else if (SvPOKp(sv) && SvLEN(sv)) {
2768 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2769 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2771 #ifdef NV_PRESERVES_UV
2772 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2773 == IS_NUMBER_IN_UV) {
2774 /* It's definitely an integer */
2775 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2777 SvNV_set(sv, Atof(SvPVX_const(sv)));
2780 SvNV_set(sv, Atof(SvPVX_const(sv)));
2781 /* Only set the public NV OK flag if this NV preserves the value in
2782 the PV at least as well as an IV/UV would.
2783 Not sure how to do this 100% reliably. */
2784 /* if that shift count is out of range then Configure's test is
2785 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2787 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2788 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2789 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2790 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2791 /* Can't use strtol etc to convert this string, so don't try.
2792 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2795 /* value has been set. It may not be precise. */
2796 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2797 /* 2s complement assumption for (UV)IV_MIN */
2798 SvNOK_on(sv); /* Integer is too negative. */
2803 if (numtype & IS_NUMBER_NEG) {
2804 SvIV_set(sv, -(IV)value);
2805 } else if (value <= (UV)IV_MAX) {
2806 SvIV_set(sv, (IV)value);
2808 SvUV_set(sv, value);
2812 if (numtype & IS_NUMBER_NOT_INT) {
2813 /* I believe that even if the original PV had decimals,
2814 they are lost beyond the limit of the FP precision.
2815 However, neither is canonical, so both only get p
2816 flags. NWC, 2000/11/25 */
2817 /* Both already have p flags, so do nothing */
2819 const NV nv = SvNVX(sv);
2820 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2821 if (SvIVX(sv) == I_V(nv)) {
2826 /* It had no "." so it must be integer. */
2829 /* between IV_MAX and NV(UV_MAX).
2830 Could be slightly > UV_MAX */
2832 if (numtype & IS_NUMBER_NOT_INT) {
2833 /* UV and NV both imprecise. */
2835 const UV nv_as_uv = U_V(nv);
2837 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2848 #endif /* NV_PRESERVES_UV */
2851 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2853 if (SvTYPE(sv) < SVt_NV)
2854 /* Typically the caller expects that sv_any is not NULL now. */
2855 /* XXX Ilya implies that this is a bug in callers that assume this
2856 and ideally should be fixed. */
2857 sv_upgrade(sv, SVt_NV);
2860 #if defined(USE_LONG_DOUBLE)
2862 STORE_NUMERIC_LOCAL_SET_STANDARD();
2863 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2864 PTR2UV(sv), SvNVX(sv));
2865 RESTORE_NUMERIC_LOCAL();
2869 STORE_NUMERIC_LOCAL_SET_STANDARD();
2870 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2871 PTR2UV(sv), SvNVX(sv));
2872 RESTORE_NUMERIC_LOCAL();
2878 /* asIV(): extract an integer from the string value of an SV.
2879 * Caller must validate PVX */
2882 S_asIV(pTHX_ SV *sv)
2885 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2887 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2888 == IS_NUMBER_IN_UV) {
2889 /* It's definitely an integer */
2890 if (numtype & IS_NUMBER_NEG) {
2891 if (value < (UV)IV_MIN)
2894 if (value < (UV)IV_MAX)
2899 if (ckWARN(WARN_NUMERIC))
2902 return I_V(Atof(SvPVX_const(sv)));
2905 /* asUV(): extract an unsigned integer from the string value of an SV
2906 * Caller must validate PVX */
2909 S_asUV(pTHX_ SV *sv)
2912 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2914 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2915 == IS_NUMBER_IN_UV) {
2916 /* It's definitely an integer */
2917 if (!(numtype & IS_NUMBER_NEG))
2921 if (ckWARN(WARN_NUMERIC))
2924 return U_V(Atof(SvPVX_const(sv)));
2928 =for apidoc sv_2pv_nolen
2930 Like C<sv_2pv()>, but doesn't return the length too. You should usually
2931 use the macro wrapper C<SvPV_nolen(sv)> instead.
2936 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2938 return sv_2pv(sv, 0);
2941 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2942 * UV as a string towards the end of buf, and return pointers to start and
2945 * We assume that buf is at least TYPE_CHARS(UV) long.
2949 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2951 char *ptr = buf + TYPE_CHARS(UV);
2965 *--ptr = '0' + (char)(uv % 10);
2973 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
2974 * this function provided for binary compatibility only
2978 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2980 return sv_2pv_flags(sv, lp, SV_GMAGIC);
2984 =for apidoc sv_2pv_flags
2986 Returns a pointer to the string value of an SV, and sets *lp to its length.
2987 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2989 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2990 usually end up here too.
2996 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3001 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3002 char *tmpbuf = tbuf;
3009 if (SvGMAGICAL(sv)) {
3010 if (flags & SV_GMAGIC)
3015 if (flags & SV_MUTABLE_RETURN)
3016 return SvPVX_mutable(sv);
3017 if (flags & SV_CONST_RETURN)
3018 return (char *)SvPVX_const(sv);
3023 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
3025 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3030 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3035 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3036 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3044 if (SvTHINKFIRST(sv)) {
3047 register const char *typestr;
3048 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3049 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3051 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
3054 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
3055 if (flags & SV_CONST_RETURN) {
3056 pv = (char *) SvPVX_const(tmpstr);
3058 pv = (flags & SV_MUTABLE_RETURN)
3059 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
3062 *lp = SvCUR(tmpstr);
3064 pv = sv_2pv_flags(tmpstr, lp, flags);
3075 typestr = "NULLREF";
3079 switch (SvTYPE(sv)) {
3081 if ( ((SvFLAGS(sv) &
3082 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3083 == (SVs_OBJECT|SVs_SMG))
3084 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3085 const regexp *re = (regexp *)mg->mg_obj;
3088 const char *fptr = "msix";
3093 char need_newline = 0;
3094 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3096 while((ch = *fptr++)) {
3098 reflags[left++] = ch;
3101 reflags[right--] = ch;
3106 reflags[left] = '-';
3110 mg->mg_len = re->prelen + 4 + left;
3112 * If /x was used, we have to worry about a regex
3113 * ending with a comment later being embedded
3114 * within another regex. If so, we don't want this
3115 * regex's "commentization" to leak out to the
3116 * right part of the enclosing regex, we must cap
3117 * it with a newline.
3119 * So, if /x was used, we scan backwards from the
3120 * end of the regex. If we find a '#' before we
3121 * find a newline, we need to add a newline
3122 * ourself. If we find a '\n' first (or if we
3123 * don't find '#' or '\n'), we don't need to add
3124 * anything. -jfriedl
3126 if (PMf_EXTENDED & re->reganch)
3128 const char *endptr = re->precomp + re->prelen;
3129 while (endptr >= re->precomp)
3131 const char c = *(endptr--);
3133 break; /* don't need another */
3135 /* we end while in a comment, so we
3137 mg->mg_len++; /* save space for it */
3138 need_newline = 1; /* note to add it */
3144 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3145 Copy("(?", mg->mg_ptr, 2, char);
3146 Copy(reflags, mg->mg_ptr+2, left, char);
3147 Copy(":", mg->mg_ptr+left+2, 1, char);
3148 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3150 mg->mg_ptr[mg->mg_len - 2] = '\n';
3151 mg->mg_ptr[mg->mg_len - 1] = ')';
3152 mg->mg_ptr[mg->mg_len] = 0;
3154 PL_reginterp_cnt += re->program[0].next_off;
3156 if (re->reganch & ROPT_UTF8)
3172 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3173 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3174 /* tied lvalues should appear to be
3175 * scalars for backwards compatitbility */
3176 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3177 ? "SCALAR" : "LVALUE"; break;
3178 case SVt_PVAV: typestr = "ARRAY"; break;
3179 case SVt_PVHV: typestr = "HASH"; break;
3180 case SVt_PVCV: typestr = "CODE"; break;
3181 case SVt_PVGV: typestr = "GLOB"; break;
3182 case SVt_PVFM: typestr = "FORMAT"; break;
3183 case SVt_PVIO: typestr = "IO"; break;
3184 default: typestr = "UNKNOWN"; break;
3188 const char *name = HvNAME_get(SvSTASH(sv));
3189 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3190 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3193 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3197 *lp = strlen(typestr);
3198 return (char *)typestr;
3200 if (SvREADONLY(sv) && !SvOK(sv)) {
3201 if (ckWARN(WARN_UNINITIALIZED))
3208 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3209 /* I'm assuming that if both IV and NV are equally valid then
3210 converting the IV is going to be more efficient */
3211 const U32 isIOK = SvIOK(sv);
3212 const U32 isUIOK = SvIsUV(sv);
3213 char buf[TYPE_CHARS(UV)];
3216 if (SvTYPE(sv) < SVt_PVIV)
3217 sv_upgrade(sv, SVt_PVIV);
3219 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3221 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3222 /* inlined from sv_setpvn */
3223 SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
3224 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
3225 SvCUR_set(sv, ebuf - ptr);
3235 else if (SvNOKp(sv)) {
3236 if (SvTYPE(sv) < SVt_PVNV)
3237 sv_upgrade(sv, SVt_PVNV);
3238 /* The +20 is pure guesswork. Configure test needed. --jhi */
3239 s = SvGROW_mutable(sv, NV_DIG + 20);
3240 olderrno = errno; /* some Xenix systems wipe out errno here */
3242 if (SvNVX(sv) == 0.0)
3243 (void)strcpy(s,"0");
3247 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3250 #ifdef FIXNEGATIVEZERO
3251 if (*s == '-' && s[1] == '0' && !s[2])
3261 if (ckWARN(WARN_UNINITIALIZED)
3262 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3266 if (SvTYPE(sv) < SVt_PV)
3267 /* Typically the caller expects that sv_any is not NULL now. */
3268 sv_upgrade(sv, SVt_PV);
3272 STRLEN len = s - SvPVX_const(sv);
3278 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3279 PTR2UV(sv),SvPVX_const(sv)));
3280 if (flags & SV_CONST_RETURN)
3281 return (char *)SvPVX_const(sv);
3282 if (flags & SV_MUTABLE_RETURN)
3283 return SvPVX_mutable(sv);
3287 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3288 /* Sneaky stuff here */
3292 tsv = newSVpv(tmpbuf, 0);
3305 t = SvPVX_const(tsv);
3310 len = strlen(tmpbuf);
3312 #ifdef FIXNEGATIVEZERO
3313 if (len == 2 && t[0] == '-' && t[1] == '0') {
3318 SvUPGRADE(sv, SVt_PV);
3321 s = SvGROW_mutable(sv, len + 1);
3324 return memcpy(s, t, len + 1);
3329 =for apidoc sv_copypv
3331 Copies a stringified representation of the source SV into the
3332 destination SV. Automatically performs any necessary mg_get and
3333 coercion of numeric values into strings. Guaranteed to preserve
3334 UTF-8 flag even from overloaded objects. Similar in nature to
3335 sv_2pv[_flags] but operates directly on an SV instead of just the
3336 string. Mostly uses sv_2pv_flags to do its work, except when that
3337 would lose the UTF-8'ness of the PV.
3343 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3346 const char * const s = SvPV_const(ssv,len);
3347 sv_setpvn(dsv,s,len);
3355 =for apidoc sv_2pvbyte_nolen
3357 Return a pointer to the byte-encoded representation of the SV.
3358 May cause the SV to be downgraded from UTF-8 as a side-effect.
3360 Usually accessed via the C<SvPVbyte_nolen> macro.
3366 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3368 return sv_2pvbyte(sv, 0);
3372 =for apidoc sv_2pvbyte
3374 Return a pointer to the byte-encoded representation of the SV, and set *lp
3375 to its length. May cause the SV to be downgraded from UTF-8 as a
3378 Usually accessed via the C<SvPVbyte> macro.
3384 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3386 sv_utf8_downgrade(sv,0);
3387 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3391 =for apidoc sv_2pvutf8_nolen
3393 Return a pointer to the UTF-8-encoded representation of the SV.
3394 May cause the SV to be upgraded to UTF-8 as a side-effect.
3396 Usually accessed via the C<SvPVutf8_nolen> macro.
3402 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3404 return sv_2pvutf8(sv, 0);
3408 =for apidoc sv_2pvutf8
3410 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3411 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3413 Usually accessed via the C<SvPVutf8> macro.
3419 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3421 sv_utf8_upgrade(sv);
3422 return SvPV(sv,*lp);
3426 =for apidoc sv_2bool
3428 This function is only called on magical items, and is only used by
3429 sv_true() or its macro equivalent.
3435 Perl_sv_2bool(pTHX_ register SV *sv)
3444 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3445 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3446 return (bool)SvTRUE(tmpsv);
3447 return SvRV(sv) != 0;
3450 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3452 (*sv->sv_u.svu_pv > '0' ||
3453 Xpvtmp->xpv_cur > 1 ||
3454 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3461 return SvIVX(sv) != 0;
3464 return SvNVX(sv) != 0.0;
3471 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3472 * this function provided for binary compatibility only
3477 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3479 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3483 =for apidoc sv_utf8_upgrade
3485 Converts the PV of an SV to its UTF-8-encoded form.
3486 Forces the SV to string form if it is not already.
3487 Always sets the SvUTF8 flag to avoid future validity checks even
3488 if all the bytes have hibit clear.
3490 This is not as a general purpose byte encoding to Unicode interface:
3491 use the Encode extension for that.
3493 =for apidoc sv_utf8_upgrade_flags
3495 Converts the PV of an SV to its UTF-8-encoded form.
3496 Forces the SV to string form if it is not already.
3497 Always sets the SvUTF8 flag to avoid future validity checks even
3498 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3499 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3500 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3502 This is not as a general purpose byte encoding to Unicode interface:
3503 use the Encode extension for that.
3509 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3511 if (sv == &PL_sv_undef)
3515 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3516 (void) sv_2pv_flags(sv,&len, flags);
3520 (void) SvPV_force(sv,len);
3529 sv_force_normal_flags(sv, 0);
3532 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3533 sv_recode_to_utf8(sv, PL_encoding);
3534 else { /* Assume Latin-1/EBCDIC */
3535 /* This function could be much more efficient if we
3536 * had a FLAG in SVs to signal if there are any hibit
3537 * chars in the PV. Given that there isn't such a flag
3538 * make the loop as fast as possible. */
3539 const U8 *s = (U8 *) SvPVX_const(sv);
3540 const U8 *e = (U8 *) SvEND(sv);
3546 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3550 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3551 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
3553 SvPV_free(sv); /* No longer using what was there before. */
3555 SvPV_set(sv, (char*)recoded);
3556 SvCUR_set(sv, len - 1);
3557 SvLEN_set(sv, len); /* No longer know the real size. */
3559 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3566 =for apidoc sv_utf8_downgrade
3568 Attempts to convert the PV of an SV from characters to bytes.
3569 If the PV contains a character beyond byte, this conversion will fail;
3570 in this case, either returns false or, if C<fail_ok> is not
3573 This is not as a general purpose Unicode to byte encoding interface:
3574 use the Encode extension for that.
3580 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3582 if (SvPOKp(sv) && SvUTF8(sv)) {
3588 sv_force_normal_flags(sv, 0);
3590 s = (U8 *) SvPV(sv, len);
3591 if (!utf8_to_bytes(s, &len)) {
3596 Perl_croak(aTHX_ "Wide character in %s",
3599 Perl_croak(aTHX_ "Wide character");
3610 =for apidoc sv_utf8_encode
3612 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3613 flag off so that it looks like octets again.
3619 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3621 (void) sv_utf8_upgrade(sv);
3623 sv_force_normal_flags(sv, 0);
3625 if (SvREADONLY(sv)) {
3626 Perl_croak(aTHX_ PL_no_modify);
3632 =for apidoc sv_utf8_decode
3634 If the PV of the SV is an octet sequence in UTF-8
3635 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3636 so that it looks like a character. If the PV contains only single-byte
3637 characters, the C<SvUTF8> flag stays being off.
3638 Scans PV for validity and returns false if the PV is invalid UTF-8.
3644 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3650 /* The octets may have got themselves encoded - get them back as
3653 if (!sv_utf8_downgrade(sv, TRUE))
3656 /* it is actually just a matter of turning the utf8 flag on, but
3657 * we want to make sure everything inside is valid utf8 first.
3659 c = (const U8 *) SvPVX_const(sv);
3660 if (!is_utf8_string(c, SvCUR(sv)+1))
3662 e = (const U8 *) SvEND(sv);
3665 if (!UTF8_IS_INVARIANT(ch)) {
3674 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
3675 * this function provided for binary compatibility only
3679 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3681 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3685 =for apidoc sv_setsv
3687 Copies the contents of the source SV C<ssv> into the destination SV
3688 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3689 function if the source SV needs to be reused. Does not handle 'set' magic.
3690 Loosely speaking, it performs a copy-by-value, obliterating any previous
3691 content of the destination.
3693 You probably want to use one of the assortment of wrappers, such as
3694 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3695 C<SvSetMagicSV_nosteal>.
3697 =for apidoc sv_setsv_flags
3699 Copies the contents of the source SV C<ssv> into the destination SV
3700 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3701 function if the source SV needs to be reused. Does not handle 'set' magic.
3702 Loosely speaking, it performs a copy-by-value, obliterating any previous
3703 content of the destination.
3704 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3705 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3706 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3707 and C<sv_setsv_nomg> are implemented in terms of this function.
3709 You probably want to use one of the assortment of wrappers, such as
3710 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3711 C<SvSetMagicSV_nosteal>.
3713 This is the primary function for copying scalars, and most other
3714 copy-ish functions and macros use this underneath.
3720 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3722 register U32 sflags;
3728 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3730 sstr = &PL_sv_undef;
3731 stype = SvTYPE(sstr);
3732 dtype = SvTYPE(dstr);
3737 /* need to nuke the magic */
3739 SvRMAGICAL_off(dstr);
3742 /* There's a lot of redundancy below but we're going for speed here */
3747 if (dtype != SVt_PVGV) {
3748 (void)SvOK_off(dstr);
3756 sv_upgrade(dstr, SVt_IV);
3759 sv_upgrade(dstr, SVt_PVNV);
3763 sv_upgrade(dstr, SVt_PVIV);
3766 (void)SvIOK_only(dstr);
3767 SvIV_set(dstr, SvIVX(sstr));
3770 if (SvTAINTED(sstr))
3781 sv_upgrade(dstr, SVt_NV);
3786 sv_upgrade(dstr, SVt_PVNV);
3789 SvNV_set(dstr, SvNVX(sstr));
3790 (void)SvNOK_only(dstr);
3791 if (SvTAINTED(sstr))
3799 sv_upgrade(dstr, SVt_RV);
3800 else if (dtype == SVt_PVGV &&
3801 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3804 if (GvIMPORTED(dstr) != GVf_IMPORTED
3805 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3807 GvIMPORTED_on(dstr);
3816 #ifdef PERL_OLD_COPY_ON_WRITE
3817 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3818 if (dtype < SVt_PVIV)
3819 sv_upgrade(dstr, SVt_PVIV);
3826 sv_upgrade(dstr, SVt_PV);
3829 if (dtype < SVt_PVIV)
3830 sv_upgrade(dstr, SVt_PVIV);
3833 if (dtype < SVt_PVNV)
3834 sv_upgrade(dstr, SVt_PVNV);
3841 const char * const type = sv_reftype(sstr,0);
3843 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3845 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3850 if (dtype <= SVt_PVGV) {
3852 if (dtype != SVt_PVGV) {
3853 const char * const name = GvNAME(sstr);
3854 const STRLEN len = GvNAMELEN(sstr);
3855 /* don't upgrade SVt_PVLV: it can hold a glob */
3856 if (dtype != SVt_PVLV)
3857 sv_upgrade(dstr, SVt_PVGV);
3858 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3859 GvSTASH(dstr) = GvSTASH(sstr);
3861 Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3862 GvNAME(dstr) = savepvn(name, len);
3863 GvNAMELEN(dstr) = len;
3864 SvFAKE_on(dstr); /* can coerce to non-glob */
3866 /* ahem, death to those who redefine active sort subs */
3867 else if (PL_curstackinfo->si_type == PERLSI_SORT
3868 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3869 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3872 #ifdef GV_UNIQUE_CHECK
3873 if (GvUNIQUE((GV*)dstr)) {
3874 Perl_croak(aTHX_ PL_no_modify);
3878 (void)SvOK_off(dstr);
3879 GvINTRO_off(dstr); /* one-shot flag */
3881 GvGP(dstr) = gp_ref(GvGP(sstr));
3882 if (SvTAINTED(sstr))
3884 if (GvIMPORTED(dstr) != GVf_IMPORTED
3885 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3887 GvIMPORTED_on(dstr);
3895 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3897 if ((int)SvTYPE(sstr) != stype) {
3898 stype = SvTYPE(sstr);
3899 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3903 if (stype == SVt_PVLV)
3904 SvUPGRADE(dstr, SVt_PVNV);
3906 SvUPGRADE(dstr, (U32)stype);
3909 sflags = SvFLAGS(sstr);
3911 if (sflags & SVf_ROK) {
3912 if (dtype >= SVt_PV) {
3913 if (dtype == SVt_PVGV) {
3914 SV *sref = SvREFCNT_inc(SvRV(sstr));
3916 const int intro = GvINTRO(dstr);
3918 #ifdef GV_UNIQUE_CHECK
3919 if (GvUNIQUE((GV*)dstr)) {
3920 Perl_croak(aTHX_ PL_no_modify);
3925 GvINTRO_off(dstr); /* one-shot flag */
3926 GvLINE(dstr) = CopLINE(PL_curcop);
3927 GvEGV(dstr) = (GV*)dstr;
3930 switch (SvTYPE(sref)) {
3933 SAVEGENERICSV(GvAV(dstr));
3935 dref = (SV*)GvAV(dstr);
3936 GvAV(dstr) = (AV*)sref;
3937 if (!GvIMPORTED_AV(dstr)
3938 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3940 GvIMPORTED_AV_on(dstr);
3945 SAVEGENERICSV(GvHV(dstr));
3947 dref = (SV*)GvHV(dstr);
3948 GvHV(dstr) = (HV*)sref;
3949 if (!GvIMPORTED_HV(dstr)
3950 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3952 GvIMPORTED_HV_on(dstr);
3957 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3958 SvREFCNT_dec(GvCV(dstr));
3959 GvCV(dstr) = Nullcv;
3960 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3961 PL_sub_generation++;
3963 SAVEGENERICSV(GvCV(dstr));
3966 dref = (SV*)GvCV(dstr);
3967 if (GvCV(dstr) != (CV*)sref) {
3968 CV* cv = GvCV(dstr);
3970 if (!GvCVGEN((GV*)dstr) &&
3971 (CvROOT(cv) || CvXSUB(cv)))
3973 /* ahem, death to those who redefine
3974 * active sort subs */
3975 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3976 PL_sortcop == CvSTART(cv))
3978 "Can't redefine active sort subroutine %s",
3979 GvENAME((GV*)dstr));
3980 /* Redefining a sub - warning is mandatory if
3981 it was a const and its value changed. */
3982 if (ckWARN(WARN_REDEFINE)
3984 && (!CvCONST((CV*)sref)
3985 || sv_cmp(cv_const_sv(cv),
3986 cv_const_sv((CV*)sref)))))
3988 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3990 ? "Constant subroutine %s::%s redefined"
3991 : "Subroutine %s::%s redefined",
3992 HvNAME_get(GvSTASH((GV*)dstr)),
3993 GvENAME((GV*)dstr));
3997 cv_ckproto(cv, (GV*)dstr,
3999 ? SvPVX_const(sref) : Nullch);
4001 GvCV(dstr) = (CV*)sref;
4002 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4003 GvASSUMECV_on(dstr);
4004 PL_sub_generation++;
4006 if (!GvIMPORTED_CV(dstr)
4007 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4009 GvIMPORTED_CV_on(dstr);
4014 SAVEGENERICSV(GvIOp(dstr));
4016 dref = (SV*)GvIOp(dstr);
4017 GvIOp(dstr) = (IO*)sref;
4021 SAVEGENERICSV(GvFORM(dstr));
4023 dref = (SV*)GvFORM(dstr);
4024 GvFORM(dstr) = (CV*)sref;
4028 SAVEGENERICSV(GvSV(dstr));
4030 dref = (SV*)GvSV(dstr);
4032 if (!GvIMPORTED_SV(dstr)
4033 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4035 GvIMPORTED_SV_on(dstr);
4041 if (SvTAINTED(sstr))
4045 if (SvPVX_const(dstr)) {
4051 (void)SvOK_off(dstr);
4052 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4054 if (sflags & SVp_NOK) {
4056 /* Only set the public OK flag if the source has public OK. */
4057 if (sflags & SVf_NOK)
4058 SvFLAGS(dstr) |= SVf_NOK;
4059 SvNV_set(dstr, SvNVX(sstr));
4061 if (sflags & SVp_IOK) {
4062 (void)SvIOKp_on(dstr);
4063 if (sflags & SVf_IOK)
4064 SvFLAGS(dstr) |= SVf_IOK;
4065 if (sflags & SVf_IVisUV)
4067 SvIV_set(dstr, SvIVX(sstr));
4069 if (SvAMAGIC(sstr)) {
4073 else if (sflags & SVp_POK) {
4077 * Check to see if we can just swipe the string. If so, it's a
4078 * possible small lose on short strings, but a big win on long ones.
4079 * It might even be a win on short strings if SvPVX_const(dstr)
4080 * has to be allocated and SvPVX_const(sstr) has to be freed.
4083 /* Whichever path we take through the next code, we want this true,
4084 and doing it now facilitates the COW check. */
4085 (void)SvPOK_only(dstr);
4088 /* We're not already COW */
4089 ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4090 #ifndef PERL_OLD_COPY_ON_WRITE
4091 /* or we are, but dstr isn't a suitable target. */
4092 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4097 (sflags & SVs_TEMP) && /* slated for free anyway? */
4098 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4099 (!(flags & SV_NOSTEAL)) &&
4100 /* and we're allowed to steal temps */
4101 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4102 SvLEN(sstr) && /* and really is a string */
4103 /* and won't be needed again, potentially */
4104 !(PL_op && PL_op->op_type == OP_AASSIGN))
4105 #ifdef PERL_OLD_COPY_ON_WRITE
4106 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4107 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4108 && SvTYPE(sstr) >= SVt_PVIV)
4111 /* Failed the swipe test, and it's not a shared hash key either.
4112 Have to copy the string. */
4113 STRLEN len = SvCUR(sstr);
4114 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4115 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4116 SvCUR_set(dstr, len);
4117 *SvEND(dstr) = '\0';
4119 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4121 /* Either it's a shared hash key, or it's suitable for
4122 copy-on-write or we can swipe the string. */
4124 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4128 #ifdef PERL_OLD_COPY_ON_WRITE
4130 /* I believe I should acquire a global SV mutex if
4131 it's a COW sv (not a shared hash key) to stop
4132 it going un copy-on-write.
4133 If the source SV has gone un copy on write between up there
4134 and down here, then (assert() that) it is of the correct
4135 form to make it copy on write again */
4136 if ((sflags & (SVf_FAKE | SVf_READONLY))
4137 != (SVf_FAKE | SVf_READONLY)) {
4138 SvREADONLY_on(sstr);
4140 /* Make the source SV into a loop of 1.
4141 (about to become 2) */
4142 SV_COW_NEXT_SV_SET(sstr, sstr);
4146 /* Initial code is common. */
4147 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4152 /* making another shared SV. */
4153 STRLEN cur = SvCUR(sstr);
4154 STRLEN len = SvLEN(sstr);
4155 #ifdef PERL_OLD_COPY_ON_WRITE
4157 assert (SvTYPE(dstr) >= SVt_PVIV);
4158 /* SvIsCOW_normal */
4159 /* splice us in between source and next-after-source. */
4160 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4161 SV_COW_NEXT_SV_SET(sstr, dstr);
4162 SvPV_set(dstr, SvPVX_mutable(sstr));
4166 /* SvIsCOW_shared_hash */
4167 DEBUG_C(PerlIO_printf(Perl_debug_log,
4168 "Copy on write: Sharing hash\n"));
4170 assert (SvTYPE(dstr) >= SVt_PV);
4172 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4174 SvLEN_set(dstr, len);
4175 SvCUR_set(dstr, cur);
4176 SvREADONLY_on(dstr);
4178 /* Relesase a global SV mutex. */
4181 { /* Passes the swipe test. */
4182 SvPV_set(dstr, SvPVX_mutable(sstr));
4183 SvLEN_set(dstr, SvLEN(sstr));
4184 SvCUR_set(dstr, SvCUR(sstr));
4187 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4188 SvPV_set(sstr, Nullch);
4194 if (sflags & SVf_UTF8)
4196 if (sflags & SVp_NOK) {
4198 if (sflags & SVf_NOK)
4199 SvFLAGS(dstr) |= SVf_NOK;
4200 SvNV_set(dstr, SvNVX(sstr));
4202 if (sflags & SVp_IOK) {
4203 (void)SvIOKp_on(dstr);
4204 if (sflags & SVf_IOK)
4205 SvFLAGS(dstr) |= SVf_IOK;
4206 if (sflags & SVf_IVisUV)
4208 SvIV_set(dstr, SvIVX(sstr));
4211 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4212 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4213 smg->mg_ptr, smg->mg_len);
4214 SvRMAGICAL_on(dstr);
4217 else if (sflags & SVp_IOK) {
4218 if (sflags & SVf_IOK)
4219 (void)SvIOK_only(dstr);
4221 (void)SvOK_off(dstr);
4222 (void)SvIOKp_on(dstr);
4224 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4225 if (sflags & SVf_IVisUV)
4227 SvIV_set(dstr, SvIVX(sstr));
4228 if (sflags & SVp_NOK) {
4229 if (sflags & SVf_NOK)
4230 (void)SvNOK_on(dstr);
4232 (void)SvNOKp_on(dstr);
4233 SvNV_set(dstr, SvNVX(sstr));
4236 else if (sflags & SVp_NOK) {
4237 if (sflags & SVf_NOK)
4238 (void)SvNOK_only(dstr);
4240 (void)SvOK_off(dstr);
4243 SvNV_set(dstr, SvNVX(sstr));
4246 if (dtype == SVt_PVGV) {
4247 if (ckWARN(WARN_MISC))
4248 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4251 (void)SvOK_off(dstr);
4253 if (SvTAINTED(sstr))
4258 =for apidoc sv_setsv_mg
4260 Like C<sv_setsv>, but also handles 'set' magic.
4266 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4268 sv_setsv(dstr,sstr);
4272 #ifdef PERL_OLD_COPY_ON_WRITE
4274 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4276 STRLEN cur = SvCUR(sstr);
4277 STRLEN len = SvLEN(sstr);
4278 register char *new_pv;
4281 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4289 if (SvTHINKFIRST(dstr))
4290 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4291 else if (SvPVX_const(dstr))
4292 Safefree(SvPVX_const(dstr));
4296 SvUPGRADE(dstr, SVt_PVIV);
4298 assert (SvPOK(sstr));
4299 assert (SvPOKp(sstr));
4300 assert (!SvIOK(sstr));
4301 assert (!SvIOKp(sstr));
4302 assert (!SvNOK(sstr));
4303 assert (!SvNOKp(sstr));
4305 if (SvIsCOW(sstr)) {
4307 if (SvLEN(sstr) == 0) {
4308 /* source is a COW shared hash key. */
4309 DEBUG_C(PerlIO_printf(Perl_debug_log,
4310 "Fast copy on write: Sharing hash\n"));
4311 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4314 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4316 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4317 SvUPGRADE(sstr, SVt_PVIV);
4318 SvREADONLY_on(sstr);
4320 DEBUG_C(PerlIO_printf(Perl_debug_log,
4321 "Fast copy on write: Converting sstr to COW\n"));
4322 SV_COW_NEXT_SV_SET(dstr, sstr);
4324 SV_COW_NEXT_SV_SET(sstr, dstr);
4325 new_pv = SvPVX_mutable(sstr);
4328 SvPV_set(dstr, new_pv);
4329 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4332 SvLEN_set(dstr, len);
4333 SvCUR_set(dstr, cur);
4342 =for apidoc sv_setpvn
4344 Copies a string into an SV. The C<len> parameter indicates the number of
4345 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4346 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4352 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4354 register char *dptr;
4356 SV_CHECK_THINKFIRST_COW_DROP(sv);
4362 /* len is STRLEN which is unsigned, need to copy to signed */
4365 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4367 SvUPGRADE(sv, SVt_PV);
4369 dptr = SvGROW(sv, len + 1);
4370 Move(ptr,dptr,len,char);
4373 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4378 =for apidoc sv_setpvn_mg
4380 Like C<sv_setpvn>, but also handles 'set' magic.
4386 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4388 sv_setpvn(sv,ptr,len);
4393 =for apidoc sv_setpv
4395 Copies a string into an SV. The string must be null-terminated. Does not
4396 handle 'set' magic. See C<sv_setpv_mg>.
4402 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4404 register STRLEN len;
4406 SV_CHECK_THINKFIRST_COW_DROP(sv);
4412 SvUPGRADE(sv, SVt_PV);
4414 SvGROW(sv, len + 1);
4415 Move(ptr,SvPVX(sv),len+1,char);
4417 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4422 =for apidoc sv_setpv_mg
4424 Like C<sv_setpv>, but also handles 'set' magic.
4430 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4437 =for apidoc sv_usepvn
4439 Tells an SV to use C<ptr> to find its string value. Normally the string is
4440 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4441 The C<ptr> should point to memory that was allocated by C<malloc>. The
4442 string length, C<len>, must be supplied. This function will realloc the
4443 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4444 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4445 See C<sv_usepvn_mg>.
4451 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4454 SV_CHECK_THINKFIRST_COW_DROP(sv);
4455 SvUPGRADE(sv, SVt_PV);
4460 if (SvPVX_const(sv))
4463 allocate = PERL_STRLEN_ROUNDUP(len + 1);
4464 ptr = saferealloc (ptr, allocate);
4467 SvLEN_set(sv, allocate);
4469 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4474 =for apidoc sv_usepvn_mg
4476 Like C<sv_usepvn>, but also handles 'set' magic.
4482 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4484 sv_usepvn(sv,ptr,len);
4488 #ifdef PERL_OLD_COPY_ON_WRITE
4489 /* Need to do this *after* making the SV normal, as we need the buffer
4490 pointer to remain valid until after we've copied it. If we let go too early,
4491 another thread could invalidate it by unsharing last of the same hash key
4492 (which it can do by means other than releasing copy-on-write Svs)
4493 or by changing the other copy-on-write SVs in the loop. */
4495 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
4497 if (len) { /* this SV was SvIsCOW_normal(sv) */
4498 /* we need to find the SV pointing to us. */
4499 SV *current = SV_COW_NEXT_SV(after);
4501 if (current == sv) {
4502 /* The SV we point to points back to us (there were only two of us
4504 Hence other SV is no longer copy on write either. */
4506 SvREADONLY_off(after);
4508 /* We need to follow the pointers around the loop. */
4510 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4513 /* don't loop forever if the structure is bust, and we have
4514 a pointer into a closed loop. */
4515 assert (current != after);
4516 assert (SvPVX_const(current) == pvx);
4518 /* Make the SV before us point to the SV after us. */
4519 SV_COW_NEXT_SV_SET(current, after);
4522 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4527 Perl_sv_release_IVX(pTHX_ register SV *sv)
4530 sv_force_normal_flags(sv, 0);
4536 =for apidoc sv_force_normal_flags
4538 Undo various types of fakery on an SV: if the PV is a shared string, make
4539 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4540 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4541 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4542 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4543 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4544 set to some other value.) In addition, the C<flags> parameter gets passed to
4545 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4546 with flags set to 0.
4552 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4554 #ifdef PERL_OLD_COPY_ON_WRITE
4555 if (SvREADONLY(sv)) {
4556 /* At this point I believe I should acquire a global SV mutex. */
4558 const char *pvx = SvPVX_const(sv);
4559 const STRLEN len = SvLEN(sv);
4560 const STRLEN cur = SvCUR(sv);
4561 SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
4563 PerlIO_printf(Perl_debug_log,
4564 "Copy on write: Force normal %ld\n",
4570 /* This SV doesn't own the buffer, so need to New() a new one: */
4571 SvPV_set(sv, (char*)0);
4573 if (flags & SV_COW_DROP_PV) {
4574 /* OK, so we don't need to copy our buffer. */
4577 SvGROW(sv, cur + 1);
4578 Move(pvx,SvPVX(sv),cur,char);
4582 sv_release_COW(sv, pvx, len, next);
4587 else if (IN_PERL_RUNTIME)
4588 Perl_croak(aTHX_ PL_no_modify);
4589 /* At this point I believe that I can drop the global SV mutex. */
4592 if (SvREADONLY(sv)) {
4594 const char *pvx = SvPVX_const(sv);
4595 const STRLEN len = SvCUR(sv);
4598 SvPV_set(sv, Nullch);
4600 SvGROW(sv, len + 1);
4601 Move(pvx,SvPVX_const(sv),len,char);
4603 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4605 else if (IN_PERL_RUNTIME)
4606 Perl_croak(aTHX_ PL_no_modify);
4610 sv_unref_flags(sv, flags);
4611 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4616 =for apidoc sv_force_normal
4618 Undo various types of fakery on an SV: if the PV is a shared string, make
4619 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4620 an xpvmg. See also C<sv_force_normal_flags>.
4626 Perl_sv_force_normal(pTHX_ register SV *sv)
4628 sv_force_normal_flags(sv, 0);
4634 Efficient removal of characters from the beginning of the string buffer.
4635 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4636 the string buffer. The C<ptr> becomes the first character of the adjusted
4637 string. Uses the "OOK hack".
4638 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4639 refer to the same chunk of data.
4645 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
4647 register STRLEN delta;
4648 if (!ptr || !SvPOKp(sv))
4650 delta = ptr - SvPVX_const(sv);
4651 SV_CHECK_THINKFIRST(sv);
4652 if (SvTYPE(sv) < SVt_PVIV)
4653 sv_upgrade(sv,SVt_PVIV);
4656 if (!SvLEN(sv)) { /* make copy of shared string */
4657 const char *pvx = SvPVX_const(sv);
4658 const STRLEN len = SvCUR(sv);
4659 SvGROW(sv, len + 1);
4660 Move(pvx,SvPVX_const(sv),len,char);
4664 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
4665 and we do that anyway inside the SvNIOK_off
4667 SvFLAGS(sv) |= SVf_OOK;
4670 SvLEN_set(sv, SvLEN(sv) - delta);
4671 SvCUR_set(sv, SvCUR(sv) - delta);
4672 SvPV_set(sv, SvPVX(sv) + delta);
4673 SvIV_set(sv, SvIVX(sv) + delta);
4676 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
4677 * this function provided for binary compatibility only
4681 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
4683 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
4687 =for apidoc sv_catpvn
4689 Concatenates the string onto the end of the string which is in the SV. The
4690 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4691 status set, then the bytes appended should be valid UTF-8.
4692 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4694 =for apidoc sv_catpvn_flags
4696 Concatenates the string onto the end of the string which is in the SV. The
4697 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4698 status set, then the bytes appended should be valid UTF-8.
4699 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4700 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4701 in terms of this function.
4707 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4710 const char *dstr = SvPV_force_flags(dsv, dlen, flags);
4712 SvGROW(dsv, dlen + slen + 1);
4714 sstr = SvPVX_const(dsv);
4715 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4716 SvCUR_set(dsv, SvCUR(dsv) + slen);
4718 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4723 =for apidoc sv_catpvn_mg
4725 Like C<sv_catpvn>, but also handles 'set' magic.
4731 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4733 sv_catpvn(sv,ptr,len);
4737 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
4738 * this function provided for binary compatibility only
4742 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
4744 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
4748 =for apidoc sv_catsv
4750 Concatenates the string from SV C<ssv> onto the end of the string in
4751 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4752 not 'set' magic. See C<sv_catsv_mg>.
4754 =for apidoc sv_catsv_flags
4756 Concatenates the string from SV C<ssv> onto the end of the string in
4757 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4758 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4759 and C<sv_catsv_nomg> are implemented in terms of this function.
4764 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4770 if ((spv = SvPV_const(ssv, slen))) {
4771 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4772 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4773 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4774 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4775 dsv->sv_flags doesn't have that bit set.
4776 Andy Dougherty 12 Oct 2001
4778 const I32 sutf8 = DO_UTF8(ssv);
4781 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4783 dutf8 = DO_UTF8(dsv);
4785 if (dutf8 != sutf8) {
4787 /* Not modifying source SV, so taking a temporary copy. */
4788 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4790 sv_utf8_upgrade(csv);
4791 spv = SvPV_const(csv, slen);
4794 sv_utf8_upgrade_nomg(dsv);
4796 sv_catpvn_nomg(dsv, spv, slen);
4801 =for apidoc sv_catsv_mg
4803 Like C<sv_catsv>, but also handles 'set' magic.
4809 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4816 =for apidoc sv_catpv
4818 Concatenates the string onto the end of the string which is in the SV.
4819 If the SV has the UTF-8 status set, then the bytes appended should be
4820 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4825 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4827 register STRLEN len;
4833 junk = SvPV_force(sv, tlen);
4835 SvGROW(sv, tlen + len + 1);
4837 ptr = SvPVX_const(sv);
4838 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4839 SvCUR_set(sv, SvCUR(sv) + len);
4840 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4845 =for apidoc sv_catpv_mg
4847 Like C<sv_catpv>, but also handles 'set' magic.
4853 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4862 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4863 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4870 Perl_newSV(pTHX_ STRLEN len)
4876 sv_upgrade(sv, SVt_PV);
4877 SvGROW(sv, len + 1);
4882 =for apidoc sv_magicext
4884 Adds magic to an SV, upgrading it if necessary. Applies the
4885 supplied vtable and returns a pointer to the magic added.
4887 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4888 In particular, you can add magic to SvREADONLY SVs, and add more than
4889 one instance of the same 'how'.
4891 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4892 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4893 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4894 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4896 (This is now used as a subroutine by C<sv_magic>.)
4901 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
4902 const char* name, I32 namlen)
4906 if (SvTYPE(sv) < SVt_PVMG) {
4907 SvUPGRADE(sv, SVt_PVMG);
4909 Newz(702,mg, 1, MAGIC);
4910 mg->mg_moremagic = SvMAGIC(sv);
4911 SvMAGIC_set(sv, mg);
4913 /* Sometimes a magic contains a reference loop, where the sv and
4914 object refer to each other. To prevent a reference loop that
4915 would prevent such objects being freed, we look for such loops
4916 and if we find one we avoid incrementing the object refcount.
4918 Note we cannot do this to avoid self-tie loops as intervening RV must
4919 have its REFCNT incremented to keep it in existence.
4922 if (!obj || obj == sv ||
4923 how == PERL_MAGIC_arylen ||
4924 how == PERL_MAGIC_qr ||
4925 how == PERL_MAGIC_symtab ||
4926 (SvTYPE(obj) == SVt_PVGV &&
4927 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4928 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4929 GvFORM(obj) == (CV*)sv)))
4934 mg->mg_obj = SvREFCNT_inc(obj);
4935 mg->mg_flags |= MGf_REFCOUNTED;
4938 /* Normal self-ties simply pass a null object, and instead of
4939 using mg_obj directly, use the SvTIED_obj macro to produce a
4940 new RV as needed. For glob "self-ties", we are tieing the PVIO
4941 with an RV obj pointing to the glob containing the PVIO. In
4942 this case, to avoid a reference loop, we need to weaken the
4946 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4947 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4953 mg->mg_len = namlen;
4956 mg->mg_ptr = savepvn(name, namlen);
4957 else if (namlen == HEf_SVKEY)
4958 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4960 mg->mg_ptr = (char *) name;
4962 mg->mg_virtual = vtable;
4966 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4971 =for apidoc sv_magic
4973 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4974 then adds a new magic item of type C<how> to the head of the magic list.
4976 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4977 handling of the C<name> and C<namlen> arguments.
4979 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4980 to add more than one instance of the same 'how'.
4986 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4988 const MGVTBL *vtable = 0;
4991 #ifdef PERL_OLD_COPY_ON_WRITE
4993 sv_force_normal_flags(sv, 0);
4995 if (SvREADONLY(sv)) {
4997 /* its okay to attach magic to shared strings; the subsequent
4998 * upgrade to PVMG will unshare the string */
4999 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
5002 && how != PERL_MAGIC_regex_global
5003 && how != PERL_MAGIC_bm
5004 && how != PERL_MAGIC_fm
5005 && how != PERL_MAGIC_sv
5006 && how != PERL_MAGIC_backref
5009 Perl_croak(aTHX_ PL_no_modify);
5012 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5013 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5014 /* sv_magic() refuses to add a magic of the same 'how' as an
5017 if (how == PERL_MAGIC_taint)
5025 vtable = &PL_vtbl_sv;
5027 case PERL_MAGIC_overload:
5028 vtable = &PL_vtbl_amagic;
5030 case PERL_MAGIC_overload_elem:
5031 vtable = &PL_vtbl_amagicelem;
5033 case PERL_MAGIC_overload_table:
5034 vtable = &PL_vtbl_ovrld;
5037 vtable = &PL_vtbl_bm;
5039 case PERL_MAGIC_regdata:
5040 vtable = &PL_vtbl_regdata;
5042 case PERL_MAGIC_regdatum:
5043 vtable = &PL_vtbl_regdatum;
5045 case PERL_MAGIC_env:
5046 vtable = &PL_vtbl_env;
5049 vtable = &PL_vtbl_fm;
5051 case PERL_MAGIC_envelem:
5052 vtable = &PL_vtbl_envelem;
5054 case PERL_MAGIC_regex_global:
5055 vtable = &PL_vtbl_mglob;
5057 case PERL_MAGIC_isa:
5058 vtable = &PL_vtbl_isa;
5060 case PERL_MAGIC_isaelem:
5061 vtable = &PL_vtbl_isaelem;
5063 case PERL_MAGIC_nkeys:
5064 vtable = &PL_vtbl_nkeys;
5066 case PERL_MAGIC_dbfile:
5069 case PERL_MAGIC_dbline:
5070 vtable = &PL_vtbl_dbline;
5072 #ifdef USE_LOCALE_COLLATE
5073 case PERL_MAGIC_collxfrm:
5074 vtable = &PL_vtbl_collxfrm;
5076 #endif /* USE_LOCALE_COLLATE */
5077 case PERL_MAGIC_tied:
5078 vtable = &PL_vtbl_pack;
5080 case PERL_MAGIC_tiedelem:
5081 case PERL_MAGIC_tiedscalar:
5082 vtable = &PL_vtbl_packelem;
5085 vtable = &PL_vtbl_regexp;
5087 case PERL_MAGIC_sig:
5088 vtable = &PL_vtbl_sig;
5090 case PERL_MAGIC_sigelem:
5091 vtable = &PL_vtbl_sigelem;
5093 case PERL_MAGIC_taint:
5094 vtable = &PL_vtbl_taint;
5096 case PERL_MAGIC_uvar:
5097 vtable = &PL_vtbl_uvar;
5099 case PERL_MAGIC_vec:
5100 vtable = &PL_vtbl_vec;
5102 case PERL_MAGIC_arylen_p:
5103 case PERL_MAGIC_rhash:
5104 case PERL_MAGIC_symtab:
5105 case PERL_MAGIC_vstring:
5108 case PERL_MAGIC_utf8:
5109 vtable = &PL_vtbl_utf8;
5111 case PERL_MAGIC_substr:
5112 vtable = &PL_vtbl_substr;
5114 case PERL_MAGIC_defelem:
5115 vtable = &PL_vtbl_defelem;
5117 case PERL_MAGIC_glob:
5118 vtable = &PL_vtbl_glob;
5120 case PERL_MAGIC_arylen:
5121 vtable = &PL_vtbl_arylen;
5123 case PERL_MAGIC_pos:
5124 vtable = &PL_vtbl_pos;
5126 case PERL_MAGIC_backref:
5127 vtable = &PL_vtbl_backref;
5129 case PERL_MAGIC_ext:
5130 /* Reserved for use by extensions not perl internals. */
5131 /* Useful for attaching extension internal data to perl vars. */
5132 /* Note that multiple extensions may clash if magical scalars */
5133 /* etc holding private data from one are passed to another. */
5136 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5139 /* Rest of work is done else where */
5140 mg = sv_magicext(sv,obj,how,(MGVTBL*)vtable,name,namlen);
5143 case PERL_MAGIC_taint:
5146 case PERL_MAGIC_ext:
5147 case PERL_MAGIC_dbfile:
5154 =for apidoc sv_unmagic
5156 Removes all magic of type C<type> from an SV.
5162 Perl_sv_unmagic(pTHX_ SV *sv, int type)
5166 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5169 for (mg = *mgp; mg; mg = *mgp) {
5170 if (mg->mg_type == type) {
5171 const MGVTBL* const vtbl = mg->mg_virtual;
5172 *mgp = mg->mg_moremagic;
5173 if (vtbl && vtbl->svt_free)
5174 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5175 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5177 Safefree(mg->mg_ptr);
5178 else if (mg->mg_len == HEf_SVKEY)
5179 SvREFCNT_dec((SV*)mg->mg_ptr);
5180 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
5181 Safefree(mg->mg_ptr);
5183 if (mg->mg_flags & MGf_REFCOUNTED)
5184 SvREFCNT_dec(mg->mg_obj);
5188 mgp = &mg->mg_moremagic;
5192 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5199 =for apidoc sv_rvweaken
5201 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5202 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5203 push a back-reference to this RV onto the array of backreferences
5204 associated with that magic.
5210 Perl_sv_rvweaken(pTHX_ SV *sv)
5213 if (!SvOK(sv)) /* let undefs pass */
5216 Perl_croak(aTHX_ "Can't weaken a nonreference");
5217 else if (SvWEAKREF(sv)) {
5218 if (ckWARN(WARN_MISC))
5219 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5223 Perl_sv_add_backref(aTHX_ tsv, sv);
5229 /* Give tsv backref magic if it hasn't already got it, then push a
5230 * back-reference to sv onto the array associated with the backref magic.
5234 Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
5238 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
5239 av = (AV*)mg->mg_obj;
5242 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5243 /* av now has a refcnt of 2, which avoids it getting freed
5244 * before us during global cleanup. The extra ref is removed
5245 * by magic_killbackrefs() when tsv is being freed */
5247 if (AvFILLp(av) >= AvMAX(av)) {
5248 av_extend(av, AvFILLp(av)+1);
5250 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5253 /* delete a back-reference to ourselves from the backref magic associated
5254 * with the SV we point to.
5258 S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
5264 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) {
5265 if (PL_in_clean_all)
5268 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
5269 Perl_croak(aTHX_ "panic: del_backref");
5270 av = (AV *)mg->mg_obj;
5272 /* We shouldn't be in here more than once, but for paranoia reasons lets
5274 for (i = AvFILLp(av); i >= 0; i--) {
5276 const SSize_t fill = AvFILLp(av);
5278 /* We weren't the last entry.
5279 An unordered list has this property that you can take the
5280 last element off the end to fill the hole, and it's still
5281 an unordered list :-)
5286 AvFILLp(av) = fill - 1;
5292 =for apidoc sv_insert
5294 Inserts a string at the specified offset/length within the SV. Similar to
5295 the Perl substr() function.
5301 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
5305 register char *midend;
5306 register char *bigend;
5312 Perl_croak(aTHX_ "Can't modify non-existent substring");
5313 SvPV_force(bigstr, curlen);
5314 (void)SvPOK_only_UTF8(bigstr);
5315 if (offset + len > curlen) {
5316 SvGROW(bigstr, offset+len+1);
5317 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5318 SvCUR_set(bigstr, offset+len);
5322 i = littlelen - len;
5323 if (i > 0) { /* string might grow */
5324 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5325 mid = big + offset + len;
5326 midend = bigend = big + SvCUR(bigstr);
5329 while (midend > mid) /* shove everything down */
5330 *--bigend = *--midend;
5331 Move(little,big+offset,littlelen,char);
5332 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5337 Move(little,SvPVX(bigstr)+offset,len,char);
5342 big = SvPVX(bigstr);
5345 bigend = big + SvCUR(bigstr);
5347 if (midend > bigend)
5348 Perl_croak(aTHX_ "panic: sv_insert");
5350 if (mid - big > bigend - midend) { /* faster to shorten from end */
5352 Move(little, mid, littlelen,char);
5355 i = bigend - midend;
5357 Move(midend, mid, i,char);
5361 SvCUR_set(bigstr, mid - big);
5363 else if ((i = mid - big)) { /* faster from front */
5364 midend -= littlelen;
5366 sv_chop(bigstr,midend-i);
5371 Move(little, mid, littlelen,char);
5373 else if (littlelen) {
5374 midend -= littlelen;
5375 sv_chop(bigstr,midend);
5376 Move(little,midend,littlelen,char);
5379 sv_chop(bigstr,midend);
5385 =for apidoc sv_replace
5387 Make the first argument a copy of the second, then delete the original.
5388 The target SV physically takes over ownership of the body of the source SV
5389 and inherits its flags; however, the target keeps any magic it owns,
5390 and any magic in the source is discarded.
5391 Note that this is a rather specialist SV copying operation; most of the
5392 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5398 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5400 const U32 refcnt = SvREFCNT(sv);
5401 SV_CHECK_THINKFIRST_COW_DROP(sv);
5402 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
5403 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
5404 if (SvMAGICAL(sv)) {
5408 sv_upgrade(nsv, SVt_PVMG);
5409 SvMAGIC_set(nsv, SvMAGIC(sv));
5410 SvFLAGS(nsv) |= SvMAGICAL(sv);
5412 SvMAGIC_set(sv, NULL);
5416 assert(!SvREFCNT(sv));
5417 #ifdef DEBUG_LEAKING_SCALARS
5418 sv->sv_flags = nsv->sv_flags;
5419 sv->sv_any = nsv->sv_any;
5420 sv->sv_refcnt = nsv->sv_refcnt;
5421 sv->sv_u = nsv->sv_u;
5423 StructCopy(nsv,sv,SV);
5425 /* Currently could join these into one piece of pointer arithmetic, but
5426 it would be unclear. */
5427 if(SvTYPE(sv) == SVt_IV)
5429 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5430 else if (SvTYPE(sv) == SVt_RV) {
5431 SvANY(sv) = &sv->sv_u.svu_rv;
5435 #ifdef PERL_OLD_COPY_ON_WRITE
5436 if (SvIsCOW_normal(nsv)) {
5437 /* We need to follow the pointers around the loop to make the
5438 previous SV point to sv, rather than nsv. */
5441 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5444 assert(SvPVX_const(current) == SvPVX_const(nsv));
5446 /* Make the SV before us point to the SV after us. */
5448 PerlIO_printf(Perl_debug_log, "previous is\n");
5450 PerlIO_printf(Perl_debug_log,
5451 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5452 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5454 SV_COW_NEXT_SV_SET(current, sv);
5457 SvREFCNT(sv) = refcnt;
5458 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5464 =for apidoc sv_clear
5466 Clear an SV: call any destructors, free up any memory used by the body,
5467 and free the body itself. The SV's head is I<not> freed, although
5468 its type is set to all 1's so that it won't inadvertently be assumed
5469 to be live during global destruction etc.
5470 This function should only be called when REFCNT is zero. Most of the time
5471 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5478 Perl_sv_clear(pTHX_ register SV *sv)
5481 void** old_body_arena;
5482 size_t old_body_offset;
5483 const U32 type = SvTYPE(sv);
5486 assert(SvREFCNT(sv) == 0);
5492 old_body_offset = 0;
5495 if (PL_defstash) { /* Still have a symbol table? */
5500 stash = SvSTASH(sv);
5501 destructor = StashHANDLER(stash,DESTROY);
5503 SV* const tmpref = newRV(sv);
5504 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5506 PUSHSTACKi(PERLSI_DESTROY);
5511 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5517 if(SvREFCNT(tmpref) < 2) {
5518 /* tmpref is not kept alive! */
5520 SvRV_set(tmpref, NULL);
5523 SvREFCNT_dec(tmpref);
5525 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5529 if (PL_in_clean_objs)
5530 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5532 /* DESTROY gave object new lease on life */
5538 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5539 SvOBJECT_off(sv); /* Curse the object. */
5540 if (type != SVt_PVIO)
5541 --PL_sv_objcount; /* XXX Might want something more general */
5544 if (type >= SVt_PVMG) {
5547 if (type == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
5548 SvREFCNT_dec(SvSTASH(sv));
5553 IoIFP(sv) != PerlIO_stdin() &&
5554 IoIFP(sv) != PerlIO_stdout() &&
5555 IoIFP(sv) != PerlIO_stderr())
5557 io_close((IO*)sv, FALSE);
5559 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5560 PerlDir_close(IoDIRP(sv));
5561 IoDIRP(sv) = (DIR*)NULL;
5562 Safefree(IoTOP_NAME(sv));
5563 Safefree(IoFMT_NAME(sv));
5564 Safefree(IoBOTTOM_NAME(sv));
5565 /* PVIOs aren't from arenas */
5568 old_body_arena = (void **) &PL_xpvbm_root;
5571 old_body_arena = (void **) &PL_xpvcv_root;
5573 /* PVFMs aren't from arenas */
5578 old_body_arena = (void **) &PL_xpvhv_root;
5579 old_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill);
5583 old_body_arena = (void **) &PL_xpvav_root;
5584 old_body_offset = STRUCT_OFFSET(XPVAV, xav_fill);
5587 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5588 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5589 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5590 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5592 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5593 SvREFCNT_dec(LvTARG(sv));
5594 old_body_arena = (void **) &PL_xpvlv_root;
5598 Safefree(GvNAME(sv));
5599 /* If we're in a stash, we don't own a reference to it. However it does
5600 have a back reference to us, which needs to be cleared. */
5602 sv_del_backref((SV*)GvSTASH(sv), sv);
5603 old_body_arena = (void **) &PL_xpvgv_root;
5606 old_body_arena = (void **) &PL_xpvmg_root;
5609 old_body_arena = (void **) &PL_xpvnv_root;
5612 old_body_arena = (void **) &PL_xpviv_root;
5613 old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur);
5615 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5617 SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
5618 /* Don't even bother with turning off the OOK flag. */
5622 old_body_arena = (void **) &PL_xpv_root;
5623 old_body_offset = STRUCT_OFFSET(XPV, xpv_cur);
5627 SV *target = SvRV(sv);
5629 sv_del_backref(target, sv);
5631 SvREFCNT_dec(target);
5633 #ifdef PERL_OLD_COPY_ON_WRITE
5634 else if (SvPVX_const(sv)) {
5636 /* I believe I need to grab the global SV mutex here and
5637 then recheck the COW status. */
5639 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5642 sv_release_COW(sv, SvPVX_const(sv), SvLEN(sv),
5643 SV_COW_NEXT_SV(sv));
5644 /* And drop it here. */
5646 } else if (SvLEN(sv)) {
5647 Safefree(SvPVX_const(sv));
5651 else if (SvPVX_const(sv) && SvLEN(sv))
5652 Safefree(SvPVX_mutable(sv));
5653 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5654 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5660 old_body_arena = (void **) &PL_xnv_root;
5664 SvFLAGS(sv) &= SVf_BREAK;
5665 SvFLAGS(sv) |= SVTYPEMASK;
5668 if (old_body_arena) {
5669 del_body(((char *)SvANY(sv) + old_body_offset), old_body_arena);
5673 if (type > SVt_RV) {
5674 my_safefree(SvANY(sv));
5679 =for apidoc sv_newref
5681 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5688 Perl_sv_newref(pTHX_ SV *sv)
5698 Decrement an SV's reference count, and if it drops to zero, call
5699 C<sv_clear> to invoke destructors and free up any memory used by
5700 the body; finally, deallocate the SV's head itself.
5701 Normally called via a wrapper macro C<SvREFCNT_dec>.
5707 Perl_sv_free(pTHX_ SV *sv)
5712 if (SvREFCNT(sv) == 0) {
5713 if (SvFLAGS(sv) & SVf_BREAK)
5714 /* this SV's refcnt has been artificially decremented to
5715 * trigger cleanup */
5717 if (PL_in_clean_all) /* All is fair */
5719 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5720 /* make sure SvREFCNT(sv)==0 happens very seldom */
5721 SvREFCNT(sv) = (~(U32)0)/2;
5724 if (ckWARN_d(WARN_INTERNAL)) {
5725 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5726 "Attempt to free unreferenced scalar: SV 0x%"UVxf
5727 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5728 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5729 Perl_dump_sv_child(aTHX_ sv);
5734 if (--(SvREFCNT(sv)) > 0)
5736 Perl_sv_free2(aTHX_ sv);
5740 Perl_sv_free2(pTHX_ SV *sv)
5745 if (ckWARN_d(WARN_DEBUGGING))
5746 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5747 "Attempt to free temp prematurely: SV 0x%"UVxf
5748 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5752 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5753 /* make sure SvREFCNT(sv)==0 happens very seldom */
5754 SvREFCNT(sv) = (~(U32)0)/2;
5765 Returns the length of the string in the SV. Handles magic and type
5766 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5772 Perl_sv_len(pTHX_ register SV *sv)
5780 len = mg_length(sv);
5782 (void)SvPV_const(sv, len);
5787 =for apidoc sv_len_utf8
5789 Returns the number of characters in the string in an SV, counting wide
5790 UTF-8 bytes as a single character. Handles magic and type coercion.
5796 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
5797 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
5798 * (Note that the mg_len is not the length of the mg_ptr field.)
5803 Perl_sv_len_utf8(pTHX_ register SV *sv)
5809 return mg_length(sv);
5813 const U8 *s = (U8*)SvPV_const(sv, len);
5814 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
5816 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
5818 #ifdef PERL_UTF8_CACHE_ASSERT
5819 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
5823 ulen = Perl_utf8_length(aTHX_ s, s + len);
5824 if (!mg && !SvREADONLY(sv)) {
5825 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5826 mg = mg_find(sv, PERL_MAGIC_utf8);
5836 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
5837 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5838 * between UTF-8 and byte offsets. There are two (substr offset and substr
5839 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
5840 * and byte offset) cache positions.
5842 * The mg_len field is used by sv_len_utf8(), see its comments.
5843 * Note that the mg_len is not the length of the mg_ptr field.
5847 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i,
5848 I32 offsetp, const U8 *s, const U8 *start)
5852 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5854 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
5858 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5860 Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5861 (*mgp)->mg_ptr = (char *) *cachep;
5865 (*cachep)[i] = offsetp;
5866 (*cachep)[i+1] = s - start;
5874 * S_utf8_mg_pos() is used to query and update mg_ptr field of
5875 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5876 * between UTF-8 and byte offsets. See also the comments of
5877 * S_utf8_mg_pos_init().
5881 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)
5885 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5887 *mgp = mg_find(sv, PERL_MAGIC_utf8);
5888 if (*mgp && (*mgp)->mg_ptr) {
5889 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5890 ASSERT_UTF8_CACHE(*cachep);
5891 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
5893 else { /* We will skip to the right spot. */
5898 /* The assumption is that going backward is half
5899 * the speed of going forward (that's where the
5900 * 2 * backw in the below comes from). (The real
5901 * figure of course depends on the UTF-8 data.) */
5903 if ((*cachep)[i] > (STRLEN)uoff) {
5905 backw = (*cachep)[i] - (STRLEN)uoff;
5907 if (forw < 2 * backw)
5910 p = start + (*cachep)[i+1];
5912 /* Try this only for the substr offset (i == 0),
5913 * not for the substr length (i == 2). */
5914 else if (i == 0) { /* (*cachep)[i] < uoff */
5915 const STRLEN ulen = sv_len_utf8(sv);
5917 if ((STRLEN)uoff < ulen) {
5918 forw = (STRLEN)uoff - (*cachep)[i];
5919 backw = ulen - (STRLEN)uoff;
5921 if (forw < 2 * backw)
5922 p = start + (*cachep)[i+1];
5927 /* If the string is not long enough for uoff,
5928 * we could extend it, but not at this low a level. */
5932 if (forw < 2 * backw) {
5939 while (UTF8_IS_CONTINUATION(*p))
5944 /* Update the cache. */
5945 (*cachep)[i] = (STRLEN)uoff;
5946 (*cachep)[i+1] = p - start;
5948 /* Drop the stale "length" cache */
5957 if (found) { /* Setup the return values. */
5958 *offsetp = (*cachep)[i+1];
5959 *sp = start + *offsetp;
5962 *offsetp = send - start;
5964 else if (*sp < start) {
5970 #ifdef PERL_UTF8_CACHE_ASSERT
5975 while (n-- && s < send)
5979 assert(*offsetp == s - start);
5980 assert((*cachep)[0] == (STRLEN)uoff);
5981 assert((*cachep)[1] == *offsetp);
5983 ASSERT_UTF8_CACHE(*cachep);
5992 =for apidoc sv_pos_u2b
5994 Converts the value pointed to by offsetp from a count of UTF-8 chars from
5995 the start of the string, to a count of the equivalent number of bytes; if
5996 lenp is non-zero, it does the same to lenp, but this time starting from
5997 the offset, rather than from the start of the string. Handles magic and
6004 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6005 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6006 * byte offsets. See also the comments of S_utf8_mg_pos().
6011 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
6019 start = (U8*)SvPV_const(sv, len);
6023 const U8 *s = start;
6024 I32 uoffset = *offsetp;
6025 const U8 * const send = s + len;
6029 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
6031 if (!found && uoffset > 0) {
6032 while (s < send && uoffset--)
6036 if (utf8_mg_pos_init(sv, &mg, &cache, 0, *offsetp, s, start))
6038 *offsetp = s - start;
6043 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) {
6047 if (!found && *lenp > 0) {
6050 while (s < send && ulen--)
6054 utf8_mg_pos_init(sv, &mg, &cache, 2, *lenp, s, start);
6058 ASSERT_UTF8_CACHE(cache);
6070 =for apidoc sv_pos_b2u
6072 Converts the value pointed to by offsetp from a count of bytes from the
6073 start of the string, to a count of the equivalent number of UTF-8 chars.
6074 Handles magic and type coercion.
6080 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6081 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6082 * byte offsets. See also the comments of S_utf8_mg_pos().
6087 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
6095 s = (const U8*)SvPV_const(sv, len);
6096 if ((I32)len < *offsetp)
6097 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6099 const U8* send = s + *offsetp;
6101 STRLEN *cache = NULL;
6105 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6106 mg = mg_find(sv, PERL_MAGIC_utf8);
6107 if (mg && mg->mg_ptr) {
6108 cache = (STRLEN *) mg->mg_ptr;
6109 if (cache[1] == (STRLEN)*offsetp) {
6110 /* An exact match. */
6111 *offsetp = cache[0];
6115 else if (cache[1] < (STRLEN)*offsetp) {
6116 /* We already know part of the way. */
6119 /* Let the below loop do the rest. */
6121 else { /* cache[1] > *offsetp */
6122 /* We already know all of the way, now we may
6123 * be able to walk back. The same assumption
6124 * is made as in S_utf8_mg_pos(), namely that
6125 * walking backward is twice slower than
6126 * walking forward. */
6127 const STRLEN forw = *offsetp;
6128 STRLEN backw = cache[1] - *offsetp;
6130 if (!(forw < 2 * backw)) {
6131 const U8 *p = s + cache[1];
6138 while (UTF8_IS_CONTINUATION(*p)) {
6146 *offsetp = cache[0];
6148 /* Drop the stale "length" cache */
6156 ASSERT_UTF8_CACHE(cache);
6162 /* Call utf8n_to_uvchr() to validate the sequence
6163 * (unless a simple non-UTF character) */
6164 if (!UTF8_IS_INVARIANT(*s))
6165 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
6174 if (!SvREADONLY(sv)) {
6176 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6177 mg = mg_find(sv, PERL_MAGIC_utf8);
6182 Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6183 mg->mg_ptr = (char *) cache;
6188 cache[1] = *offsetp;
6189 /* Drop the stale "length" cache */
6202 Returns a boolean indicating whether the strings in the two SVs are
6203 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6204 coerce its args to strings if necessary.
6210 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6218 SV* svrecode = Nullsv;
6225 pv1 = SvPV_const(sv1, cur1);
6232 pv2 = SvPV_const(sv2, cur2);
6234 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6235 /* Differing utf8ness.
6236 * Do not UTF8size the comparands as a side-effect. */
6239 svrecode = newSVpvn(pv2, cur2);
6240 sv_recode_to_utf8(svrecode, PL_encoding);
6241 pv2 = SvPV_const(svrecode, cur2);
6244 svrecode = newSVpvn(pv1, cur1);
6245 sv_recode_to_utf8(svrecode, PL_encoding);
6246 pv1 = SvPV_const(svrecode, cur1);
6248 /* Now both are in UTF-8. */
6250 SvREFCNT_dec(svrecode);
6255 bool is_utf8 = TRUE;
6258 /* sv1 is the UTF-8 one,
6259 * if is equal it must be downgrade-able */
6260 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6266 /* sv2 is the UTF-8 one,
6267 * if is equal it must be downgrade-able */
6268 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6274 /* Downgrade not possible - cannot be eq */
6282 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6285 SvREFCNT_dec(svrecode);
6296 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6297 string in C<sv1> is less than, equal to, or greater than the string in
6298 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6299 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6305 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6308 const char *pv1, *pv2;
6311 SV *svrecode = Nullsv;
6318 pv1 = SvPV_const(sv1, cur1);
6325 pv2 = SvPV_const(sv2, cur2);
6327 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6328 /* Differing utf8ness.
6329 * Do not UTF8size the comparands as a side-effect. */
6332 svrecode = newSVpvn(pv2, cur2);
6333 sv_recode_to_utf8(svrecode, PL_encoding);
6334 pv2 = SvPV_const(svrecode, cur2);
6337 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6342 svrecode = newSVpvn(pv1, cur1);
6343 sv_recode_to_utf8(svrecode, PL_encoding);
6344 pv1 = SvPV_const(svrecode, cur1);
6347 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6353 cmp = cur2 ? -1 : 0;
6357 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6360 cmp = retval < 0 ? -1 : 1;
6361 } else if (cur1 == cur2) {
6364 cmp = cur1 < cur2 ? -1 : 1;
6369 SvREFCNT_dec(svrecode);
6378 =for apidoc sv_cmp_locale
6380 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6381 'use bytes' aware, handles get magic, and will coerce its args to strings
6382 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6388 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6390 #ifdef USE_LOCALE_COLLATE
6396 if (PL_collation_standard)
6400 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6402 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6404 if (!pv1 || !len1) {
6415 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6418 return retval < 0 ? -1 : 1;
6421 * When the result of collation is equality, that doesn't mean
6422 * that there are no differences -- some locales exclude some
6423 * characters from consideration. So to avoid false equalities,
6424 * we use the raw string as a tiebreaker.
6430 #endif /* USE_LOCALE_COLLATE */
6432 return sv_cmp(sv1, sv2);
6436 #ifdef USE_LOCALE_COLLATE
6439 =for apidoc sv_collxfrm
6441 Add Collate Transform magic to an SV if it doesn't already have it.
6443 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6444 scalar data of the variable, but transformed to such a format that a normal
6445 memory comparison can be used to compare the data according to the locale
6452 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6456 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6457 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6463 Safefree(mg->mg_ptr);
6464 s = SvPV_const(sv, len);
6465 if ((xf = mem_collxfrm(s, len, &xlen))) {
6466 if (SvREADONLY(sv)) {
6469 return xf + sizeof(PL_collation_ix);
6472 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6473 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6486 if (mg && mg->mg_ptr) {
6488 return mg->mg_ptr + sizeof(PL_collation_ix);
6496 #endif /* USE_LOCALE_COLLATE */
6501 Get a line from the filehandle and store it into the SV, optionally
6502 appending to the currently-stored string.
6508 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6512 register STDCHAR rslast;
6513 register STDCHAR *bp;
6519 if (SvTHINKFIRST(sv))
6520 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6521 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6523 However, perlbench says it's slower, because the existing swipe code
6524 is faster than copy on write.
6525 Swings and roundabouts. */
6526 SvUPGRADE(sv, SVt_PV);
6531 if (PerlIO_isutf8(fp)) {
6533 sv_utf8_upgrade_nomg(sv);
6534 sv_pos_u2b(sv,&append,0);
6536 } else if (SvUTF8(sv)) {
6537 SV * const tsv = NEWSV(0,0);
6538 sv_gets(tsv, fp, 0);
6539 sv_utf8_upgrade_nomg(tsv);
6540 SvCUR_set(sv,append);
6543 goto return_string_or_null;
6548 if (PerlIO_isutf8(fp))
6551 if (IN_PERL_COMPILETIME) {
6552 /* we always read code in line mode */
6556 else if (RsSNARF(PL_rs)) {
6557 /* If it is a regular disk file use size from stat() as estimate
6558 of amount we are going to read - may result in malloc-ing
6559 more memory than we realy need if layers bellow reduce
6560 size we read (e.g. CRLF or a gzip layer)
6563 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6564 const Off_t offset = PerlIO_tell(fp);
6565 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6566 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6572 else if (RsRECORD(PL_rs)) {
6576 /* Grab the size of the record we're getting */
6577 recsize = SvIV(SvRV(PL_rs));
6578 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6581 /* VMS wants read instead of fread, because fread doesn't respect */
6582 /* RMS record boundaries. This is not necessarily a good thing to be */
6583 /* doing, but we've got no other real choice - except avoid stdio
6584 as implementation - perhaps write a :vms layer ?
6586 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6588 bytesread = PerlIO_read(fp, buffer, recsize);
6592 SvCUR_set(sv, bytesread += append);
6593 buffer[bytesread] = '\0';
6594 goto return_string_or_null;
6596 else if (RsPARA(PL_rs)) {
6602 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6603 if (PerlIO_isutf8(fp)) {
6604 rsptr = SvPVutf8(PL_rs, rslen);
6607 if (SvUTF8(PL_rs)) {
6608 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6609 Perl_croak(aTHX_ "Wide character in $/");
6612 rsptr = SvPV_const(PL_rs, rslen);
6616 rslast = rslen ? rsptr[rslen - 1] : '\0';
6618 if (rspara) { /* have to do this both before and after */
6619 do { /* to make sure file boundaries work right */
6622 i = PerlIO_getc(fp);
6626 PerlIO_ungetc(fp,i);
6632 /* See if we know enough about I/O mechanism to cheat it ! */
6634 /* This used to be #ifdef test - it is made run-time test for ease
6635 of abstracting out stdio interface. One call should be cheap
6636 enough here - and may even be a macro allowing compile
6640 if (PerlIO_fast_gets(fp)) {
6643 * We're going to steal some values from the stdio struct
6644 * and put EVERYTHING in the innermost loop into registers.
6646 register STDCHAR *ptr;
6650 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6651 /* An ungetc()d char is handled separately from the regular
6652 * buffer, so we getc() it back out and stuff it in the buffer.
6654 i = PerlIO_getc(fp);
6655 if (i == EOF) return 0;
6656 *(--((*fp)->_ptr)) = (unsigned char) i;
6660 /* Here is some breathtakingly efficient cheating */
6662 cnt = PerlIO_get_cnt(fp); /* get count into register */
6663 /* make sure we have the room */
6664 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
6665 /* Not room for all of it
6666 if we are looking for a separator and room for some
6668 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
6669 /* just process what we have room for */
6670 shortbuffered = cnt - SvLEN(sv) + append + 1;
6671 cnt -= shortbuffered;
6675 /* remember that cnt can be negative */
6676 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
6681 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
6682 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
6683 DEBUG_P(PerlIO_printf(Perl_debug_log,
6684 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6685 DEBUG_P(PerlIO_printf(Perl_debug_log,
6686 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6687 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6688 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6693 while (cnt > 0) { /* this | eat */
6695 if ((*bp++ = *ptr++) == rslast) /* really | dust */
6696 goto thats_all_folks; /* screams | sed :-) */
6700 Copy(ptr, bp, cnt, char); /* this | eat */
6701 bp += cnt; /* screams | dust */
6702 ptr += cnt; /* louder | sed :-) */
6707 if (shortbuffered) { /* oh well, must extend */
6708 cnt = shortbuffered;
6710 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6712 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6713 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6717 DEBUG_P(PerlIO_printf(Perl_debug_log,
6718 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6719 PTR2UV(ptr),(long)cnt));
6720 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6722 DEBUG_P(PerlIO_printf(Perl_debug_log,
6723 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6724 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6725 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6727 /* This used to call 'filbuf' in stdio form, but as that behaves like
6728 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6729 another abstraction. */
6730 i = PerlIO_getc(fp); /* get more characters */
6732 DEBUG_P(PerlIO_printf(Perl_debug_log,
6733 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6734 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6735 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6737 cnt = PerlIO_get_cnt(fp);
6738 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
6739 DEBUG_P(PerlIO_printf(Perl_debug_log,
6740 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6742 if (i == EOF) /* all done for ever? */
6743 goto thats_really_all_folks;
6745 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6747 SvGROW(sv, bpx + cnt + 2);
6748 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6750 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
6752 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
6753 goto thats_all_folks;
6757 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
6758 memNE((char*)bp - rslen, rsptr, rslen))
6759 goto screamer; /* go back to the fray */
6760 thats_really_all_folks:
6762 cnt += shortbuffered;
6763 DEBUG_P(PerlIO_printf(Perl_debug_log,
6764 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6765 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
6766 DEBUG_P(PerlIO_printf(Perl_debug_log,
6767 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6768 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6769 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6771 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
6772 DEBUG_P(PerlIO_printf(Perl_debug_log,
6773 "Screamer: done, len=%ld, string=|%.*s|\n",
6774 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
6778 /*The big, slow, and stupid way. */
6779 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
6781 New(0, buf, 8192, STDCHAR);
6789 const register STDCHAR *bpe = buf + sizeof(buf);
6791 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6792 ; /* keep reading */
6796 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6797 /* Accomodate broken VAXC compiler, which applies U8 cast to
6798 * both args of ?: operator, causing EOF to change into 255
6801 i = (U8)buf[cnt - 1];
6807 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
6809 sv_catpvn(sv, (char *) buf, cnt);
6811 sv_setpvn(sv, (char *) buf, cnt);
6813 if (i != EOF && /* joy */
6815 SvCUR(sv) < rslen ||
6816 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6820 * If we're reading from a TTY and we get a short read,
6821 * indicating that the user hit his EOF character, we need
6822 * to notice it now, because if we try to read from the TTY
6823 * again, the EOF condition will disappear.
6825 * The comparison of cnt to sizeof(buf) is an optimization
6826 * that prevents unnecessary calls to feof().
6830 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
6834 #ifdef USE_HEAP_INSTEAD_OF_STACK
6839 if (rspara) { /* have to do this both before and after */
6840 while (i != EOF) { /* to make sure file boundaries work right */
6841 i = PerlIO_getc(fp);
6843 PerlIO_ungetc(fp,i);
6849 return_string_or_null:
6850 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
6856 Auto-increment of the value in the SV, doing string to numeric conversion
6857 if necessary. Handles 'get' magic.
6863 Perl_sv_inc(pTHX_ register SV *sv)
6872 if (SvTHINKFIRST(sv)) {
6874 sv_force_normal_flags(sv, 0);
6875 if (SvREADONLY(sv)) {
6876 if (IN_PERL_RUNTIME)
6877 Perl_croak(aTHX_ PL_no_modify);
6881 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6883 i = PTR2IV(SvRV(sv));
6888 flags = SvFLAGS(sv);
6889 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6890 /* It's (privately or publicly) a float, but not tested as an
6891 integer, so test it to see. */
6893 flags = SvFLAGS(sv);
6895 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6896 /* It's publicly an integer, or privately an integer-not-float */
6897 #ifdef PERL_PRESERVE_IVUV
6901 if (SvUVX(sv) == UV_MAX)
6902 sv_setnv(sv, UV_MAX_P1);
6904 (void)SvIOK_only_UV(sv);
6905 SvUV_set(sv, SvUVX(sv) + 1);
6907 if (SvIVX(sv) == IV_MAX)
6908 sv_setuv(sv, (UV)IV_MAX + 1);
6910 (void)SvIOK_only(sv);
6911 SvIV_set(sv, SvIVX(sv) + 1);
6916 if (flags & SVp_NOK) {
6917 (void)SvNOK_only(sv);
6918 SvNV_set(sv, SvNVX(sv) + 1.0);
6922 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
6923 if ((flags & SVTYPEMASK) < SVt_PVIV)
6924 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
6925 (void)SvIOK_only(sv);
6930 while (isALPHA(*d)) d++;
6931 while (isDIGIT(*d)) d++;
6933 #ifdef PERL_PRESERVE_IVUV
6934 /* Got to punt this as an integer if needs be, but we don't issue
6935 warnings. Probably ought to make the sv_iv_please() that does
6936 the conversion if possible, and silently. */
6937 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6938 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6939 /* Need to try really hard to see if it's an integer.
6940 9.22337203685478e+18 is an integer.
6941 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6942 so $a="9.22337203685478e+18"; $a+0; $a++
6943 needs to be the same as $a="9.22337203685478e+18"; $a++
6950 /* sv_2iv *should* have made this an NV */
6951 if (flags & SVp_NOK) {
6952 (void)SvNOK_only(sv);
6953 SvNV_set(sv, SvNVX(sv) + 1.0);
6956 /* I don't think we can get here. Maybe I should assert this
6957 And if we do get here I suspect that sv_setnv will croak. NWC
6959 #if defined(USE_LONG_DOUBLE)
6960 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",
6961 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6963 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6964 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6967 #endif /* PERL_PRESERVE_IVUV */
6968 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
6972 while (d >= SvPVX_const(sv)) {
6980 /* MKS: The original code here died if letters weren't consecutive.
6981 * at least it didn't have to worry about non-C locales. The
6982 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6983 * arranged in order (although not consecutively) and that only
6984 * [A-Za-z] are accepted by isALPHA in the C locale.
6986 if (*d != 'z' && *d != 'Z') {
6987 do { ++*d; } while (!isALPHA(*d));
6990 *(d--) -= 'z' - 'a';
6995 *(d--) -= 'z' - 'a' + 1;
6999 /* oh,oh, the number grew */
7000 SvGROW(sv, SvCUR(sv) + 2);
7001 SvCUR_set(sv, SvCUR(sv) + 1);
7002 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7013 Auto-decrement of the value in the SV, doing string to numeric conversion
7014 if necessary. Handles 'get' magic.
7020 Perl_sv_dec(pTHX_ register SV *sv)
7028 if (SvTHINKFIRST(sv)) {
7030 sv_force_normal_flags(sv, 0);
7031 if (SvREADONLY(sv)) {
7032 if (IN_PERL_RUNTIME)
7033 Perl_croak(aTHX_ PL_no_modify);
7037 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7039 i = PTR2IV(SvRV(sv));
7044 /* Unlike sv_inc we don't have to worry about string-never-numbers
7045 and keeping them magic. But we mustn't warn on punting */
7046 flags = SvFLAGS(sv);
7047 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7048 /* It's publicly an integer, or privately an integer-not-float */
7049 #ifdef PERL_PRESERVE_IVUV
7053 if (SvUVX(sv) == 0) {
7054 (void)SvIOK_only(sv);
7058 (void)SvIOK_only_UV(sv);
7059 SvUV_set(sv, SvUVX(sv) + 1);
7062 if (SvIVX(sv) == IV_MIN)
7063 sv_setnv(sv, (NV)IV_MIN - 1.0);
7065 (void)SvIOK_only(sv);
7066 SvIV_set(sv, SvIVX(sv) - 1);
7071 if (flags & SVp_NOK) {
7072 SvNV_set(sv, SvNVX(sv) - 1.0);
7073 (void)SvNOK_only(sv);
7076 if (!(flags & SVp_POK)) {
7077 if ((flags & SVTYPEMASK) < SVt_PVIV)
7078 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
7080 (void)SvIOK_only(sv);
7083 #ifdef PERL_PRESERVE_IVUV
7085 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7086 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7087 /* Need to try really hard to see if it's an integer.
7088 9.22337203685478e+18 is an integer.
7089 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7090 so $a="9.22337203685478e+18"; $a+0; $a--
7091 needs to be the same as $a="9.22337203685478e+18"; $a--
7098 /* sv_2iv *should* have made this an NV */
7099 if (flags & SVp_NOK) {
7100 (void)SvNOK_only(sv);
7101 SvNV_set(sv, SvNVX(sv) - 1.0);
7104 /* I don't think we can get here. Maybe I should assert this
7105 And if we do get here I suspect that sv_setnv will croak. NWC
7107 #if defined(USE_LONG_DOUBLE)
7108 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",
7109 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7111 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7112 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7116 #endif /* PERL_PRESERVE_IVUV */
7117 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
7121 =for apidoc sv_mortalcopy
7123 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7124 The new SV is marked as mortal. It will be destroyed "soon", either by an
7125 explicit call to FREETMPS, or by an implicit call at places such as
7126 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7131 /* Make a string that will exist for the duration of the expression
7132 * evaluation. Actually, it may have to last longer than that, but
7133 * hopefully we won't free it until it has been assigned to a
7134 * permanent location. */
7137 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
7142 sv_setsv(sv,oldstr);
7144 PL_tmps_stack[++PL_tmps_ix] = sv;
7150 =for apidoc sv_newmortal
7152 Creates a new null SV which is mortal. The reference count of the SV is
7153 set to 1. It will be destroyed "soon", either by an explicit call to
7154 FREETMPS, or by an implicit call at places such as statement boundaries.
7155 See also C<sv_mortalcopy> and C<sv_2mortal>.
7161 Perl_sv_newmortal(pTHX)
7166 SvFLAGS(sv) = SVs_TEMP;
7168 PL_tmps_stack[++PL_tmps_ix] = sv;
7173 =for apidoc sv_2mortal
7175 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7176 by an explicit call to FREETMPS, or by an implicit call at places such as
7177 statement boundaries. SvTEMP() is turned on which means that the SV's
7178 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7179 and C<sv_mortalcopy>.
7185 Perl_sv_2mortal(pTHX_ register SV *sv)
7190 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7193 PL_tmps_stack[++PL_tmps_ix] = sv;
7201 Creates a new SV and copies a string into it. The reference count for the
7202 SV is set to 1. If C<len> is zero, Perl will compute the length using
7203 strlen(). For efficiency, consider using C<newSVpvn> instead.
7209 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
7214 sv_setpvn(sv,s,len ? len : strlen(s));
7219 =for apidoc newSVpvn
7221 Creates a new SV and copies a string into it. The reference count for the
7222 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7223 string. You are responsible for ensuring that the source string is at least
7224 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7230 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7235 sv_setpvn(sv,s,len);
7241 =for apidoc newSVhek
7243 Creates a new SV from the hash key structure. It will generate scalars that
7244 point to the shared string table where possible. Returns a new (undefined)
7245 SV if the hek is NULL.
7251 Perl_newSVhek(pTHX_ const HEK *hek)
7260 if (HEK_LEN(hek) == HEf_SVKEY) {
7261 return newSVsv(*(SV**)HEK_KEY(hek));
7263 const int flags = HEK_FLAGS(hek);
7264 if (flags & HVhek_WASUTF8) {
7266 Andreas would like keys he put in as utf8 to come back as utf8
7268 STRLEN utf8_len = HEK_LEN(hek);
7269 U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7270 SV *sv = newSVpvn ((char*)as_utf8, utf8_len);
7273 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7275 } else if (flags & HVhek_REHASH) {
7276 /* We don't have a pointer to the hv, so we have to replicate the
7277 flag into every HEK. This hv is using custom a hasing
7278 algorithm. Hence we can't return a shared string scalar, as
7279 that would contain the (wrong) hash value, and might get passed
7280 into an hv routine with a regular hash */
7282 SV *sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7287 /* This will be overwhelminly the most common case. */
7288 return newSVpvn_share(HEK_KEY(hek),
7289 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
7295 =for apidoc newSVpvn_share
7297 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7298 table. If the string does not already exist in the table, it is created
7299 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
7300 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
7301 otherwise the hash is computed. The idea here is that as the string table
7302 is used for shared hash keys these strings will have SvPVX_const == HeKEY and
7303 hash lookup will avoid string compare.
7309 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7312 bool is_utf8 = FALSE;
7314 STRLEN tmplen = -len;
7316 /* See the note in hv.c:hv_fetch() --jhi */
7317 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7321 PERL_HASH(hash, src, len);
7323 sv_upgrade(sv, SVt_PV);
7324 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7336 #if defined(PERL_IMPLICIT_CONTEXT)
7338 /* pTHX_ magic can't cope with varargs, so this is a no-context
7339 * version of the main function, (which may itself be aliased to us).
7340 * Don't access this version directly.
7344 Perl_newSVpvf_nocontext(const char* pat, ...)
7349 va_start(args, pat);
7350 sv = vnewSVpvf(pat, &args);
7357 =for apidoc newSVpvf
7359 Creates a new SV and initializes it with the string formatted like
7366 Perl_newSVpvf(pTHX_ const char* pat, ...)
7370 va_start(args, pat);
7371 sv = vnewSVpvf(pat, &args);
7376 /* backend for newSVpvf() and newSVpvf_nocontext() */
7379 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7383 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7390 Creates a new SV and copies a floating point value into it.
7391 The reference count for the SV is set to 1.
7397 Perl_newSVnv(pTHX_ NV n)
7409 Creates a new SV and copies an integer into it. The reference count for the
7416 Perl_newSViv(pTHX_ IV i)
7428 Creates a new SV and copies an unsigned integer into it.
7429 The reference count for the SV is set to 1.
7435 Perl_newSVuv(pTHX_ UV u)
7445 =for apidoc newRV_noinc
7447 Creates an RV wrapper for an SV. The reference count for the original
7448 SV is B<not> incremented.
7454 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7459 sv_upgrade(sv, SVt_RV);
7461 SvRV_set(sv, tmpRef);
7466 /* newRV_inc is the official function name to use now.
7467 * newRV_inc is in fact #defined to newRV in sv.h
7471 Perl_newRV(pTHX_ SV *tmpRef)
7473 return newRV_noinc(SvREFCNT_inc(tmpRef));
7479 Creates a new SV which is an exact duplicate of the original SV.
7486 Perl_newSVsv(pTHX_ register SV *old)
7492 if (SvTYPE(old) == SVTYPEMASK) {
7493 if (ckWARN_d(WARN_INTERNAL))
7494 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7498 /* SV_GMAGIC is the default for sv_setv()
7499 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7500 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7501 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7506 =for apidoc sv_reset
7508 Underlying implementation for the C<reset> Perl function.
7509 Note that the perl-level function is vaguely deprecated.
7515 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
7518 char todo[PERL_UCHAR_MAX+1];
7523 if (!*s) { /* reset ?? searches */
7524 MAGIC *mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
7526 PMOP *pm = (PMOP *) mg->mg_obj;
7528 pm->op_pmdynflags &= ~PMdf_USED;
7535 /* reset variables */
7537 if (!HvARRAY(stash))
7540 Zero(todo, 256, char);
7543 I32 i = (unsigned char)*s;
7547 max = (unsigned char)*s++;
7548 for ( ; i <= max; i++) {
7551 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7553 for (entry = HvARRAY(stash)[i];
7555 entry = HeNEXT(entry))
7560 if (!todo[(U8)*HeKEY(entry)])
7562 gv = (GV*)HeVAL(entry);
7565 if (SvTHINKFIRST(sv)) {
7566 if (!SvREADONLY(sv) && SvROK(sv))
7568 /* XXX Is this continue a bug? Why should THINKFIRST
7569 exempt us from resetting arrays and hashes? */
7573 if (SvTYPE(sv) >= SVt_PV) {
7575 if (SvPVX_const(sv) != Nullch)
7583 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
7586 #ifdef USE_ENVIRON_ARRAY
7588 # ifdef USE_ITHREADS
7589 && PL_curinterp == aTHX
7593 environ[0] = Nullch;
7596 #endif /* !PERL_MICRO */
7606 Using various gambits, try to get an IO from an SV: the IO slot if its a
7607 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7608 named after the PV if we're a string.
7614 Perl_sv_2io(pTHX_ SV *sv)
7619 switch (SvTYPE(sv)) {
7627 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7631 Perl_croak(aTHX_ PL_no_usym, "filehandle");
7633 return sv_2io(SvRV(sv));
7634 gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
7640 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
7649 Using various gambits, try to get a CV from an SV; in addition, try if
7650 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7656 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7663 return *gvp = Nullgv, Nullcv;
7664 switch (SvTYPE(sv)) {
7683 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
7684 tryAMAGICunDEREF(to_cv);
7687 if (SvTYPE(sv) == SVt_PVCV) {
7696 Perl_croak(aTHX_ "Not a subroutine reference");
7701 gv = gv_fetchsv(sv, lref, SVt_PVCV);
7707 if (lref && !GvCVu(gv)) {
7710 tmpsv = NEWSV(704,0);
7711 gv_efullname3(tmpsv, gv, Nullch);
7712 /* XXX this is probably not what they think they're getting.
7713 * It has the same effect as "sub name;", i.e. just a forward
7715 newSUB(start_subparse(FALSE, 0),
7716 newSVOP(OP_CONST, 0, tmpsv),
7721 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
7731 Returns true if the SV has a true value by Perl's rules.
7732 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
7733 instead use an in-line version.
7739 Perl_sv_true(pTHX_ register SV *sv)
7744 const register XPV* tXpv;
7745 if ((tXpv = (XPV*)SvANY(sv)) &&
7746 (tXpv->xpv_cur > 1 ||
7747 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
7754 return SvIVX(sv) != 0;
7757 return SvNVX(sv) != 0.0;
7759 return sv_2bool(sv);
7767 A private implementation of the C<SvIVx> macro for compilers which can't
7768 cope with complex macro expressions. Always use the macro instead.
7774 Perl_sv_iv(pTHX_ register SV *sv)
7778 return (IV)SvUVX(sv);
7787 A private implementation of the C<SvUVx> macro for compilers which can't
7788 cope with complex macro expressions. Always use the macro instead.
7794 Perl_sv_uv(pTHX_ register SV *sv)
7799 return (UV)SvIVX(sv);
7807 A private implementation of the C<SvNVx> macro for compilers which can't
7808 cope with complex macro expressions. Always use the macro instead.
7814 Perl_sv_nv(pTHX_ register SV *sv)
7821 /* sv_pv() is now a macro using SvPV_nolen();
7822 * this function provided for binary compatibility only
7826 Perl_sv_pv(pTHX_ SV *sv)
7831 return sv_2pv(sv, 0);
7837 Use the C<SvPV_nolen> macro instead
7841 A private implementation of the C<SvPV> macro for compilers which can't
7842 cope with complex macro expressions. Always use the macro instead.
7848 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
7854 return sv_2pv(sv, lp);
7859 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
7865 return sv_2pv_flags(sv, lp, 0);
7868 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
7869 * this function provided for binary compatibility only
7873 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
7875 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
7879 =for apidoc sv_pvn_force
7881 Get a sensible string out of the SV somehow.
7882 A private implementation of the C<SvPV_force> macro for compilers which
7883 can't cope with complex macro expressions. Always use the macro instead.
7885 =for apidoc sv_pvn_force_flags
7887 Get a sensible string out of the SV somehow.
7888 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
7889 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
7890 implemented in terms of this function.
7891 You normally want to use the various wrapper macros instead: see
7892 C<SvPV_force> and C<SvPV_force_nomg>
7898 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
7901 if (SvTHINKFIRST(sv) && !SvROK(sv))
7902 sv_force_normal_flags(sv, 0);
7912 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
7914 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
7915 sv_reftype(sv,0), OP_NAME(PL_op));
7917 Perl_croak(aTHX_ "Can't coerce readonly %s to string",
7920 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
7921 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
7925 s = sv_2pv_flags(sv, &len, flags);
7929 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
7932 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
7933 SvGROW(sv, len + 1);
7934 Move(s,SvPVX_const(sv),len,char);
7939 SvPOK_on(sv); /* validate pointer */
7941 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
7942 PTR2UV(sv),SvPVX_const(sv)));
7945 return SvPVX_mutable(sv);
7948 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
7949 * this function provided for binary compatibility only
7953 Perl_sv_pvbyte(pTHX_ SV *sv)
7955 sv_utf8_downgrade(sv,0);
7960 =for apidoc sv_pvbyte
7962 Use C<SvPVbyte_nolen> instead.
7964 =for apidoc sv_pvbyten
7966 A private implementation of the C<SvPVbyte> macro for compilers
7967 which can't cope with complex macro expressions. Always use the macro
7974 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
7976 sv_utf8_downgrade(sv,0);
7977 return sv_pvn(sv,lp);
7981 =for apidoc sv_pvbyten_force
7983 A private implementation of the C<SvPVbytex_force> macro for compilers
7984 which can't cope with complex macro expressions. Always use the macro
7991 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
7993 sv_pvn_force(sv,lp);
7994 sv_utf8_downgrade(sv,0);
7999 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
8000 * this function provided for binary compatibility only
8004 Perl_sv_pvutf8(pTHX_ SV *sv)
8006 sv_utf8_upgrade(sv);
8011 =for apidoc sv_pvutf8
8013 Use the C<SvPVutf8_nolen> macro instead
8015 =for apidoc sv_pvutf8n
8017 A private implementation of the C<SvPVutf8> macro for compilers
8018 which can't cope with complex macro expressions. Always use the macro
8025 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
8027 sv_utf8_upgrade(sv);
8028 return sv_pvn(sv,lp);
8032 =for apidoc sv_pvutf8n_force
8034 A private implementation of the C<SvPVutf8_force> macro for compilers
8035 which can't cope with complex macro expressions. Always use the macro
8042 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
8044 sv_pvn_force(sv,lp);
8045 sv_utf8_upgrade(sv);
8051 =for apidoc sv_reftype
8053 Returns a string describing what the SV is a reference to.
8059 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
8061 /* The fact that I don't need to downcast to char * everywhere, only in ?:
8062 inside return suggests a const propagation bug in g++. */
8063 if (ob && SvOBJECT(sv)) {
8064 char * const name = HvNAME_get(SvSTASH(sv));
8065 return name ? name : (char *) "__ANON__";
8068 switch (SvTYPE(sv)) {
8085 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
8086 /* tied lvalues should appear to be
8087 * scalars for backwards compatitbility */
8088 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8089 ? "SCALAR" : "LVALUE");
8090 case SVt_PVAV: return "ARRAY";
8091 case SVt_PVHV: return "HASH";
8092 case SVt_PVCV: return "CODE";
8093 case SVt_PVGV: return "GLOB";
8094 case SVt_PVFM: return "FORMAT";
8095 case SVt_PVIO: return "IO";
8096 default: return "UNKNOWN";
8102 =for apidoc sv_isobject
8104 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8105 object. If the SV is not an RV, or if the object is not blessed, then this
8112 Perl_sv_isobject(pTHX_ SV *sv)
8129 Returns a boolean indicating whether the SV is blessed into the specified
8130 class. This does not check for subtypes; use C<sv_derived_from> to verify
8131 an inheritance relationship.
8137 Perl_sv_isa(pTHX_ SV *sv, const char *name)
8149 hvname = HvNAME_get(SvSTASH(sv));
8153 return strEQ(hvname, name);
8159 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
8160 it will be upgraded to one. If C<classname> is non-null then the new SV will
8161 be blessed in the specified package. The new SV is returned and its
8162 reference count is 1.
8168 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
8174 SV_CHECK_THINKFIRST_COW_DROP(rv);
8177 if (SvTYPE(rv) >= SVt_PVMG) {
8178 const U32 refcnt = SvREFCNT(rv);
8182 SvREFCNT(rv) = refcnt;
8185 if (SvTYPE(rv) < SVt_RV)
8186 sv_upgrade(rv, SVt_RV);
8187 else if (SvTYPE(rv) > SVt_RV) {
8198 HV* const stash = gv_stashpv(classname, TRUE);
8199 (void)sv_bless(rv, stash);
8205 =for apidoc sv_setref_pv
8207 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
8208 argument will be upgraded to an RV. That RV will be modified to point to
8209 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8210 into the SV. The C<classname> argument indicates the package for the
8211 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8212 will have a reference count of 1, and the RV will be returned.
8214 Do not use with other Perl types such as HV, AV, SV, CV, because those
8215 objects will become corrupted by the pointer copy process.
8217 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8223 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
8226 sv_setsv(rv, &PL_sv_undef);
8230 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8235 =for apidoc sv_setref_iv
8237 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
8238 argument will be upgraded to an RV. That RV will be modified to point to
8239 the new SV. The C<classname> argument indicates the package for the
8240 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8241 will have a reference count of 1, and the RV will be returned.
8247 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
8249 sv_setiv(newSVrv(rv,classname), iv);
8254 =for apidoc sv_setref_uv
8256 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
8257 argument will be upgraded to an RV. That RV will be modified to point to
8258 the new SV. The C<classname> argument indicates the package for the
8259 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8260 will have a reference count of 1, and the RV will be returned.
8266 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
8268 sv_setuv(newSVrv(rv,classname), uv);
8273 =for apidoc sv_setref_nv
8275 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8276 argument will be upgraded to an RV. That RV will be modified to point to
8277 the new SV. The C<classname> argument indicates the package for the
8278 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8279 will have a reference count of 1, and the RV will be returned.
8285 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
8287 sv_setnv(newSVrv(rv,classname), nv);
8292 =for apidoc sv_setref_pvn
8294 Copies a string into a new SV, optionally blessing the SV. The length of the
8295 string must be specified with C<n>. The C<rv> argument will be upgraded to
8296 an RV. That RV will be modified to point to the new SV. The C<classname>
8297 argument indicates the package for the blessing. Set C<classname> to
8298 C<Nullch> to avoid the blessing. The new SV will have a reference count
8299 of 1, and the RV will be returned.
8301 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8307 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n)
8309 sv_setpvn(newSVrv(rv,classname), pv, n);
8314 =for apidoc sv_bless
8316 Blesses an SV into a specified package. The SV must be an RV. The package
8317 must be designated by its stash (see C<gv_stashpv()>). The reference count
8318 of the SV is unaffected.
8324 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8328 Perl_croak(aTHX_ "Can't bless non-reference value");
8330 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8331 if (SvREADONLY(tmpRef))
8332 Perl_croak(aTHX_ PL_no_modify);
8333 if (SvOBJECT(tmpRef)) {
8334 if (SvTYPE(tmpRef) != SVt_PVIO)
8336 SvREFCNT_dec(SvSTASH(tmpRef));
8339 SvOBJECT_on(tmpRef);
8340 if (SvTYPE(tmpRef) != SVt_PVIO)
8342 SvUPGRADE(tmpRef, SVt_PVMG);
8343 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
8350 if(SvSMAGICAL(tmpRef))
8351 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8359 /* Downgrades a PVGV to a PVMG.
8363 S_sv_unglob(pTHX_ SV *sv)
8367 assert(SvTYPE(sv) == SVt_PVGV);
8372 sv_del_backref((SV*)GvSTASH(sv), sv);
8373 GvSTASH(sv) = Nullhv;
8375 sv_unmagic(sv, PERL_MAGIC_glob);
8376 Safefree(GvNAME(sv));
8379 /* need to keep SvANY(sv) in the right arena */
8380 xpvmg = new_XPVMG();
8381 StructCopy(SvANY(sv), xpvmg, XPVMG);
8382 del_XPVGV(SvANY(sv));
8385 SvFLAGS(sv) &= ~SVTYPEMASK;
8386 SvFLAGS(sv) |= SVt_PVMG;
8390 =for apidoc sv_unref_flags
8392 Unsets the RV status of the SV, and decrements the reference count of
8393 whatever was being referenced by the RV. This can almost be thought of
8394 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8395 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8396 (otherwise the decrementing is conditional on the reference count being
8397 different from one or the reference being a readonly SV).
8404 Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags)
8406 SV* target = SvRV(ref);
8408 if (SvWEAKREF(ref)) {
8409 sv_del_backref(target, ref);
8411 SvRV_set(ref, NULL);
8414 SvRV_set(ref, NULL);
8416 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
8417 assigned to as BEGIN {$a = \"Foo"} will fail. */
8418 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
8419 SvREFCNT_dec(target);
8420 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8421 sv_2mortal(target); /* Schedule for freeing later */
8425 =for apidoc sv_unref
8427 Unsets the RV status of the SV, and decrements the reference count of
8428 whatever was being referenced by the RV. This can almost be thought of
8429 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
8430 being zero. See C<SvROK_off>.
8436 Perl_sv_unref(pTHX_ SV *sv)
8438 sv_unref_flags(sv, 0);
8442 =for apidoc sv_taint
8444 Taint an SV. Use C<SvTAINTED_on> instead.
8449 Perl_sv_taint(pTHX_ SV *sv)
8451 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
8455 =for apidoc sv_untaint
8457 Untaint an SV. Use C<SvTAINTED_off> instead.
8462 Perl_sv_untaint(pTHX_ SV *sv)
8464 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8465 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8472 =for apidoc sv_tainted
8474 Test an SV for taintedness. Use C<SvTAINTED> instead.
8479 Perl_sv_tainted(pTHX_ SV *sv)
8481 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8482 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8483 if (mg && (mg->mg_len & 1) )
8490 =for apidoc sv_setpviv
8492 Copies an integer into the given SV, also updating its string value.
8493 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8499 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8501 char buf[TYPE_CHARS(UV)];
8503 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8505 sv_setpvn(sv, ptr, ebuf - ptr);
8509 =for apidoc sv_setpviv_mg
8511 Like C<sv_setpviv>, but also handles 'set' magic.
8517 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8519 char buf[TYPE_CHARS(UV)];
8521 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8523 sv_setpvn(sv, ptr, ebuf - ptr);
8527 #if defined(PERL_IMPLICIT_CONTEXT)
8529 /* pTHX_ magic can't cope with varargs, so this is a no-context
8530 * version of the main function, (which may itself be aliased to us).
8531 * Don't access this version directly.
8535 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8539 va_start(args, pat);
8540 sv_vsetpvf(sv, pat, &args);
8544 /* pTHX_ magic can't cope with varargs, so this is a no-context
8545 * version of the main function, (which may itself be aliased to us).
8546 * Don't access this version directly.
8550 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8554 va_start(args, pat);
8555 sv_vsetpvf_mg(sv, pat, &args);
8561 =for apidoc sv_setpvf
8563 Works like C<sv_catpvf> but copies the text into the SV instead of
8564 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8570 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8573 va_start(args, pat);
8574 sv_vsetpvf(sv, pat, &args);
8579 =for apidoc sv_vsetpvf
8581 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8582 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8584 Usually used via its frontend C<sv_setpvf>.
8590 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8592 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8596 =for apidoc sv_setpvf_mg
8598 Like C<sv_setpvf>, but also handles 'set' magic.
8604 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8607 va_start(args, pat);
8608 sv_vsetpvf_mg(sv, pat, &args);
8613 =for apidoc sv_vsetpvf_mg
8615 Like C<sv_vsetpvf>, but also handles 'set' magic.
8617 Usually used via its frontend C<sv_setpvf_mg>.
8623 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8625 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8629 #if defined(PERL_IMPLICIT_CONTEXT)
8631 /* pTHX_ magic can't cope with varargs, so this is a no-context
8632 * version of the main function, (which may itself be aliased to us).
8633 * Don't access this version directly.
8637 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8641 va_start(args, pat);
8642 sv_vcatpvf(sv, pat, &args);
8646 /* pTHX_ magic can't cope with varargs, so this is a no-context
8647 * version of the main function, (which may itself be aliased to us).
8648 * Don't access this version directly.
8652 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8656 va_start(args, pat);
8657 sv_vcatpvf_mg(sv, pat, &args);
8663 =for apidoc sv_catpvf
8665 Processes its arguments like C<sprintf> and appends the formatted
8666 output to an SV. If the appended data contains "wide" characters
8667 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8668 and characters >255 formatted with %c), the original SV might get
8669 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
8670 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
8671 valid UTF-8; if the original SV was bytes, the pattern should be too.
8676 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8679 va_start(args, pat);
8680 sv_vcatpvf(sv, pat, &args);
8685 =for apidoc sv_vcatpvf
8687 Processes its arguments like C<vsprintf> and appends the formatted output
8688 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
8690 Usually used via its frontend C<sv_catpvf>.
8696 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8698 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8702 =for apidoc sv_catpvf_mg
8704 Like C<sv_catpvf>, but also handles 'set' magic.
8710 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8713 va_start(args, pat);
8714 sv_vcatpvf_mg(sv, pat, &args);
8719 =for apidoc sv_vcatpvf_mg
8721 Like C<sv_vcatpvf>, but also handles 'set' magic.
8723 Usually used via its frontend C<sv_catpvf_mg>.
8729 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8731 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8736 =for apidoc sv_vsetpvfn
8738 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
8741 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
8747 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8749 sv_setpvn(sv, "", 0);
8750 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8753 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
8756 S_expect_number(pTHX_ char** pattern)
8759 switch (**pattern) {
8760 case '1': case '2': case '3':
8761 case '4': case '5': case '6':
8762 case '7': case '8': case '9':
8763 while (isDIGIT(**pattern))
8764 var = var * 10 + (*(*pattern)++ - '0');
8768 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
8771 F0convert(NV nv, char *endbuf, STRLEN *len)
8773 const int neg = nv < 0;
8782 if (uv & 1 && uv == nv)
8783 uv--; /* Round to even */
8785 const unsigned dig = uv % 10;
8798 =for apidoc sv_vcatpvfn
8800 Processes its arguments like C<vsprintf> and appends the formatted output
8801 to an SV. Uses an array of SVs if the C style variable argument list is
8802 missing (NULL). When running with taint checks enabled, indicates via
8803 C<maybe_tainted> if results are untrustworthy (often due to the use of
8806 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
8811 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
8814 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8821 static const char nullstr[] = "(null)";
8823 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
8824 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
8826 /* Times 4: a decimal digit takes more than 3 binary digits.
8827 * NV_DIG: mantissa takes than many decimal digits.
8828 * Plus 32: Playing safe. */
8829 char ebuf[IV_DIG * 4 + NV_DIG + 32];
8830 /* large enough for "%#.#f" --chip */
8831 /* what about long double NVs? --jhi */
8833 PERL_UNUSED_ARG(maybe_tainted);
8835 /* no matter what, this is a string now */
8836 (void)SvPV_force(sv, origlen);
8838 /* special-case "", "%s", and "%-p" (SVf) */
8841 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
8843 const char * const s = va_arg(*args, char*);
8844 sv_catpv(sv, s ? s : nullstr);
8846 else if (svix < svmax) {
8847 sv_catsv(sv, *svargs);
8848 if (DO_UTF8(*svargs))
8853 if (patlen == 3 && pat[0] == '%' &&
8854 pat[1] == '-' && pat[2] == 'p') {
8856 argsv = va_arg(*args, SV*);
8857 sv_catsv(sv, argsv);
8864 #ifndef USE_LONG_DOUBLE
8865 /* special-case "%.<number>[gf]" */
8866 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
8867 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
8868 unsigned digits = 0;
8872 while (*pp >= '0' && *pp <= '9')
8873 digits = 10 * digits + (*pp++ - '0');
8874 if (pp - pat == (int)patlen - 1) {
8882 /* Add check for digits != 0 because it seems that some
8883 gconverts are buggy in this case, and we don't yet have
8884 a Configure test for this. */
8885 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
8886 /* 0, point, slack */
8887 Gconvert(nv, (int)digits, 0, ebuf);
8889 if (*ebuf) /* May return an empty string for digits==0 */
8892 } else if (!digits) {
8895 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
8896 sv_catpvn(sv, p, l);
8902 #endif /* !USE_LONG_DOUBLE */
8904 if (!args && svix < svmax && DO_UTF8(*svargs))
8907 patend = (char*)pat + patlen;
8908 for (p = (char*)pat; p < patend; p = q) {
8911 bool vectorize = FALSE;
8912 bool vectorarg = FALSE;
8913 bool vec_utf8 = FALSE;
8919 bool has_precis = FALSE;
8922 bool is_utf8 = FALSE; /* is this item utf8? */
8923 #ifdef HAS_LDBL_SPRINTF_BUG
8924 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8925 with sfio - Allen <allens@cpan.org> */
8926 bool fix_ldbl_sprintf_bug = FALSE;
8930 U8 utf8buf[UTF8_MAXBYTES+1];
8931 STRLEN esignlen = 0;
8933 const char *eptr = Nullch;
8936 const U8 *vecstr = Null(U8*);
8943 /* we need a long double target in case HAS_LONG_DOUBLE but
8946 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
8954 const char *dotstr = ".";
8955 STRLEN dotstrlen = 1;
8956 I32 efix = 0; /* explicit format parameter index */
8957 I32 ewix = 0; /* explicit width index */
8958 I32 epix = 0; /* explicit precision index */
8959 I32 evix = 0; /* explicit vector index */
8960 bool asterisk = FALSE;
8962 /* echo everything up to the next format specification */
8963 for (q = p; q < patend && *q != '%'; ++q) ;
8965 if (has_utf8 && !pat_utf8)
8966 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
8968 sv_catpvn(sv, p, q - p);
8975 We allow format specification elements in this order:
8976 \d+\$ explicit format parameter index
8978 v|\*(\d+\$)?v vector with optional (optionally specified) arg
8979 0 flag (as above): repeated to allow "v02"
8980 \d+|\*(\d+\$)? width using optional (optionally specified) arg
8981 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8983 [%bcdefginopsux_DFOUX] format (mandatory)
8985 if (EXPECT_NUMBER(q, width)) {
9026 if (EXPECT_NUMBER(q, ewix))
9035 if ((vectorarg = asterisk)) {
9047 EXPECT_NUMBER(q, width);
9052 vecsv = va_arg(*args, SV*);
9054 vecsv = (evix ? evix <= svmax : svix < svmax) ?
9055 svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
9056 dotstr = SvPV_const(vecsv, dotstrlen);
9061 vecsv = va_arg(*args, SV*);
9062 vecstr = (U8*)SvPV_const(vecsv,veclen);
9063 vec_utf8 = DO_UTF8(vecsv);
9065 else if (efix ? efix <= svmax : svix < svmax) {
9066 vecsv = svargs[efix ? efix-1 : svix++];
9067 vecstr = (U8*)SvPV_const(vecsv,veclen);
9068 vec_utf8 = DO_UTF8(vecsv);
9069 /* if this is a version object, we need to return the
9070 * stringified representation (which the SvPVX_const has
9071 * already done for us), but not vectorize the args
9073 if ( *q == 'd' && sv_derived_from(vecsv,"version") )
9075 q++; /* skip past the rest of the %vd format */
9076 eptr = (const char *) vecstr;
9077 elen = strlen(eptr);
9090 i = va_arg(*args, int);
9092 i = (ewix ? ewix <= svmax : svix < svmax) ?
9093 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9095 width = (i < 0) ? -i : i;
9105 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
9107 /* XXX: todo, support specified precision parameter */
9111 i = va_arg(*args, int);
9113 i = (ewix ? ewix <= svmax : svix < svmax)
9114 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9115 precis = (i < 0) ? 0 : i;
9120 precis = precis * 10 + (*q++ - '0');
9129 case 'I': /* Ix, I32x, and I64x */
9131 if (q[1] == '6' && q[2] == '4') {
9137 if (q[1] == '3' && q[2] == '2') {
9147 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9158 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9159 if (*(q + 1) == 'l') { /* lld, llf */
9184 argsv = (efix ? efix <= svmax : svix < svmax) ?
9185 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
9192 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
9194 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9196 eptr = (char*)utf8buf;
9197 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9208 if (args && !vectorize) {
9209 eptr = va_arg(*args, char*);
9211 #ifdef MACOS_TRADITIONAL
9212 /* On MacOS, %#s format is used for Pascal strings */
9217 elen = strlen(eptr);
9219 eptr = (char *)nullstr;
9220 elen = sizeof nullstr - 1;
9224 eptr = SvPVx_const(argsv, elen);
9225 if (DO_UTF8(argsv)) {
9226 if (has_precis && precis < elen) {
9228 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9231 if (width) { /* fudge width (can't fudge elen) */
9232 width += elen - sv_len_utf8(argsv);
9240 if (has_precis && elen > precis)
9247 if (left && args) { /* SVf */
9256 argsv = va_arg(*args, SV*);
9257 eptr = SvPVx_const(argsv, elen);
9262 if (alt || vectorize)
9264 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9282 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9291 esignbuf[esignlen++] = plus;
9295 case 'h': iv = (short)va_arg(*args, int); break;
9296 case 'l': iv = va_arg(*args, long); break;
9297 case 'V': iv = va_arg(*args, IV); break;
9298 default: iv = va_arg(*args, int); break;
9300 case 'q': iv = va_arg(*args, Quad_t); break;
9305 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
9307 case 'h': iv = (short)tiv; break;
9308 case 'l': iv = (long)tiv; break;
9310 default: iv = tiv; break;
9312 case 'q': iv = (Quad_t)tiv; break;
9316 if ( !vectorize ) /* we already set uv above */
9321 esignbuf[esignlen++] = plus;
9325 esignbuf[esignlen++] = '-';
9368 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9379 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9380 case 'l': uv = va_arg(*args, unsigned long); break;
9381 case 'V': uv = va_arg(*args, UV); break;
9382 default: uv = va_arg(*args, unsigned); break;
9384 case 'q': uv = va_arg(*args, Uquad_t); break;
9389 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9391 case 'h': uv = (unsigned short)tuv; break;
9392 case 'l': uv = (unsigned long)tuv; break;
9394 default: uv = tuv; break;
9396 case 'q': uv = (Uquad_t)tuv; break;
9403 char *ptr = ebuf + sizeof ebuf;
9409 p = (char*)((c == 'X')
9410 ? "0123456789ABCDEF" : "0123456789abcdef");
9416 esignbuf[esignlen++] = '0';
9417 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9425 if (alt && *ptr != '0')
9434 esignbuf[esignlen++] = '0';
9435 esignbuf[esignlen++] = 'b';
9438 default: /* it had better be ten or less */
9442 } while (uv /= base);
9445 elen = (ebuf + sizeof ebuf) - ptr;
9449 zeros = precis - elen;
9450 else if (precis == 0 && elen == 1 && *eptr == '0')
9456 /* FLOATING POINT */
9459 c = 'f'; /* maybe %F isn't supported here */
9465 /* This is evil, but floating point is even more evil */
9467 /* for SV-style calling, we can only get NV
9468 for C-style calling, we assume %f is double;
9469 for simplicity we allow any of %Lf, %llf, %qf for long double
9473 #if defined(USE_LONG_DOUBLE)
9477 /* [perl #20339] - we should accept and ignore %lf rather than die */
9481 #if defined(USE_LONG_DOUBLE)
9482 intsize = args ? 0 : 'q';
9486 #if defined(HAS_LONG_DOUBLE)
9495 /* now we need (long double) if intsize == 'q', else (double) */
9496 nv = (args && !vectorize) ?
9497 #if LONG_DOUBLESIZE > DOUBLESIZE
9499 va_arg(*args, long double) :
9500 va_arg(*args, double)
9502 va_arg(*args, double)
9508 if (c != 'e' && c != 'E') {
9510 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9511 will cast our (long double) to (double) */
9512 (void)Perl_frexp(nv, &i);
9513 if (i == PERL_INT_MIN)
9514 Perl_die(aTHX_ "panic: frexp");
9516 need = BIT_DIGITS(i);
9518 need += has_precis ? precis : 6; /* known default */
9523 #ifdef HAS_LDBL_SPRINTF_BUG
9524 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9525 with sfio - Allen <allens@cpan.org> */
9528 # define MY_DBL_MAX DBL_MAX
9529 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9530 # if DOUBLESIZE >= 8
9531 # define MY_DBL_MAX 1.7976931348623157E+308L
9533 # define MY_DBL_MAX 3.40282347E+38L
9537 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9538 # define MY_DBL_MAX_BUG 1L
9540 # define MY_DBL_MAX_BUG MY_DBL_MAX
9544 # define MY_DBL_MIN DBL_MIN
9545 # else /* XXX guessing! -Allen */
9546 # if DOUBLESIZE >= 8
9547 # define MY_DBL_MIN 2.2250738585072014E-308L
9549 # define MY_DBL_MIN 1.17549435E-38L
9553 if ((intsize == 'q') && (c == 'f') &&
9554 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9556 /* it's going to be short enough that
9557 * long double precision is not needed */
9559 if ((nv <= 0L) && (nv >= -0L))
9560 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9562 /* would use Perl_fp_class as a double-check but not
9563 * functional on IRIX - see perl.h comments */
9565 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9566 /* It's within the range that a double can represent */
9567 #if defined(DBL_MAX) && !defined(DBL_MIN)
9568 if ((nv >= ((long double)1/DBL_MAX)) ||
9569 (nv <= (-(long double)1/DBL_MAX)))
9571 fix_ldbl_sprintf_bug = TRUE;
9574 if (fix_ldbl_sprintf_bug == TRUE) {
9584 # undef MY_DBL_MAX_BUG
9587 #endif /* HAS_LDBL_SPRINTF_BUG */
9589 need += 20; /* fudge factor */
9590 if (PL_efloatsize < need) {
9591 Safefree(PL_efloatbuf);
9592 PL_efloatsize = need + 20; /* more fudge */
9593 New(906, PL_efloatbuf, PL_efloatsize, char);
9594 PL_efloatbuf[0] = '\0';
9597 if ( !(width || left || plus || alt) && fill != '0'
9598 && has_precis && intsize != 'q' ) { /* Shortcuts */
9599 /* See earlier comment about buggy Gconvert when digits,
9601 if ( c == 'g' && precis) {
9602 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9603 if (*PL_efloatbuf) /* May return an empty string for digits==0 */
9604 goto float_converted;
9605 } else if ( c == 'f' && !precis) {
9606 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9611 char *ptr = ebuf + sizeof ebuf;
9614 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9615 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9616 if (intsize == 'q') {
9617 /* Copy the one or more characters in a long double
9618 * format before the 'base' ([efgEFG]) character to
9619 * the format string. */
9620 static char const prifldbl[] = PERL_PRIfldbl;
9621 char const *p = prifldbl + sizeof(prifldbl) - 3;
9622 while (p >= prifldbl) { *--ptr = *p--; }
9627 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9632 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9644 /* No taint. Otherwise we are in the strange situation
9645 * where printf() taints but print($float) doesn't.
9647 #if defined(HAS_LONG_DOUBLE)
9649 (void)sprintf(PL_efloatbuf, ptr, nv);
9651 (void)sprintf(PL_efloatbuf, ptr, (double)nv);
9653 (void)sprintf(PL_efloatbuf, ptr, nv);
9657 eptr = PL_efloatbuf;
9658 elen = strlen(PL_efloatbuf);
9664 i = SvCUR(sv) - origlen;
9665 if (args && !vectorize) {
9667 case 'h': *(va_arg(*args, short*)) = i; break;
9668 default: *(va_arg(*args, int*)) = i; break;
9669 case 'l': *(va_arg(*args, long*)) = i; break;
9670 case 'V': *(va_arg(*args, IV*)) = i; break;
9672 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
9677 sv_setuv_mg(argsv, (UV)i);
9679 continue; /* not "break" */
9685 if (!args && ckWARN(WARN_PRINTF) &&
9686 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
9687 SV *msg = sv_newmortal();
9688 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9689 (PL_op->op_type == OP_PRTF) ? "" : "s");
9692 Perl_sv_catpvf(aTHX_ msg,
9693 "\"%%%c\"", c & 0xFF);
9695 Perl_sv_catpvf(aTHX_ msg,
9696 "\"%%\\%03"UVof"\"",
9699 sv_catpv(msg, "end of string");
9700 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
9703 /* output mangled stuff ... */
9709 /* ... right here, because formatting flags should not apply */
9710 SvGROW(sv, SvCUR(sv) + elen + 1);
9712 Copy(eptr, p, elen, char);
9715 SvCUR_set(sv, p - SvPVX_const(sv));
9717 continue; /* not "break" */
9720 /* calculate width before utf8_upgrade changes it */
9721 have = esignlen + zeros + elen;
9723 if (is_utf8 != has_utf8) {
9726 sv_utf8_upgrade(sv);
9729 SV * const nsv = sv_2mortal(newSVpvn(eptr, elen));
9730 sv_utf8_upgrade(nsv);
9731 eptr = SvPVX_const(nsv);
9734 SvGROW(sv, SvCUR(sv) + elen + 1);
9739 need = (have > width ? have : width);
9742 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
9744 if (esignlen && fill == '0') {
9746 for (i = 0; i < (int)esignlen; i++)
9750 memset(p, fill, gap);
9753 if (esignlen && fill != '0') {
9755 for (i = 0; i < (int)esignlen; i++)
9760 for (i = zeros; i; i--)
9764 Copy(eptr, p, elen, char);
9768 memset(p, ' ', gap);
9773 Copy(dotstr, p, dotstrlen, char);
9777 vectorize = FALSE; /* done iterating over vecstr */
9784 SvCUR_set(sv, p - SvPVX_const(sv));
9792 /* =========================================================================
9794 =head1 Cloning an interpreter
9796 All the macros and functions in this section are for the private use of
9797 the main function, perl_clone().
9799 The foo_dup() functions make an exact copy of an existing foo thinngy.
9800 During the course of a cloning, a hash table is used to map old addresses
9801 to new addresses. The table is created and manipulated with the
9802 ptr_table_* functions.
9806 ============================================================================*/
9809 #if defined(USE_ITHREADS)
9811 #ifndef GpREFCNT_inc
9812 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
9816 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
9817 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
9818 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9819 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
9820 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9821 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
9822 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9823 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
9824 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
9825 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
9826 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9827 #define SAVEPV(p) (p ? savepv(p) : Nullch)
9828 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
9831 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
9832 regcomp.c. AMS 20010712 */
9835 Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
9840 struct reg_substr_datum *s;
9843 return (REGEXP *)NULL;
9845 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
9848 len = r->offsets[0];
9849 npar = r->nparens+1;
9851 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
9852 Copy(r->program, ret->program, len+1, regnode);
9854 New(0, ret->startp, npar, I32);
9855 Copy(r->startp, ret->startp, npar, I32);
9856 New(0, ret->endp, npar, I32);
9857 Copy(r->startp, ret->startp, npar, I32);
9859 New(0, ret->substrs, 1, struct reg_substr_data);
9860 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
9861 s->min_offset = r->substrs->data[i].min_offset;
9862 s->max_offset = r->substrs->data[i].max_offset;
9863 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
9864 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
9867 ret->regstclass = NULL;
9870 const int count = r->data->count;
9873 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
9874 char, struct reg_data);
9875 New(0, d->what, count, U8);
9878 for (i = 0; i < count; i++) {
9879 d->what[i] = r->data->what[i];
9880 switch (d->what[i]) {
9881 /* legal options are one of: sfpont
9882 see also regcomp.h and pregfree() */
9884 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
9887 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
9890 /* This is cheating. */
9891 New(0, d->data[i], 1, struct regnode_charclass_class);
9892 StructCopy(r->data->data[i], d->data[i],
9893 struct regnode_charclass_class);
9894 ret->regstclass = (regnode*)d->data[i];
9897 /* Compiled op trees are readonly, and can thus be
9898 shared without duplication. */
9900 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
9904 d->data[i] = r->data->data[i];
9907 d->data[i] = r->data->data[i];
9909 ((reg_trie_data*)d->data[i])->refcount++;
9913 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
9922 New(0, ret->offsets, 2*len+1, U32);
9923 Copy(r->offsets, ret->offsets, 2*len+1, U32);
9925 ret->precomp = SAVEPVN(r->precomp, r->prelen);
9926 ret->refcnt = r->refcnt;
9927 ret->minlen = r->minlen;
9928 ret->prelen = r->prelen;
9929 ret->nparens = r->nparens;
9930 ret->lastparen = r->lastparen;
9931 ret->lastcloseparen = r->lastcloseparen;
9932 ret->reganch = r->reganch;
9934 ret->sublen = r->sublen;
9936 if (RX_MATCH_COPIED(ret))
9937 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
9939 ret->subbeg = Nullch;
9940 #ifdef PERL_OLD_COPY_ON_WRITE
9941 ret->saved_copy = Nullsv;
9944 ptr_table_store(PL_ptr_table, r, ret);
9948 /* duplicate a file handle */
9951 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
9955 PERL_UNUSED_ARG(type);
9958 return (PerlIO*)NULL;
9960 /* look for it in the table first */
9961 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
9965 /* create anew and remember what it is */
9966 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
9967 ptr_table_store(PL_ptr_table, fp, ret);
9971 /* duplicate a directory handle */
9974 Perl_dirp_dup(pTHX_ DIR *dp)
9982 /* duplicate a typeglob */
9985 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
9990 /* look for it in the table first */
9991 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
9995 /* create anew and remember what it is */
9996 Newz(0, ret, 1, GP);
9997 ptr_table_store(PL_ptr_table, gp, ret);
10000 ret->gp_refcnt = 0; /* must be before any other dups! */
10001 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
10002 ret->gp_io = io_dup_inc(gp->gp_io, param);
10003 ret->gp_form = cv_dup_inc(gp->gp_form, param);
10004 ret->gp_av = av_dup_inc(gp->gp_av, param);
10005 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
10006 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10007 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
10008 ret->gp_cvgen = gp->gp_cvgen;
10009 ret->gp_line = gp->gp_line;
10010 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
10014 /* duplicate a chain of magic */
10017 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
10019 MAGIC *mgprev = (MAGIC*)NULL;
10022 return (MAGIC*)NULL;
10023 /* look for it in the table first */
10024 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
10028 for (; mg; mg = mg->mg_moremagic) {
10030 Newz(0, nmg, 1, MAGIC);
10032 mgprev->mg_moremagic = nmg;
10035 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
10036 nmg->mg_private = mg->mg_private;
10037 nmg->mg_type = mg->mg_type;
10038 nmg->mg_flags = mg->mg_flags;
10039 if (mg->mg_type == PERL_MAGIC_qr) {
10040 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
10042 else if(mg->mg_type == PERL_MAGIC_backref) {
10043 const AV * const av = (AV*) mg->mg_obj;
10046 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
10048 for (i = AvFILLp(av); i >= 0; i--) {
10049 if (!svp[i]) continue;
10050 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
10053 else if (mg->mg_type == PERL_MAGIC_symtab) {
10054 nmg->mg_obj = mg->mg_obj;
10057 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
10058 ? sv_dup_inc(mg->mg_obj, param)
10059 : sv_dup(mg->mg_obj, param);
10061 nmg->mg_len = mg->mg_len;
10062 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
10063 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
10064 if (mg->mg_len > 0) {
10065 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
10066 if (mg->mg_type == PERL_MAGIC_overload_table &&
10067 AMT_AMAGIC((AMT*)mg->mg_ptr))
10069 AMT *amtp = (AMT*)mg->mg_ptr;
10070 AMT *namtp = (AMT*)nmg->mg_ptr;
10072 for (i = 1; i < NofAMmeth; i++) {
10073 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
10077 else if (mg->mg_len == HEf_SVKEY)
10078 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
10080 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
10081 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10088 /* create a new pointer-mapping table */
10091 Perl_ptr_table_new(pTHX)
10094 Newz(0, tbl, 1, PTR_TBL_t);
10095 tbl->tbl_max = 511;
10096 tbl->tbl_items = 0;
10097 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10102 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
10104 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
10107 #define new_pte() new_body(struct ptr_tbl_ent, pte)
10108 #define del_pte(p) del_body_type(p, struct ptr_tbl_ent, pte)
10110 /* map an existing pointer using a table */
10113 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
10115 PTR_TBL_ENT_t *tblent;
10116 const UV hash = PTR_TABLE_HASH(sv);
10118 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10119 for (; tblent; tblent = tblent->next) {
10120 if (tblent->oldval == sv)
10121 return tblent->newval;
10123 return (void*)NULL;
10126 /* add a new entry to a pointer-mapping table */
10129 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldv, void *newv)
10131 PTR_TBL_ENT_t *tblent, **otblent;
10132 /* XXX this may be pessimal on platforms where pointers aren't good
10133 * hash values e.g. if they grow faster in the most significant
10135 const UV hash = PTR_TABLE_HASH(oldv);
10139 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
10140 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
10141 if (tblent->oldval == oldv) {
10142 tblent->newval = newv;
10146 tblent = new_pte();
10147 tblent->oldval = oldv;
10148 tblent->newval = newv;
10149 tblent->next = *otblent;
10152 if (!empty && tbl->tbl_items > tbl->tbl_max)
10153 ptr_table_split(tbl);
10156 /* double the hash bucket size of an existing ptr table */
10159 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
10161 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10162 const UV oldsize = tbl->tbl_max + 1;
10163 UV newsize = oldsize * 2;
10166 Renew(ary, newsize, PTR_TBL_ENT_t*);
10167 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10168 tbl->tbl_max = --newsize;
10169 tbl->tbl_ary = ary;
10170 for (i=0; i < oldsize; i++, ary++) {
10171 PTR_TBL_ENT_t **curentp, **entp, *ent;
10174 curentp = ary + oldsize;
10175 for (entp = ary, ent = *ary; ent; ent = *entp) {
10176 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10178 ent->next = *curentp;
10188 /* remove all the entries from a ptr table */
10191 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
10193 register PTR_TBL_ENT_t **array;
10194 register PTR_TBL_ENT_t *entry;
10198 if (!tbl || !tbl->tbl_items) {
10202 array = tbl->tbl_ary;
10204 max = tbl->tbl_max;
10208 PTR_TBL_ENT_t *oentry = entry;
10209 entry = entry->next;
10213 if (++riter > max) {
10216 entry = array[riter];
10220 tbl->tbl_items = 0;
10223 /* clear and free a ptr table */
10226 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
10231 ptr_table_clear(tbl);
10232 Safefree(tbl->tbl_ary);
10238 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
10241 SvRV_set(dstr, SvWEAKREF(sstr)
10242 ? sv_dup(SvRV(sstr), param)
10243 : sv_dup_inc(SvRV(sstr), param));
10246 else if (SvPVX_const(sstr)) {
10247 /* Has something there */
10249 /* Normal PV - clone whole allocated space */
10250 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
10251 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10252 /* Not that normal - actually sstr is copy on write.
10253 But we are a true, independant SV, so: */
10254 SvREADONLY_off(dstr);
10259 /* Special case - not normally malloced for some reason */
10260 if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
10261 /* A "shared" PV - clone it as "shared" PV */
10263 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
10267 /* Some other special case - random pointer */
10268 SvPV_set(dstr, SvPVX(sstr));
10273 /* Copy the Null */
10274 if (SvTYPE(dstr) == SVt_RV)
10275 SvRV_set(dstr, NULL);
10281 /* duplicate an SV of any type (including AV, HV etc) */
10284 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
10289 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10291 /* look for it in the table first */
10292 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10296 if(param->flags & CLONEf_JOIN_IN) {
10297 /** We are joining here so we don't want do clone
10298 something that is bad **/
10299 const char *hvname;
10301 if(SvTYPE(sstr) == SVt_PVHV &&
10302 (hvname = HvNAME_get(sstr))) {
10303 /** don't clone stashes if they already exist **/
10304 HV* old_stash = gv_stashpv(hvname,0);
10305 return (SV*) old_stash;
10309 /* create anew and remember what it is */
10312 #ifdef DEBUG_LEAKING_SCALARS
10313 dstr->sv_debug_optype = sstr->sv_debug_optype;
10314 dstr->sv_debug_line = sstr->sv_debug_line;
10315 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10316 dstr->sv_debug_cloned = 1;
10318 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10320 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
10324 ptr_table_store(PL_ptr_table, sstr, dstr);
10327 SvFLAGS(dstr) = SvFLAGS(sstr);
10328 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10329 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10332 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
10333 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10334 PL_watch_pvx, SvPVX_const(sstr));
10337 /* don't clone objects whose class has asked us not to */
10338 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10339 SvFLAGS(dstr) &= ~SVTYPEMASK;
10340 SvOBJECT_off(dstr);
10344 switch (SvTYPE(sstr)) {
10346 SvANY(dstr) = NULL;
10349 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
10350 SvIV_set(dstr, SvIVX(sstr));
10353 SvANY(dstr) = new_XNV();
10354 SvNV_set(dstr, SvNVX(sstr));
10357 SvANY(dstr) = &(dstr->sv_u.svu_rv);
10358 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10362 /* These are all the types that need complex bodies allocating. */
10363 size_t new_body_length;
10364 size_t new_body_offset = 0;
10365 void **new_body_arena;
10366 void **new_body_arenaroot;
10369 switch (SvTYPE(sstr)) {
10371 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]",
10376 new_body = new_XPVIO();
10377 new_body_length = sizeof(XPVIO);
10380 new_body = new_XPVFM();
10381 new_body_length = sizeof(XPVFM);
10385 new_body_arena = (void **) &PL_xpvhv_root;
10386 new_body_arenaroot = (void **) &PL_xpvhv_arenaroot;
10387 new_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill)
10388 - STRUCT_OFFSET(xpvhv_allocated, xhv_fill);
10389 new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash)
10390 + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash)
10394 new_body_arena = (void **) &PL_xpvav_root;
10395 new_body_arenaroot = (void **) &PL_xpvav_arenaroot;
10396 new_body_offset = STRUCT_OFFSET(XPVAV, xav_fill)
10397 - STRUCT_OFFSET(xpvav_allocated, xav_fill);
10398 new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash)
10399 + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash)
10403 new_body_length = sizeof(XPVBM);
10404 new_body_arena = (void **) &PL_xpvbm_root;
10405 new_body_arenaroot = (void **) &PL_xpvbm_arenaroot;
10408 if (GvUNIQUE((GV*)sstr)) {
10409 /* Do sharing here. */
10411 new_body_length = sizeof(XPVGV);
10412 new_body_arena = (void **) &PL_xpvgv_root;
10413 new_body_arenaroot = (void **) &PL_xpvgv_arenaroot;
10416 new_body_length = sizeof(XPVCV);
10417 new_body_arena = (void **) &PL_xpvcv_root;
10418 new_body_arenaroot = (void **) &PL_xpvcv_arenaroot;
10421 new_body_length = sizeof(XPVLV);
10422 new_body_arena = (void **) &PL_xpvlv_root;
10423 new_body_arenaroot = (void **) &PL_xpvlv_arenaroot;
10426 new_body_length = sizeof(XPVMG);
10427 new_body_arena = (void **) &PL_xpvmg_root;
10428 new_body_arenaroot = (void **) &PL_xpvmg_arenaroot;
10431 new_body_length = sizeof(XPVNV);
10432 new_body_arena = (void **) &PL_xpvnv_root;
10433 new_body_arenaroot = (void **) &PL_xpvnv_arenaroot;
10436 new_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
10437 - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
10438 new_body_length = sizeof(XPVIV) - new_body_offset;
10439 new_body_arena = (void **) &PL_xpviv_root;
10440 new_body_arenaroot = (void **) &PL_xpviv_arenaroot;
10443 new_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
10444 - STRUCT_OFFSET(xpv_allocated, xpv_cur);
10445 new_body_length = sizeof(XPV) - new_body_offset;
10446 new_body_arena = (void **) &PL_xpv_root;
10447 new_body_arenaroot = (void **) &PL_xpv_arenaroot;
10449 assert(new_body_length);
10451 new_body = (void*)((char*)S_new_body(aTHX_ new_body_arenaroot,
10454 - new_body_offset);
10456 /* We always allocated the full length item with PURIFY */
10457 new_body_length += new_body_offset;
10458 new_body_offset = 0;
10459 new_body = my_safemalloc(new_body_length);
10463 SvANY(dstr) = new_body;
10465 Copy(((char*)SvANY(sstr)) + new_body_offset,
10466 ((char*)SvANY(dstr)) + new_body_offset,
10467 new_body_length, char);
10469 if (SvTYPE(sstr) != SVt_PVAV && SvTYPE(sstr) != SVt_PVHV)
10470 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10472 /* The Copy above means that all the source (unduplicated) pointers
10473 are now in the destination. We can check the flags and the
10474 pointers in either, but it's possible that there's less cache
10475 missing by always going for the destination.
10476 FIXME - instrument and check that assumption */
10477 if (SvTYPE(sstr) >= SVt_PVMG) {
10479 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
10481 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
10484 switch (SvTYPE(sstr)) {
10496 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
10497 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
10498 LvTARG(dstr) = dstr;
10499 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
10500 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
10502 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
10505 GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr));
10506 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
10507 /* Don't call sv_add_backref here as it's going to be created
10508 as part of the magic cloning of the symbol table. */
10509 GvGP(dstr) = gp_dup(GvGP(dstr), param);
10510 (void)GpREFCNT_inc(GvGP(dstr));
10513 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
10514 if (IoOFP(dstr) == IoIFP(sstr))
10515 IoOFP(dstr) = IoIFP(dstr);
10517 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
10518 /* PL_rsfp_filters entries have fake IoDIRP() */
10519 if (IoDIRP(dstr) && !(IoFLAGS(dstr) & IOf_FAKE_DIRP))
10520 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
10521 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
10522 /* I have no idea why fake dirp (rsfps)
10523 should be treated differently but otherwise
10524 we end up with leaks -- sky*/
10525 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
10526 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
10527 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
10529 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
10530 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
10531 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
10533 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
10534 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
10535 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
10538 if (AvARRAY((AV*)sstr)) {
10539 SV **dst_ary, **src_ary;
10540 SSize_t items = AvFILLp((AV*)sstr) + 1;
10542 src_ary = AvARRAY((AV*)sstr);
10543 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
10544 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10545 SvPV_set(dstr, (char*)dst_ary);
10546 AvALLOC((AV*)dstr) = dst_ary;
10547 if (AvREAL((AV*)sstr)) {
10548 while (items-- > 0)
10549 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10552 while (items-- > 0)
10553 *dst_ary++ = sv_dup(*src_ary++, param);
10555 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10556 while (items-- > 0) {
10557 *dst_ary++ = &PL_sv_undef;
10561 SvPV_set(dstr, Nullch);
10562 AvALLOC((AV*)dstr) = (SV**)NULL;
10569 if (HvARRAY((HV*)sstr)) {
10571 const bool sharekeys = !!HvSHAREKEYS(sstr);
10572 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
10573 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
10576 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
10577 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
10579 HvARRAY(dstr) = (HE**)darray;
10580 while (i <= sxhv->xhv_max) {
10581 HE *source = HvARRAY(sstr)[i];
10582 HvARRAY(dstr)[i] = source
10583 ? he_dup(source, sharekeys, param) : 0;
10587 struct xpvhv_aux *saux = HvAUX(sstr);
10588 struct xpvhv_aux *daux = HvAUX(dstr);
10589 /* This flag isn't copied. */
10590 /* SvOOK_on(hv) attacks the IV flags. */
10591 SvFLAGS(dstr) |= SVf_OOK;
10593 hvname = saux->xhv_name;
10595 = hvname ? hek_dup(hvname, param) : hvname;
10597 daux->xhv_riter = saux->xhv_riter;
10598 daux->xhv_eiter = saux->xhv_eiter
10599 ? he_dup(saux->xhv_eiter,
10600 (bool)!!HvSHAREKEYS(sstr), param) : 0;
10604 SvPV_set(dstr, Nullch);
10606 /* Record stashes for possible cloning in Perl_clone(). */
10608 av_push(param->stashes, dstr);
10613 /* NOTE: not refcounted */
10614 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
10616 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
10618 if (CvCONST(dstr)) {
10619 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
10620 SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
10621 sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
10623 /* don't dup if copying back - CvGV isn't refcounted, so the
10624 * duped GV may never be freed. A bit of a hack! DAPM */
10625 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
10626 Nullgv : gv_dup(CvGV(dstr), param) ;
10627 if (!(param->flags & CLONEf_COPY_STACKS)) {
10630 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10632 CvWEAKOUTSIDE(sstr)
10633 ? cv_dup( CvOUTSIDE(dstr), param)
10634 : cv_dup_inc(CvOUTSIDE(dstr), param);
10636 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
10642 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10648 /* duplicate a context */
10651 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10653 PERL_CONTEXT *ncxs;
10656 return (PERL_CONTEXT*)NULL;
10658 /* look for it in the table first */
10659 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10663 /* create anew and remember what it is */
10664 Newz(56, ncxs, max + 1, PERL_CONTEXT);
10665 ptr_table_store(PL_ptr_table, cxs, ncxs);
10668 PERL_CONTEXT *cx = &cxs[ix];
10669 PERL_CONTEXT *ncx = &ncxs[ix];
10670 ncx->cx_type = cx->cx_type;
10671 if (CxTYPE(cx) == CXt_SUBST) {
10672 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10675 ncx->blk_oldsp = cx->blk_oldsp;
10676 ncx->blk_oldcop = cx->blk_oldcop;
10677 ncx->blk_oldmarksp = cx->blk_oldmarksp;
10678 ncx->blk_oldscopesp = cx->blk_oldscopesp;
10679 ncx->blk_oldpm = cx->blk_oldpm;
10680 ncx->blk_gimme = cx->blk_gimme;
10681 switch (CxTYPE(cx)) {
10683 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
10684 ? cv_dup_inc(cx->blk_sub.cv, param)
10685 : cv_dup(cx->blk_sub.cv,param));
10686 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
10687 ? av_dup_inc(cx->blk_sub.argarray, param)
10689 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
10690 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
10691 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10692 ncx->blk_sub.lval = cx->blk_sub.lval;
10693 ncx->blk_sub.retop = cx->blk_sub.retop;
10696 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
10697 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
10698 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
10699 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
10700 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
10701 ncx->blk_eval.retop = cx->blk_eval.retop;
10704 ncx->blk_loop.label = cx->blk_loop.label;
10705 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
10706 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
10707 ncx->blk_loop.next_op = cx->blk_loop.next_op;
10708 ncx->blk_loop.last_op = cx->blk_loop.last_op;
10709 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
10710 ? cx->blk_loop.iterdata
10711 : gv_dup((GV*)cx->blk_loop.iterdata, param));
10712 ncx->blk_loop.oldcomppad
10713 = (PAD*)ptr_table_fetch(PL_ptr_table,
10714 cx->blk_loop.oldcomppad);
10715 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
10716 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
10717 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
10718 ncx->blk_loop.iterix = cx->blk_loop.iterix;
10719 ncx->blk_loop.itermax = cx->blk_loop.itermax;
10722 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
10723 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
10724 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
10725 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10726 ncx->blk_sub.retop = cx->blk_sub.retop;
10738 /* duplicate a stack info structure */
10741 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10746 return (PERL_SI*)NULL;
10748 /* look for it in the table first */
10749 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10753 /* create anew and remember what it is */
10754 Newz(56, nsi, 1, PERL_SI);
10755 ptr_table_store(PL_ptr_table, si, nsi);
10757 nsi->si_stack = av_dup_inc(si->si_stack, param);
10758 nsi->si_cxix = si->si_cxix;
10759 nsi->si_cxmax = si->si_cxmax;
10760 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
10761 nsi->si_type = si->si_type;
10762 nsi->si_prev = si_dup(si->si_prev, param);
10763 nsi->si_next = si_dup(si->si_next, param);
10764 nsi->si_markoff = si->si_markoff;
10769 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
10770 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
10771 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
10772 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
10773 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
10774 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
10775 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
10776 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
10777 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
10778 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
10779 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
10780 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
10781 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
10782 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
10785 #define pv_dup_inc(p) SAVEPV(p)
10786 #define pv_dup(p) SAVEPV(p)
10787 #define svp_dup_inc(p,pp) any_dup(p,pp)
10789 /* map any object to the new equivent - either something in the
10790 * ptr table, or something in the interpreter structure
10794 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
10799 return (void*)NULL;
10801 /* look for it in the table first */
10802 ret = ptr_table_fetch(PL_ptr_table, v);
10806 /* see if it is part of the interpreter structure */
10807 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
10808 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
10816 /* duplicate the save stack */
10819 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
10821 ANY * const ss = proto_perl->Tsavestack;
10822 const I32 max = proto_perl->Tsavestack_max;
10823 I32 ix = proto_perl->Tsavestack_ix;
10835 void (*dptr) (void*);
10836 void (*dxptr) (pTHX_ void*);
10838 Newz(54, nss, max, ANY);
10841 I32 i = POPINT(ss,ix);
10842 TOPINT(nss,ix) = i;
10844 case SAVEt_ITEM: /* normal string */
10845 sv = (SV*)POPPTR(ss,ix);
10846 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10847 sv = (SV*)POPPTR(ss,ix);
10848 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10850 case SAVEt_SV: /* scalar reference */
10851 sv = (SV*)POPPTR(ss,ix);
10852 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10853 gv = (GV*)POPPTR(ss,ix);
10854 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10856 case SAVEt_GENERIC_PVREF: /* generic char* */
10857 c = (char*)POPPTR(ss,ix);
10858 TOPPTR(nss,ix) = pv_dup(c);
10859 ptr = POPPTR(ss,ix);
10860 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10862 case SAVEt_SHARED_PVREF: /* char* in shared space */
10863 c = (char*)POPPTR(ss,ix);
10864 TOPPTR(nss,ix) = savesharedpv(c);
10865 ptr = POPPTR(ss,ix);
10866 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10868 case SAVEt_GENERIC_SVREF: /* generic sv */
10869 case SAVEt_SVREF: /* scalar reference */
10870 sv = (SV*)POPPTR(ss,ix);
10871 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10872 ptr = POPPTR(ss,ix);
10873 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
10875 case SAVEt_AV: /* array reference */
10876 av = (AV*)POPPTR(ss,ix);
10877 TOPPTR(nss,ix) = av_dup_inc(av, param);
10878 gv = (GV*)POPPTR(ss,ix);
10879 TOPPTR(nss,ix) = gv_dup(gv, param);
10881 case SAVEt_HV: /* hash reference */
10882 hv = (HV*)POPPTR(ss,ix);
10883 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10884 gv = (GV*)POPPTR(ss,ix);
10885 TOPPTR(nss,ix) = gv_dup(gv, param);
10887 case SAVEt_INT: /* int reference */
10888 ptr = POPPTR(ss,ix);
10889 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10890 intval = (int)POPINT(ss,ix);
10891 TOPINT(nss,ix) = intval;
10893 case SAVEt_LONG: /* long reference */
10894 ptr = POPPTR(ss,ix);
10895 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10896 longval = (long)POPLONG(ss,ix);
10897 TOPLONG(nss,ix) = longval;
10899 case SAVEt_I32: /* I32 reference */
10900 case SAVEt_I16: /* I16 reference */
10901 case SAVEt_I8: /* I8 reference */
10902 ptr = POPPTR(ss,ix);
10903 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10905 TOPINT(nss,ix) = i;
10907 case SAVEt_IV: /* IV reference */
10908 ptr = POPPTR(ss,ix);
10909 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10911 TOPIV(nss,ix) = iv;
10913 case SAVEt_SPTR: /* SV* reference */
10914 ptr = POPPTR(ss,ix);
10915 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10916 sv = (SV*)POPPTR(ss,ix);
10917 TOPPTR(nss,ix) = sv_dup(sv, param);
10919 case SAVEt_VPTR: /* random* reference */
10920 ptr = POPPTR(ss,ix);
10921 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10922 ptr = POPPTR(ss,ix);
10923 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10925 case SAVEt_PPTR: /* char* reference */
10926 ptr = POPPTR(ss,ix);
10927 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10928 c = (char*)POPPTR(ss,ix);
10929 TOPPTR(nss,ix) = pv_dup(c);
10931 case SAVEt_HPTR: /* HV* reference */
10932 ptr = POPPTR(ss,ix);
10933 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10934 hv = (HV*)POPPTR(ss,ix);
10935 TOPPTR(nss,ix) = hv_dup(hv, param);
10937 case SAVEt_APTR: /* AV* reference */
10938 ptr = POPPTR(ss,ix);
10939 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10940 av = (AV*)POPPTR(ss,ix);
10941 TOPPTR(nss,ix) = av_dup(av, param);
10944 gv = (GV*)POPPTR(ss,ix);
10945 TOPPTR(nss,ix) = gv_dup(gv, param);
10947 case SAVEt_GP: /* scalar reference */
10948 gp = (GP*)POPPTR(ss,ix);
10949 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
10950 (void)GpREFCNT_inc(gp);
10951 gv = (GV*)POPPTR(ss,ix);
10952 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10953 c = (char*)POPPTR(ss,ix);
10954 TOPPTR(nss,ix) = pv_dup(c);
10956 TOPIV(nss,ix) = iv;
10958 TOPIV(nss,ix) = iv;
10961 case SAVEt_MORTALIZESV:
10962 sv = (SV*)POPPTR(ss,ix);
10963 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10966 ptr = POPPTR(ss,ix);
10967 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
10968 /* these are assumed to be refcounted properly */
10970 switch (((OP*)ptr)->op_type) {
10972 case OP_LEAVESUBLV:
10976 case OP_LEAVEWRITE:
10977 TOPPTR(nss,ix) = ptr;
10982 TOPPTR(nss,ix) = Nullop;
10987 TOPPTR(nss,ix) = Nullop;
10990 c = (char*)POPPTR(ss,ix);
10991 TOPPTR(nss,ix) = pv_dup_inc(c);
10993 case SAVEt_CLEARSV:
10994 longval = POPLONG(ss,ix);
10995 TOPLONG(nss,ix) = longval;
10998 hv = (HV*)POPPTR(ss,ix);
10999 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11000 c = (char*)POPPTR(ss,ix);
11001 TOPPTR(nss,ix) = pv_dup_inc(c);
11003 TOPINT(nss,ix) = i;
11005 case SAVEt_DESTRUCTOR:
11006 ptr = POPPTR(ss,ix);
11007 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11008 dptr = POPDPTR(ss,ix);
11009 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
11010 any_dup(FPTR2DPTR(void *, dptr),
11013 case SAVEt_DESTRUCTOR_X:
11014 ptr = POPPTR(ss,ix);
11015 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11016 dxptr = POPDXPTR(ss,ix);
11017 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
11018 any_dup(FPTR2DPTR(void *, dxptr),
11021 case SAVEt_REGCONTEXT:
11024 TOPINT(nss,ix) = i;
11027 case SAVEt_STACK_POS: /* Position on Perl stack */
11029 TOPINT(nss,ix) = i;
11031 case SAVEt_AELEM: /* array element */
11032 sv = (SV*)POPPTR(ss,ix);
11033 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11035 TOPINT(nss,ix) = i;
11036 av = (AV*)POPPTR(ss,ix);
11037 TOPPTR(nss,ix) = av_dup_inc(av, param);
11039 case SAVEt_HELEM: /* hash element */
11040 sv = (SV*)POPPTR(ss,ix);
11041 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11042 sv = (SV*)POPPTR(ss,ix);
11043 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11044 hv = (HV*)POPPTR(ss,ix);
11045 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11048 ptr = POPPTR(ss,ix);
11049 TOPPTR(nss,ix) = ptr;
11053 TOPINT(nss,ix) = i;
11055 case SAVEt_COMPPAD:
11056 av = (AV*)POPPTR(ss,ix);
11057 TOPPTR(nss,ix) = av_dup(av, param);
11060 longval = (long)POPLONG(ss,ix);
11061 TOPLONG(nss,ix) = longval;
11062 ptr = POPPTR(ss,ix);
11063 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11064 sv = (SV*)POPPTR(ss,ix);
11065 TOPPTR(nss,ix) = sv_dup(sv, param);
11068 ptr = POPPTR(ss,ix);
11069 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11070 longval = (long)POPBOOL(ss,ix);
11071 TOPBOOL(nss,ix) = (bool)longval;
11073 case SAVEt_SET_SVFLAGS:
11075 TOPINT(nss,ix) = i;
11077 TOPINT(nss,ix) = i;
11078 sv = (SV*)POPPTR(ss,ix);
11079 TOPPTR(nss,ix) = sv_dup(sv, param);
11082 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
11090 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11091 * flag to the result. This is done for each stash before cloning starts,
11092 * so we know which stashes want their objects cloned */
11095 do_mark_cloneable_stash(pTHX_ SV *sv)
11097 const HEK * const hvname = HvNAME_HEK((HV*)sv);
11099 GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
11100 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11101 if (cloner && GvCV(cloner)) {
11108 XPUSHs(sv_2mortal(newSVhek(hvname)));
11110 call_sv((SV*)GvCV(cloner), G_SCALAR);
11117 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11125 =for apidoc perl_clone
11127 Create and return a new interpreter by cloning the current one.
11129 perl_clone takes these flags as parameters:
11131 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11132 without it we only clone the data and zero the stacks,
11133 with it we copy the stacks and the new perl interpreter is
11134 ready to run at the exact same point as the previous one.
11135 The pseudo-fork code uses COPY_STACKS while the
11136 threads->new doesn't.
11138 CLONEf_KEEP_PTR_TABLE
11139 perl_clone keeps a ptr_table with the pointer of the old
11140 variable as a key and the new variable as a value,
11141 this allows it to check if something has been cloned and not
11142 clone it again but rather just use the value and increase the
11143 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11144 the ptr_table using the function
11145 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11146 reason to keep it around is if you want to dup some of your own
11147 variable who are outside the graph perl scans, example of this
11148 code is in threads.xs create
11151 This is a win32 thing, it is ignored on unix, it tells perls
11152 win32host code (which is c++) to clone itself, this is needed on
11153 win32 if you want to run two threads at the same time,
11154 if you just want to do some stuff in a separate perl interpreter
11155 and then throw it away and return to the original one,
11156 you don't need to do anything.
11161 /* XXX the above needs expanding by someone who actually understands it ! */
11162 EXTERN_C PerlInterpreter *
11163 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11166 perl_clone(PerlInterpreter *proto_perl, UV flags)
11169 #ifdef PERL_IMPLICIT_SYS
11171 /* perlhost.h so we need to call into it
11172 to clone the host, CPerlHost should have a c interface, sky */
11174 if (flags & CLONEf_CLONE_HOST) {
11175 return perl_clone_host(proto_perl,flags);
11177 return perl_clone_using(proto_perl, flags,
11179 proto_perl->IMemShared,
11180 proto_perl->IMemParse,
11182 proto_perl->IStdIO,
11186 proto_perl->IProc);
11190 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11191 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11192 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11193 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11194 struct IPerlDir* ipD, struct IPerlSock* ipS,
11195 struct IPerlProc* ipP)
11197 /* XXX many of the string copies here can be optimized if they're
11198 * constants; they need to be allocated as common memory and just
11199 * their pointers copied. */
11202 CLONE_PARAMS clone_params;
11203 CLONE_PARAMS* param = &clone_params;
11205 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11206 /* for each stash, determine whether its objects should be cloned */
11207 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11208 PERL_SET_THX(my_perl);
11211 Poison(my_perl, 1, PerlInterpreter);
11213 PL_curcop = (COP *)Nullop;
11217 PL_savestack_ix = 0;
11218 PL_savestack_max = -1;
11219 PL_sig_pending = 0;
11220 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11221 # else /* !DEBUGGING */
11222 Zero(my_perl, 1, PerlInterpreter);
11223 # endif /* DEBUGGING */
11225 /* host pointers */
11227 PL_MemShared = ipMS;
11228 PL_MemParse = ipMP;
11235 #else /* !PERL_IMPLICIT_SYS */
11237 CLONE_PARAMS clone_params;
11238 CLONE_PARAMS* param = &clone_params;
11239 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11240 /* for each stash, determine whether its objects should be cloned */
11241 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11242 PERL_SET_THX(my_perl);
11245 Poison(my_perl, 1, PerlInterpreter);
11247 PL_curcop = (COP *)Nullop;
11251 PL_savestack_ix = 0;
11252 PL_savestack_max = -1;
11253 PL_sig_pending = 0;
11254 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11255 # else /* !DEBUGGING */
11256 Zero(my_perl, 1, PerlInterpreter);
11257 # endif /* DEBUGGING */
11258 #endif /* PERL_IMPLICIT_SYS */
11259 param->flags = flags;
11260 param->proto_perl = proto_perl;
11263 PL_xnv_arenaroot = NULL;
11264 PL_xnv_root = NULL;
11265 PL_xpv_arenaroot = NULL;
11266 PL_xpv_root = NULL;
11267 PL_xpviv_arenaroot = NULL;
11268 PL_xpviv_root = NULL;
11269 PL_xpvnv_arenaroot = NULL;
11270 PL_xpvnv_root = NULL;
11271 PL_xpvcv_arenaroot = NULL;
11272 PL_xpvcv_root = NULL;
11273 PL_xpvav_arenaroot = NULL;
11274 PL_xpvav_root = NULL;
11275 PL_xpvhv_arenaroot = NULL;
11276 PL_xpvhv_root = NULL;
11277 PL_xpvmg_arenaroot = NULL;
11278 PL_xpvmg_root = NULL;
11279 PL_xpvgv_arenaroot = NULL;
11280 PL_xpvgv_root = NULL;
11281 PL_xpvlv_arenaroot = NULL;
11282 PL_xpvlv_root = NULL;
11283 PL_xpvbm_arenaroot = NULL;
11284 PL_xpvbm_root = NULL;
11285 PL_he_arenaroot = NULL;
11287 #if defined(USE_ITHREADS)
11288 PL_pte_arenaroot = NULL;
11289 PL_pte_root = NULL;
11291 PL_nice_chunk = NULL;
11292 PL_nice_chunk_size = 0;
11294 PL_sv_objcount = 0;
11295 PL_sv_root = Nullsv;
11296 PL_sv_arenaroot = Nullsv;
11298 PL_debug = proto_perl->Idebug;
11300 PL_hash_seed = proto_perl->Ihash_seed;
11301 PL_rehash_seed = proto_perl->Irehash_seed;
11303 #ifdef USE_REENTRANT_API
11304 /* XXX: things like -Dm will segfault here in perlio, but doing
11305 * PERL_SET_CONTEXT(proto_perl);
11306 * breaks too many other things
11308 Perl_reentrant_init(aTHX);
11311 /* create SV map for pointer relocation */
11312 PL_ptr_table = ptr_table_new();
11314 /* initialize these special pointers as early as possible */
11315 SvANY(&PL_sv_undef) = NULL;
11316 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11317 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11318 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11320 SvANY(&PL_sv_no) = new_XPVNV();
11321 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11322 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11323 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11324 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
11325 SvCUR_set(&PL_sv_no, 0);
11326 SvLEN_set(&PL_sv_no, 1);
11327 SvIV_set(&PL_sv_no, 0);
11328 SvNV_set(&PL_sv_no, 0);
11329 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11331 SvANY(&PL_sv_yes) = new_XPVNV();
11332 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11333 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11334 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11335 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
11336 SvCUR_set(&PL_sv_yes, 1);
11337 SvLEN_set(&PL_sv_yes, 2);
11338 SvIV_set(&PL_sv_yes, 1);
11339 SvNV_set(&PL_sv_yes, 1);
11340 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11342 /* create (a non-shared!) shared string table */
11343 PL_strtab = newHV();
11344 HvSHAREKEYS_off(PL_strtab);
11345 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
11346 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11348 PL_compiling = proto_perl->Icompiling;
11350 /* These two PVs will be free'd special way so must set them same way op.c does */
11351 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11352 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11354 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11355 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11357 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11358 if (!specialWARN(PL_compiling.cop_warnings))
11359 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
11360 if (!specialCopIO(PL_compiling.cop_io))
11361 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
11362 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
11364 /* pseudo environmental stuff */
11365 PL_origargc = proto_perl->Iorigargc;
11366 PL_origargv = proto_perl->Iorigargv;
11368 param->stashes = newAV(); /* Setup array of objects to call clone on */
11370 #ifdef PERLIO_LAYERS
11371 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11372 PerlIO_clone(aTHX_ proto_perl, param);
11375 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11376 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11377 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11378 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11379 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11380 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11383 PL_minus_c = proto_perl->Iminus_c;
11384 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11385 PL_localpatches = proto_perl->Ilocalpatches;
11386 PL_splitstr = proto_perl->Isplitstr;
11387 PL_preprocess = proto_perl->Ipreprocess;
11388 PL_minus_n = proto_perl->Iminus_n;
11389 PL_minus_p = proto_perl->Iminus_p;
11390 PL_minus_l = proto_perl->Iminus_l;
11391 PL_minus_a = proto_perl->Iminus_a;
11392 PL_minus_F = proto_perl->Iminus_F;
11393 PL_doswitches = proto_perl->Idoswitches;
11394 PL_dowarn = proto_perl->Idowarn;
11395 PL_doextract = proto_perl->Idoextract;
11396 PL_sawampersand = proto_perl->Isawampersand;
11397 PL_unsafe = proto_perl->Iunsafe;
11398 PL_inplace = SAVEPV(proto_perl->Iinplace);
11399 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11400 PL_perldb = proto_perl->Iperldb;
11401 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11402 PL_exit_flags = proto_perl->Iexit_flags;
11404 /* magical thingies */
11405 /* XXX time(&PL_basetime) when asked for? */
11406 PL_basetime = proto_perl->Ibasetime;
11407 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11409 PL_maxsysfd = proto_perl->Imaxsysfd;
11410 PL_multiline = proto_perl->Imultiline;
11411 PL_statusvalue = proto_perl->Istatusvalue;
11413 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11415 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11417 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11418 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11419 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11421 /* Clone the regex array */
11422 PL_regex_padav = newAV();
11424 const I32 len = av_len((AV*)proto_perl->Iregex_padav);
11425 SV** const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11427 av_push(PL_regex_padav,
11428 sv_dup_inc(regexen[0],param));
11429 for(i = 1; i <= len; i++) {
11430 if(SvREPADTMP(regexen[i])) {
11431 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11433 av_push(PL_regex_padav,
11435 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11436 SvIVX(regexen[i])), param)))
11441 PL_regex_pad = AvARRAY(PL_regex_padav);
11443 /* shortcuts to various I/O objects */
11444 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11445 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11446 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11447 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11448 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11449 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11451 /* shortcuts to regexp stuff */
11452 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11454 /* shortcuts to misc objects */
11455 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11457 /* shortcuts to debugging objects */
11458 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11459 PL_DBline = gv_dup(proto_perl->IDBline, param);
11460 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11461 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11462 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11463 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11464 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11465 PL_lineary = av_dup(proto_perl->Ilineary, param);
11466 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11468 /* symbol tables */
11469 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11470 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11471 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11472 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11473 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11475 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11476 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11477 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11478 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11479 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11480 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11482 PL_sub_generation = proto_perl->Isub_generation;
11484 /* funky return mechanisms */
11485 PL_forkprocess = proto_perl->Iforkprocess;
11487 /* subprocess state */
11488 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11490 /* internal state */
11491 PL_tainting = proto_perl->Itainting;
11492 PL_taint_warn = proto_perl->Itaint_warn;
11493 PL_maxo = proto_perl->Imaxo;
11494 if (proto_perl->Iop_mask)
11495 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11497 PL_op_mask = Nullch;
11498 /* PL_asserting = proto_perl->Iasserting; */
11500 /* current interpreter roots */
11501 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11502 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11503 PL_main_start = proto_perl->Imain_start;
11504 PL_eval_root = proto_perl->Ieval_root;
11505 PL_eval_start = proto_perl->Ieval_start;
11507 /* runtime control stuff */
11508 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11509 PL_copline = proto_perl->Icopline;
11511 PL_filemode = proto_perl->Ifilemode;
11512 PL_lastfd = proto_perl->Ilastfd;
11513 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11516 PL_gensym = proto_perl->Igensym;
11517 PL_preambled = proto_perl->Ipreambled;
11518 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11519 PL_laststatval = proto_perl->Ilaststatval;
11520 PL_laststype = proto_perl->Ilaststype;
11521 PL_mess_sv = Nullsv;
11523 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11525 /* interpreter atexit processing */
11526 PL_exitlistlen = proto_perl->Iexitlistlen;
11527 if (PL_exitlistlen) {
11528 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11529 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11532 PL_exitlist = (PerlExitListEntry*)NULL;
11533 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11534 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11535 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11537 PL_profiledata = NULL;
11538 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
11539 /* PL_rsfp_filters entries have fake IoDIRP() */
11540 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
11542 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11544 PAD_CLONE_VARS(proto_perl, param);
11546 #ifdef HAVE_INTERP_INTERN
11547 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11550 /* more statics moved here */
11551 PL_generation = proto_perl->Igeneration;
11552 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11554 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11555 PL_in_clean_all = proto_perl->Iin_clean_all;
11557 PL_uid = proto_perl->Iuid;
11558 PL_euid = proto_perl->Ieuid;
11559 PL_gid = proto_perl->Igid;
11560 PL_egid = proto_perl->Iegid;
11561 PL_nomemok = proto_perl->Inomemok;
11562 PL_an = proto_perl->Ian;
11563 PL_evalseq = proto_perl->Ievalseq;
11564 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11565 PL_origalen = proto_perl->Iorigalen;
11566 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11567 PL_osname = SAVEPV(proto_perl->Iosname);
11568 PL_sighandlerp = proto_perl->Isighandlerp;
11570 PL_runops = proto_perl->Irunops;
11572 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11575 PL_cshlen = proto_perl->Icshlen;
11576 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
11579 PL_lex_state = proto_perl->Ilex_state;
11580 PL_lex_defer = proto_perl->Ilex_defer;
11581 PL_lex_expect = proto_perl->Ilex_expect;
11582 PL_lex_formbrack = proto_perl->Ilex_formbrack;
11583 PL_lex_dojoin = proto_perl->Ilex_dojoin;
11584 PL_lex_starts = proto_perl->Ilex_starts;
11585 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
11586 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
11587 PL_lex_op = proto_perl->Ilex_op;
11588 PL_lex_inpat = proto_perl->Ilex_inpat;
11589 PL_lex_inwhat = proto_perl->Ilex_inwhat;
11590 PL_lex_brackets = proto_perl->Ilex_brackets;
11591 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11592 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
11593 PL_lex_casemods = proto_perl->Ilex_casemods;
11594 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11595 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
11597 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11598 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
11599 PL_nexttoke = proto_perl->Inexttoke;
11601 /* XXX This is probably masking the deeper issue of why
11602 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11603 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11604 * (A little debugging with a watchpoint on it may help.)
11606 if (SvANY(proto_perl->Ilinestr)) {
11607 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
11608 i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
11609 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11610 i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
11611 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11612 i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
11613 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11614 i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
11615 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11618 PL_linestr = NEWSV(65,79);
11619 sv_upgrade(PL_linestr,SVt_PVIV);
11620 sv_setpvn(PL_linestr,"",0);
11621 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
11623 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11624 PL_pending_ident = proto_perl->Ipending_ident;
11625 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
11627 PL_expect = proto_perl->Iexpect;
11629 PL_multi_start = proto_perl->Imulti_start;
11630 PL_multi_end = proto_perl->Imulti_end;
11631 PL_multi_open = proto_perl->Imulti_open;
11632 PL_multi_close = proto_perl->Imulti_close;
11634 PL_error_count = proto_perl->Ierror_count;
11635 PL_subline = proto_perl->Isubline;
11636 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
11638 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
11639 if (SvANY(proto_perl->Ilinestr)) {
11640 i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
11641 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11642 i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
11643 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11644 PL_last_lop_op = proto_perl->Ilast_lop_op;
11647 PL_last_uni = SvPVX(PL_linestr);
11648 PL_last_lop = SvPVX(PL_linestr);
11649 PL_last_lop_op = 0;
11651 PL_in_my = proto_perl->Iin_my;
11652 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
11654 PL_cryptseen = proto_perl->Icryptseen;
11657 PL_hints = proto_perl->Ihints;
11659 PL_amagic_generation = proto_perl->Iamagic_generation;
11661 #ifdef USE_LOCALE_COLLATE
11662 PL_collation_ix = proto_perl->Icollation_ix;
11663 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
11664 PL_collation_standard = proto_perl->Icollation_standard;
11665 PL_collxfrm_base = proto_perl->Icollxfrm_base;
11666 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
11667 #endif /* USE_LOCALE_COLLATE */
11669 #ifdef USE_LOCALE_NUMERIC
11670 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
11671 PL_numeric_standard = proto_perl->Inumeric_standard;
11672 PL_numeric_local = proto_perl->Inumeric_local;
11673 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11674 #endif /* !USE_LOCALE_NUMERIC */
11676 /* utf8 character classes */
11677 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11678 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11679 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11680 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11681 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
11682 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11683 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
11684 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
11685 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
11686 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
11687 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
11688 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
11689 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11690 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
11691 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11692 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11693 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11694 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11695 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11696 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11698 /* Did the locale setup indicate UTF-8? */
11699 PL_utf8locale = proto_perl->Iutf8locale;
11700 /* Unicode features (see perlrun/-C) */
11701 PL_unicode = proto_perl->Iunicode;
11703 /* Pre-5.8 signals control */
11704 PL_signals = proto_perl->Isignals;
11706 /* times() ticks per second */
11707 PL_clocktick = proto_perl->Iclocktick;
11709 /* Recursion stopper for PerlIO_find_layer */
11710 PL_in_load_module = proto_perl->Iin_load_module;
11712 /* sort() routine */
11713 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
11715 /* Not really needed/useful since the reenrant_retint is "volatile",
11716 * but do it for consistency's sake. */
11717 PL_reentrant_retint = proto_perl->Ireentrant_retint;
11719 /* Hooks to shared SVs and locks. */
11720 PL_sharehook = proto_perl->Isharehook;
11721 PL_lockhook = proto_perl->Ilockhook;
11722 PL_unlockhook = proto_perl->Iunlockhook;
11723 PL_threadhook = proto_perl->Ithreadhook;
11725 PL_runops_std = proto_perl->Irunops_std;
11726 PL_runops_dbg = proto_perl->Irunops_dbg;
11728 #ifdef THREADS_HAVE_PIDS
11729 PL_ppid = proto_perl->Ippid;
11733 PL_last_swash_hv = Nullhv; /* reinits on demand */
11734 PL_last_swash_klen = 0;
11735 PL_last_swash_key[0]= '\0';
11736 PL_last_swash_tmps = (U8*)NULL;
11737 PL_last_swash_slen = 0;
11739 PL_glob_index = proto_perl->Iglob_index;
11740 PL_srand_called = proto_perl->Isrand_called;
11741 PL_uudmap['M'] = 0; /* reinits on demand */
11742 PL_bitcount = Nullch; /* reinits on demand */
11744 if (proto_perl->Ipsig_pend) {
11745 Newz(0, PL_psig_pend, SIG_SIZE, int);
11748 PL_psig_pend = (int*)NULL;
11751 if (proto_perl->Ipsig_ptr) {
11752 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
11753 Newz(0, PL_psig_name, SIG_SIZE, SV*);
11754 for (i = 1; i < SIG_SIZE; i++) {
11755 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11756 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11760 PL_psig_ptr = (SV**)NULL;
11761 PL_psig_name = (SV**)NULL;
11764 /* thrdvar.h stuff */
11766 if (flags & CLONEf_COPY_STACKS) {
11767 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11768 PL_tmps_ix = proto_perl->Ttmps_ix;
11769 PL_tmps_max = proto_perl->Ttmps_max;
11770 PL_tmps_floor = proto_perl->Ttmps_floor;
11771 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
11773 while (i <= PL_tmps_ix) {
11774 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
11778 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11779 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
11780 Newz(54, PL_markstack, i, I32);
11781 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
11782 - proto_perl->Tmarkstack);
11783 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
11784 - proto_perl->Tmarkstack);
11785 Copy(proto_perl->Tmarkstack, PL_markstack,
11786 PL_markstack_ptr - PL_markstack + 1, I32);
11788 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
11789 * NOTE: unlike the others! */
11790 PL_scopestack_ix = proto_perl->Tscopestack_ix;
11791 PL_scopestack_max = proto_perl->Tscopestack_max;
11792 Newz(54, PL_scopestack, PL_scopestack_max, I32);
11793 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
11795 /* NOTE: si_dup() looks at PL_markstack */
11796 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
11798 /* PL_curstack = PL_curstackinfo->si_stack; */
11799 PL_curstack = av_dup(proto_perl->Tcurstack, param);
11800 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
11802 /* next PUSHs() etc. set *(PL_stack_sp+1) */
11803 PL_stack_base = AvARRAY(PL_curstack);
11804 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
11805 - proto_perl->Tstack_base);
11806 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
11808 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
11809 * NOTE: unlike the others! */
11810 PL_savestack_ix = proto_perl->Tsavestack_ix;
11811 PL_savestack_max = proto_perl->Tsavestack_max;
11812 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
11813 PL_savestack = ss_dup(proto_perl, param);
11817 ENTER; /* perl_destruct() wants to LEAVE; */
11820 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
11821 PL_top_env = &PL_start_env;
11823 PL_op = proto_perl->Top;
11826 PL_Xpv = (XPV*)NULL;
11827 PL_na = proto_perl->Tna;
11829 PL_statbuf = proto_perl->Tstatbuf;
11830 PL_statcache = proto_perl->Tstatcache;
11831 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
11832 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
11834 PL_timesbuf = proto_perl->Ttimesbuf;
11837 PL_tainted = proto_perl->Ttainted;
11838 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
11839 PL_rs = sv_dup_inc(proto_perl->Trs, param);
11840 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
11841 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
11842 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
11843 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
11844 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
11845 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
11846 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
11848 PL_restartop = proto_perl->Trestartop;
11849 PL_in_eval = proto_perl->Tin_eval;
11850 PL_delaymagic = proto_perl->Tdelaymagic;
11851 PL_dirty = proto_perl->Tdirty;
11852 PL_localizing = proto_perl->Tlocalizing;
11854 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
11855 PL_hv_fetch_ent_mh = Nullhe;
11856 PL_modcount = proto_perl->Tmodcount;
11857 PL_lastgotoprobe = Nullop;
11858 PL_dumpindent = proto_perl->Tdumpindent;
11860 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
11861 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
11862 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
11863 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
11864 PL_sortcxix = proto_perl->Tsortcxix;
11865 PL_efloatbuf = Nullch; /* reinits on demand */
11866 PL_efloatsize = 0; /* reinits on demand */
11870 PL_screamfirst = NULL;
11871 PL_screamnext = NULL;
11872 PL_maxscream = -1; /* reinits on demand */
11873 PL_lastscream = Nullsv;
11875 PL_watchaddr = NULL;
11876 PL_watchok = Nullch;
11878 PL_regdummy = proto_perl->Tregdummy;
11879 PL_regprecomp = Nullch;
11882 PL_colorset = 0; /* reinits PL_colors[] */
11883 /*PL_colors[6] = {0,0,0,0,0,0};*/
11884 PL_reginput = Nullch;
11885 PL_regbol = Nullch;
11886 PL_regeol = Nullch;
11887 PL_regstartp = (I32*)NULL;
11888 PL_regendp = (I32*)NULL;
11889 PL_reglastparen = (U32*)NULL;
11890 PL_reglastcloseparen = (U32*)NULL;
11891 PL_regtill = Nullch;
11892 PL_reg_start_tmp = (char**)NULL;
11893 PL_reg_start_tmpl = 0;
11894 PL_regdata = (struct reg_data*)NULL;
11897 PL_reg_eval_set = 0;
11899 PL_regprogram = (regnode*)NULL;
11901 PL_regcc = (CURCUR*)NULL;
11902 PL_reg_call_cc = (struct re_cc_state*)NULL;
11903 PL_reg_re = (regexp*)NULL;
11904 PL_reg_ganch = Nullch;
11905 PL_reg_sv = Nullsv;
11906 PL_reg_match_utf8 = FALSE;
11907 PL_reg_magic = (MAGIC*)NULL;
11909 PL_reg_oldcurpm = (PMOP*)NULL;
11910 PL_reg_curpm = (PMOP*)NULL;
11911 PL_reg_oldsaved = Nullch;
11912 PL_reg_oldsavedlen = 0;
11913 #ifdef PERL_OLD_COPY_ON_WRITE
11916 PL_reg_maxiter = 0;
11917 PL_reg_leftiter = 0;
11918 PL_reg_poscache = Nullch;
11919 PL_reg_poscache_size= 0;
11921 /* RE engine - function pointers */
11922 PL_regcompp = proto_perl->Tregcompp;
11923 PL_regexecp = proto_perl->Tregexecp;
11924 PL_regint_start = proto_perl->Tregint_start;
11925 PL_regint_string = proto_perl->Tregint_string;
11926 PL_regfree = proto_perl->Tregfree;
11928 PL_reginterp_cnt = 0;
11929 PL_reg_starttry = 0;
11931 /* Pluggable optimizer */
11932 PL_peepp = proto_perl->Tpeepp;
11934 PL_stashcache = newHV();
11936 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
11937 ptr_table_free(PL_ptr_table);
11938 PL_ptr_table = NULL;
11941 /* Call the ->CLONE method, if it exists, for each of the stashes
11942 identified by sv_dup() above.
11944 while(av_len(param->stashes) != -1) {
11945 HV* const stash = (HV*) av_shift(param->stashes);
11946 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
11947 if (cloner && GvCV(cloner)) {
11952 XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
11954 call_sv((SV*)GvCV(cloner), G_DISCARD);
11960 SvREFCNT_dec(param->stashes);
11962 /* orphaned? eg threads->new inside BEGIN or use */
11963 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
11964 (void)SvREFCNT_inc(PL_compcv);
11965 SAVEFREESV(PL_compcv);
11971 #endif /* USE_ITHREADS */
11974 =head1 Unicode Support
11976 =for apidoc sv_recode_to_utf8
11978 The encoding is assumed to be an Encode object, on entry the PV
11979 of the sv is assumed to be octets in that encoding, and the sv
11980 will be converted into Unicode (and UTF-8).
11982 If the sv already is UTF-8 (or if it is not POK), or if the encoding
11983 is not a reference, nothing is done to the sv. If the encoding is not
11984 an C<Encode::XS> Encoding object, bad things will happen.
11985 (See F<lib/encoding.pm> and L<Encode>).
11987 The PV of the sv is returned.
11992 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
11995 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12009 Passing sv_yes is wrong - it needs to be or'ed set of constants
12010 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12011 remove converted chars from source.
12013 Both will default the value - let them.
12015 XPUSHs(&PL_sv_yes);
12018 call_method("decode", G_SCALAR);
12022 s = SvPV_const(uni, len);
12023 if (s != SvPVX_const(sv)) {
12024 SvGROW(sv, len + 1);
12025 Move(s, SvPVX(sv), len + 1, char);
12026 SvCUR_set(sv, len);
12033 return SvPOKp(sv) ? SvPVX(sv) : NULL;
12037 =for apidoc sv_cat_decode
12039 The encoding is assumed to be an Encode object, the PV of the ssv is
12040 assumed to be octets in that encoding and decoding the input starts
12041 from the position which (PV + *offset) pointed to. The dsv will be
12042 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
12043 when the string tstr appears in decoding output or the input ends on
12044 the PV of the ssv. The value which the offset points will be modified
12045 to the last input position on the ssv.
12047 Returns TRUE if the terminator was found, else returns FALSE.
12052 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12053 SV *ssv, int *offset, char *tstr, int tlen)
12057 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12068 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
12069 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
12071 call_method("cat_decode", G_SCALAR);
12073 ret = SvTRUE(TOPs);
12074 *offset = SvIV(offsv);
12080 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12086 * c-indentation-style: bsd
12087 * c-basic-offset: 4
12088 * indent-tabs-mode: t
12091 * ex: set ts=8 sts=4 sw=4 noet: