3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
9 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
12 * This file contains the code that creates, manipulates and destroys
13 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
14 * structure of an SV, so their creation and destruction is handled
15 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
16 * level functions (eg. substr, split, join) for each of the types are
28 /* Missing proto on LynxOS */
29 char *gconvert(double, int, int, char *);
32 #ifdef PERL_UTF8_CACHE_ASSERT
33 /* The cache element 0 is the Unicode offset;
34 * the cache element 1 is the byte offset of the element 0;
35 * the cache element 2 is the Unicode length of the substring;
36 * the cache element 3 is the byte length of the substring;
37 * The checking of the substring side would be good
38 * but substr() has enough code paths to make my head spin;
39 * if adding more checks watch out for the following tests:
40 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
41 * lib/utf8.t lib/Unicode/Collate/t/index.t
44 #define ASSERT_UTF8_CACHE(cache) \
45 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
47 #define ASSERT_UTF8_CACHE(cache) NOOP
50 #ifdef PERL_OLD_COPY_ON_WRITE
51 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
52 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
53 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
57 /* ============================================================================
59 =head1 Allocation and deallocation of SVs.
61 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
62 av, hv...) contains type and reference count information, as well as a
63 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
64 specific to each type.
66 Normally, this allocation is done using arenas, which by default are
67 approximately 4K chunks of memory parcelled up into N heads or bodies. The
68 first slot in each arena is reserved, and is used to hold a link to the next
69 arena. In the case of heads, the unused first slot also contains some flags
70 and a note of the number of slots. Snaked through each arena chain is a
71 linked list of free items; when this becomes empty, an extra arena is
72 allocated and divided up into N items which are threaded into the free list.
74 The following global variables are associated with arenas:
76 PL_sv_arenaroot pointer to list of SV arenas
77 PL_sv_root pointer to list of free SV structures
79 PL_foo_arenaroot pointer to list of foo arenas,
80 PL_foo_root pointer to list of free foo bodies
81 ... for foo in xiv, xnv, xrv, xpv etc.
83 Note that some of the larger and more rarely used body types (eg xpvio)
84 are not allocated using arenas, but are instead just malloc()/free()ed as
85 required. Also, if PURIFY is defined, arenas are abandoned altogether,
86 with all items individually malloc()ed. In addition, a few SV heads are
87 not allocated from an arena, but are instead directly created as static
88 or auto variables, eg PL_sv_undef. The size of arenas can be changed from
89 the default by setting PERL_ARENA_SIZE appropriately at compile time.
91 The SV arena serves the secondary purpose of allowing still-live SVs
92 to be located and destroyed during final cleanup.
94 At the lowest level, the macros new_SV() and del_SV() grab and free
95 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
96 to return the SV to the free list with error checking.) new_SV() calls
97 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
98 SVs in the free list have their SvTYPE field set to all ones.
100 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
101 that allocate and return individual body types. Normally these are mapped
102 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
103 instead mapped directly to malloc()/free() if PURIFY is defined. The
104 new/del functions remove from, or add to, the appropriate PL_foo_root
105 list, and call more_xiv() etc to add a new arena if the list is empty.
107 At the time of very final cleanup, sv_free_arenas() is called from
108 perl_destruct() to physically free all the arenas allocated since the
109 start of the interpreter. Note that this also clears PL_he_arenaroot,
110 which is otherwise dealt with in hv.c.
112 Manipulation of any of the PL_*root pointers is protected by enclosing
113 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
114 if threads are enabled.
116 The function visit() scans the SV arenas list, and calls a specified
117 function for each SV it finds which is still live - ie which has an SvTYPE
118 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
119 following functions (specified as [function that calls visit()] / [function
120 called by visit() for each SV]):
122 sv_report_used() / do_report_used()
123 dump all remaining SVs (debugging aid)
125 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
126 Attempt to free all objects pointed to by RVs,
127 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
128 try to do the same for all objects indirectly
129 referenced by typeglobs too. Called once from
130 perl_destruct(), prior to calling sv_clean_all()
133 sv_clean_all() / do_clean_all()
134 SvREFCNT_dec(sv) each remaining SV, possibly
135 triggering an sv_free(). It also sets the
136 SVf_BREAK flag on the SV to indicate that the
137 refcnt has been artificially lowered, and thus
138 stopping sv_free() from giving spurious warnings
139 about SVs which unexpectedly have a refcnt
140 of zero. called repeatedly from perl_destruct()
141 until there are no SVs left.
145 Private API to rest of sv.c
149 new_XIV(), del_XIV(),
150 new_XNV(), del_XNV(),
155 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
160 ============================================================================ */
165 * "A time to plant, and a time to uproot what was planted..."
169 * nice_chunk and nice_chunk size need to be set
170 * and queried under the protection of sv_mutex
173 Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
178 new_chunk = (void *)(chunk);
179 new_chunk_size = (chunk_size);
180 if (new_chunk_size > PL_nice_chunk_size) {
181 Safefree(PL_nice_chunk);
182 PL_nice_chunk = (char *) new_chunk;
183 PL_nice_chunk_size = new_chunk_size;
190 #ifdef DEBUG_LEAKING_SCALARS
191 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
193 # define FREE_SV_DEBUG_FILE(sv)
196 #define plant_SV(p) \
198 FREE_SV_DEBUG_FILE(p); \
199 SvANY(p) = (void *)PL_sv_root; \
200 SvFLAGS(p) = SVTYPEMASK; \
205 /* sv_mutex must be held while calling uproot_SV() */
206 #define uproot_SV(p) \
209 PL_sv_root = (SV*)SvANY(p); \
214 /* make some more SVs by adding another arena */
216 /* sv_mutex must be held while calling more_sv() */
223 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
224 PL_nice_chunk = Nullch;
225 PL_nice_chunk_size = 0;
228 char *chunk; /* must use New here to match call to */
229 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
230 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
236 /* new_SV(): return a new, empty SV head */
238 #ifdef DEBUG_LEAKING_SCALARS
239 /* provide a real function for a debugger to play with */
249 sv = S_more_sv(aTHX);
254 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
255 sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
256 (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
257 sv->sv_debug_inpad = 0;
258 sv->sv_debug_cloned = 0;
259 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
263 # define new_SV(p) (p)=S_new_SV(aTHX)
272 (p) = S_more_sv(aTHX); \
281 /* del_SV(): return an empty SV head to the free list */
296 S_del_sv(pTHX_ SV *p)
301 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
302 const SV * const sv = sva + 1;
303 const SV * const svend = &sva[SvREFCNT(sva)];
304 if (p >= sv && p < svend) {
310 if (ckWARN_d(WARN_INTERNAL))
311 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
312 "Attempt to free non-arena SV: 0x%"UVxf
313 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
320 #else /* ! DEBUGGING */
322 #define del_SV(p) plant_SV(p)
324 #endif /* DEBUGGING */
328 =head1 SV Manipulation Functions
330 =for apidoc sv_add_arena
332 Given a chunk of memory, link it to the head of the list of arenas,
333 and split it into a list of free SVs.
339 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
345 /* The first SV in an arena isn't an SV. */
346 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
347 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
348 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
350 PL_sv_arenaroot = sva;
351 PL_sv_root = sva + 1;
353 svend = &sva[SvREFCNT(sva) - 1];
356 SvANY(sv) = (void *)(SV*)(sv + 1);
360 /* Must always set typemask because it's awlays checked in on cleanup
361 when the arenas are walked looking for objects. */
362 SvFLAGS(sv) = SVTYPEMASK;
369 SvFLAGS(sv) = SVTYPEMASK;
372 /* visit(): call the named function for each non-free SV in the arenas
373 * whose flags field matches the flags/mask args. */
376 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
381 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
382 register const SV * const svend = &sva[SvREFCNT(sva)];
384 for (sv = sva + 1; sv < svend; ++sv) {
385 if (SvTYPE(sv) != SVTYPEMASK
386 && (sv->sv_flags & mask) == flags
399 /* called by sv_report_used() for each live SV */
402 do_report_used(pTHX_ SV *sv)
404 if (SvTYPE(sv) != SVTYPEMASK) {
405 PerlIO_printf(Perl_debug_log, "****\n");
412 =for apidoc sv_report_used
414 Dump the contents of all SVs not yet freed. (Debugging aid).
420 Perl_sv_report_used(pTHX)
423 visit(do_report_used, 0, 0);
427 /* called by sv_clean_objs() for each live SV */
430 do_clean_objs(pTHX_ SV *ref)
434 if (SvROK(ref) && SvOBJECT(target = SvRV(ref))) {
435 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
436 if (SvWEAKREF(ref)) {
437 sv_del_backref(target, ref);
443 SvREFCNT_dec(target);
447 /* XXX Might want to check arrays, etc. */
450 /* called by sv_clean_objs() for each live SV */
452 #ifndef DISABLE_DESTRUCTOR_KLUDGE
454 do_clean_named_objs(pTHX_ SV *sv)
456 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
458 #ifdef PERL_DONT_CREATE_GVSV
461 SvOBJECT(GvSV(sv))) ||
462 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
463 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
464 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
465 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
467 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
468 SvFLAGS(sv) |= SVf_BREAK;
476 =for apidoc sv_clean_objs
478 Attempt to destroy all objects not yet freed
484 Perl_sv_clean_objs(pTHX)
486 PL_in_clean_objs = TRUE;
487 visit(do_clean_objs, SVf_ROK, SVf_ROK);
488 #ifndef DISABLE_DESTRUCTOR_KLUDGE
489 /* some barnacles may yet remain, clinging to typeglobs */
490 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
492 PL_in_clean_objs = FALSE;
495 /* called by sv_clean_all() for each live SV */
498 do_clean_all(pTHX_ SV *sv)
500 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
501 SvFLAGS(sv) |= SVf_BREAK;
502 if (PL_comppad == (AV*)sv) {
504 PL_curpad = Null(SV**);
510 =for apidoc sv_clean_all
512 Decrement the refcnt of each remaining SV, possibly triggering a
513 cleanup. This function may have to be called multiple times to free
514 SVs which are in complex self-referential hierarchies.
520 Perl_sv_clean_all(pTHX)
523 PL_in_clean_all = TRUE;
524 cleaned = visit(do_clean_all, 0,0);
525 PL_in_clean_all = FALSE;
530 S_free_arena(pTHX_ void **root) {
532 void ** const next = *(void **)root;
539 =for apidoc sv_free_arenas
541 Deallocate the memory used by all arenas. Note that all the individual SV
542 heads and bodies within the arenas must already have been freed.
547 #define free_arena(name) \
549 S_free_arena(aTHX_ (void**) PL_ ## name ## _arenaroot); \
550 PL_ ## name ## _arenaroot = 0; \
551 PL_ ## name ## _root = 0; \
555 Perl_sv_free_arenas(pTHX)
560 /* Free arenas here, but be careful about fake ones. (We assume
561 contiguity of the fake ones with the corresponding real ones.) */
563 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
564 svanext = (SV*) SvANY(sva);
565 while (svanext && SvFAKE(svanext))
566 svanext = (SV*) SvANY(svanext);
584 #if defined(USE_ITHREADS)
588 Safefree(PL_nice_chunk);
589 PL_nice_chunk = Nullch;
590 PL_nice_chunk_size = 0;
595 /* ---------------------------------------------------------------------
597 * support functions for report_uninit()
600 /* the maxiumum size of array or hash where we will scan looking
601 * for the undefined element that triggered the warning */
603 #define FUV_MAX_SEARCH_SIZE 1000
605 /* Look for an entry in the hash whose value has the same SV as val;
606 * If so, return a mortal copy of the key. */
609 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
615 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
616 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
621 for (i=HvMAX(hv); i>0; i--) {
623 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
624 if (HeVAL(entry) != val)
626 if ( HeVAL(entry) == &PL_sv_undef ||
627 HeVAL(entry) == &PL_sv_placeholder)
631 if (HeKLEN(entry) == HEf_SVKEY)
632 return sv_mortalcopy(HeKEY_sv(entry));
633 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
639 /* Look for an entry in the array whose value has the same SV as val;
640 * If so, return the index, otherwise return -1. */
643 S_find_array_subscript(pTHX_ AV *av, SV* val)
647 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
648 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
652 for (i=AvFILLp(av); i>=0; i--) {
653 if (svp[i] == val && svp[i] != &PL_sv_undef)
659 /* S_varname(): return the name of a variable, optionally with a subscript.
660 * If gv is non-zero, use the name of that global, along with gvtype (one
661 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
662 * targ. Depending on the value of the subscript_type flag, return:
665 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
666 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
667 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
668 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
671 S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
672 SV* keyname, I32 aindex, int subscript_type)
675 SV * const name = sv_newmortal();
678 /* simulate gv_fullname4(), but add literal '^' for $^FOO names
679 * XXX get rid of all this if gv_fullnameX() ever supports this
683 HV * const hv = GvSTASH(gv);
686 else if (!(p=HvNAME_get(hv)))
688 if (strEQ(p, "main"))
689 sv_setpvn(name, &gvtype, 1);
691 Perl_sv_setpvf(aTHX_ name, "%c%s::", gvtype, p);
693 if (GvNAMELEN(gv)>= 1 &&
694 ((unsigned int)*GvNAME(gv)) <= 26)
696 Perl_sv_catpvf(aTHX_ name,"^%c", *GvNAME(gv) + 'A' - 1);
697 sv_catpvn(name,GvNAME(gv)+1,GvNAMELEN(gv)-1);
700 sv_catpvn(name,GvNAME(gv),GvNAMELEN(gv));
704 CV * const cv = find_runcv(&unused);
708 if (!cv || !CvPADLIST(cv))
710 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
711 sv = *av_fetch(av, targ, FALSE);
712 /* SvLEN in a pad name is not to be trusted */
713 sv_setpv(name, SvPV_nolen_const(sv));
716 if (subscript_type == FUV_SUBSCRIPT_HASH) {
717 SV * const sv = NEWSV(0,0);
719 Perl_sv_catpvf(aTHX_ name, "{%s}",
720 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
723 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
725 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
727 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
728 sv_insert(name, 0, 0, "within ", 7);
735 =for apidoc find_uninit_var
737 Find the name of the undefined variable (if any) that caused the operator o
738 to issue a "Use of uninitialized value" warning.
739 If match is true, only return a name if it's value matches uninit_sv.
740 So roughly speaking, if a unary operator (such as OP_COS) generates a
741 warning, then following the direct child of the op may yield an
742 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
743 other hand, with OP_ADD there are two branches to follow, so we only print
744 the variable name if we get an exact match.
746 The name is returned as a mortal SV.
748 Assumes that PL_op is the op that originally triggered the error, and that
749 PL_comppad/PL_curpad points to the currently executing pad.
755 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
763 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
764 uninit_sv == &PL_sv_placeholder)))
767 switch (obase->op_type) {
774 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
775 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
778 int subscript_type = FUV_SUBSCRIPT_WITHIN;
780 if (pad) { /* @lex, %lex */
781 sv = PAD_SVl(obase->op_targ);
785 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
786 /* @global, %global */
787 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
790 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
792 else /* @{expr}, %{expr} */
793 return find_uninit_var(cUNOPx(obase)->op_first,
797 /* attempt to find a match within the aggregate */
799 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
801 subscript_type = FUV_SUBSCRIPT_HASH;
804 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
806 subscript_type = FUV_SUBSCRIPT_ARRAY;
809 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
812 return varname(gv, hash ? '%' : '@', obase->op_targ,
813 keysv, index, subscript_type);
817 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
819 return varname(Nullgv, '$', obase->op_targ,
820 Nullsv, 0, FUV_SUBSCRIPT_NONE);
823 gv = cGVOPx_gv(obase);
824 if (!gv || (match && GvSV(gv) != uninit_sv))
826 return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
829 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
832 av = (AV*)PAD_SV(obase->op_targ);
833 if (!av || SvRMAGICAL(av))
835 svp = av_fetch(av, (I32)obase->op_private, FALSE);
836 if (!svp || *svp != uninit_sv)
839 return varname(Nullgv, '$', obase->op_targ,
840 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
843 gv = cGVOPx_gv(obase);
849 if (!av || SvRMAGICAL(av))
851 svp = av_fetch(av, (I32)obase->op_private, FALSE);
852 if (!svp || *svp != uninit_sv)
855 return varname(gv, '$', 0,
856 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
861 o = cUNOPx(obase)->op_first;
862 if (!o || o->op_type != OP_NULL ||
863 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
865 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
870 /* $a[uninit_expr] or $h{uninit_expr} */
871 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
874 o = cBINOPx(obase)->op_first;
875 kid = cBINOPx(obase)->op_last;
877 /* get the av or hv, and optionally the gv */
879 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
880 sv = PAD_SV(o->op_targ);
882 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
883 && cUNOPo->op_first->op_type == OP_GV)
885 gv = cGVOPx_gv(cUNOPo->op_first);
888 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
893 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
894 /* index is constant */
898 if (obase->op_type == OP_HELEM) {
899 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
900 if (!he || HeVAL(he) != uninit_sv)
904 SV ** const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
905 if (!svp || *svp != uninit_sv)
909 if (obase->op_type == OP_HELEM)
910 return varname(gv, '%', o->op_targ,
911 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
913 return varname(gv, '@', o->op_targ, Nullsv,
914 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
918 /* index is an expression;
919 * attempt to find a match within the aggregate */
920 if (obase->op_type == OP_HELEM) {
921 SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
923 return varname(gv, '%', o->op_targ,
924 keysv, 0, FUV_SUBSCRIPT_HASH);
927 const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
929 return varname(gv, '@', o->op_targ,
930 Nullsv, index, FUV_SUBSCRIPT_ARRAY);
935 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
937 o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
943 /* only examine RHS */
944 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
947 o = cUNOPx(obase)->op_first;
948 if (o->op_type == OP_PUSHMARK)
951 if (!o->op_sibling) {
952 /* one-arg version of open is highly magical */
954 if (o->op_type == OP_GV) { /* open FOO; */
956 if (match && GvSV(gv) != uninit_sv)
958 return varname(gv, '$', 0,
959 Nullsv, 0, FUV_SUBSCRIPT_NONE);
961 /* other possibilities not handled are:
962 * open $x; or open my $x; should return '${*$x}'
963 * open expr; should return '$'.expr ideally
969 /* ops where $_ may be an implicit arg */
973 if ( !(obase->op_flags & OPf_STACKED)) {
974 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
975 ? PAD_SVl(obase->op_targ)
979 sv_setpvn(sv, "$_", 2);
987 /* skip filehandle as it can't produce 'undef' warning */
988 o = cUNOPx(obase)->op_first;
989 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
990 o = o->op_sibling->op_sibling;
997 match = 1; /* XS or custom code could trigger random warnings */
1002 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
1003 return sv_2mortal(newSVpvn("${$/}", 5));
1008 if (!(obase->op_flags & OPf_KIDS))
1010 o = cUNOPx(obase)->op_first;
1016 /* if all except one arg are constant, or have no side-effects,
1017 * or are optimized away, then it's unambiguous */
1019 for (kid=o; kid; kid = kid->op_sibling) {
1021 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
1022 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
1023 || (kid->op_type == OP_PUSHMARK)
1027 if (o2) { /* more than one found */
1034 return find_uninit_var(o2, uninit_sv, match);
1038 sv = find_uninit_var(o, uninit_sv, 1);
1050 =for apidoc report_uninit
1052 Print appropriate "Use of uninitialized variable" warning
1058 Perl_report_uninit(pTHX_ SV* uninit_sv)
1061 SV* varname = Nullsv;
1063 varname = find_uninit_var(PL_op, uninit_sv,0);
1065 sv_insert(varname, 0, 0, " ", 1);
1067 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1068 varname ? SvPV_nolen_const(varname) : "",
1069 " in ", OP_DESC(PL_op));
1072 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1077 S_more_bodies (pTHX_ void **arena_root, void **root, size_t size)
1081 const size_t count = PERL_ARENA_SIZE/size;
1082 Newx(start, count*size, char);
1083 *((void **) start) = *arena_root;
1084 *arena_root = (void *)start;
1086 end = start + (count-1) * size;
1088 /* The initial slot is used to link the arenas together, so it isn't to be
1089 linked into the list of ready-to-use bodies. */
1093 *root = (void *)start;
1095 while (start < end) {
1096 char * const next = start + size;
1097 *(void**) start = (void *)next;
1100 *(void **)start = 0;
1105 /* grab a new thing from the free list, allocating more if necessary */
1107 /* 1st, the inline version */
1109 #define new_body_inline(xpv, arena_root, root, size) \
1112 xpv = *((void **)(root)) \
1113 ? *((void **)(root)) : S_more_bodies(aTHX_ arena_root, root, size); \
1114 *(root) = *(void**)(xpv); \
1118 /* now use the inline version in the proper function */
1121 S_new_body(pTHX_ void **arena_root, void **root, size_t size)
1124 new_body_inline(xpv, arena_root, root, size);
1128 /* return a thing to the free list */
1130 #define del_body(thing, root) \
1132 void **thing_copy = (void **)thing; \
1134 *thing_copy = *root; \
1135 *root = (void*)thing_copy; \
1139 /* Conventionally we simply malloc() a big block of memory, then divide it
1140 up into lots of the thing that we're allocating.
1142 This macro will expand to call to S_new_body. So for XPVBM (with ithreads),
1145 S_new_body(my_perl, (void**)&(my_perl->Ixpvbm_arenaroot),
1146 (void**)&(my_perl->Ixpvbm_root), sizeof(XPVBM), 0)
1149 #define new_body_type(TYPE,lctype) \
1150 S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \
1151 (void**)&PL_ ## lctype ## _root, \
1154 #define del_body_type(p,TYPE,lctype) \
1155 del_body((void*)p, (void**)&PL_ ## lctype ## _root)
1157 /* But for some types, we cheat. The type starts with some members that are
1158 never accessed. So we allocate the substructure, starting at the first used
1159 member, then adjust the pointer back in memory by the size of the bit not
1160 allocated, so it's as if we allocated the full structure.
1161 (But things will all go boom if you write to the part that is "not there",
1162 because you'll be overwriting the last members of the preceding structure
1165 We calculate the correction using the STRUCT_OFFSET macro. For example, if
1166 xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
1167 and the pointer is unchanged. If the allocated structure is smaller (no
1168 initial NV actually allocated) then the net effect is to subtract the size
1169 of the NV from the pointer, to return a new pointer as if an initial NV were
1172 This is the same trick as was used for NV and IV bodies. Ironically it
1173 doesn't need to be used for NV bodies any more, because NV is now at the
1174 start of the structure. IV bodies don't need it either, because they are
1175 no longer allocated. */
1177 #define new_body_allocated(TYPE,lctype,member) \
1178 (void*)((char*)S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \
1179 (void**)&PL_ ## lctype ## _root, \
1180 sizeof(lctype ## _allocated)) - \
1181 STRUCT_OFFSET(TYPE, member) \
1182 + STRUCT_OFFSET(lctype ## _allocated, member))
1185 #define del_body_allocated(p,TYPE,lctype,member) \
1186 del_body((void*)((char*)p + STRUCT_OFFSET(TYPE, member) \
1187 - STRUCT_OFFSET(lctype ## _allocated, member)), \
1188 (void**)&PL_ ## lctype ## _root)
1190 #define my_safemalloc(s) (void*)safemalloc(s)
1191 #define my_safefree(p) safefree((char*)p)
1195 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1196 #define del_XNV(p) my_safefree(p)
1198 #define new_XPV() my_safemalloc(sizeof(XPV))
1199 #define del_XPV(p) my_safefree(p)
1201 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1202 #define del_XPVIV(p) my_safefree(p)
1204 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1205 #define del_XPVNV(p) my_safefree(p)
1207 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1208 #define del_XPVCV(p) my_safefree(p)
1210 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1211 #define del_XPVAV(p) my_safefree(p)
1213 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1214 #define del_XPVHV(p) my_safefree(p)
1216 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1217 #define del_XPVMG(p) my_safefree(p)
1219 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1220 #define del_XPVGV(p) my_safefree(p)
1222 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1223 #define del_XPVLV(p) my_safefree(p)
1225 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1226 #define del_XPVBM(p) my_safefree(p)
1230 #define new_XNV() new_body_type(NV, xnv)
1231 #define del_XNV(p) del_body_type(p, NV, xnv)
1233 #define new_XPV() new_body_allocated(XPV, xpv, xpv_cur)
1234 #define del_XPV(p) del_body_allocated(p, XPV, xpv, xpv_cur)
1236 #define new_XPVIV() new_body_allocated(XPVIV, xpviv, xpv_cur)
1237 #define del_XPVIV(p) del_body_allocated(p, XPVIV, xpviv, xpv_cur)
1239 #define new_XPVNV() new_body_type(XPVNV, xpvnv)
1240 #define del_XPVNV(p) del_body_type(p, XPVNV, xpvnv)
1242 #define new_XPVCV() new_body_type(XPVCV, xpvcv)
1243 #define del_XPVCV(p) del_body_type(p, XPVCV, xpvcv)
1245 #define new_XPVAV() new_body_allocated(XPVAV, xpvav, xav_fill)
1246 #define del_XPVAV(p) del_body_allocated(p, XPVAV, xpvav, xav_fill)
1248 #define new_XPVHV() new_body_allocated(XPVHV, xpvhv, xhv_fill)
1249 #define del_XPVHV(p) del_body_allocated(p, XPVHV, xpvhv, xhv_fill)
1251 #define new_XPVMG() new_body_type(XPVMG, xpvmg)
1252 #define del_XPVMG(p) del_body_type(p, XPVMG, xpvmg)
1254 #define new_XPVGV() new_body_type(XPVGV, xpvgv)
1255 #define del_XPVGV(p) del_body_type(p, XPVGV, xpvgv)
1257 #define new_XPVLV() new_body_type(XPVLV, xpvlv)
1258 #define del_XPVLV(p) del_body_type(p, XPVLV, xpvlv)
1260 #define new_XPVBM() new_body_type(XPVBM, xpvbm)
1261 #define del_XPVBM(p) del_body_type(p, XPVBM, xpvbm)
1265 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1266 #define del_XPVFM(p) my_safefree(p)
1268 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1269 #define del_XPVIO(p) my_safefree(p)
1272 =for apidoc sv_upgrade
1274 Upgrade an SV to a more complex form. Generally adds a new body type to the
1275 SV, then copies across as much information as possible from the old body.
1276 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1282 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1284 void** old_body_arena;
1285 size_t old_body_offset;
1286 size_t old_body_length; /* Well, the length to copy. */
1288 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1289 /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct
1291 bool zero_nv = TRUE;
1294 size_t new_body_length;
1295 size_t new_body_offset;
1296 void** new_body_arena;
1297 void** new_body_arenaroot;
1298 const U32 old_type = SvTYPE(sv);
1300 if (mt != SVt_PV && SvIsCOW(sv)) {
1301 sv_force_normal_flags(sv, 0);
1304 if (SvTYPE(sv) == mt)
1307 if (SvTYPE(sv) > mt)
1308 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1309 (int)SvTYPE(sv), (int)mt);
1312 old_body = SvANY(sv);
1314 old_body_offset = 0;
1315 old_body_length = 0;
1316 new_body_offset = 0;
1317 new_body_length = ~0;
1319 /* Copying structures onto other structures that have been neatly zeroed
1320 has a subtle gotcha. Consider XPVMG
1322 +------+------+------+------+------+-------+-------+
1323 | NV | CUR | LEN | IV | MAGIC | STASH |
1324 +------+------+------+------+------+-------+-------+
1325 0 4 8 12 16 20 24 28
1327 where NVs are aligned to 8 bytes, so that sizeof that structure is
1328 actually 32 bytes long, with 4 bytes of padding at the end:
1330 +------+------+------+------+------+-------+-------+------+
1331 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1332 +------+------+------+------+------+-------+-------+------+
1333 0 4 8 12 16 20 24 28 32
1335 so what happens if you allocate memory for this structure:
1337 +------+------+------+------+------+-------+-------+------+------+...
1338 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1339 +------+------+------+------+------+-------+-------+------+------+...
1340 0 4 8 12 16 20 24 28 32 36
1342 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1343 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1344 started out as zero once, but it's quite possible that it isn't. So now,
1345 rather than a nicely zeroed GP, you have it pointing somewhere random.
1348 (In fact, GP ends up pointing at a previous GP structure, because the
1349 principle cause of the padding in XPVMG getting garbage is a copy of
1350 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob)
1352 So we are careful and work out the size of used parts of all the
1355 switch (SvTYPE(sv)) {
1361 else if (mt < SVt_PVIV)
1363 old_body_offset = STRUCT_OFFSET(XPVIV, xiv_iv);
1364 old_body_length = sizeof(IV);
1367 old_body_arena = (void **) &PL_xnv_root;
1368 old_body_length = sizeof(NV);
1369 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1378 old_body_arena = (void **) &PL_xpv_root;
1379 old_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
1380 - STRUCT_OFFSET(xpv_allocated, xpv_cur);
1381 old_body_length = STRUCT_OFFSET(XPV, xpv_len)
1382 + sizeof (((XPV*)SvANY(sv))->xpv_len)
1386 else if (mt == SVt_NV)
1390 old_body_arena = (void **) &PL_xpviv_root;
1391 old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
1392 - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
1393 old_body_length = STRUCT_OFFSET(XPVIV, xiv_u)
1394 + sizeof (((XPVIV*)SvANY(sv))->xiv_u)
1398 old_body_arena = (void **) &PL_xpvnv_root;
1399 old_body_length = STRUCT_OFFSET(XPVNV, xiv_u)
1400 + sizeof (((XPVNV*)SvANY(sv))->xiv_u);
1401 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1406 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1407 there's no way that it can be safely upgraded, because perl.c
1408 expects to Safefree(SvANY(PL_mess_sv)) */
1409 assert(sv != PL_mess_sv);
1410 /* This flag bit is used to mean other things in other scalar types.
1411 Given that it only has meaning inside the pad, it shouldn't be set
1412 on anything that can get upgraded. */
1413 assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
1414 old_body_arena = (void **) &PL_xpvmg_root;
1415 old_body_length = STRUCT_OFFSET(XPVMG, xmg_stash)
1416 + sizeof (((XPVMG*)SvANY(sv))->xmg_stash);
1417 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1422 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1425 SvFLAGS(sv) &= ~SVTYPEMASK;
1430 Perl_croak(aTHX_ "Can't upgrade to undef");
1432 assert(old_type == SVt_NULL);
1433 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1437 assert(old_type == SVt_NULL);
1438 SvANY(sv) = new_XNV();
1442 assert(old_type == SVt_NULL);
1443 SvANY(sv) = &sv->sv_u.svu_rv;
1447 SvANY(sv) = new_XPVHV();
1450 HvTOTALKEYS(sv) = 0;
1455 SvANY(sv) = new_XPVAV();
1462 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1463 The target created by newSVrv also is, and it can have magic.
1464 However, it never has SvPVX set.
1466 if (old_type >= SVt_RV) {
1467 assert(SvPVX_const(sv) == 0);
1470 /* Could put this in the else clause below, as PVMG must have SvPVX
1471 0 already (the assertion above) */
1472 SvPV_set(sv, (char*)0);
1474 if (old_type >= SVt_PVMG) {
1475 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic);
1476 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1484 new_body = new_XPVIO();
1485 new_body_length = sizeof(XPVIO);
1488 new_body = new_XPVFM();
1489 new_body_length = sizeof(XPVFM);
1493 new_body_length = sizeof(XPVBM);
1494 new_body_arena = (void **) &PL_xpvbm_root;
1495 new_body_arenaroot = (void **) &PL_xpvbm_arenaroot;
1498 new_body_length = sizeof(XPVGV);
1499 new_body_arena = (void **) &PL_xpvgv_root;
1500 new_body_arenaroot = (void **) &PL_xpvgv_arenaroot;
1503 new_body_length = sizeof(XPVCV);
1504 new_body_arena = (void **) &PL_xpvcv_root;
1505 new_body_arenaroot = (void **) &PL_xpvcv_arenaroot;
1508 new_body_length = sizeof(XPVLV);
1509 new_body_arena = (void **) &PL_xpvlv_root;
1510 new_body_arenaroot = (void **) &PL_xpvlv_arenaroot;
1513 new_body_length = sizeof(XPVMG);
1514 new_body_arena = (void **) &PL_xpvmg_root;
1515 new_body_arenaroot = (void **) &PL_xpvmg_arenaroot;
1518 new_body_length = sizeof(XPVNV);
1519 new_body_arena = (void **) &PL_xpvnv_root;
1520 new_body_arenaroot = (void **) &PL_xpvnv_arenaroot;
1523 new_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
1524 - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
1525 new_body_length = sizeof(XPVIV) - new_body_offset;
1526 new_body_arena = (void **) &PL_xpviv_root;
1527 new_body_arenaroot = (void **) &PL_xpviv_arenaroot;
1528 /* XXX Is this still needed? Was it ever needed? Surely as there is
1529 no route from NV to PVIV, NOK can never be true */
1533 goto new_body_no_NV;
1535 new_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
1536 - STRUCT_OFFSET(xpv_allocated, xpv_cur);
1537 new_body_length = sizeof(XPV) - new_body_offset;
1538 new_body_arena = (void **) &PL_xpv_root;
1539 new_body_arenaroot = (void **) &PL_xpv_arenaroot;
1541 /* PV and PVIV don't have an NV slot. */
1542 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1547 assert(new_body_length);
1549 /* This points to the start of the allocated area. */
1550 new_body_inline(new_body, new_body_arenaroot, new_body_arena,
1553 /* We always allocated the full length item with PURIFY */
1554 new_body_length += new_body_offset;
1555 new_body_offset = 0;
1556 new_body = my_safemalloc(new_body_length);
1560 Zero(new_body, new_body_length, char);
1561 new_body = ((char *)new_body) - new_body_offset;
1562 SvANY(sv) = new_body;
1564 if (old_body_length) {
1565 Copy((char *)old_body + old_body_offset,
1566 (char *)new_body + old_body_offset,
1567 old_body_length, char);
1570 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1576 IoPAGE_LEN(sv) = 60;
1577 if (old_type < SVt_RV)
1581 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", mt);
1585 if (old_body_arena) {
1587 my_safefree(old_body);
1589 del_body((void*)((char*)old_body + old_body_offset),
1596 =for apidoc sv_backoff
1598 Remove any string offset. You should normally use the C<SvOOK_off> macro
1605 Perl_sv_backoff(pTHX_ register SV *sv)
1608 assert(SvTYPE(sv) != SVt_PVHV);
1609 assert(SvTYPE(sv) != SVt_PVAV);
1611 const char * const s = SvPVX_const(sv);
1612 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1613 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1615 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1617 SvFLAGS(sv) &= ~SVf_OOK;
1624 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1625 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1626 Use the C<SvGROW> wrapper instead.
1632 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1636 #ifdef HAS_64K_LIMIT
1637 if (newlen >= 0x10000) {
1638 PerlIO_printf(Perl_debug_log,
1639 "Allocation too large: %"UVxf"\n", (UV)newlen);
1642 #endif /* HAS_64K_LIMIT */
1645 if (SvTYPE(sv) < SVt_PV) {
1646 sv_upgrade(sv, SVt_PV);
1647 s = SvPVX_mutable(sv);
1649 else if (SvOOK(sv)) { /* pv is offset? */
1651 s = SvPVX_mutable(sv);
1652 if (newlen > SvLEN(sv))
1653 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1654 #ifdef HAS_64K_LIMIT
1655 if (newlen >= 0x10000)
1660 s = SvPVX_mutable(sv);
1662 if (newlen > SvLEN(sv)) { /* need more room? */
1663 newlen = PERL_STRLEN_ROUNDUP(newlen);
1664 if (SvLEN(sv) && s) {
1666 const STRLEN l = malloced_size((void*)SvPVX_const(sv));
1672 s = saferealloc(s, newlen);
1675 s = safemalloc(newlen);
1676 if (SvPVX_const(sv) && SvCUR(sv)) {
1677 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1681 SvLEN_set(sv, newlen);
1687 =for apidoc sv_setiv
1689 Copies an integer into the given SV, upgrading first if necessary.
1690 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1696 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1698 SV_CHECK_THINKFIRST_COW_DROP(sv);
1699 switch (SvTYPE(sv)) {
1701 sv_upgrade(sv, SVt_IV);
1704 sv_upgrade(sv, SVt_PVNV);
1708 sv_upgrade(sv, SVt_PVIV);
1717 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1720 (void)SvIOK_only(sv); /* validate number */
1726 =for apidoc sv_setiv_mg
1728 Like C<sv_setiv>, but also handles 'set' magic.
1734 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1741 =for apidoc sv_setuv
1743 Copies an unsigned integer into the given SV, upgrading first if necessary.
1744 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1750 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1752 /* With these two if statements:
1753 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1756 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1758 If you wish to remove them, please benchmark to see what the effect is
1760 if (u <= (UV)IV_MAX) {
1761 sv_setiv(sv, (IV)u);
1770 =for apidoc sv_setuv_mg
1772 Like C<sv_setuv>, but also handles 'set' magic.
1778 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1787 =for apidoc sv_setnv
1789 Copies a double into the given SV, upgrading first if necessary.
1790 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1796 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1798 SV_CHECK_THINKFIRST_COW_DROP(sv);
1799 switch (SvTYPE(sv)) {
1802 sv_upgrade(sv, SVt_NV);
1807 sv_upgrade(sv, SVt_PVNV);
1816 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1820 (void)SvNOK_only(sv); /* validate number */
1825 =for apidoc sv_setnv_mg
1827 Like C<sv_setnv>, but also handles 'set' magic.
1833 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1839 /* Print an "isn't numeric" warning, using a cleaned-up,
1840 * printable version of the offending string
1844 S_not_a_number(pTHX_ SV *sv)
1851 dsv = sv_2mortal(newSVpvn("", 0));
1852 pv = sv_uni_display(dsv, sv, 10, 0);
1855 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1856 /* each *s can expand to 4 chars + "...\0",
1857 i.e. need room for 8 chars */
1859 const char *s, *end;
1860 for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit;
1863 if (ch & 128 && !isPRINT_LC(ch)) {
1872 else if (ch == '\r') {
1876 else if (ch == '\f') {
1880 else if (ch == '\\') {
1884 else if (ch == '\0') {
1888 else if (isPRINT_LC(ch))
1905 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1906 "Argument \"%s\" isn't numeric in %s", pv,
1909 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1910 "Argument \"%s\" isn't numeric", pv);
1914 =for apidoc looks_like_number
1916 Test if the content of an SV looks like a number (or is a number).
1917 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1918 non-numeric warning), even if your atof() doesn't grok them.
1924 Perl_looks_like_number(pTHX_ SV *sv)
1926 register const char *sbegin;
1930 sbegin = SvPVX_const(sv);
1933 else if (SvPOKp(sv))
1934 sbegin = SvPV_const(sv, len);
1936 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1937 return grok_number(sbegin, len, NULL);
1940 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1941 until proven guilty, assume that things are not that bad... */
1946 As 64 bit platforms often have an NV that doesn't preserve all bits of
1947 an IV (an assumption perl has been based on to date) it becomes necessary
1948 to remove the assumption that the NV always carries enough precision to
1949 recreate the IV whenever needed, and that the NV is the canonical form.
1950 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1951 precision as a side effect of conversion (which would lead to insanity
1952 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1953 1) to distinguish between IV/UV/NV slots that have cached a valid
1954 conversion where precision was lost and IV/UV/NV slots that have a
1955 valid conversion which has lost no precision
1956 2) to ensure that if a numeric conversion to one form is requested that
1957 would lose precision, the precise conversion (or differently
1958 imprecise conversion) is also performed and cached, to prevent
1959 requests for different numeric formats on the same SV causing
1960 lossy conversion chains. (lossless conversion chains are perfectly
1965 SvIOKp is true if the IV slot contains a valid value
1966 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1967 SvNOKp is true if the NV slot contains a valid value
1968 SvNOK is true only if the NV value is accurate
1971 while converting from PV to NV, check to see if converting that NV to an
1972 IV(or UV) would lose accuracy over a direct conversion from PV to
1973 IV(or UV). If it would, cache both conversions, return NV, but mark
1974 SV as IOK NOKp (ie not NOK).
1976 While converting from PV to IV, check to see if converting that IV to an
1977 NV would lose accuracy over a direct conversion from PV to NV. If it
1978 would, cache both conversions, flag similarly.
1980 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1981 correctly because if IV & NV were set NV *always* overruled.
1982 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1983 changes - now IV and NV together means that the two are interchangeable:
1984 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1986 The benefit of this is that operations such as pp_add know that if
1987 SvIOK is true for both left and right operands, then integer addition
1988 can be used instead of floating point (for cases where the result won't
1989 overflow). Before, floating point was always used, which could lead to
1990 loss of precision compared with integer addition.
1992 * making IV and NV equal status should make maths accurate on 64 bit
1994 * may speed up maths somewhat if pp_add and friends start to use
1995 integers when possible instead of fp. (Hopefully the overhead in
1996 looking for SvIOK and checking for overflow will not outweigh the
1997 fp to integer speedup)
1998 * will slow down integer operations (callers of SvIV) on "inaccurate"
1999 values, as the change from SvIOK to SvIOKp will cause a call into
2000 sv_2iv each time rather than a macro access direct to the IV slot
2001 * should speed up number->string conversion on integers as IV is
2002 favoured when IV and NV are equally accurate
2004 ####################################################################
2005 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2006 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2007 On the other hand, SvUOK is true iff UV.
2008 ####################################################################
2010 Your mileage will vary depending your CPU's relative fp to integer
2014 #ifndef NV_PRESERVES_UV
2015 # define IS_NUMBER_UNDERFLOW_IV 1
2016 # define IS_NUMBER_UNDERFLOW_UV 2
2017 # define IS_NUMBER_IV_AND_UV 2
2018 # define IS_NUMBER_OVERFLOW_IV 4
2019 # define IS_NUMBER_OVERFLOW_UV 5
2021 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2023 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2025 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2027 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));
2028 if (SvNVX(sv) < (NV)IV_MIN) {
2029 (void)SvIOKp_on(sv);
2031 SvIV_set(sv, IV_MIN);
2032 return IS_NUMBER_UNDERFLOW_IV;
2034 if (SvNVX(sv) > (NV)UV_MAX) {
2035 (void)SvIOKp_on(sv);
2038 SvUV_set(sv, UV_MAX);
2039 return IS_NUMBER_OVERFLOW_UV;
2041 (void)SvIOKp_on(sv);
2043 /* Can't use strtol etc to convert this string. (See truth table in
2045 if (SvNVX(sv) <= (UV)IV_MAX) {
2046 SvIV_set(sv, I_V(SvNVX(sv)));
2047 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2048 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2050 /* Integer is imprecise. NOK, IOKp */
2052 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2055 SvUV_set(sv, U_V(SvNVX(sv)));
2056 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2057 if (SvUVX(sv) == UV_MAX) {
2058 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2059 possibly be preserved by NV. Hence, it must be overflow.
2061 return IS_NUMBER_OVERFLOW_UV;
2063 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2065 /* Integer is imprecise. NOK, IOKp */
2067 return IS_NUMBER_OVERFLOW_IV;
2069 #endif /* !NV_PRESERVES_UV*/
2071 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
2072 * this function provided for binary compatibility only
2076 Perl_sv_2iv(pTHX_ register SV *sv)
2078 return sv_2iv_flags(sv, SV_GMAGIC);
2082 =for apidoc sv_2iv_flags
2084 Return the integer value of an SV, doing any necessary string
2085 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2086 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2092 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2096 if (SvGMAGICAL(sv)) {
2097 if (flags & SV_GMAGIC)
2102 return I_V(SvNVX(sv));
2104 if (SvPOKp(sv) && SvLEN(sv))
2107 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2108 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2114 if (SvTHINKFIRST(sv)) {
2117 SV * const tmpstr=AMG_CALLun(sv,numer);
2118 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2119 return SvIV(tmpstr);
2122 return PTR2IV(SvRV(sv));
2125 sv_force_normal_flags(sv, 0);
2127 if (SvREADONLY(sv) && !SvOK(sv)) {
2128 if (ckWARN(WARN_UNINITIALIZED))
2135 return (IV)(SvUVX(sv));
2142 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2143 * without also getting a cached IV/UV from it at the same time
2144 * (ie PV->NV conversion should detect loss of accuracy and cache
2145 * IV or UV at same time to avoid this. NWC */
2147 if (SvTYPE(sv) == SVt_NV)
2148 sv_upgrade(sv, SVt_PVNV);
2150 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2151 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2152 certainly cast into the IV range at IV_MAX, whereas the correct
2153 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2155 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2156 SvIV_set(sv, I_V(SvNVX(sv)));
2157 if (SvNVX(sv) == (NV) SvIVX(sv)
2158 #ifndef NV_PRESERVES_UV
2159 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2160 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2161 /* Don't flag it as "accurately an integer" if the number
2162 came from a (by definition imprecise) NV operation, and
2163 we're outside the range of NV integer precision */
2166 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2167 DEBUG_c(PerlIO_printf(Perl_debug_log,
2168 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2174 /* IV not precise. No need to convert from PV, as NV
2175 conversion would already have cached IV if it detected
2176 that PV->IV would be better than PV->NV->IV
2177 flags already correct - don't set public IOK. */
2178 DEBUG_c(PerlIO_printf(Perl_debug_log,
2179 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2184 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2185 but the cast (NV)IV_MIN rounds to a the value less (more
2186 negative) than IV_MIN which happens to be equal to SvNVX ??
2187 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2188 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2189 (NV)UVX == NVX are both true, but the values differ. :-(
2190 Hopefully for 2s complement IV_MIN is something like
2191 0x8000000000000000 which will be exact. NWC */
2194 SvUV_set(sv, U_V(SvNVX(sv)));
2196 (SvNVX(sv) == (NV) SvUVX(sv))
2197 #ifndef NV_PRESERVES_UV
2198 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2199 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2200 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2201 /* Don't flag it as "accurately an integer" if the number
2202 came from a (by definition imprecise) NV operation, and
2203 we're outside the range of NV integer precision */
2209 DEBUG_c(PerlIO_printf(Perl_debug_log,
2210 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2214 return (IV)SvUVX(sv);
2217 else if (SvPOKp(sv) && SvLEN(sv)) {
2219 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2220 /* We want to avoid a possible problem when we cache an IV which
2221 may be later translated to an NV, and the resulting NV is not
2222 the same as the direct translation of the initial string
2223 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2224 be careful to ensure that the value with the .456 is around if the
2225 NV value is requested in the future).
2227 This means that if we cache such an IV, we need to cache the
2228 NV as well. Moreover, we trade speed for space, and do not
2229 cache the NV if we are sure it's not needed.
2232 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2233 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2234 == IS_NUMBER_IN_UV) {
2235 /* It's definitely an integer, only upgrade to PVIV */
2236 if (SvTYPE(sv) < SVt_PVIV)
2237 sv_upgrade(sv, SVt_PVIV);
2239 } else if (SvTYPE(sv) < SVt_PVNV)
2240 sv_upgrade(sv, SVt_PVNV);
2242 /* If NV preserves UV then we only use the UV value if we know that
2243 we aren't going to call atof() below. If NVs don't preserve UVs
2244 then the value returned may have more precision than atof() will
2245 return, even though value isn't perfectly accurate. */
2246 if ((numtype & (IS_NUMBER_IN_UV
2247 #ifdef NV_PRESERVES_UV
2250 )) == IS_NUMBER_IN_UV) {
2251 /* This won't turn off the public IOK flag if it was set above */
2252 (void)SvIOKp_on(sv);
2254 if (!(numtype & IS_NUMBER_NEG)) {
2256 if (value <= (UV)IV_MAX) {
2257 SvIV_set(sv, (IV)value);
2259 SvUV_set(sv, value);
2263 /* 2s complement assumption */
2264 if (value <= (UV)IV_MIN) {
2265 SvIV_set(sv, -(IV)value);
2267 /* Too negative for an IV. This is a double upgrade, but
2268 I'm assuming it will be rare. */
2269 if (SvTYPE(sv) < SVt_PVNV)
2270 sv_upgrade(sv, SVt_PVNV);
2274 SvNV_set(sv, -(NV)value);
2275 SvIV_set(sv, IV_MIN);
2279 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2280 will be in the previous block to set the IV slot, and the next
2281 block to set the NV slot. So no else here. */
2283 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2284 != IS_NUMBER_IN_UV) {
2285 /* It wasn't an (integer that doesn't overflow the UV). */
2286 SvNV_set(sv, Atof(SvPVX_const(sv)));
2288 if (! numtype && ckWARN(WARN_NUMERIC))
2291 #if defined(USE_LONG_DOUBLE)
2292 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2293 PTR2UV(sv), SvNVX(sv)));
2295 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2296 PTR2UV(sv), SvNVX(sv)));
2300 #ifdef NV_PRESERVES_UV
2301 (void)SvIOKp_on(sv);
2303 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2304 SvIV_set(sv, I_V(SvNVX(sv)));
2305 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2308 /* Integer is imprecise. NOK, IOKp */
2310 /* UV will not work better than IV */
2312 if (SvNVX(sv) > (NV)UV_MAX) {
2314 /* Integer is inaccurate. NOK, IOKp, is UV */
2315 SvUV_set(sv, UV_MAX);
2318 SvUV_set(sv, U_V(SvNVX(sv)));
2319 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2320 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2324 /* Integer is imprecise. NOK, IOKp, is UV */
2330 #else /* NV_PRESERVES_UV */
2331 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2332 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2333 /* The IV slot will have been set from value returned by
2334 grok_number above. The NV slot has just been set using
2337 assert (SvIOKp(sv));
2339 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2340 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2341 /* Small enough to preserve all bits. */
2342 (void)SvIOKp_on(sv);
2344 SvIV_set(sv, I_V(SvNVX(sv)));
2345 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2347 /* Assumption: first non-preserved integer is < IV_MAX,
2348 this NV is in the preserved range, therefore: */
2349 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2351 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);
2355 0 0 already failed to read UV.
2356 0 1 already failed to read UV.
2357 1 0 you won't get here in this case. IV/UV
2358 slot set, public IOK, Atof() unneeded.
2359 1 1 already read UV.
2360 so there's no point in sv_2iuv_non_preserve() attempting
2361 to use atol, strtol, strtoul etc. */
2362 if (sv_2iuv_non_preserve (sv, numtype)
2363 >= IS_NUMBER_OVERFLOW_IV)
2367 #endif /* NV_PRESERVES_UV */
2370 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2372 if (SvTYPE(sv) < SVt_IV)
2373 /* Typically the caller expects that sv_any is not NULL now. */
2374 sv_upgrade(sv, SVt_IV);
2377 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2378 PTR2UV(sv),SvIVX(sv)));
2379 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2382 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2383 * this function provided for binary compatibility only
2387 Perl_sv_2uv(pTHX_ register SV *sv)
2389 return sv_2uv_flags(sv, SV_GMAGIC);
2393 =for apidoc sv_2uv_flags
2395 Return the unsigned integer value of an SV, doing any necessary string
2396 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2397 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2403 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2407 if (SvGMAGICAL(sv)) {
2408 if (flags & SV_GMAGIC)
2413 return U_V(SvNVX(sv));
2414 if (SvPOKp(sv) && SvLEN(sv))
2417 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2418 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2424 if (SvTHINKFIRST(sv)) {
2427 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2428 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2429 return SvUV(tmpstr);
2430 return PTR2UV(SvRV(sv));
2433 sv_force_normal_flags(sv, 0);
2435 if (SvREADONLY(sv) && !SvOK(sv)) {
2436 if (ckWARN(WARN_UNINITIALIZED))
2446 return (UV)SvIVX(sv);
2450 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2451 * without also getting a cached IV/UV from it at the same time
2452 * (ie PV->NV conversion should detect loss of accuracy and cache
2453 * IV or UV at same time to avoid this. */
2454 /* IV-over-UV optimisation - choose to cache IV if possible */
2456 if (SvTYPE(sv) == SVt_NV)
2457 sv_upgrade(sv, SVt_PVNV);
2459 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2460 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2461 SvIV_set(sv, I_V(SvNVX(sv)));
2462 if (SvNVX(sv) == (NV) SvIVX(sv)
2463 #ifndef NV_PRESERVES_UV
2464 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2465 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2466 /* Don't flag it as "accurately an integer" if the number
2467 came from a (by definition imprecise) NV operation, and
2468 we're outside the range of NV integer precision */
2471 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2472 DEBUG_c(PerlIO_printf(Perl_debug_log,
2473 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2479 /* IV not precise. No need to convert from PV, as NV
2480 conversion would already have cached IV if it detected
2481 that PV->IV would be better than PV->NV->IV
2482 flags already correct - don't set public IOK. */
2483 DEBUG_c(PerlIO_printf(Perl_debug_log,
2484 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2489 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2490 but the cast (NV)IV_MIN rounds to a the value less (more
2491 negative) than IV_MIN which happens to be equal to SvNVX ??
2492 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2493 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2494 (NV)UVX == NVX are both true, but the values differ. :-(
2495 Hopefully for 2s complement IV_MIN is something like
2496 0x8000000000000000 which will be exact. NWC */
2499 SvUV_set(sv, U_V(SvNVX(sv)));
2501 (SvNVX(sv) == (NV) SvUVX(sv))
2502 #ifndef NV_PRESERVES_UV
2503 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2504 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2505 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2506 /* Don't flag it as "accurately an integer" if the number
2507 came from a (by definition imprecise) NV operation, and
2508 we're outside the range of NV integer precision */
2513 DEBUG_c(PerlIO_printf(Perl_debug_log,
2514 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2520 else if (SvPOKp(sv) && SvLEN(sv)) {
2522 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2524 /* We want to avoid a possible problem when we cache a UV which
2525 may be later translated to an NV, and the resulting NV is not
2526 the translation of the initial data.
2528 This means that if we cache such a UV, we need to cache the
2529 NV as well. Moreover, we trade speed for space, and do not
2530 cache the NV if not needed.
2533 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2534 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2535 == IS_NUMBER_IN_UV) {
2536 /* It's definitely an integer, only upgrade to PVIV */
2537 if (SvTYPE(sv) < SVt_PVIV)
2538 sv_upgrade(sv, SVt_PVIV);
2540 } else if (SvTYPE(sv) < SVt_PVNV)
2541 sv_upgrade(sv, SVt_PVNV);
2543 /* If NV preserves UV then we only use the UV value if we know that
2544 we aren't going to call atof() below. If NVs don't preserve UVs
2545 then the value returned may have more precision than atof() will
2546 return, even though it isn't accurate. */
2547 if ((numtype & (IS_NUMBER_IN_UV
2548 #ifdef NV_PRESERVES_UV
2551 )) == IS_NUMBER_IN_UV) {
2552 /* This won't turn off the public IOK flag if it was set above */
2553 (void)SvIOKp_on(sv);
2555 if (!(numtype & IS_NUMBER_NEG)) {
2557 if (value <= (UV)IV_MAX) {
2558 SvIV_set(sv, (IV)value);
2560 /* it didn't overflow, and it was positive. */
2561 SvUV_set(sv, value);
2565 /* 2s complement assumption */
2566 if (value <= (UV)IV_MIN) {
2567 SvIV_set(sv, -(IV)value);
2569 /* Too negative for an IV. This is a double upgrade, but
2570 I'm assuming it will be rare. */
2571 if (SvTYPE(sv) < SVt_PVNV)
2572 sv_upgrade(sv, SVt_PVNV);
2576 SvNV_set(sv, -(NV)value);
2577 SvIV_set(sv, IV_MIN);
2582 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2583 != IS_NUMBER_IN_UV) {
2584 /* It wasn't an integer, or it overflowed the UV. */
2585 SvNV_set(sv, Atof(SvPVX_const(sv)));
2587 if (! numtype && ckWARN(WARN_NUMERIC))
2590 #if defined(USE_LONG_DOUBLE)
2591 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2592 PTR2UV(sv), SvNVX(sv)));
2594 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2595 PTR2UV(sv), SvNVX(sv)));
2598 #ifdef NV_PRESERVES_UV
2599 (void)SvIOKp_on(sv);
2601 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2602 SvIV_set(sv, I_V(SvNVX(sv)));
2603 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2606 /* Integer is imprecise. NOK, IOKp */
2608 /* UV will not work better than IV */
2610 if (SvNVX(sv) > (NV)UV_MAX) {
2612 /* Integer is inaccurate. NOK, IOKp, is UV */
2613 SvUV_set(sv, UV_MAX);
2616 SvUV_set(sv, U_V(SvNVX(sv)));
2617 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2618 NV preservse UV so can do correct comparison. */
2619 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2623 /* Integer is imprecise. NOK, IOKp, is UV */
2628 #else /* NV_PRESERVES_UV */
2629 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2630 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2631 /* The UV slot will have been set from value returned by
2632 grok_number above. The NV slot has just been set using
2635 assert (SvIOKp(sv));
2637 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2638 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2639 /* Small enough to preserve all bits. */
2640 (void)SvIOKp_on(sv);
2642 SvIV_set(sv, I_V(SvNVX(sv)));
2643 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2645 /* Assumption: first non-preserved integer is < IV_MAX,
2646 this NV is in the preserved range, therefore: */
2647 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2649 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);
2652 sv_2iuv_non_preserve (sv, numtype);
2654 #endif /* NV_PRESERVES_UV */
2658 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2659 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2662 if (SvTYPE(sv) < SVt_IV)
2663 /* Typically the caller expects that sv_any is not NULL now. */
2664 sv_upgrade(sv, SVt_IV);
2668 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2669 PTR2UV(sv),SvUVX(sv)));
2670 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2676 Return the num value of an SV, doing any necessary string or integer
2677 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2684 Perl_sv_2nv(pTHX_ register SV *sv)
2688 if (SvGMAGICAL(sv)) {
2692 if (SvPOKp(sv) && SvLEN(sv)) {
2693 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2694 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2696 return Atof(SvPVX_const(sv));
2700 return (NV)SvUVX(sv);
2702 return (NV)SvIVX(sv);
2705 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2706 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2712 if (SvTHINKFIRST(sv)) {
2715 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2716 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2717 return SvNV(tmpstr);
2718 return PTR2NV(SvRV(sv));
2721 sv_force_normal_flags(sv, 0);
2723 if (SvREADONLY(sv) && !SvOK(sv)) {
2724 if (ckWARN(WARN_UNINITIALIZED))
2729 if (SvTYPE(sv) < SVt_NV) {
2730 if (SvTYPE(sv) == SVt_IV)
2731 sv_upgrade(sv, SVt_PVNV);
2733 sv_upgrade(sv, SVt_NV);
2734 #ifdef USE_LONG_DOUBLE
2736 STORE_NUMERIC_LOCAL_SET_STANDARD();
2737 PerlIO_printf(Perl_debug_log,
2738 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2739 PTR2UV(sv), SvNVX(sv));
2740 RESTORE_NUMERIC_LOCAL();
2744 STORE_NUMERIC_LOCAL_SET_STANDARD();
2745 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2746 PTR2UV(sv), SvNVX(sv));
2747 RESTORE_NUMERIC_LOCAL();
2751 else if (SvTYPE(sv) < SVt_PVNV)
2752 sv_upgrade(sv, SVt_PVNV);
2757 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2758 #ifdef NV_PRESERVES_UV
2761 /* Only set the public NV OK flag if this NV preserves the IV */
2762 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2763 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2764 : (SvIVX(sv) == I_V(SvNVX(sv))))
2770 else if (SvPOKp(sv) && SvLEN(sv)) {
2772 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2773 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2775 #ifdef NV_PRESERVES_UV
2776 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2777 == IS_NUMBER_IN_UV) {
2778 /* It's definitely an integer */
2779 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2781 SvNV_set(sv, Atof(SvPVX_const(sv)));
2784 SvNV_set(sv, Atof(SvPVX_const(sv)));
2785 /* Only set the public NV OK flag if this NV preserves the value in
2786 the PV at least as well as an IV/UV would.
2787 Not sure how to do this 100% reliably. */
2788 /* if that shift count is out of range then Configure's test is
2789 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2791 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2792 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2793 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2794 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2795 /* Can't use strtol etc to convert this string, so don't try.
2796 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2799 /* value has been set. It may not be precise. */
2800 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2801 /* 2s complement assumption for (UV)IV_MIN */
2802 SvNOK_on(sv); /* Integer is too negative. */
2807 if (numtype & IS_NUMBER_NEG) {
2808 SvIV_set(sv, -(IV)value);
2809 } else if (value <= (UV)IV_MAX) {
2810 SvIV_set(sv, (IV)value);
2812 SvUV_set(sv, value);
2816 if (numtype & IS_NUMBER_NOT_INT) {
2817 /* I believe that even if the original PV had decimals,
2818 they are lost beyond the limit of the FP precision.
2819 However, neither is canonical, so both only get p
2820 flags. NWC, 2000/11/25 */
2821 /* Both already have p flags, so do nothing */
2823 const NV nv = SvNVX(sv);
2824 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2825 if (SvIVX(sv) == I_V(nv)) {
2830 /* It had no "." so it must be integer. */
2833 /* between IV_MAX and NV(UV_MAX).
2834 Could be slightly > UV_MAX */
2836 if (numtype & IS_NUMBER_NOT_INT) {
2837 /* UV and NV both imprecise. */
2839 const UV nv_as_uv = U_V(nv);
2841 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2852 #endif /* NV_PRESERVES_UV */
2855 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2857 if (SvTYPE(sv) < SVt_NV)
2858 /* Typically the caller expects that sv_any is not NULL now. */
2859 /* XXX Ilya implies that this is a bug in callers that assume this
2860 and ideally should be fixed. */
2861 sv_upgrade(sv, SVt_NV);
2864 #if defined(USE_LONG_DOUBLE)
2866 STORE_NUMERIC_LOCAL_SET_STANDARD();
2867 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2868 PTR2UV(sv), SvNVX(sv));
2869 RESTORE_NUMERIC_LOCAL();
2873 STORE_NUMERIC_LOCAL_SET_STANDARD();
2874 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2875 PTR2UV(sv), SvNVX(sv));
2876 RESTORE_NUMERIC_LOCAL();
2882 /* asIV(): extract an integer from the string value of an SV.
2883 * Caller must validate PVX */
2886 S_asIV(pTHX_ SV *sv)
2889 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2891 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2892 == IS_NUMBER_IN_UV) {
2893 /* It's definitely an integer */
2894 if (numtype & IS_NUMBER_NEG) {
2895 if (value < (UV)IV_MIN)
2898 if (value < (UV)IV_MAX)
2903 if (ckWARN(WARN_NUMERIC))
2906 return I_V(Atof(SvPVX_const(sv)));
2909 /* asUV(): extract an unsigned integer from the string value of an SV
2910 * Caller must validate PVX */
2913 S_asUV(pTHX_ SV *sv)
2916 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2918 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2919 == IS_NUMBER_IN_UV) {
2920 /* It's definitely an integer */
2921 if (!(numtype & IS_NUMBER_NEG))
2925 if (ckWARN(WARN_NUMERIC))
2928 return U_V(Atof(SvPVX_const(sv)));
2932 =for apidoc sv_2pv_nolen
2934 Like C<sv_2pv()>, but doesn't return the length too. You should usually
2935 use the macro wrapper C<SvPV_nolen(sv)> instead.
2940 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2942 return sv_2pv(sv, 0);
2945 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2946 * UV as a string towards the end of buf, and return pointers to start and
2949 * We assume that buf is at least TYPE_CHARS(UV) long.
2953 S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2955 char *ptr = buf + TYPE_CHARS(UV);
2969 *--ptr = '0' + (char)(uv % 10);
2977 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
2978 * this function provided for binary compatibility only
2982 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2984 return sv_2pv_flags(sv, lp, SV_GMAGIC);
2988 =for apidoc sv_2pv_flags
2990 Returns a pointer to the string value of an SV, and sets *lp to its length.
2991 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2993 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2994 usually end up here too.
3000 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3005 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3006 char *tmpbuf = tbuf;
3013 if (SvGMAGICAL(sv)) {
3014 if (flags & SV_GMAGIC)
3019 if (flags & SV_MUTABLE_RETURN)
3020 return SvPVX_mutable(sv);
3021 if (flags & SV_CONST_RETURN)
3022 return (char *)SvPVX_const(sv);
3027 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
3029 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3034 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3039 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3040 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3048 if (SvTHINKFIRST(sv)) {
3051 register const char *typestr;
3052 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3053 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3055 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
3058 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
3059 if (flags & SV_CONST_RETURN) {
3060 pv = (char *) SvPVX_const(tmpstr);
3062 pv = (flags & SV_MUTABLE_RETURN)
3063 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
3066 *lp = SvCUR(tmpstr);
3068 pv = sv_2pv_flags(tmpstr, lp, flags);
3079 typestr = "NULLREF";
3083 switch (SvTYPE(sv)) {
3085 if ( ((SvFLAGS(sv) &
3086 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3087 == (SVs_OBJECT|SVs_SMG))
3088 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3089 const regexp *re = (regexp *)mg->mg_obj;
3092 const char *fptr = "msix";
3097 char need_newline = 0;
3098 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3100 while((ch = *fptr++)) {
3102 reflags[left++] = ch;
3105 reflags[right--] = ch;
3110 reflags[left] = '-';
3114 mg->mg_len = re->prelen + 4 + left;
3116 * If /x was used, we have to worry about a regex
3117 * ending with a comment later being embedded
3118 * within another regex. If so, we don't want this
3119 * regex's "commentization" to leak out to the
3120 * right part of the enclosing regex, we must cap
3121 * it with a newline.
3123 * So, if /x was used, we scan backwards from the
3124 * end of the regex. If we find a '#' before we
3125 * find a newline, we need to add a newline
3126 * ourself. If we find a '\n' first (or if we
3127 * don't find '#' or '\n'), we don't need to add
3128 * anything. -jfriedl
3130 if (PMf_EXTENDED & re->reganch)
3132 const char *endptr = re->precomp + re->prelen;
3133 while (endptr >= re->precomp)
3135 const char c = *(endptr--);
3137 break; /* don't need another */
3139 /* we end while in a comment, so we
3141 mg->mg_len++; /* save space for it */
3142 need_newline = 1; /* note to add it */
3148 Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
3149 Copy("(?", mg->mg_ptr, 2, char);
3150 Copy(reflags, mg->mg_ptr+2, left, char);
3151 Copy(":", mg->mg_ptr+left+2, 1, char);
3152 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3154 mg->mg_ptr[mg->mg_len - 2] = '\n';
3155 mg->mg_ptr[mg->mg_len - 1] = ')';
3156 mg->mg_ptr[mg->mg_len] = 0;
3158 PL_reginterp_cnt += re->program[0].next_off;
3160 if (re->reganch & ROPT_UTF8)
3176 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3177 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3178 /* tied lvalues should appear to be
3179 * scalars for backwards compatitbility */
3180 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3181 ? "SCALAR" : "LVALUE"; break;
3182 case SVt_PVAV: typestr = "ARRAY"; break;
3183 case SVt_PVHV: typestr = "HASH"; break;
3184 case SVt_PVCV: typestr = "CODE"; break;
3185 case SVt_PVGV: typestr = "GLOB"; break;
3186 case SVt_PVFM: typestr = "FORMAT"; break;
3187 case SVt_PVIO: typestr = "IO"; break;
3188 default: typestr = "UNKNOWN"; break;
3192 const char *name = HvNAME_get(SvSTASH(sv));
3193 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3194 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3197 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3201 *lp = strlen(typestr);
3202 return (char *)typestr;
3204 if (SvREADONLY(sv) && !SvOK(sv)) {
3205 if (ckWARN(WARN_UNINITIALIZED))
3212 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3213 /* I'm assuming that if both IV and NV are equally valid then
3214 converting the IV is going to be more efficient */
3215 const U32 isIOK = SvIOK(sv);
3216 const U32 isUIOK = SvIsUV(sv);
3217 char buf[TYPE_CHARS(UV)];
3220 if (SvTYPE(sv) < SVt_PVIV)
3221 sv_upgrade(sv, SVt_PVIV);
3223 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3225 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3226 /* inlined from sv_setpvn */
3227 SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
3228 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
3229 SvCUR_set(sv, ebuf - ptr);
3239 else if (SvNOKp(sv)) {
3240 if (SvTYPE(sv) < SVt_PVNV)
3241 sv_upgrade(sv, SVt_PVNV);
3242 /* The +20 is pure guesswork. Configure test needed. --jhi */
3243 s = SvGROW_mutable(sv, NV_DIG + 20);
3244 olderrno = errno; /* some Xenix systems wipe out errno here */
3246 if (SvNVX(sv) == 0.0)
3247 (void)strcpy(s,"0");
3251 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3254 #ifdef FIXNEGATIVEZERO
3255 if (*s == '-' && s[1] == '0' && !s[2])
3265 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
3269 if (SvTYPE(sv) < SVt_PV)
3270 /* Typically the caller expects that sv_any is not NULL now. */
3271 sv_upgrade(sv, SVt_PV);
3275 STRLEN len = s - SvPVX_const(sv);
3281 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3282 PTR2UV(sv),SvPVX_const(sv)));
3283 if (flags & SV_CONST_RETURN)
3284 return (char *)SvPVX_const(sv);
3285 if (flags & SV_MUTABLE_RETURN)
3286 return SvPVX_mutable(sv);
3290 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3291 /* Sneaky stuff here */
3295 tsv = newSVpv(tmpbuf, 0);
3308 t = SvPVX_const(tsv);
3313 len = strlen(tmpbuf);
3315 #ifdef FIXNEGATIVEZERO
3316 if (len == 2 && t[0] == '-' && t[1] == '0') {
3321 SvUPGRADE(sv, SVt_PV);
3324 s = SvGROW_mutable(sv, len + 1);
3327 return memcpy(s, t, len + 1);
3332 =for apidoc sv_copypv
3334 Copies a stringified representation of the source SV into the
3335 destination SV. Automatically performs any necessary mg_get and
3336 coercion of numeric values into strings. Guaranteed to preserve
3337 UTF-8 flag even from overloaded objects. Similar in nature to
3338 sv_2pv[_flags] but operates directly on an SV instead of just the
3339 string. Mostly uses sv_2pv_flags to do its work, except when that
3340 would lose the UTF-8'ness of the PV.
3346 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3349 const char * const s = SvPV_const(ssv,len);
3350 sv_setpvn(dsv,s,len);
3358 =for apidoc sv_2pvbyte_nolen
3360 Return a pointer to the byte-encoded representation of the SV.
3361 May cause the SV to be downgraded from UTF-8 as a side-effect.
3363 Usually accessed via the C<SvPVbyte_nolen> macro.
3369 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3371 return sv_2pvbyte(sv, 0);
3375 =for apidoc sv_2pvbyte
3377 Return a pointer to the byte-encoded representation of the SV, and set *lp
3378 to its length. May cause the SV to be downgraded from UTF-8 as a
3381 Usually accessed via the C<SvPVbyte> macro.
3387 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3389 sv_utf8_downgrade(sv,0);
3390 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3394 =for apidoc sv_2pvutf8_nolen
3396 Return a pointer to the UTF-8-encoded representation of the SV.
3397 May cause the SV to be upgraded to UTF-8 as a side-effect.
3399 Usually accessed via the C<SvPVutf8_nolen> macro.
3405 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3407 return sv_2pvutf8(sv, 0);
3411 =for apidoc sv_2pvutf8
3413 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3414 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3416 Usually accessed via the C<SvPVutf8> macro.
3422 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3424 sv_utf8_upgrade(sv);
3425 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3429 =for apidoc sv_2bool
3431 This function is only called on magical items, and is only used by
3432 sv_true() or its macro equivalent.
3438 Perl_sv_2bool(pTHX_ register SV *sv)
3446 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3447 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3448 return (bool)SvTRUE(tmpsv);
3449 return SvRV(sv) != 0;
3452 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3454 (*sv->sv_u.svu_pv > '0' ||
3455 Xpvtmp->xpv_cur > 1 ||
3456 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3463 return SvIVX(sv) != 0;
3466 return SvNVX(sv) != 0.0;
3473 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3474 * this function provided for binary compatibility only
3479 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3481 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3485 =for apidoc sv_utf8_upgrade
3487 Converts the PV of an SV to its UTF-8-encoded form.
3488 Forces the SV to string form if it is not already.
3489 Always sets the SvUTF8 flag to avoid future validity checks even
3490 if all the bytes have hibit clear.
3492 This is not as a general purpose byte encoding to Unicode interface:
3493 use the Encode extension for that.
3495 =for apidoc sv_utf8_upgrade_flags
3497 Converts the PV of an SV to its UTF-8-encoded form.
3498 Forces the SV to string form if it is not already.
3499 Always sets the SvUTF8 flag to avoid future validity checks even
3500 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3501 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3502 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3504 This is not as a general purpose byte encoding to Unicode interface:
3505 use the Encode extension for that.
3511 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3513 if (sv == &PL_sv_undef)
3517 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3518 (void) sv_2pv_flags(sv,&len, flags);
3522 (void) SvPV_force(sv,len);
3531 sv_force_normal_flags(sv, 0);
3534 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3535 sv_recode_to_utf8(sv, PL_encoding);
3536 else { /* Assume Latin-1/EBCDIC */
3537 /* This function could be much more efficient if we
3538 * had a FLAG in SVs to signal if there are any hibit
3539 * chars in the PV. Given that there isn't such a flag
3540 * make the loop as fast as possible. */
3541 const U8 *s = (U8 *) SvPVX_const(sv);
3542 const U8 *e = (U8 *) SvEND(sv);
3548 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3552 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3553 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
3555 SvPV_free(sv); /* No longer using what was there before. */
3557 SvPV_set(sv, (char*)recoded);
3558 SvCUR_set(sv, len - 1);
3559 SvLEN_set(sv, len); /* No longer know the real size. */
3561 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3568 =for apidoc sv_utf8_downgrade
3570 Attempts to convert the PV of an SV from characters to bytes.
3571 If the PV contains a character beyond byte, this conversion will fail;
3572 in this case, either returns false or, if C<fail_ok> is not
3575 This is not as a general purpose Unicode to byte encoding interface:
3576 use the Encode extension for that.
3582 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3584 if (SvPOKp(sv) && SvUTF8(sv)) {
3590 sv_force_normal_flags(sv, 0);
3592 s = (U8 *) SvPV(sv, len);
3593 if (!utf8_to_bytes(s, &len)) {
3598 Perl_croak(aTHX_ "Wide character in %s",
3601 Perl_croak(aTHX_ "Wide character");
3612 =for apidoc sv_utf8_encode
3614 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3615 flag off so that it looks like octets again.
3621 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3623 (void) sv_utf8_upgrade(sv);
3625 sv_force_normal_flags(sv, 0);
3627 if (SvREADONLY(sv)) {
3628 Perl_croak(aTHX_ PL_no_modify);
3634 =for apidoc sv_utf8_decode
3636 If the PV of the SV is an octet sequence in UTF-8
3637 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3638 so that it looks like a character. If the PV contains only single-byte
3639 characters, the C<SvUTF8> flag stays being off.
3640 Scans PV for validity and returns false if the PV is invalid UTF-8.
3646 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3652 /* The octets may have got themselves encoded - get them back as
3655 if (!sv_utf8_downgrade(sv, TRUE))
3658 /* it is actually just a matter of turning the utf8 flag on, but
3659 * we want to make sure everything inside is valid utf8 first.
3661 c = (const U8 *) SvPVX_const(sv);
3662 if (!is_utf8_string(c, SvCUR(sv)+1))
3664 e = (const U8 *) SvEND(sv);
3667 if (!UTF8_IS_INVARIANT(ch)) {
3676 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
3677 * this function provided for binary compatibility only
3681 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3683 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3687 =for apidoc sv_setsv
3689 Copies the contents of the source SV C<ssv> into the destination SV
3690 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3691 function if the source SV needs to be reused. Does not handle 'set' magic.
3692 Loosely speaking, it performs a copy-by-value, obliterating any previous
3693 content of the destination.
3695 You probably want to use one of the assortment of wrappers, such as
3696 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3697 C<SvSetMagicSV_nosteal>.
3699 =for apidoc sv_setsv_flags
3701 Copies the contents of the source SV C<ssv> into the destination SV
3702 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3703 function if the source SV needs to be reused. Does not handle 'set' magic.
3704 Loosely speaking, it performs a copy-by-value, obliterating any previous
3705 content of the destination.
3706 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3707 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3708 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3709 and C<sv_setsv_nomg> are implemented in terms of this function.
3711 You probably want to use one of the assortment of wrappers, such as
3712 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3713 C<SvSetMagicSV_nosteal>.
3715 This is the primary function for copying scalars, and most other
3716 copy-ish functions and macros use this underneath.
3722 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3724 register U32 sflags;
3730 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3732 sstr = &PL_sv_undef;
3733 stype = SvTYPE(sstr);
3734 dtype = SvTYPE(dstr);
3739 /* need to nuke the magic */
3741 SvRMAGICAL_off(dstr);
3744 /* There's a lot of redundancy below but we're going for speed here */
3749 if (dtype != SVt_PVGV) {
3750 (void)SvOK_off(dstr);
3758 sv_upgrade(dstr, SVt_IV);
3761 sv_upgrade(dstr, SVt_PVNV);
3765 sv_upgrade(dstr, SVt_PVIV);
3768 (void)SvIOK_only(dstr);
3769 SvIV_set(dstr, SvIVX(sstr));
3772 if (SvTAINTED(sstr))
3783 sv_upgrade(dstr, SVt_NV);
3788 sv_upgrade(dstr, SVt_PVNV);
3791 SvNV_set(dstr, SvNVX(sstr));
3792 (void)SvNOK_only(dstr);
3793 if (SvTAINTED(sstr))
3801 sv_upgrade(dstr, SVt_RV);
3802 else if (dtype == SVt_PVGV &&
3803 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3806 if (GvIMPORTED(dstr) != GVf_IMPORTED
3807 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3809 GvIMPORTED_on(dstr);
3818 #ifdef PERL_OLD_COPY_ON_WRITE
3819 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3820 if (dtype < SVt_PVIV)
3821 sv_upgrade(dstr, SVt_PVIV);
3828 sv_upgrade(dstr, SVt_PV);
3831 if (dtype < SVt_PVIV)
3832 sv_upgrade(dstr, SVt_PVIV);
3835 if (dtype < SVt_PVNV)
3836 sv_upgrade(dstr, SVt_PVNV);
3843 const char * const type = sv_reftype(sstr,0);
3845 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3847 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3852 if (dtype <= SVt_PVGV) {
3854 if (dtype != SVt_PVGV) {
3855 const char * const name = GvNAME(sstr);
3856 const STRLEN len = GvNAMELEN(sstr);
3857 /* don't upgrade SVt_PVLV: it can hold a glob */
3858 if (dtype != SVt_PVLV)
3859 sv_upgrade(dstr, SVt_PVGV);
3860 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3861 GvSTASH(dstr) = GvSTASH(sstr);
3863 Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3864 GvNAME(dstr) = savepvn(name, len);
3865 GvNAMELEN(dstr) = len;
3866 SvFAKE_on(dstr); /* can coerce to non-glob */
3868 /* ahem, death to those who redefine active sort subs */
3869 else if (PL_curstackinfo->si_type == PERLSI_SORT
3870 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3871 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3874 #ifdef GV_UNIQUE_CHECK
3875 if (GvUNIQUE((GV*)dstr)) {
3876 Perl_croak(aTHX_ PL_no_modify);
3880 (void)SvOK_off(dstr);
3881 GvINTRO_off(dstr); /* one-shot flag */
3883 GvGP(dstr) = gp_ref(GvGP(sstr));
3884 if (SvTAINTED(sstr))
3886 if (GvIMPORTED(dstr) != GVf_IMPORTED
3887 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3889 GvIMPORTED_on(dstr);
3897 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3899 if ((int)SvTYPE(sstr) != stype) {
3900 stype = SvTYPE(sstr);
3901 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3905 if (stype == SVt_PVLV)
3906 SvUPGRADE(dstr, SVt_PVNV);
3908 SvUPGRADE(dstr, (U32)stype);
3911 sflags = SvFLAGS(sstr);
3913 if (sflags & SVf_ROK) {
3914 if (dtype >= SVt_PV) {
3915 if (dtype == SVt_PVGV) {
3916 SV *sref = SvREFCNT_inc(SvRV(sstr));
3918 const int intro = GvINTRO(dstr);
3920 #ifdef GV_UNIQUE_CHECK
3921 if (GvUNIQUE((GV*)dstr)) {
3922 Perl_croak(aTHX_ PL_no_modify);
3927 GvINTRO_off(dstr); /* one-shot flag */
3928 GvLINE(dstr) = CopLINE(PL_curcop);
3929 GvEGV(dstr) = (GV*)dstr;
3932 switch (SvTYPE(sref)) {
3935 SAVEGENERICSV(GvAV(dstr));
3937 dref = (SV*)GvAV(dstr);
3938 GvAV(dstr) = (AV*)sref;
3939 if (!GvIMPORTED_AV(dstr)
3940 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3942 GvIMPORTED_AV_on(dstr);
3947 SAVEGENERICSV(GvHV(dstr));
3949 dref = (SV*)GvHV(dstr);
3950 GvHV(dstr) = (HV*)sref;
3951 if (!GvIMPORTED_HV(dstr)
3952 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3954 GvIMPORTED_HV_on(dstr);
3959 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3960 SvREFCNT_dec(GvCV(dstr));
3961 GvCV(dstr) = Nullcv;
3962 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3963 PL_sub_generation++;
3965 SAVEGENERICSV(GvCV(dstr));
3968 dref = (SV*)GvCV(dstr);
3969 if (GvCV(dstr) != (CV*)sref) {
3970 CV* cv = GvCV(dstr);
3972 if (!GvCVGEN((GV*)dstr) &&
3973 (CvROOT(cv) || CvXSUB(cv)))
3975 /* ahem, death to those who redefine
3976 * active sort subs */
3977 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3978 PL_sortcop == CvSTART(cv))
3980 "Can't redefine active sort subroutine %s",
3981 GvENAME((GV*)dstr));
3982 /* Redefining a sub - warning is mandatory if
3983 it was a const and its value changed. */
3984 if (ckWARN(WARN_REDEFINE)
3986 && (!CvCONST((CV*)sref)
3987 || sv_cmp(cv_const_sv(cv),
3988 cv_const_sv((CV*)sref)))))
3990 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3992 ? "Constant subroutine %s::%s redefined"
3993 : "Subroutine %s::%s redefined",
3994 HvNAME_get(GvSTASH((GV*)dstr)),
3995 GvENAME((GV*)dstr));
3999 cv_ckproto(cv, (GV*)dstr,
4001 ? SvPVX_const(sref) : Nullch);
4003 GvCV(dstr) = (CV*)sref;
4004 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4005 GvASSUMECV_on(dstr);
4006 PL_sub_generation++;
4008 if (!GvIMPORTED_CV(dstr)
4009 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4011 GvIMPORTED_CV_on(dstr);
4016 SAVEGENERICSV(GvIOp(dstr));
4018 dref = (SV*)GvIOp(dstr);
4019 GvIOp(dstr) = (IO*)sref;
4023 SAVEGENERICSV(GvFORM(dstr));
4025 dref = (SV*)GvFORM(dstr);
4026 GvFORM(dstr) = (CV*)sref;
4030 SAVEGENERICSV(GvSV(dstr));
4032 dref = (SV*)GvSV(dstr);
4034 if (!GvIMPORTED_SV(dstr)
4035 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4037 GvIMPORTED_SV_on(dstr);
4043 if (SvTAINTED(sstr))
4047 if (SvPVX_const(dstr)) {
4053 (void)SvOK_off(dstr);
4054 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4056 if (sflags & SVp_NOK) {
4058 /* Only set the public OK flag if the source has public OK. */
4059 if (sflags & SVf_NOK)
4060 SvFLAGS(dstr) |= SVf_NOK;
4061 SvNV_set(dstr, SvNVX(sstr));
4063 if (sflags & SVp_IOK) {
4064 (void)SvIOKp_on(dstr);
4065 if (sflags & SVf_IOK)
4066 SvFLAGS(dstr) |= SVf_IOK;
4067 if (sflags & SVf_IVisUV)
4069 SvIV_set(dstr, SvIVX(sstr));
4071 if (SvAMAGIC(sstr)) {
4075 else if (sflags & SVp_POK) {
4079 * Check to see if we can just swipe the string. If so, it's a
4080 * possible small lose on short strings, but a big win on long ones.
4081 * It might even be a win on short strings if SvPVX_const(dstr)
4082 * has to be allocated and SvPVX_const(sstr) has to be freed.
4085 /* Whichever path we take through the next code, we want this true,
4086 and doing it now facilitates the COW check. */
4087 (void)SvPOK_only(dstr);
4090 /* We're not already COW */
4091 ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4092 #ifndef PERL_OLD_COPY_ON_WRITE
4093 /* or we are, but dstr isn't a suitable target. */
4094 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4099 (sflags & SVs_TEMP) && /* slated for free anyway? */
4100 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4101 (!(flags & SV_NOSTEAL)) &&
4102 /* and we're allowed to steal temps */
4103 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4104 SvLEN(sstr) && /* and really is a string */
4105 /* and won't be needed again, potentially */
4106 !(PL_op && PL_op->op_type == OP_AASSIGN))
4107 #ifdef PERL_OLD_COPY_ON_WRITE
4108 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4109 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4110 && SvTYPE(sstr) >= SVt_PVIV)
4113 /* Failed the swipe test, and it's not a shared hash key either.
4114 Have to copy the string. */
4115 STRLEN len = SvCUR(sstr);
4116 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4117 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4118 SvCUR_set(dstr, len);
4119 *SvEND(dstr) = '\0';
4121 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4123 /* Either it's a shared hash key, or it's suitable for
4124 copy-on-write or we can swipe the string. */
4126 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4130 #ifdef PERL_OLD_COPY_ON_WRITE
4132 /* I believe I should acquire a global SV mutex if
4133 it's a COW sv (not a shared hash key) to stop
4134 it going un copy-on-write.
4135 If the source SV has gone un copy on write between up there
4136 and down here, then (assert() that) it is of the correct
4137 form to make it copy on write again */
4138 if ((sflags & (SVf_FAKE | SVf_READONLY))
4139 != (SVf_FAKE | SVf_READONLY)) {
4140 SvREADONLY_on(sstr);
4142 /* Make the source SV into a loop of 1.
4143 (about to become 2) */
4144 SV_COW_NEXT_SV_SET(sstr, sstr);
4148 /* Initial code is common. */
4149 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4154 /* making another shared SV. */
4155 STRLEN cur = SvCUR(sstr);
4156 STRLEN len = SvLEN(sstr);
4157 #ifdef PERL_OLD_COPY_ON_WRITE
4159 assert (SvTYPE(dstr) >= SVt_PVIV);
4160 /* SvIsCOW_normal */
4161 /* splice us in between source and next-after-source. */
4162 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4163 SV_COW_NEXT_SV_SET(sstr, dstr);
4164 SvPV_set(dstr, SvPVX_mutable(sstr));
4168 /* SvIsCOW_shared_hash */
4169 DEBUG_C(PerlIO_printf(Perl_debug_log,
4170 "Copy on write: Sharing hash\n"));
4172 assert (SvTYPE(dstr) >= SVt_PV);
4174 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4176 SvLEN_set(dstr, len);
4177 SvCUR_set(dstr, cur);
4178 SvREADONLY_on(dstr);
4180 /* Relesase a global SV mutex. */
4183 { /* Passes the swipe test. */
4184 SvPV_set(dstr, SvPVX_mutable(sstr));
4185 SvLEN_set(dstr, SvLEN(sstr));
4186 SvCUR_set(dstr, SvCUR(sstr));
4189 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4190 SvPV_set(sstr, Nullch);
4196 if (sflags & SVf_UTF8)
4198 if (sflags & SVp_NOK) {
4200 if (sflags & SVf_NOK)
4201 SvFLAGS(dstr) |= SVf_NOK;
4202 SvNV_set(dstr, SvNVX(sstr));
4204 if (sflags & SVp_IOK) {
4205 (void)SvIOKp_on(dstr);
4206 if (sflags & SVf_IOK)
4207 SvFLAGS(dstr) |= SVf_IOK;
4208 if (sflags & SVf_IVisUV)
4210 SvIV_set(dstr, SvIVX(sstr));
4213 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4214 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4215 smg->mg_ptr, smg->mg_len);
4216 SvRMAGICAL_on(dstr);
4219 else if (sflags & SVp_IOK) {
4220 if (sflags & SVf_IOK)
4221 (void)SvIOK_only(dstr);
4223 (void)SvOK_off(dstr);
4224 (void)SvIOKp_on(dstr);
4226 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4227 if (sflags & SVf_IVisUV)
4229 SvIV_set(dstr, SvIVX(sstr));
4230 if (sflags & SVp_NOK) {
4231 if (sflags & SVf_NOK)
4232 (void)SvNOK_on(dstr);
4234 (void)SvNOKp_on(dstr);
4235 SvNV_set(dstr, SvNVX(sstr));
4238 else if (sflags & SVp_NOK) {
4239 if (sflags & SVf_NOK)
4240 (void)SvNOK_only(dstr);
4242 (void)SvOK_off(dstr);
4245 SvNV_set(dstr, SvNVX(sstr));
4248 if (dtype == SVt_PVGV) {
4249 if (ckWARN(WARN_MISC))
4250 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4253 (void)SvOK_off(dstr);
4255 if (SvTAINTED(sstr))
4260 =for apidoc sv_setsv_mg
4262 Like C<sv_setsv>, but also handles 'set' magic.
4268 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4270 sv_setsv(dstr,sstr);
4274 #ifdef PERL_OLD_COPY_ON_WRITE
4276 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4278 STRLEN cur = SvCUR(sstr);
4279 STRLEN len = SvLEN(sstr);
4280 register char *new_pv;
4283 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4291 if (SvTHINKFIRST(dstr))
4292 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4293 else if (SvPVX_const(dstr))
4294 Safefree(SvPVX_const(dstr));
4298 SvUPGRADE(dstr, SVt_PVIV);
4300 assert (SvPOK(sstr));
4301 assert (SvPOKp(sstr));
4302 assert (!SvIOK(sstr));
4303 assert (!SvIOKp(sstr));
4304 assert (!SvNOK(sstr));
4305 assert (!SvNOKp(sstr));
4307 if (SvIsCOW(sstr)) {
4309 if (SvLEN(sstr) == 0) {
4310 /* source is a COW shared hash key. */
4311 DEBUG_C(PerlIO_printf(Perl_debug_log,
4312 "Fast copy on write: Sharing hash\n"));
4313 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4316 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4318 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4319 SvUPGRADE(sstr, SVt_PVIV);
4320 SvREADONLY_on(sstr);
4322 DEBUG_C(PerlIO_printf(Perl_debug_log,
4323 "Fast copy on write: Converting sstr to COW\n"));
4324 SV_COW_NEXT_SV_SET(dstr, sstr);
4326 SV_COW_NEXT_SV_SET(sstr, dstr);
4327 new_pv = SvPVX_mutable(sstr);
4330 SvPV_set(dstr, new_pv);
4331 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4334 SvLEN_set(dstr, len);
4335 SvCUR_set(dstr, cur);
4344 =for apidoc sv_setpvn
4346 Copies a string into an SV. The C<len> parameter indicates the number of
4347 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4348 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4354 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4356 register char *dptr;
4358 SV_CHECK_THINKFIRST_COW_DROP(sv);
4364 /* len is STRLEN which is unsigned, need to copy to signed */
4367 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4369 SvUPGRADE(sv, SVt_PV);
4371 dptr = SvGROW(sv, len + 1);
4372 Move(ptr,dptr,len,char);
4375 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4380 =for apidoc sv_setpvn_mg
4382 Like C<sv_setpvn>, but also handles 'set' magic.
4388 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4390 sv_setpvn(sv,ptr,len);
4395 =for apidoc sv_setpv
4397 Copies a string into an SV. The string must be null-terminated. Does not
4398 handle 'set' magic. See C<sv_setpv_mg>.
4404 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4406 register STRLEN len;
4408 SV_CHECK_THINKFIRST_COW_DROP(sv);
4414 SvUPGRADE(sv, SVt_PV);
4416 SvGROW(sv, len + 1);
4417 Move(ptr,SvPVX(sv),len+1,char);
4419 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4424 =for apidoc sv_setpv_mg
4426 Like C<sv_setpv>, but also handles 'set' magic.
4432 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4439 =for apidoc sv_usepvn
4441 Tells an SV to use C<ptr> to find its string value. Normally the string is
4442 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4443 The C<ptr> should point to memory that was allocated by C<malloc>. The
4444 string length, C<len>, must be supplied. This function will realloc the
4445 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4446 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4447 See C<sv_usepvn_mg>.
4453 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4456 SV_CHECK_THINKFIRST_COW_DROP(sv);
4457 SvUPGRADE(sv, SVt_PV);
4462 if (SvPVX_const(sv))
4465 allocate = PERL_STRLEN_ROUNDUP(len + 1);
4466 ptr = saferealloc (ptr, allocate);
4469 SvLEN_set(sv, allocate);
4471 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4476 =for apidoc sv_usepvn_mg
4478 Like C<sv_usepvn>, but also handles 'set' magic.
4484 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4486 sv_usepvn(sv,ptr,len);
4490 #ifdef PERL_OLD_COPY_ON_WRITE
4491 /* Need to do this *after* making the SV normal, as we need the buffer
4492 pointer to remain valid until after we've copied it. If we let go too early,
4493 another thread could invalidate it by unsharing last of the same hash key
4494 (which it can do by means other than releasing copy-on-write Svs)
4495 or by changing the other copy-on-write SVs in the loop. */
4497 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
4499 if (len) { /* this SV was SvIsCOW_normal(sv) */
4500 /* we need to find the SV pointing to us. */
4501 SV * const current = SV_COW_NEXT_SV(after);
4503 if (current == sv) {
4504 /* The SV we point to points back to us (there were only two of us
4506 Hence other SV is no longer copy on write either. */
4508 SvREADONLY_off(after);
4510 /* We need to follow the pointers around the loop. */
4512 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4515 /* don't loop forever if the structure is bust, and we have
4516 a pointer into a closed loop. */
4517 assert (current != after);
4518 assert (SvPVX_const(current) == pvx);
4520 /* Make the SV before us point to the SV after us. */
4521 SV_COW_NEXT_SV_SET(current, after);
4524 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4529 Perl_sv_release_IVX(pTHX_ register SV *sv)
4532 sv_force_normal_flags(sv, 0);
4538 =for apidoc sv_force_normal_flags
4540 Undo various types of fakery on an SV: if the PV is a shared string, make
4541 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4542 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4543 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4544 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4545 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4546 set to some other value.) In addition, the C<flags> parameter gets passed to
4547 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4548 with flags set to 0.
4554 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4556 #ifdef PERL_OLD_COPY_ON_WRITE
4557 if (SvREADONLY(sv)) {
4558 /* At this point I believe I should acquire a global SV mutex. */
4560 const char * const pvx = SvPVX_const(sv);
4561 const STRLEN len = SvLEN(sv);
4562 const STRLEN cur = SvCUR(sv);
4563 SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
4565 PerlIO_printf(Perl_debug_log,
4566 "Copy on write: Force normal %ld\n",
4572 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4573 SvPV_set(sv, (char*)0);
4575 if (flags & SV_COW_DROP_PV) {
4576 /* OK, so we don't need to copy our buffer. */
4579 SvGROW(sv, cur + 1);
4580 Move(pvx,SvPVX(sv),cur,char);
4584 sv_release_COW(sv, pvx, len, next);
4589 else if (IN_PERL_RUNTIME)
4590 Perl_croak(aTHX_ PL_no_modify);
4591 /* At this point I believe that I can drop the global SV mutex. */
4594 if (SvREADONLY(sv)) {
4596 const char * const pvx = SvPVX_const(sv);
4597 const STRLEN len = SvCUR(sv);
4600 SvPV_set(sv, Nullch);
4602 SvGROW(sv, len + 1);
4603 Move(pvx,SvPVX(sv),len,char);
4605 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4607 else if (IN_PERL_RUNTIME)
4608 Perl_croak(aTHX_ PL_no_modify);
4612 sv_unref_flags(sv, flags);
4613 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4618 =for apidoc sv_force_normal
4620 Undo various types of fakery on an SV: if the PV is a shared string, make
4621 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4622 an xpvmg. See also C<sv_force_normal_flags>.
4628 Perl_sv_force_normal(pTHX_ register SV *sv)
4630 sv_force_normal_flags(sv, 0);
4636 Efficient removal of characters from the beginning of the string buffer.
4637 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4638 the string buffer. The C<ptr> becomes the first character of the adjusted
4639 string. Uses the "OOK hack".
4640 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4641 refer to the same chunk of data.
4647 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
4649 register STRLEN delta;
4650 if (!ptr || !SvPOKp(sv))
4652 delta = ptr - SvPVX_const(sv);
4653 SV_CHECK_THINKFIRST(sv);
4654 if (SvTYPE(sv) < SVt_PVIV)
4655 sv_upgrade(sv,SVt_PVIV);
4658 if (!SvLEN(sv)) { /* make copy of shared string */
4659 const char *pvx = SvPVX_const(sv);
4660 const STRLEN len = SvCUR(sv);
4661 SvGROW(sv, len + 1);
4662 Move(pvx,SvPVX(sv),len,char);
4666 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
4667 and we do that anyway inside the SvNIOK_off
4669 SvFLAGS(sv) |= SVf_OOK;
4672 SvLEN_set(sv, SvLEN(sv) - delta);
4673 SvCUR_set(sv, SvCUR(sv) - delta);
4674 SvPV_set(sv, SvPVX(sv) + delta);
4675 SvIV_set(sv, SvIVX(sv) + delta);
4678 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
4679 * this function provided for binary compatibility only
4683 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
4685 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
4689 =for apidoc sv_catpvn
4691 Concatenates the string onto the end of the string which is in the SV. The
4692 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4693 status set, then the bytes appended should be valid UTF-8.
4694 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4696 =for apidoc sv_catpvn_flags
4698 Concatenates the string onto the end of the string which is in the SV. The
4699 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4700 status set, then the bytes appended should be valid UTF-8.
4701 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4702 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4703 in terms of this function.
4709 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4712 const char *dstr = SvPV_force_flags(dsv, dlen, flags);
4714 SvGROW(dsv, dlen + slen + 1);
4716 sstr = SvPVX_const(dsv);
4717 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4718 SvCUR_set(dsv, SvCUR(dsv) + slen);
4720 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4725 =for apidoc sv_catpvn_mg
4727 Like C<sv_catpvn>, but also handles 'set' magic.
4733 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4735 sv_catpvn(sv,ptr,len);
4739 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
4740 * this function provided for binary compatibility only
4744 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
4746 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
4750 =for apidoc sv_catsv
4752 Concatenates the string from SV C<ssv> onto the end of the string in
4753 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4754 not 'set' magic. See C<sv_catsv_mg>.
4756 =for apidoc sv_catsv_flags
4758 Concatenates the string from SV C<ssv> onto the end of the string in
4759 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4760 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4761 and C<sv_catsv_nomg> are implemented in terms of this function.
4766 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4772 if ((spv = SvPV_const(ssv, slen))) {
4773 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4774 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4775 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4776 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4777 dsv->sv_flags doesn't have that bit set.
4778 Andy Dougherty 12 Oct 2001
4780 const I32 sutf8 = DO_UTF8(ssv);
4783 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4785 dutf8 = DO_UTF8(dsv);
4787 if (dutf8 != sutf8) {
4789 /* Not modifying source SV, so taking a temporary copy. */
4790 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4792 sv_utf8_upgrade(csv);
4793 spv = SvPV_const(csv, slen);
4796 sv_utf8_upgrade_nomg(dsv);
4798 sv_catpvn_nomg(dsv, spv, slen);
4803 =for apidoc sv_catsv_mg
4805 Like C<sv_catsv>, but also handles 'set' magic.
4811 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4818 =for apidoc sv_catpv
4820 Concatenates the string onto the end of the string which is in the SV.
4821 If the SV has the UTF-8 status set, then the bytes appended should be
4822 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4827 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4829 register STRLEN len;
4835 junk = SvPV_force(sv, tlen);
4837 SvGROW(sv, tlen + len + 1);
4839 ptr = SvPVX_const(sv);
4840 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4841 SvCUR_set(sv, SvCUR(sv) + len);
4842 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4847 =for apidoc sv_catpv_mg
4849 Like C<sv_catpv>, but also handles 'set' magic.
4855 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4864 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4865 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4872 Perl_newSV(pTHX_ STRLEN len)
4878 sv_upgrade(sv, SVt_PV);
4879 SvGROW(sv, len + 1);
4884 =for apidoc sv_magicext
4886 Adds magic to an SV, upgrading it if necessary. Applies the
4887 supplied vtable and returns a pointer to the magic added.
4889 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4890 In particular, you can add magic to SvREADONLY SVs, and add more than
4891 one instance of the same 'how'.
4893 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4894 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4895 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4896 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4898 (This is now used as a subroutine by C<sv_magic>.)
4903 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
4904 const char* name, I32 namlen)
4908 if (SvTYPE(sv) < SVt_PVMG) {
4909 SvUPGRADE(sv, SVt_PVMG);
4911 Newxz(mg, 1, MAGIC);
4912 mg->mg_moremagic = SvMAGIC(sv);
4913 SvMAGIC_set(sv, mg);
4915 /* Sometimes a magic contains a reference loop, where the sv and
4916 object refer to each other. To prevent a reference loop that
4917 would prevent such objects being freed, we look for such loops
4918 and if we find one we avoid incrementing the object refcount.
4920 Note we cannot do this to avoid self-tie loops as intervening RV must
4921 have its REFCNT incremented to keep it in existence.
4924 if (!obj || obj == sv ||
4925 how == PERL_MAGIC_arylen ||
4926 how == PERL_MAGIC_qr ||
4927 how == PERL_MAGIC_symtab ||
4928 (SvTYPE(obj) == SVt_PVGV &&
4929 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4930 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4931 GvFORM(obj) == (CV*)sv)))
4936 mg->mg_obj = SvREFCNT_inc(obj);
4937 mg->mg_flags |= MGf_REFCOUNTED;
4940 /* Normal self-ties simply pass a null object, and instead of
4941 using mg_obj directly, use the SvTIED_obj macro to produce a
4942 new RV as needed. For glob "self-ties", we are tieing the PVIO
4943 with an RV obj pointing to the glob containing the PVIO. In
4944 this case, to avoid a reference loop, we need to weaken the
4948 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4949 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4955 mg->mg_len = namlen;
4958 mg->mg_ptr = savepvn(name, namlen);
4959 else if (namlen == HEf_SVKEY)
4960 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4962 mg->mg_ptr = (char *) name;
4964 mg->mg_virtual = vtable;
4968 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4973 =for apidoc sv_magic
4975 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4976 then adds a new magic item of type C<how> to the head of the magic list.
4978 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4979 handling of the C<name> and C<namlen> arguments.
4981 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4982 to add more than one instance of the same 'how'.
4988 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4990 const MGVTBL *vtable;
4993 #ifdef PERL_OLD_COPY_ON_WRITE
4995 sv_force_normal_flags(sv, 0);
4997 if (SvREADONLY(sv)) {
4999 /* its okay to attach magic to shared strings; the subsequent
5000 * upgrade to PVMG will unshare the string */
5001 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
5004 && how != PERL_MAGIC_regex_global
5005 && how != PERL_MAGIC_bm
5006 && how != PERL_MAGIC_fm
5007 && how != PERL_MAGIC_sv
5008 && how != PERL_MAGIC_backref
5011 Perl_croak(aTHX_ PL_no_modify);
5014 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5015 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5016 /* sv_magic() refuses to add a magic of the same 'how' as an
5019 if (how == PERL_MAGIC_taint)
5027 vtable = &PL_vtbl_sv;
5029 case PERL_MAGIC_overload:
5030 vtable = &PL_vtbl_amagic;
5032 case PERL_MAGIC_overload_elem:
5033 vtable = &PL_vtbl_amagicelem;
5035 case PERL_MAGIC_overload_table:
5036 vtable = &PL_vtbl_ovrld;
5039 vtable = &PL_vtbl_bm;
5041 case PERL_MAGIC_regdata:
5042 vtable = &PL_vtbl_regdata;
5044 case PERL_MAGIC_regdatum:
5045 vtable = &PL_vtbl_regdatum;
5047 case PERL_MAGIC_env:
5048 vtable = &PL_vtbl_env;
5051 vtable = &PL_vtbl_fm;
5053 case PERL_MAGIC_envelem:
5054 vtable = &PL_vtbl_envelem;
5056 case PERL_MAGIC_regex_global:
5057 vtable = &PL_vtbl_mglob;
5059 case PERL_MAGIC_isa:
5060 vtable = &PL_vtbl_isa;
5062 case PERL_MAGIC_isaelem:
5063 vtable = &PL_vtbl_isaelem;
5065 case PERL_MAGIC_nkeys:
5066 vtable = &PL_vtbl_nkeys;
5068 case PERL_MAGIC_dbfile:
5071 case PERL_MAGIC_dbline:
5072 vtable = &PL_vtbl_dbline;
5074 #ifdef USE_LOCALE_COLLATE
5075 case PERL_MAGIC_collxfrm:
5076 vtable = &PL_vtbl_collxfrm;
5078 #endif /* USE_LOCALE_COLLATE */
5079 case PERL_MAGIC_tied:
5080 vtable = &PL_vtbl_pack;
5082 case PERL_MAGIC_tiedelem:
5083 case PERL_MAGIC_tiedscalar:
5084 vtable = &PL_vtbl_packelem;
5087 vtable = &PL_vtbl_regexp;
5089 case PERL_MAGIC_sig:
5090 vtable = &PL_vtbl_sig;
5092 case PERL_MAGIC_sigelem:
5093 vtable = &PL_vtbl_sigelem;
5095 case PERL_MAGIC_taint:
5096 vtable = &PL_vtbl_taint;
5098 case PERL_MAGIC_uvar:
5099 vtable = &PL_vtbl_uvar;
5101 case PERL_MAGIC_vec:
5102 vtable = &PL_vtbl_vec;
5104 case PERL_MAGIC_arylen_p:
5105 case PERL_MAGIC_rhash:
5106 case PERL_MAGIC_symtab:
5107 case PERL_MAGIC_vstring:
5110 case PERL_MAGIC_utf8:
5111 vtable = &PL_vtbl_utf8;
5113 case PERL_MAGIC_substr:
5114 vtable = &PL_vtbl_substr;
5116 case PERL_MAGIC_defelem:
5117 vtable = &PL_vtbl_defelem;
5119 case PERL_MAGIC_glob:
5120 vtable = &PL_vtbl_glob;
5122 case PERL_MAGIC_arylen:
5123 vtable = &PL_vtbl_arylen;
5125 case PERL_MAGIC_pos:
5126 vtable = &PL_vtbl_pos;
5128 case PERL_MAGIC_backref:
5129 vtable = &PL_vtbl_backref;
5131 case PERL_MAGIC_ext:
5132 /* Reserved for use by extensions not perl internals. */
5133 /* Useful for attaching extension internal data to perl vars. */
5134 /* Note that multiple extensions may clash if magical scalars */
5135 /* etc holding private data from one are passed to another. */
5139 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5142 /* Rest of work is done else where */
5143 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5146 case PERL_MAGIC_taint:
5149 case PERL_MAGIC_ext:
5150 case PERL_MAGIC_dbfile:
5157 =for apidoc sv_unmagic
5159 Removes all magic of type C<type> from an SV.
5165 Perl_sv_unmagic(pTHX_ SV *sv, int type)
5169 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5172 for (mg = *mgp; mg; mg = *mgp) {
5173 if (mg->mg_type == type) {
5174 const MGVTBL* const vtbl = mg->mg_virtual;
5175 *mgp = mg->mg_moremagic;
5176 if (vtbl && vtbl->svt_free)
5177 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5178 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5180 Safefree(mg->mg_ptr);
5181 else if (mg->mg_len == HEf_SVKEY)
5182 SvREFCNT_dec((SV*)mg->mg_ptr);
5183 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
5184 Safefree(mg->mg_ptr);
5186 if (mg->mg_flags & MGf_REFCOUNTED)
5187 SvREFCNT_dec(mg->mg_obj);
5191 mgp = &mg->mg_moremagic;
5195 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5202 =for apidoc sv_rvweaken
5204 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5205 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5206 push a back-reference to this RV onto the array of backreferences
5207 associated with that magic.
5213 Perl_sv_rvweaken(pTHX_ SV *sv)
5216 if (!SvOK(sv)) /* let undefs pass */
5219 Perl_croak(aTHX_ "Can't weaken a nonreference");
5220 else if (SvWEAKREF(sv)) {
5221 if (ckWARN(WARN_MISC))
5222 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5226 Perl_sv_add_backref(aTHX_ tsv, sv);
5232 /* Give tsv backref magic if it hasn't already got it, then push a
5233 * back-reference to sv onto the array associated with the backref magic.
5237 Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
5241 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
5242 av = (AV*)mg->mg_obj;
5245 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5246 /* av now has a refcnt of 2, which avoids it getting freed
5247 * before us during global cleanup. The extra ref is removed
5248 * by magic_killbackrefs() when tsv is being freed */
5250 if (AvFILLp(av) >= AvMAX(av)) {
5251 av_extend(av, AvFILLp(av)+1);
5253 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5256 /* delete a back-reference to ourselves from the backref magic associated
5257 * with the SV we point to.
5261 S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
5267 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) {
5268 if (PL_in_clean_all)
5271 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
5272 Perl_croak(aTHX_ "panic: del_backref");
5273 av = (AV *)mg->mg_obj;
5275 /* We shouldn't be in here more than once, but for paranoia reasons lets
5277 for (i = AvFILLp(av); i >= 0; i--) {
5279 const SSize_t fill = AvFILLp(av);
5281 /* We weren't the last entry.
5282 An unordered list has this property that you can take the
5283 last element off the end to fill the hole, and it's still
5284 an unordered list :-)
5289 AvFILLp(av) = fill - 1;
5295 =for apidoc sv_insert
5297 Inserts a string at the specified offset/length within the SV. Similar to
5298 the Perl substr() function.
5304 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
5308 register char *midend;
5309 register char *bigend;
5315 Perl_croak(aTHX_ "Can't modify non-existent substring");
5316 SvPV_force(bigstr, curlen);
5317 (void)SvPOK_only_UTF8(bigstr);
5318 if (offset + len > curlen) {
5319 SvGROW(bigstr, offset+len+1);
5320 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5321 SvCUR_set(bigstr, offset+len);
5325 i = littlelen - len;
5326 if (i > 0) { /* string might grow */
5327 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5328 mid = big + offset + len;
5329 midend = bigend = big + SvCUR(bigstr);
5332 while (midend > mid) /* shove everything down */
5333 *--bigend = *--midend;
5334 Move(little,big+offset,littlelen,char);
5335 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5340 Move(little,SvPVX(bigstr)+offset,len,char);
5345 big = SvPVX(bigstr);
5348 bigend = big + SvCUR(bigstr);
5350 if (midend > bigend)
5351 Perl_croak(aTHX_ "panic: sv_insert");
5353 if (mid - big > bigend - midend) { /* faster to shorten from end */
5355 Move(little, mid, littlelen,char);
5358 i = bigend - midend;
5360 Move(midend, mid, i,char);
5364 SvCUR_set(bigstr, mid - big);
5366 else if ((i = mid - big)) { /* faster from front */
5367 midend -= littlelen;
5369 sv_chop(bigstr,midend-i);
5374 Move(little, mid, littlelen,char);
5376 else if (littlelen) {
5377 midend -= littlelen;
5378 sv_chop(bigstr,midend);
5379 Move(little,midend,littlelen,char);
5382 sv_chop(bigstr,midend);
5388 =for apidoc sv_replace
5390 Make the first argument a copy of the second, then delete the original.
5391 The target SV physically takes over ownership of the body of the source SV
5392 and inherits its flags; however, the target keeps any magic it owns,
5393 and any magic in the source is discarded.
5394 Note that this is a rather specialist SV copying operation; most of the
5395 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5401 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5403 const U32 refcnt = SvREFCNT(sv);
5404 SV_CHECK_THINKFIRST_COW_DROP(sv);
5405 if (SvREFCNT(nsv) != 1) {
5406 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
5407 UVuf " != 1)", (UV) SvREFCNT(nsv));
5409 if (SvMAGICAL(sv)) {
5413 sv_upgrade(nsv, SVt_PVMG);
5414 SvMAGIC_set(nsv, SvMAGIC(sv));
5415 SvFLAGS(nsv) |= SvMAGICAL(sv);
5417 SvMAGIC_set(sv, NULL);
5421 assert(!SvREFCNT(sv));
5422 #ifdef DEBUG_LEAKING_SCALARS
5423 sv->sv_flags = nsv->sv_flags;
5424 sv->sv_any = nsv->sv_any;
5425 sv->sv_refcnt = nsv->sv_refcnt;
5426 sv->sv_u = nsv->sv_u;
5428 StructCopy(nsv,sv,SV);
5430 /* Currently could join these into one piece of pointer arithmetic, but
5431 it would be unclear. */
5432 if(SvTYPE(sv) == SVt_IV)
5434 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5435 else if (SvTYPE(sv) == SVt_RV) {
5436 SvANY(sv) = &sv->sv_u.svu_rv;
5440 #ifdef PERL_OLD_COPY_ON_WRITE
5441 if (SvIsCOW_normal(nsv)) {
5442 /* We need to follow the pointers around the loop to make the
5443 previous SV point to sv, rather than nsv. */
5446 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5449 assert(SvPVX_const(current) == SvPVX_const(nsv));
5451 /* Make the SV before us point to the SV after us. */
5453 PerlIO_printf(Perl_debug_log, "previous is\n");
5455 PerlIO_printf(Perl_debug_log,
5456 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5457 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5459 SV_COW_NEXT_SV_SET(current, sv);
5462 SvREFCNT(sv) = refcnt;
5463 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5469 =for apidoc sv_clear
5471 Clear an SV: call any destructors, free up any memory used by the body,
5472 and free the body itself. The SV's head is I<not> freed, although
5473 its type is set to all 1's so that it won't inadvertently be assumed
5474 to be live during global destruction etc.
5475 This function should only be called when REFCNT is zero. Most of the time
5476 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5483 Perl_sv_clear(pTHX_ register SV *sv)
5486 void** old_body_arena;
5487 size_t old_body_offset;
5488 const U32 type = SvTYPE(sv);
5491 assert(SvREFCNT(sv) == 0);
5497 old_body_offset = 0;
5500 if (PL_defstash) { /* Still have a symbol table? */
5505 stash = SvSTASH(sv);
5506 destructor = StashHANDLER(stash,DESTROY);
5508 SV* const tmpref = newRV(sv);
5509 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5511 PUSHSTACKi(PERLSI_DESTROY);
5516 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5522 if(SvREFCNT(tmpref) < 2) {
5523 /* tmpref is not kept alive! */
5525 SvRV_set(tmpref, NULL);
5528 SvREFCNT_dec(tmpref);
5530 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5534 if (PL_in_clean_objs)
5535 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5537 /* DESTROY gave object new lease on life */
5543 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5544 SvOBJECT_off(sv); /* Curse the object. */
5545 if (type != SVt_PVIO)
5546 --PL_sv_objcount; /* XXX Might want something more general */
5549 if (type >= SVt_PVMG) {
5552 if (type == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
5553 SvREFCNT_dec(SvSTASH(sv));
5558 IoIFP(sv) != PerlIO_stdin() &&
5559 IoIFP(sv) != PerlIO_stdout() &&
5560 IoIFP(sv) != PerlIO_stderr())
5562 io_close((IO*)sv, FALSE);
5564 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5565 PerlDir_close(IoDIRP(sv));
5566 IoDIRP(sv) = (DIR*)NULL;
5567 Safefree(IoTOP_NAME(sv));
5568 Safefree(IoFMT_NAME(sv));
5569 Safefree(IoBOTTOM_NAME(sv));
5570 /* PVIOs aren't from arenas */
5573 old_body_arena = (void **) &PL_xpvbm_root;
5576 old_body_arena = (void **) &PL_xpvcv_root;
5578 /* PVFMs aren't from arenas */
5583 old_body_arena = (void **) &PL_xpvhv_root;
5584 old_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill);
5588 old_body_arena = (void **) &PL_xpvav_root;
5589 old_body_offset = STRUCT_OFFSET(XPVAV, xav_fill);
5592 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5593 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5594 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5595 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5597 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5598 SvREFCNT_dec(LvTARG(sv));
5599 old_body_arena = (void **) &PL_xpvlv_root;
5603 Safefree(GvNAME(sv));
5604 /* If we're in a stash, we don't own a reference to it. However it does
5605 have a back reference to us, which needs to be cleared. */
5607 sv_del_backref((SV*)GvSTASH(sv), sv);
5608 old_body_arena = (void **) &PL_xpvgv_root;
5611 old_body_arena = (void **) &PL_xpvmg_root;
5614 old_body_arena = (void **) &PL_xpvnv_root;
5617 old_body_arena = (void **) &PL_xpviv_root;
5618 old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur);
5620 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5622 SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
5623 /* Don't even bother with turning off the OOK flag. */
5627 old_body_arena = (void **) &PL_xpv_root;
5628 old_body_offset = STRUCT_OFFSET(XPV, xpv_cur);
5632 SV *target = SvRV(sv);
5634 sv_del_backref(target, sv);
5636 SvREFCNT_dec(target);
5638 #ifdef PERL_OLD_COPY_ON_WRITE
5639 else if (SvPVX_const(sv)) {
5641 /* I believe I need to grab the global SV mutex here and
5642 then recheck the COW status. */
5644 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5647 sv_release_COW(sv, SvPVX_const(sv), SvLEN(sv),
5648 SV_COW_NEXT_SV(sv));
5649 /* And drop it here. */
5651 } else if (SvLEN(sv)) {
5652 Safefree(SvPVX_const(sv));
5656 else if (SvPVX_const(sv) && SvLEN(sv))
5657 Safefree(SvPVX_mutable(sv));
5658 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5659 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5665 old_body_arena = (void **) &PL_xnv_root;
5669 SvFLAGS(sv) &= SVf_BREAK;
5670 SvFLAGS(sv) |= SVTYPEMASK;
5673 if (old_body_arena) {
5674 del_body(((char *)SvANY(sv) + old_body_offset), old_body_arena);
5678 if (type > SVt_RV) {
5679 my_safefree(SvANY(sv));
5684 =for apidoc sv_newref
5686 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5693 Perl_sv_newref(pTHX_ SV *sv)
5703 Decrement an SV's reference count, and if it drops to zero, call
5704 C<sv_clear> to invoke destructors and free up any memory used by
5705 the body; finally, deallocate the SV's head itself.
5706 Normally called via a wrapper macro C<SvREFCNT_dec>.
5712 Perl_sv_free(pTHX_ SV *sv)
5717 if (SvREFCNT(sv) == 0) {
5718 if (SvFLAGS(sv) & SVf_BREAK)
5719 /* this SV's refcnt has been artificially decremented to
5720 * trigger cleanup */
5722 if (PL_in_clean_all) /* All is fair */
5724 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5725 /* make sure SvREFCNT(sv)==0 happens very seldom */
5726 SvREFCNT(sv) = (~(U32)0)/2;
5729 if (ckWARN_d(WARN_INTERNAL)) {
5730 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5731 "Attempt to free unreferenced scalar: SV 0x%"UVxf
5732 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5733 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5734 Perl_dump_sv_child(aTHX_ sv);
5739 if (--(SvREFCNT(sv)) > 0)
5741 Perl_sv_free2(aTHX_ sv);
5745 Perl_sv_free2(pTHX_ SV *sv)
5750 if (ckWARN_d(WARN_DEBUGGING))
5751 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5752 "Attempt to free temp prematurely: SV 0x%"UVxf
5753 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5757 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5758 /* make sure SvREFCNT(sv)==0 happens very seldom */
5759 SvREFCNT(sv) = (~(U32)0)/2;
5770 Returns the length of the string in the SV. Handles magic and type
5771 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5777 Perl_sv_len(pTHX_ register SV *sv)
5785 len = mg_length(sv);
5787 (void)SvPV_const(sv, len);
5792 =for apidoc sv_len_utf8
5794 Returns the number of characters in the string in an SV, counting wide
5795 UTF-8 bytes as a single character. Handles magic and type coercion.
5801 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
5802 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
5803 * (Note that the mg_len is not the length of the mg_ptr field.)
5808 Perl_sv_len_utf8(pTHX_ register SV *sv)
5814 return mg_length(sv);
5818 const U8 *s = (U8*)SvPV_const(sv, len);
5819 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
5821 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
5823 #ifdef PERL_UTF8_CACHE_ASSERT
5824 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
5828 ulen = Perl_utf8_length(aTHX_ s, s + len);
5829 if (!mg && !SvREADONLY(sv)) {
5830 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5831 mg = mg_find(sv, PERL_MAGIC_utf8);
5841 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
5842 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5843 * between UTF-8 and byte offsets. There are two (substr offset and substr
5844 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
5845 * and byte offset) cache positions.
5847 * The mg_len field is used by sv_len_utf8(), see its comments.
5848 * Note that the mg_len is not the length of the mg_ptr field.
5852 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i,
5853 I32 offsetp, const U8 *s, const U8 *start)
5857 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5859 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
5863 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5865 Newxz(*cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5866 (*mgp)->mg_ptr = (char *) *cachep;
5870 (*cachep)[i] = offsetp;
5871 (*cachep)[i+1] = s - start;
5879 * S_utf8_mg_pos() is used to query and update mg_ptr field of
5880 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5881 * between UTF-8 and byte offsets. See also the comments of
5882 * S_utf8_mg_pos_init().
5886 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)
5890 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5892 *mgp = mg_find(sv, PERL_MAGIC_utf8);
5893 if (*mgp && (*mgp)->mg_ptr) {
5894 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5895 ASSERT_UTF8_CACHE(*cachep);
5896 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
5898 else { /* We will skip to the right spot. */
5903 /* The assumption is that going backward is half
5904 * the speed of going forward (that's where the
5905 * 2 * backw in the below comes from). (The real
5906 * figure of course depends on the UTF-8 data.) */
5908 if ((*cachep)[i] > (STRLEN)uoff) {
5910 backw = (*cachep)[i] - (STRLEN)uoff;
5912 if (forw < 2 * backw)
5915 p = start + (*cachep)[i+1];
5917 /* Try this only for the substr offset (i == 0),
5918 * not for the substr length (i == 2). */
5919 else if (i == 0) { /* (*cachep)[i] < uoff */
5920 const STRLEN ulen = sv_len_utf8(sv);
5922 if ((STRLEN)uoff < ulen) {
5923 forw = (STRLEN)uoff - (*cachep)[i];
5924 backw = ulen - (STRLEN)uoff;
5926 if (forw < 2 * backw)
5927 p = start + (*cachep)[i+1];
5932 /* If the string is not long enough for uoff,
5933 * we could extend it, but not at this low a level. */
5937 if (forw < 2 * backw) {
5944 while (UTF8_IS_CONTINUATION(*p))
5949 /* Update the cache. */
5950 (*cachep)[i] = (STRLEN)uoff;
5951 (*cachep)[i+1] = p - start;
5953 /* Drop the stale "length" cache */
5962 if (found) { /* Setup the return values. */
5963 *offsetp = (*cachep)[i+1];
5964 *sp = start + *offsetp;
5967 *offsetp = send - start;
5969 else if (*sp < start) {
5975 #ifdef PERL_UTF8_CACHE_ASSERT
5980 while (n-- && s < send)
5984 assert(*offsetp == s - start);
5985 assert((*cachep)[0] == (STRLEN)uoff);
5986 assert((*cachep)[1] == *offsetp);
5988 ASSERT_UTF8_CACHE(*cachep);
5997 =for apidoc sv_pos_u2b
5999 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6000 the start of the string, to a count of the equivalent number of bytes; if
6001 lenp is non-zero, it does the same to lenp, but this time starting from
6002 the offset, rather than from the start of the string. Handles magic and
6009 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6010 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6011 * byte offsets. See also the comments of S_utf8_mg_pos().
6016 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
6024 start = (U8*)SvPV_const(sv, len);
6028 const U8 *s = start;
6029 I32 uoffset = *offsetp;
6030 const U8 * const send = s + len;
6034 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
6036 if (!found && uoffset > 0) {
6037 while (s < send && uoffset--)
6041 if (utf8_mg_pos_init(sv, &mg, &cache, 0, *offsetp, s, start))
6043 *offsetp = s - start;
6048 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) {
6052 if (!found && *lenp > 0) {
6055 while (s < send && ulen--)
6059 utf8_mg_pos_init(sv, &mg, &cache, 2, *lenp, s, start);
6063 ASSERT_UTF8_CACHE(cache);
6075 =for apidoc sv_pos_b2u
6077 Converts the value pointed to by offsetp from a count of bytes from the
6078 start of the string, to a count of the equivalent number of UTF-8 chars.
6079 Handles magic and type coercion.
6085 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6086 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6087 * byte offsets. See also the comments of S_utf8_mg_pos().
6092 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
6100 s = (const U8*)SvPV_const(sv, len);
6101 if ((I32)len < *offsetp)
6102 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6104 const U8* send = s + *offsetp;
6106 STRLEN *cache = NULL;
6110 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6111 mg = mg_find(sv, PERL_MAGIC_utf8);
6112 if (mg && mg->mg_ptr) {
6113 cache = (STRLEN *) mg->mg_ptr;
6114 if (cache[1] == (STRLEN)*offsetp) {
6115 /* An exact match. */
6116 *offsetp = cache[0];
6120 else if (cache[1] < (STRLEN)*offsetp) {
6121 /* We already know part of the way. */
6124 /* Let the below loop do the rest. */
6126 else { /* cache[1] > *offsetp */
6127 /* We already know all of the way, now we may
6128 * be able to walk back. The same assumption
6129 * is made as in S_utf8_mg_pos(), namely that
6130 * walking backward is twice slower than
6131 * walking forward. */
6132 const STRLEN forw = *offsetp;
6133 STRLEN backw = cache[1] - *offsetp;
6135 if (!(forw < 2 * backw)) {
6136 const U8 *p = s + cache[1];
6143 while (UTF8_IS_CONTINUATION(*p)) {
6151 *offsetp = cache[0];
6153 /* Drop the stale "length" cache */
6161 ASSERT_UTF8_CACHE(cache);
6167 /* Call utf8n_to_uvchr() to validate the sequence
6168 * (unless a simple non-UTF character) */
6169 if (!UTF8_IS_INVARIANT(*s))
6170 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
6179 if (!SvREADONLY(sv)) {
6181 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6182 mg = mg_find(sv, PERL_MAGIC_utf8);
6187 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6188 mg->mg_ptr = (char *) cache;
6193 cache[1] = *offsetp;
6194 /* Drop the stale "length" cache */
6207 Returns a boolean indicating whether the strings in the two SVs are
6208 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6209 coerce its args to strings if necessary.
6215 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6223 SV* svrecode = Nullsv;
6230 pv1 = SvPV_const(sv1, cur1);
6237 pv2 = SvPV_const(sv2, cur2);
6239 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6240 /* Differing utf8ness.
6241 * Do not UTF8size the comparands as a side-effect. */
6244 svrecode = newSVpvn(pv2, cur2);
6245 sv_recode_to_utf8(svrecode, PL_encoding);
6246 pv2 = SvPV_const(svrecode, cur2);
6249 svrecode = newSVpvn(pv1, cur1);
6250 sv_recode_to_utf8(svrecode, PL_encoding);
6251 pv1 = SvPV_const(svrecode, cur1);
6253 /* Now both are in UTF-8. */
6255 SvREFCNT_dec(svrecode);
6260 bool is_utf8 = TRUE;
6263 /* sv1 is the UTF-8 one,
6264 * if is equal it must be downgrade-able */
6265 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6271 /* sv2 is the UTF-8 one,
6272 * if is equal it must be downgrade-able */
6273 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6279 /* Downgrade not possible - cannot be eq */
6287 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6290 SvREFCNT_dec(svrecode);
6301 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6302 string in C<sv1> is less than, equal to, or greater than the string in
6303 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6304 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6310 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6313 const char *pv1, *pv2;
6316 SV *svrecode = Nullsv;
6323 pv1 = SvPV_const(sv1, cur1);
6330 pv2 = SvPV_const(sv2, cur2);
6332 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6333 /* Differing utf8ness.
6334 * Do not UTF8size the comparands as a side-effect. */
6337 svrecode = newSVpvn(pv2, cur2);
6338 sv_recode_to_utf8(svrecode, PL_encoding);
6339 pv2 = SvPV_const(svrecode, cur2);
6342 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6347 svrecode = newSVpvn(pv1, cur1);
6348 sv_recode_to_utf8(svrecode, PL_encoding);
6349 pv1 = SvPV_const(svrecode, cur1);
6352 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6358 cmp = cur2 ? -1 : 0;
6362 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6365 cmp = retval < 0 ? -1 : 1;
6366 } else if (cur1 == cur2) {
6369 cmp = cur1 < cur2 ? -1 : 1;
6374 SvREFCNT_dec(svrecode);
6383 =for apidoc sv_cmp_locale
6385 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6386 'use bytes' aware, handles get magic, and will coerce its args to strings
6387 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6393 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6395 #ifdef USE_LOCALE_COLLATE
6401 if (PL_collation_standard)
6405 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6407 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6409 if (!pv1 || !len1) {
6420 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6423 return retval < 0 ? -1 : 1;
6426 * When the result of collation is equality, that doesn't mean
6427 * that there are no differences -- some locales exclude some
6428 * characters from consideration. So to avoid false equalities,
6429 * we use the raw string as a tiebreaker.
6435 #endif /* USE_LOCALE_COLLATE */
6437 return sv_cmp(sv1, sv2);
6441 #ifdef USE_LOCALE_COLLATE
6444 =for apidoc sv_collxfrm
6446 Add Collate Transform magic to an SV if it doesn't already have it.
6448 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6449 scalar data of the variable, but transformed to such a format that a normal
6450 memory comparison can be used to compare the data according to the locale
6457 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6461 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6462 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6468 Safefree(mg->mg_ptr);
6469 s = SvPV_const(sv, len);
6470 if ((xf = mem_collxfrm(s, len, &xlen))) {
6471 if (SvREADONLY(sv)) {
6474 return xf + sizeof(PL_collation_ix);
6477 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6478 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6491 if (mg && mg->mg_ptr) {
6493 return mg->mg_ptr + sizeof(PL_collation_ix);
6501 #endif /* USE_LOCALE_COLLATE */
6506 Get a line from the filehandle and store it into the SV, optionally
6507 appending to the currently-stored string.
6513 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6517 register STDCHAR rslast;
6518 register STDCHAR *bp;
6524 if (SvTHINKFIRST(sv))
6525 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6526 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6528 However, perlbench says it's slower, because the existing swipe code
6529 is faster than copy on write.
6530 Swings and roundabouts. */
6531 SvUPGRADE(sv, SVt_PV);
6536 if (PerlIO_isutf8(fp)) {
6538 sv_utf8_upgrade_nomg(sv);
6539 sv_pos_u2b(sv,&append,0);
6541 } else if (SvUTF8(sv)) {
6542 SV * const tsv = NEWSV(0,0);
6543 sv_gets(tsv, fp, 0);
6544 sv_utf8_upgrade_nomg(tsv);
6545 SvCUR_set(sv,append);
6548 goto return_string_or_null;
6553 if (PerlIO_isutf8(fp))
6556 if (IN_PERL_COMPILETIME) {
6557 /* we always read code in line mode */
6561 else if (RsSNARF(PL_rs)) {
6562 /* If it is a regular disk file use size from stat() as estimate
6563 of amount we are going to read - may result in malloc-ing
6564 more memory than we realy need if layers bellow reduce
6565 size we read (e.g. CRLF or a gzip layer)
6568 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6569 const Off_t offset = PerlIO_tell(fp);
6570 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6571 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6577 else if (RsRECORD(PL_rs)) {
6581 /* Grab the size of the record we're getting */
6582 recsize = SvIV(SvRV(PL_rs));
6583 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6586 /* VMS wants read instead of fread, because fread doesn't respect */
6587 /* RMS record boundaries. This is not necessarily a good thing to be */
6588 /* doing, but we've got no other real choice - except avoid stdio
6589 as implementation - perhaps write a :vms layer ?
6591 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6593 bytesread = PerlIO_read(fp, buffer, recsize);
6597 SvCUR_set(sv, bytesread += append);
6598 buffer[bytesread] = '\0';
6599 goto return_string_or_null;
6601 else if (RsPARA(PL_rs)) {
6607 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6608 if (PerlIO_isutf8(fp)) {
6609 rsptr = SvPVutf8(PL_rs, rslen);
6612 if (SvUTF8(PL_rs)) {
6613 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6614 Perl_croak(aTHX_ "Wide character in $/");
6617 rsptr = SvPV_const(PL_rs, rslen);
6621 rslast = rslen ? rsptr[rslen - 1] : '\0';
6623 if (rspara) { /* have to do this both before and after */
6624 do { /* to make sure file boundaries work right */
6627 i = PerlIO_getc(fp);
6631 PerlIO_ungetc(fp,i);
6637 /* See if we know enough about I/O mechanism to cheat it ! */
6639 /* This used to be #ifdef test - it is made run-time test for ease
6640 of abstracting out stdio interface. One call should be cheap
6641 enough here - and may even be a macro allowing compile
6645 if (PerlIO_fast_gets(fp)) {
6648 * We're going to steal some values from the stdio struct
6649 * and put EVERYTHING in the innermost loop into registers.
6651 register STDCHAR *ptr;
6655 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6656 /* An ungetc()d char is handled separately from the regular
6657 * buffer, so we getc() it back out and stuff it in the buffer.
6659 i = PerlIO_getc(fp);
6660 if (i == EOF) return 0;
6661 *(--((*fp)->_ptr)) = (unsigned char) i;
6665 /* Here is some breathtakingly efficient cheating */
6667 cnt = PerlIO_get_cnt(fp); /* get count into register */
6668 /* make sure we have the room */
6669 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
6670 /* Not room for all of it
6671 if we are looking for a separator and room for some
6673 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
6674 /* just process what we have room for */
6675 shortbuffered = cnt - SvLEN(sv) + append + 1;
6676 cnt -= shortbuffered;
6680 /* remember that cnt can be negative */
6681 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
6686 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
6687 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
6688 DEBUG_P(PerlIO_printf(Perl_debug_log,
6689 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6690 DEBUG_P(PerlIO_printf(Perl_debug_log,
6691 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6692 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6693 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6698 while (cnt > 0) { /* this | eat */
6700 if ((*bp++ = *ptr++) == rslast) /* really | dust */
6701 goto thats_all_folks; /* screams | sed :-) */
6705 Copy(ptr, bp, cnt, char); /* this | eat */
6706 bp += cnt; /* screams | dust */
6707 ptr += cnt; /* louder | sed :-) */
6712 if (shortbuffered) { /* oh well, must extend */
6713 cnt = shortbuffered;
6715 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6717 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6718 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6722 DEBUG_P(PerlIO_printf(Perl_debug_log,
6723 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6724 PTR2UV(ptr),(long)cnt));
6725 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6727 DEBUG_P(PerlIO_printf(Perl_debug_log,
6728 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6729 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6730 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6732 /* This used to call 'filbuf' in stdio form, but as that behaves like
6733 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6734 another abstraction. */
6735 i = PerlIO_getc(fp); /* get more characters */
6737 DEBUG_P(PerlIO_printf(Perl_debug_log,
6738 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6739 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6740 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6742 cnt = PerlIO_get_cnt(fp);
6743 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
6744 DEBUG_P(PerlIO_printf(Perl_debug_log,
6745 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6747 if (i == EOF) /* all done for ever? */
6748 goto thats_really_all_folks;
6750 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6752 SvGROW(sv, bpx + cnt + 2);
6753 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6755 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
6757 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
6758 goto thats_all_folks;
6762 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
6763 memNE((char*)bp - rslen, rsptr, rslen))
6764 goto screamer; /* go back to the fray */
6765 thats_really_all_folks:
6767 cnt += shortbuffered;
6768 DEBUG_P(PerlIO_printf(Perl_debug_log,
6769 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6770 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
6771 DEBUG_P(PerlIO_printf(Perl_debug_log,
6772 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6773 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6774 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6776 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
6777 DEBUG_P(PerlIO_printf(Perl_debug_log,
6778 "Screamer: done, len=%ld, string=|%.*s|\n",
6779 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
6783 /*The big, slow, and stupid way. */
6784 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
6786 Newx(buf, 8192, STDCHAR);
6794 register const STDCHAR *bpe = buf + sizeof(buf);
6796 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6797 ; /* keep reading */
6801 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6802 /* Accomodate broken VAXC compiler, which applies U8 cast to
6803 * both args of ?: operator, causing EOF to change into 255
6806 i = (U8)buf[cnt - 1];
6812 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
6814 sv_catpvn(sv, (char *) buf, cnt);
6816 sv_setpvn(sv, (char *) buf, cnt);
6818 if (i != EOF && /* joy */
6820 SvCUR(sv) < rslen ||
6821 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6825 * If we're reading from a TTY and we get a short read,
6826 * indicating that the user hit his EOF character, we need
6827 * to notice it now, because if we try to read from the TTY
6828 * again, the EOF condition will disappear.
6830 * The comparison of cnt to sizeof(buf) is an optimization
6831 * that prevents unnecessary calls to feof().
6835 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
6839 #ifdef USE_HEAP_INSTEAD_OF_STACK
6844 if (rspara) { /* have to do this both before and after */
6845 while (i != EOF) { /* to make sure file boundaries work right */
6846 i = PerlIO_getc(fp);
6848 PerlIO_ungetc(fp,i);
6854 return_string_or_null:
6855 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
6861 Auto-increment of the value in the SV, doing string to numeric conversion
6862 if necessary. Handles 'get' magic.
6868 Perl_sv_inc(pTHX_ register SV *sv)
6876 if (SvTHINKFIRST(sv)) {
6878 sv_force_normal_flags(sv, 0);
6879 if (SvREADONLY(sv)) {
6880 if (IN_PERL_RUNTIME)
6881 Perl_croak(aTHX_ PL_no_modify);
6885 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6887 i = PTR2IV(SvRV(sv));
6892 flags = SvFLAGS(sv);
6893 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6894 /* It's (privately or publicly) a float, but not tested as an
6895 integer, so test it to see. */
6897 flags = SvFLAGS(sv);
6899 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6900 /* It's publicly an integer, or privately an integer-not-float */
6901 #ifdef PERL_PRESERVE_IVUV
6905 if (SvUVX(sv) == UV_MAX)
6906 sv_setnv(sv, UV_MAX_P1);
6908 (void)SvIOK_only_UV(sv);
6909 SvUV_set(sv, SvUVX(sv) + 1);
6911 if (SvIVX(sv) == IV_MAX)
6912 sv_setuv(sv, (UV)IV_MAX + 1);
6914 (void)SvIOK_only(sv);
6915 SvIV_set(sv, SvIVX(sv) + 1);
6920 if (flags & SVp_NOK) {
6921 (void)SvNOK_only(sv);
6922 SvNV_set(sv, SvNVX(sv) + 1.0);
6926 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
6927 if ((flags & SVTYPEMASK) < SVt_PVIV)
6928 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
6929 (void)SvIOK_only(sv);
6934 while (isALPHA(*d)) d++;
6935 while (isDIGIT(*d)) d++;
6937 #ifdef PERL_PRESERVE_IVUV
6938 /* Got to punt this as an integer if needs be, but we don't issue
6939 warnings. Probably ought to make the sv_iv_please() that does
6940 the conversion if possible, and silently. */
6941 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6942 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6943 /* Need to try really hard to see if it's an integer.
6944 9.22337203685478e+18 is an integer.
6945 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6946 so $a="9.22337203685478e+18"; $a+0; $a++
6947 needs to be the same as $a="9.22337203685478e+18"; $a++
6954 /* sv_2iv *should* have made this an NV */
6955 if (flags & SVp_NOK) {
6956 (void)SvNOK_only(sv);
6957 SvNV_set(sv, SvNVX(sv) + 1.0);
6960 /* I don't think we can get here. Maybe I should assert this
6961 And if we do get here I suspect that sv_setnv will croak. NWC
6963 #if defined(USE_LONG_DOUBLE)
6964 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",
6965 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6967 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6968 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6971 #endif /* PERL_PRESERVE_IVUV */
6972 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
6976 while (d >= SvPVX_const(sv)) {
6984 /* MKS: The original code here died if letters weren't consecutive.
6985 * at least it didn't have to worry about non-C locales. The
6986 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6987 * arranged in order (although not consecutively) and that only
6988 * [A-Za-z] are accepted by isALPHA in the C locale.
6990 if (*d != 'z' && *d != 'Z') {
6991 do { ++*d; } while (!isALPHA(*d));
6994 *(d--) -= 'z' - 'a';
6999 *(d--) -= 'z' - 'a' + 1;
7003 /* oh,oh, the number grew */
7004 SvGROW(sv, SvCUR(sv) + 2);
7005 SvCUR_set(sv, SvCUR(sv) + 1);
7006 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7017 Auto-decrement of the value in the SV, doing string to numeric conversion
7018 if necessary. Handles 'get' magic.
7024 Perl_sv_dec(pTHX_ register SV *sv)
7031 if (SvTHINKFIRST(sv)) {
7033 sv_force_normal_flags(sv, 0);
7034 if (SvREADONLY(sv)) {
7035 if (IN_PERL_RUNTIME)
7036 Perl_croak(aTHX_ PL_no_modify);
7040 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7042 i = PTR2IV(SvRV(sv));
7047 /* Unlike sv_inc we don't have to worry about string-never-numbers
7048 and keeping them magic. But we mustn't warn on punting */
7049 flags = SvFLAGS(sv);
7050 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7051 /* It's publicly an integer, or privately an integer-not-float */
7052 #ifdef PERL_PRESERVE_IVUV
7056 if (SvUVX(sv) == 0) {
7057 (void)SvIOK_only(sv);
7061 (void)SvIOK_only_UV(sv);
7062 SvUV_set(sv, SvUVX(sv) - 1);
7065 if (SvIVX(sv) == IV_MIN)
7066 sv_setnv(sv, (NV)IV_MIN - 1.0);
7068 (void)SvIOK_only(sv);
7069 SvIV_set(sv, SvIVX(sv) - 1);
7074 if (flags & SVp_NOK) {
7075 SvNV_set(sv, SvNVX(sv) - 1.0);
7076 (void)SvNOK_only(sv);
7079 if (!(flags & SVp_POK)) {
7080 if ((flags & SVTYPEMASK) < SVt_PVIV)
7081 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
7083 (void)SvIOK_only(sv);
7086 #ifdef PERL_PRESERVE_IVUV
7088 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7089 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7090 /* Need to try really hard to see if it's an integer.
7091 9.22337203685478e+18 is an integer.
7092 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7093 so $a="9.22337203685478e+18"; $a+0; $a--
7094 needs to be the same as $a="9.22337203685478e+18"; $a--
7101 /* sv_2iv *should* have made this an NV */
7102 if (flags & SVp_NOK) {
7103 (void)SvNOK_only(sv);
7104 SvNV_set(sv, SvNVX(sv) - 1.0);
7107 /* I don't think we can get here. Maybe I should assert this
7108 And if we do get here I suspect that sv_setnv will croak. NWC
7110 #if defined(USE_LONG_DOUBLE)
7111 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",
7112 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7114 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7115 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7119 #endif /* PERL_PRESERVE_IVUV */
7120 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
7124 =for apidoc sv_mortalcopy
7126 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7127 The new SV is marked as mortal. It will be destroyed "soon", either by an
7128 explicit call to FREETMPS, or by an implicit call at places such as
7129 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7134 /* Make a string that will exist for the duration of the expression
7135 * evaluation. Actually, it may have to last longer than that, but
7136 * hopefully we won't free it until it has been assigned to a
7137 * permanent location. */
7140 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
7145 sv_setsv(sv,oldstr);
7147 PL_tmps_stack[++PL_tmps_ix] = sv;
7153 =for apidoc sv_newmortal
7155 Creates a new null SV which is mortal. The reference count of the SV is
7156 set to 1. It will be destroyed "soon", either by an explicit call to
7157 FREETMPS, or by an implicit call at places such as statement boundaries.
7158 See also C<sv_mortalcopy> and C<sv_2mortal>.
7164 Perl_sv_newmortal(pTHX)
7169 SvFLAGS(sv) = SVs_TEMP;
7171 PL_tmps_stack[++PL_tmps_ix] = sv;
7176 =for apidoc sv_2mortal
7178 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7179 by an explicit call to FREETMPS, or by an implicit call at places such as
7180 statement boundaries. SvTEMP() is turned on which means that the SV's
7181 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7182 and C<sv_mortalcopy>.
7188 Perl_sv_2mortal(pTHX_ register SV *sv)
7193 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7196 PL_tmps_stack[++PL_tmps_ix] = sv;
7204 Creates a new SV and copies a string into it. The reference count for the
7205 SV is set to 1. If C<len> is zero, Perl will compute the length using
7206 strlen(). For efficiency, consider using C<newSVpvn> instead.
7212 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
7217 sv_setpvn(sv,s,len ? len : strlen(s));
7222 =for apidoc newSVpvn
7224 Creates a new SV and copies a string into it. The reference count for the
7225 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7226 string. You are responsible for ensuring that the source string is at least
7227 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7233 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7238 sv_setpvn(sv,s,len);
7244 =for apidoc newSVhek
7246 Creates a new SV from the hash key structure. It will generate scalars that
7247 point to the shared string table where possible. Returns a new (undefined)
7248 SV if the hek is NULL.
7254 Perl_newSVhek(pTHX_ const HEK *hek)
7263 if (HEK_LEN(hek) == HEf_SVKEY) {
7264 return newSVsv(*(SV**)HEK_KEY(hek));
7266 const int flags = HEK_FLAGS(hek);
7267 if (flags & HVhek_WASUTF8) {
7269 Andreas would like keys he put in as utf8 to come back as utf8
7271 STRLEN utf8_len = HEK_LEN(hek);
7272 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7273 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
7276 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7278 } else if (flags & HVhek_REHASH) {
7279 /* We don't have a pointer to the hv, so we have to replicate the
7280 flag into every HEK. This hv is using custom a hasing
7281 algorithm. Hence we can't return a shared string scalar, as
7282 that would contain the (wrong) hash value, and might get passed
7283 into an hv routine with a regular hash */
7285 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7290 /* This will be overwhelminly the most common case. */
7291 return newSVpvn_share(HEK_KEY(hek),
7292 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
7298 =for apidoc newSVpvn_share
7300 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7301 table. If the string does not already exist in the table, it is created
7302 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
7303 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
7304 otherwise the hash is computed. The idea here is that as the string table
7305 is used for shared hash keys these strings will have SvPVX_const == HeKEY and
7306 hash lookup will avoid string compare.
7312 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7315 bool is_utf8 = FALSE;
7317 STRLEN tmplen = -len;
7319 /* See the note in hv.c:hv_fetch() --jhi */
7320 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7324 PERL_HASH(hash, src, len);
7326 sv_upgrade(sv, SVt_PV);
7327 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7339 #if defined(PERL_IMPLICIT_CONTEXT)
7341 /* pTHX_ magic can't cope with varargs, so this is a no-context
7342 * version of the main function, (which may itself be aliased to us).
7343 * Don't access this version directly.
7347 Perl_newSVpvf_nocontext(const char* pat, ...)
7352 va_start(args, pat);
7353 sv = vnewSVpvf(pat, &args);
7360 =for apidoc newSVpvf
7362 Creates a new SV and initializes it with the string formatted like
7369 Perl_newSVpvf(pTHX_ const char* pat, ...)
7373 va_start(args, pat);
7374 sv = vnewSVpvf(pat, &args);
7379 /* backend for newSVpvf() and newSVpvf_nocontext() */
7382 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7386 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7393 Creates a new SV and copies a floating point value into it.
7394 The reference count for the SV is set to 1.
7400 Perl_newSVnv(pTHX_ NV n)
7412 Creates a new SV and copies an integer into it. The reference count for the
7419 Perl_newSViv(pTHX_ IV i)
7431 Creates a new SV and copies an unsigned integer into it.
7432 The reference count for the SV is set to 1.
7438 Perl_newSVuv(pTHX_ UV u)
7448 =for apidoc newRV_noinc
7450 Creates an RV wrapper for an SV. The reference count for the original
7451 SV is B<not> incremented.
7457 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7462 sv_upgrade(sv, SVt_RV);
7464 SvRV_set(sv, tmpRef);
7469 /* newRV_inc is the official function name to use now.
7470 * newRV_inc is in fact #defined to newRV in sv.h
7474 Perl_newRV(pTHX_ SV *tmpRef)
7476 return newRV_noinc(SvREFCNT_inc(tmpRef));
7482 Creates a new SV which is an exact duplicate of the original SV.
7489 Perl_newSVsv(pTHX_ register SV *old)
7495 if (SvTYPE(old) == SVTYPEMASK) {
7496 if (ckWARN_d(WARN_INTERNAL))
7497 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7501 /* SV_GMAGIC is the default for sv_setv()
7502 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7503 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7504 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7509 =for apidoc sv_reset
7511 Underlying implementation for the C<reset> Perl function.
7512 Note that the perl-level function is vaguely deprecated.
7518 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
7521 char todo[PERL_UCHAR_MAX+1];
7526 if (!*s) { /* reset ?? searches */
7527 MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
7529 PMOP *pm = (PMOP *) mg->mg_obj;
7531 pm->op_pmdynflags &= ~PMdf_USED;
7538 /* reset variables */
7540 if (!HvARRAY(stash))
7543 Zero(todo, 256, char);
7546 I32 i = (unsigned char)*s;
7550 max = (unsigned char)*s++;
7551 for ( ; i <= max; i++) {
7554 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7556 for (entry = HvARRAY(stash)[i];
7558 entry = HeNEXT(entry))
7563 if (!todo[(U8)*HeKEY(entry)])
7565 gv = (GV*)HeVAL(entry);
7568 if (SvTHINKFIRST(sv)) {
7569 if (!SvREADONLY(sv) && SvROK(sv))
7571 /* XXX Is this continue a bug? Why should THINKFIRST
7572 exempt us from resetting arrays and hashes? */
7576 if (SvTYPE(sv) >= SVt_PV) {
7578 if (SvPVX_const(sv) != Nullch)
7586 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
7589 #ifdef USE_ENVIRON_ARRAY
7591 # ifdef USE_ITHREADS
7592 && PL_curinterp == aTHX
7596 environ[0] = Nullch;
7599 #endif /* !PERL_MICRO */
7609 Using various gambits, try to get an IO from an SV: the IO slot if its a
7610 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7611 named after the PV if we're a string.
7617 Perl_sv_2io(pTHX_ SV *sv)
7622 switch (SvTYPE(sv)) {
7630 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7634 Perl_croak(aTHX_ PL_no_usym, "filehandle");
7636 return sv_2io(SvRV(sv));
7637 gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
7643 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
7652 Using various gambits, try to get a CV from an SV; in addition, try if
7653 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7659 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7666 return *gvp = Nullgv, Nullcv;
7667 switch (SvTYPE(sv)) {
7685 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
7686 tryAMAGICunDEREF(to_cv);
7689 if (SvTYPE(sv) == SVt_PVCV) {
7698 Perl_croak(aTHX_ "Not a subroutine reference");
7703 gv = gv_fetchsv(sv, lref, SVt_PVCV);
7709 if (lref && !GvCVu(gv)) {
7712 tmpsv = NEWSV(704,0);
7713 gv_efullname3(tmpsv, gv, Nullch);
7714 /* XXX this is probably not what they think they're getting.
7715 * It has the same effect as "sub name;", i.e. just a forward
7717 newSUB(start_subparse(FALSE, 0),
7718 newSVOP(OP_CONST, 0, tmpsv),
7723 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
7733 Returns true if the SV has a true value by Perl's rules.
7734 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
7735 instead use an in-line version.
7741 Perl_sv_true(pTHX_ register SV *sv)
7746 register const XPV* tXpv;
7747 if ((tXpv = (XPV*)SvANY(sv)) &&
7748 (tXpv->xpv_cur > 1 ||
7749 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
7756 return SvIVX(sv) != 0;
7759 return SvNVX(sv) != 0.0;
7761 return sv_2bool(sv);
7769 A private implementation of the C<SvIVx> macro for compilers which can't
7770 cope with complex macro expressions. Always use the macro instead.
7776 Perl_sv_iv(pTHX_ register SV *sv)
7780 return (IV)SvUVX(sv);
7789 A private implementation of the C<SvUVx> macro for compilers which can't
7790 cope with complex macro expressions. Always use the macro instead.
7796 Perl_sv_uv(pTHX_ register SV *sv)
7801 return (UV)SvIVX(sv);
7809 A private implementation of the C<SvNVx> macro for compilers which can't
7810 cope with complex macro expressions. Always use the macro instead.
7816 Perl_sv_nv(pTHX_ register SV *sv)
7823 /* sv_pv() is now a macro using SvPV_nolen();
7824 * this function provided for binary compatibility only
7828 Perl_sv_pv(pTHX_ SV *sv)
7833 return sv_2pv(sv, 0);
7839 Use the C<SvPV_nolen> macro instead
7843 A private implementation of the C<SvPV> macro for compilers which can't
7844 cope with complex macro expressions. Always use the macro instead.
7850 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
7856 return sv_2pv(sv, lp);
7861 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
7867 return sv_2pv_flags(sv, lp, 0);
7870 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
7871 * this function provided for binary compatibility only
7875 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
7877 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
7881 =for apidoc sv_pvn_force
7883 Get a sensible string out of the SV somehow.
7884 A private implementation of the C<SvPV_force> macro for compilers which
7885 can't cope with complex macro expressions. Always use the macro instead.
7887 =for apidoc sv_pvn_force_flags
7889 Get a sensible string out of the SV somehow.
7890 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
7891 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
7892 implemented in terms of this function.
7893 You normally want to use the various wrapper macros instead: see
7894 C<SvPV_force> and C<SvPV_force_nomg>
7900 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
7903 if (SvTHINKFIRST(sv) && !SvROK(sv))
7904 sv_force_normal_flags(sv, 0);
7914 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
7915 const char * const ref = sv_reftype(sv,0);
7917 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
7918 ref, OP_NAME(PL_op));
7920 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
7922 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
7923 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(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)
8128 Returns a boolean indicating whether the SV is blessed into the specified
8129 class. This does not check for subtypes; use C<sv_derived_from> to verify
8130 an inheritance relationship.
8136 Perl_sv_isa(pTHX_ SV *sv, const char *name)
8147 hvname = HvNAME_get(SvSTASH(sv));
8151 return strEQ(hvname, name);
8157 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
8158 it will be upgraded to one. If C<classname> is non-null then the new SV will
8159 be blessed in the specified package. The new SV is returned and its
8160 reference count is 1.
8166 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
8172 SV_CHECK_THINKFIRST_COW_DROP(rv);
8175 if (SvTYPE(rv) >= SVt_PVMG) {
8176 const U32 refcnt = SvREFCNT(rv);
8180 SvREFCNT(rv) = refcnt;
8183 if (SvTYPE(rv) < SVt_RV)
8184 sv_upgrade(rv, SVt_RV);
8185 else if (SvTYPE(rv) > SVt_RV) {
8196 HV* const stash = gv_stashpv(classname, TRUE);
8197 (void)sv_bless(rv, stash);
8203 =for apidoc sv_setref_pv
8205 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
8206 argument will be upgraded to an RV. That RV will be modified to point to
8207 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8208 into the SV. The C<classname> argument indicates the package for the
8209 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8210 will have a reference count of 1, and the RV will be returned.
8212 Do not use with other Perl types such as HV, AV, SV, CV, because those
8213 objects will become corrupted by the pointer copy process.
8215 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8221 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
8224 sv_setsv(rv, &PL_sv_undef);
8228 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8233 =for apidoc sv_setref_iv
8235 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
8236 argument will be upgraded to an RV. That RV will be modified to point to
8237 the new SV. The C<classname> argument indicates the package for the
8238 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8239 will have a reference count of 1, and the RV will be returned.
8245 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
8247 sv_setiv(newSVrv(rv,classname), iv);
8252 =for apidoc sv_setref_uv
8254 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
8255 argument will be upgraded to an RV. That RV will be modified to point to
8256 the new SV. The C<classname> argument indicates the package for the
8257 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8258 will have a reference count of 1, and the RV will be returned.
8264 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
8266 sv_setuv(newSVrv(rv,classname), uv);
8271 =for apidoc sv_setref_nv
8273 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8274 argument will be upgraded to an RV. That RV will be modified to point to
8275 the new SV. The C<classname> argument indicates the package for the
8276 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8277 will have a reference count of 1, and the RV will be returned.
8283 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
8285 sv_setnv(newSVrv(rv,classname), nv);
8290 =for apidoc sv_setref_pvn
8292 Copies a string into a new SV, optionally blessing the SV. The length of the
8293 string must be specified with C<n>. The C<rv> argument will be upgraded to
8294 an RV. That RV will be modified to point to the new SV. The C<classname>
8295 argument indicates the package for the blessing. Set C<classname> to
8296 C<Nullch> to avoid the blessing. The new SV will have a reference count
8297 of 1, and the RV will be returned.
8299 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8305 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n)
8307 sv_setpvn(newSVrv(rv,classname), pv, n);
8312 =for apidoc sv_bless
8314 Blesses an SV into a specified package. The SV must be an RV. The package
8315 must be designated by its stash (see C<gv_stashpv()>). The reference count
8316 of the SV is unaffected.
8322 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8326 Perl_croak(aTHX_ "Can't bless non-reference value");
8328 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8329 if (SvREADONLY(tmpRef))
8330 Perl_croak(aTHX_ PL_no_modify);
8331 if (SvOBJECT(tmpRef)) {
8332 if (SvTYPE(tmpRef) != SVt_PVIO)
8334 SvREFCNT_dec(SvSTASH(tmpRef));
8337 SvOBJECT_on(tmpRef);
8338 if (SvTYPE(tmpRef) != SVt_PVIO)
8340 SvUPGRADE(tmpRef, SVt_PVMG);
8341 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
8348 if(SvSMAGICAL(tmpRef))
8349 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8357 /* Downgrades a PVGV to a PVMG.
8361 S_sv_unglob(pTHX_ SV *sv)
8365 assert(SvTYPE(sv) == SVt_PVGV);
8370 sv_del_backref((SV*)GvSTASH(sv), sv);
8371 GvSTASH(sv) = Nullhv;
8373 sv_unmagic(sv, PERL_MAGIC_glob);
8374 Safefree(GvNAME(sv));
8377 /* need to keep SvANY(sv) in the right arena */
8378 xpvmg = new_XPVMG();
8379 StructCopy(SvANY(sv), xpvmg, XPVMG);
8380 del_XPVGV(SvANY(sv));
8383 SvFLAGS(sv) &= ~SVTYPEMASK;
8384 SvFLAGS(sv) |= SVt_PVMG;
8388 =for apidoc sv_unref_flags
8390 Unsets the RV status of the SV, and decrements the reference count of
8391 whatever was being referenced by the RV. This can almost be thought of
8392 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8393 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8394 (otherwise the decrementing is conditional on the reference count being
8395 different from one or the reference being a readonly SV).
8402 Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags)
8404 SV* const target = SvRV(ref);
8406 if (SvWEAKREF(ref)) {
8407 sv_del_backref(target, ref);
8409 SvRV_set(ref, NULL);
8412 SvRV_set(ref, NULL);
8414 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
8415 assigned to as BEGIN {$a = \"Foo"} will fail. */
8416 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
8417 SvREFCNT_dec(target);
8418 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8419 sv_2mortal(target); /* Schedule for freeing later */
8423 =for apidoc sv_unref
8425 Unsets the RV status of the SV, and decrements the reference count of
8426 whatever was being referenced by the RV. This can almost be thought of
8427 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
8428 being zero. See C<SvROK_off>.
8434 Perl_sv_unref(pTHX_ SV *sv)
8436 sv_unref_flags(sv, 0);
8440 =for apidoc sv_taint
8442 Taint an SV. Use C<SvTAINTED_on> instead.
8447 Perl_sv_taint(pTHX_ SV *sv)
8449 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
8453 =for apidoc sv_untaint
8455 Untaint an SV. Use C<SvTAINTED_off> instead.
8460 Perl_sv_untaint(pTHX_ SV *sv)
8462 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8463 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8470 =for apidoc sv_tainted
8472 Test an SV for taintedness. Use C<SvTAINTED> instead.
8477 Perl_sv_tainted(pTHX_ SV *sv)
8479 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8480 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8481 if (mg && (mg->mg_len & 1) )
8488 =for apidoc sv_setpviv
8490 Copies an integer into the given SV, also updating its string value.
8491 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8497 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8499 char buf[TYPE_CHARS(UV)];
8501 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8503 sv_setpvn(sv, ptr, ebuf - ptr);
8507 =for apidoc sv_setpviv_mg
8509 Like C<sv_setpviv>, but also handles 'set' magic.
8515 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8517 char buf[TYPE_CHARS(UV)];
8519 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8521 sv_setpvn(sv, ptr, ebuf - ptr);
8525 #if defined(PERL_IMPLICIT_CONTEXT)
8527 /* pTHX_ magic can't cope with varargs, so this is a no-context
8528 * version of the main function, (which may itself be aliased to us).
8529 * Don't access this version directly.
8533 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8537 va_start(args, pat);
8538 sv_vsetpvf(sv, pat, &args);
8542 /* pTHX_ magic can't cope with varargs, so this is a no-context
8543 * version of the main function, (which may itself be aliased to us).
8544 * Don't access this version directly.
8548 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8552 va_start(args, pat);
8553 sv_vsetpvf_mg(sv, pat, &args);
8559 =for apidoc sv_setpvf
8561 Works like C<sv_catpvf> but copies the text into the SV instead of
8562 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8568 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8571 va_start(args, pat);
8572 sv_vsetpvf(sv, pat, &args);
8577 =for apidoc sv_vsetpvf
8579 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8580 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8582 Usually used via its frontend C<sv_setpvf>.
8588 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8590 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8594 =for apidoc sv_setpvf_mg
8596 Like C<sv_setpvf>, but also handles 'set' magic.
8602 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8605 va_start(args, pat);
8606 sv_vsetpvf_mg(sv, pat, &args);
8611 =for apidoc sv_vsetpvf_mg
8613 Like C<sv_vsetpvf>, but also handles 'set' magic.
8615 Usually used via its frontend C<sv_setpvf_mg>.
8621 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8623 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8627 #if defined(PERL_IMPLICIT_CONTEXT)
8629 /* pTHX_ magic can't cope with varargs, so this is a no-context
8630 * version of the main function, (which may itself be aliased to us).
8631 * Don't access this version directly.
8635 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8639 va_start(args, pat);
8640 sv_vcatpvf(sv, pat, &args);
8644 /* pTHX_ magic can't cope with varargs, so this is a no-context
8645 * version of the main function, (which may itself be aliased to us).
8646 * Don't access this version directly.
8650 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8654 va_start(args, pat);
8655 sv_vcatpvf_mg(sv, pat, &args);
8661 =for apidoc sv_catpvf
8663 Processes its arguments like C<sprintf> and appends the formatted
8664 output to an SV. If the appended data contains "wide" characters
8665 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8666 and characters >255 formatted with %c), the original SV might get
8667 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
8668 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
8669 valid UTF-8; if the original SV was bytes, the pattern should be too.
8674 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8677 va_start(args, pat);
8678 sv_vcatpvf(sv, pat, &args);
8683 =for apidoc sv_vcatpvf
8685 Processes its arguments like C<vsprintf> and appends the formatted output
8686 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
8688 Usually used via its frontend C<sv_catpvf>.
8694 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8696 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8700 =for apidoc sv_catpvf_mg
8702 Like C<sv_catpvf>, but also handles 'set' magic.
8708 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8711 va_start(args, pat);
8712 sv_vcatpvf_mg(sv, pat, &args);
8717 =for apidoc sv_vcatpvf_mg
8719 Like C<sv_vcatpvf>, but also handles 'set' magic.
8721 Usually used via its frontend C<sv_catpvf_mg>.
8727 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8729 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8734 =for apidoc sv_vsetpvfn
8736 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
8739 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
8745 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8747 sv_setpvn(sv, "", 0);
8748 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8751 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
8754 S_expect_number(pTHX_ char** pattern)
8757 switch (**pattern) {
8758 case '1': case '2': case '3':
8759 case '4': case '5': case '6':
8760 case '7': case '8': case '9':
8761 while (isDIGIT(**pattern))
8762 var = var * 10 + (*(*pattern)++ - '0');
8766 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
8769 F0convert(NV nv, char *endbuf, STRLEN *len)
8771 const int neg = nv < 0;
8780 if (uv & 1 && uv == nv)
8781 uv--; /* Round to even */
8783 const unsigned dig = uv % 10;
8796 =for apidoc sv_vcatpvfn
8798 Processes its arguments like C<vsprintf> and appends the formatted output
8799 to an SV. Uses an array of SVs if the C style variable argument list is
8800 missing (NULL). When running with taint checks enabled, indicates via
8801 C<maybe_tainted> if results are untrustworthy (often due to the use of
8804 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
8810 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
8811 vecstr = (U8*)SvPV_const(vecsv,veclen);\
8812 vec_utf8 = DO_UTF8(vecsv);
8814 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
8817 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8824 static const char nullstr[] = "(null)";
8826 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
8827 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
8829 /* Times 4: a decimal digit takes more than 3 binary digits.
8830 * NV_DIG: mantissa takes than many decimal digits.
8831 * Plus 32: Playing safe. */
8832 char ebuf[IV_DIG * 4 + NV_DIG + 32];
8833 /* large enough for "%#.#f" --chip */
8834 /* what about long double NVs? --jhi */
8836 PERL_UNUSED_ARG(maybe_tainted);
8838 /* no matter what, this is a string now */
8839 (void)SvPV_force(sv, origlen);
8841 /* special-case "", "%s", and "%-p" (SVf - see below) */
8844 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
8846 const char * const s = va_arg(*args, char*);
8847 sv_catpv(sv, s ? s : nullstr);
8849 else if (svix < svmax) {
8850 sv_catsv(sv, *svargs);
8851 if (DO_UTF8(*svargs))
8856 if (args && patlen == 3 && pat[0] == '%' &&
8857 pat[1] == '-' && pat[2] == 'p') {
8858 argsv = va_arg(*args, SV*);
8859 sv_catsv(sv, argsv);
8865 #ifndef USE_LONG_DOUBLE
8866 /* special-case "%.<number>[gf]" */
8867 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
8868 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
8869 unsigned digits = 0;
8873 while (*pp >= '0' && *pp <= '9')
8874 digits = 10 * digits + (*pp++ - '0');
8875 if (pp - pat == (int)patlen - 1) {
8883 /* Add check for digits != 0 because it seems that some
8884 gconverts are buggy in this case, and we don't yet have
8885 a Configure test for this. */
8886 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
8887 /* 0, point, slack */
8888 Gconvert(nv, (int)digits, 0, ebuf);
8890 if (*ebuf) /* May return an empty string for digits==0 */
8893 } else if (!digits) {
8896 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
8897 sv_catpvn(sv, p, l);
8903 #endif /* !USE_LONG_DOUBLE */
8905 if (!args && svix < svmax && DO_UTF8(*svargs))
8908 patend = (char*)pat + patlen;
8909 for (p = (char*)pat; p < patend; p = q) {
8912 bool vectorize = FALSE;
8913 bool vectorarg = FALSE;
8914 bool vec_utf8 = FALSE;
8920 bool has_precis = FALSE;
8923 bool is_utf8 = FALSE; /* is this item utf8? */
8924 #ifdef HAS_LDBL_SPRINTF_BUG
8925 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8926 with sfio - Allen <allens@cpan.org> */
8927 bool fix_ldbl_sprintf_bug = FALSE;
8931 U8 utf8buf[UTF8_MAXBYTES+1];
8932 STRLEN esignlen = 0;
8934 const char *eptr = Nullch;
8937 const U8 *vecstr = Null(U8*);
8944 /* we need a long double target in case HAS_LONG_DOUBLE but
8947 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
8955 const char *dotstr = ".";
8956 STRLEN dotstrlen = 1;
8957 I32 efix = 0; /* explicit format parameter index */
8958 I32 ewix = 0; /* explicit width index */
8959 I32 epix = 0; /* explicit precision index */
8960 I32 evix = 0; /* explicit vector index */
8961 bool asterisk = FALSE;
8963 /* echo everything up to the next format specification */
8964 for (q = p; q < patend && *q != '%'; ++q) ;
8966 if (has_utf8 && !pat_utf8)
8967 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
8969 sv_catpvn(sv, p, q - p);
8976 We allow format specification elements in this order:
8977 \d+\$ explicit format parameter index
8979 v|\*(\d+\$)?v vector with optional (optionally specified) arg
8980 0 flag (as above): repeated to allow "v02"
8981 \d+|\*(\d+\$)? width using optional (optionally specified) arg
8982 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8984 [%bcdefginopsuxDFOUX] format (mandatory)
8989 As of perl5.9.3, printf format checking is on by default.
8990 Internally, perl uses %p formats to provide an escape to
8991 some extended formatting. This block deals with those
8992 extensions: if it does not match, (char*)q is reset and
8993 the normal format processing code is used.
8995 Currently defined extensions are:
8996 %p include pointer address (standard)
8997 %-p (SVf) include an SV (previously %_)
8998 %-<num>p include an SV with precision <num>
8999 %1p (VDf) include a v-string (as %vd)
9000 %<num>p reserved for future extensions
9002 Robin Barker 2005-07-14
9009 EXPECT_NUMBER(q, n);
9016 argsv = va_arg(*args, SV*);
9017 eptr = SvPVx_const(argsv, elen);
9023 else if (n == vdNUMBER) { /* VDf */
9030 if (ckWARN_d(WARN_INTERNAL))
9031 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9032 "internal %%<num>p might conflict with future printf extensions");
9038 if (EXPECT_NUMBER(q, width)) {
9079 if (EXPECT_NUMBER(q, ewix))
9088 if ((vectorarg = asterisk)) {
9101 EXPECT_NUMBER(q, width);
9107 vecsv = va_arg(*args, SV*);
9109 vecsv = (evix ? evix <= svmax : svix < svmax) ?
9110 svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
9111 dotstr = SvPV_const(vecsv, dotstrlen);
9118 else if (efix ? efix <= svmax : svix < svmax) {
9119 vecsv = svargs[efix ? efix-1 : svix++];
9120 vecstr = (U8*)SvPV_const(vecsv,veclen);
9121 vec_utf8 = DO_UTF8(vecsv);
9122 /* if this is a version object, we need to return the
9123 * stringified representation (which the SvPVX_const has
9124 * already done for us), but not vectorize the args
9126 if ( *q == 'd' && sv_derived_from(vecsv,"version") )
9128 q++; /* skip past the rest of the %vd format */
9129 eptr = (const char *) vecstr;
9130 elen = strlen(eptr);
9143 i = va_arg(*args, int);
9145 i = (ewix ? ewix <= svmax : svix < svmax) ?
9146 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9148 width = (i < 0) ? -i : i;
9158 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
9160 /* XXX: todo, support specified precision parameter */
9164 i = va_arg(*args, int);
9166 i = (ewix ? ewix <= svmax : svix < svmax)
9167 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9168 precis = (i < 0) ? 0 : i;
9173 precis = precis * 10 + (*q++ - '0');
9182 case 'I': /* Ix, I32x, and I64x */
9184 if (q[1] == '6' && q[2] == '4') {
9190 if (q[1] == '3' && q[2] == '2') {
9200 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9211 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9212 if (*(q + 1) == 'l') { /* lld, llf */
9237 argsv = (efix ? efix <= svmax : svix < svmax) ?
9238 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
9245 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
9247 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9249 eptr = (char*)utf8buf;
9250 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9261 if (args && !vectorize) {
9262 eptr = va_arg(*args, char*);
9264 #ifdef MACOS_TRADITIONAL
9265 /* On MacOS, %#s format is used for Pascal strings */
9270 elen = strlen(eptr);
9272 eptr = (char *)nullstr;
9273 elen = sizeof nullstr - 1;
9277 eptr = SvPVx_const(argsv, elen);
9278 if (DO_UTF8(argsv)) {
9279 if (has_precis && precis < elen) {
9281 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9284 if (width) { /* fudge width (can't fudge elen) */
9285 width += elen - sv_len_utf8(argsv);
9293 if (has_precis && elen > precis)
9300 if (alt || vectorize)
9302 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9323 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9332 esignbuf[esignlen++] = plus;
9336 case 'h': iv = (short)va_arg(*args, int); break;
9337 case 'l': iv = va_arg(*args, long); break;
9338 case 'V': iv = va_arg(*args, IV); break;
9339 default: iv = va_arg(*args, int); break;
9341 case 'q': iv = va_arg(*args, Quad_t); break;
9346 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
9348 case 'h': iv = (short)tiv; break;
9349 case 'l': iv = (long)tiv; break;
9351 default: iv = tiv; break;
9353 case 'q': iv = (Quad_t)tiv; break;
9357 if ( !vectorize ) /* we already set uv above */
9362 esignbuf[esignlen++] = plus;
9366 esignbuf[esignlen++] = '-';
9409 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9420 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9421 case 'l': uv = va_arg(*args, unsigned long); break;
9422 case 'V': uv = va_arg(*args, UV); break;
9423 default: uv = va_arg(*args, unsigned); break;
9425 case 'q': uv = va_arg(*args, Uquad_t); break;
9430 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9432 case 'h': uv = (unsigned short)tuv; break;
9433 case 'l': uv = (unsigned long)tuv; break;
9435 default: uv = tuv; break;
9437 case 'q': uv = (Uquad_t)tuv; break;
9444 char *ptr = ebuf + sizeof ebuf;
9450 p = (char*)((c == 'X')
9451 ? "0123456789ABCDEF" : "0123456789abcdef");
9457 esignbuf[esignlen++] = '0';
9458 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9466 if (alt && *ptr != '0')
9475 esignbuf[esignlen++] = '0';
9476 esignbuf[esignlen++] = 'b';
9479 default: /* it had better be ten or less */
9483 } while (uv /= base);
9486 elen = (ebuf + sizeof ebuf) - ptr;
9490 zeros = precis - elen;
9491 else if (precis == 0 && elen == 1 && *eptr == '0')
9497 /* FLOATING POINT */
9500 c = 'f'; /* maybe %F isn't supported here */
9506 /* This is evil, but floating point is even more evil */
9508 /* for SV-style calling, we can only get NV
9509 for C-style calling, we assume %f is double;
9510 for simplicity we allow any of %Lf, %llf, %qf for long double
9514 #if defined(USE_LONG_DOUBLE)
9518 /* [perl #20339] - we should accept and ignore %lf rather than die */
9522 #if defined(USE_LONG_DOUBLE)
9523 intsize = args ? 0 : 'q';
9527 #if defined(HAS_LONG_DOUBLE)
9536 /* now we need (long double) if intsize == 'q', else (double) */
9537 nv = (args && !vectorize) ?
9538 #if LONG_DOUBLESIZE > DOUBLESIZE
9540 va_arg(*args, long double) :
9541 va_arg(*args, double)
9543 va_arg(*args, double)
9549 if (c != 'e' && c != 'E') {
9551 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9552 will cast our (long double) to (double) */
9553 (void)Perl_frexp(nv, &i);
9554 if (i == PERL_INT_MIN)
9555 Perl_die(aTHX_ "panic: frexp");
9557 need = BIT_DIGITS(i);
9559 need += has_precis ? precis : 6; /* known default */
9564 #ifdef HAS_LDBL_SPRINTF_BUG
9565 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9566 with sfio - Allen <allens@cpan.org> */
9569 # define MY_DBL_MAX DBL_MAX
9570 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9571 # if DOUBLESIZE >= 8
9572 # define MY_DBL_MAX 1.7976931348623157E+308L
9574 # define MY_DBL_MAX 3.40282347E+38L
9578 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9579 # define MY_DBL_MAX_BUG 1L
9581 # define MY_DBL_MAX_BUG MY_DBL_MAX
9585 # define MY_DBL_MIN DBL_MIN
9586 # else /* XXX guessing! -Allen */
9587 # if DOUBLESIZE >= 8
9588 # define MY_DBL_MIN 2.2250738585072014E-308L
9590 # define MY_DBL_MIN 1.17549435E-38L
9594 if ((intsize == 'q') && (c == 'f') &&
9595 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9597 /* it's going to be short enough that
9598 * long double precision is not needed */
9600 if ((nv <= 0L) && (nv >= -0L))
9601 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9603 /* would use Perl_fp_class as a double-check but not
9604 * functional on IRIX - see perl.h comments */
9606 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9607 /* It's within the range that a double can represent */
9608 #if defined(DBL_MAX) && !defined(DBL_MIN)
9609 if ((nv >= ((long double)1/DBL_MAX)) ||
9610 (nv <= (-(long double)1/DBL_MAX)))
9612 fix_ldbl_sprintf_bug = TRUE;
9615 if (fix_ldbl_sprintf_bug == TRUE) {
9625 # undef MY_DBL_MAX_BUG
9628 #endif /* HAS_LDBL_SPRINTF_BUG */
9630 need += 20; /* fudge factor */
9631 if (PL_efloatsize < need) {
9632 Safefree(PL_efloatbuf);
9633 PL_efloatsize = need + 20; /* more fudge */
9634 Newx(PL_efloatbuf, PL_efloatsize, char);
9635 PL_efloatbuf[0] = '\0';
9638 if ( !(width || left || plus || alt) && fill != '0'
9639 && has_precis && intsize != 'q' ) { /* Shortcuts */
9640 /* See earlier comment about buggy Gconvert when digits,
9642 if ( c == 'g' && precis) {
9643 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9644 if (*PL_efloatbuf) /* May return an empty string for digits==0 */
9645 goto float_converted;
9646 } else if ( c == 'f' && !precis) {
9647 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9652 char *ptr = ebuf + sizeof ebuf;
9655 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9656 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9657 if (intsize == 'q') {
9658 /* Copy the one or more characters in a long double
9659 * format before the 'base' ([efgEFG]) character to
9660 * the format string. */
9661 static char const prifldbl[] = PERL_PRIfldbl;
9662 char const *p = prifldbl + sizeof(prifldbl) - 3;
9663 while (p >= prifldbl) { *--ptr = *p--; }
9668 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9673 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9685 /* No taint. Otherwise we are in the strange situation
9686 * where printf() taints but print($float) doesn't.
9688 #if defined(HAS_LONG_DOUBLE)
9690 (void)sprintf(PL_efloatbuf, ptr, nv);
9692 (void)sprintf(PL_efloatbuf, ptr, (double)nv);
9694 (void)sprintf(PL_efloatbuf, ptr, nv);
9698 eptr = PL_efloatbuf;
9699 elen = strlen(PL_efloatbuf);
9705 i = SvCUR(sv) - origlen;
9706 if (args && !vectorize) {
9708 case 'h': *(va_arg(*args, short*)) = i; break;
9709 default: *(va_arg(*args, int*)) = i; break;
9710 case 'l': *(va_arg(*args, long*)) = i; break;
9711 case 'V': *(va_arg(*args, IV*)) = i; break;
9713 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
9718 sv_setuv_mg(argsv, (UV)i);
9720 continue; /* not "break" */
9727 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
9728 && ckWARN(WARN_PRINTF))
9730 SV *msg = sv_newmortal();
9731 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9732 (PL_op->op_type == OP_PRTF) ? "" : "s");
9735 Perl_sv_catpvf(aTHX_ msg,
9736 "\"%%%c\"", c & 0xFF);
9738 Perl_sv_catpvf(aTHX_ msg,
9739 "\"%%\\%03"UVof"\"",
9742 sv_catpv(msg, "end of string");
9743 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
9746 /* output mangled stuff ... */
9752 /* ... right here, because formatting flags should not apply */
9753 SvGROW(sv, SvCUR(sv) + elen + 1);
9755 Copy(eptr, p, elen, char);
9758 SvCUR_set(sv, p - SvPVX_const(sv));
9760 continue; /* not "break" */
9763 /* calculate width before utf8_upgrade changes it */
9764 have = esignlen + zeros + elen;
9766 if (is_utf8 != has_utf8) {
9769 sv_utf8_upgrade(sv);
9772 SV * const nsv = sv_2mortal(newSVpvn(eptr, elen));
9773 sv_utf8_upgrade(nsv);
9774 eptr = SvPVX_const(nsv);
9777 SvGROW(sv, SvCUR(sv) + elen + 1);
9782 need = (have > width ? have : width);
9785 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
9787 if (esignlen && fill == '0') {
9789 for (i = 0; i < (int)esignlen; i++)
9793 memset(p, fill, gap);
9796 if (esignlen && fill != '0') {
9798 for (i = 0; i < (int)esignlen; i++)
9803 for (i = zeros; i; i--)
9807 Copy(eptr, p, elen, char);
9811 memset(p, ' ', gap);
9816 Copy(dotstr, p, dotstrlen, char);
9820 vectorize = FALSE; /* done iterating over vecstr */
9827 SvCUR_set(sv, p - SvPVX_const(sv));
9835 /* =========================================================================
9837 =head1 Cloning an interpreter
9839 All the macros and functions in this section are for the private use of
9840 the main function, perl_clone().
9842 The foo_dup() functions make an exact copy of an existing foo thinngy.
9843 During the course of a cloning, a hash table is used to map old addresses
9844 to new addresses. The table is created and manipulated with the
9845 ptr_table_* functions.
9849 ============================================================================*/
9852 #if defined(USE_ITHREADS)
9854 #ifndef GpREFCNT_inc
9855 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
9859 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
9860 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
9861 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9862 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
9863 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9864 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
9865 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9866 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
9867 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
9868 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
9869 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9870 #define SAVEPV(p) (p ? savepv(p) : Nullch)
9871 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
9874 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
9875 regcomp.c. AMS 20010712 */
9878 Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
9883 struct reg_substr_datum *s;
9886 return (REGEXP *)NULL;
9888 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
9891 len = r->offsets[0];
9892 npar = r->nparens+1;
9894 Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
9895 Copy(r->program, ret->program, len+1, regnode);
9897 Newx(ret->startp, npar, I32);
9898 Copy(r->startp, ret->startp, npar, I32);
9899 Newx(ret->endp, npar, I32);
9900 Copy(r->startp, ret->startp, npar, I32);
9902 Newx(ret->substrs, 1, struct reg_substr_data);
9903 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
9904 s->min_offset = r->substrs->data[i].min_offset;
9905 s->max_offset = r->substrs->data[i].max_offset;
9906 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
9907 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
9910 ret->regstclass = NULL;
9913 const int count = r->data->count;
9916 Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
9917 char, struct reg_data);
9918 Newx(d->what, count, U8);
9921 for (i = 0; i < count; i++) {
9922 d->what[i] = r->data->what[i];
9923 switch (d->what[i]) {
9924 /* legal options are one of: sfpont
9925 see also regcomp.h and pregfree() */
9927 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
9930 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
9933 /* This is cheating. */
9934 Newx(d->data[i], 1, struct regnode_charclass_class);
9935 StructCopy(r->data->data[i], d->data[i],
9936 struct regnode_charclass_class);
9937 ret->regstclass = (regnode*)d->data[i];
9940 /* Compiled op trees are readonly, and can thus be
9941 shared without duplication. */
9943 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
9947 d->data[i] = r->data->data[i];
9950 d->data[i] = r->data->data[i];
9952 ((reg_trie_data*)d->data[i])->refcount++;
9956 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
9965 Newx(ret->offsets, 2*len+1, U32);
9966 Copy(r->offsets, ret->offsets, 2*len+1, U32);
9968 ret->precomp = SAVEPVN(r->precomp, r->prelen);
9969 ret->refcnt = r->refcnt;
9970 ret->minlen = r->minlen;
9971 ret->prelen = r->prelen;
9972 ret->nparens = r->nparens;
9973 ret->lastparen = r->lastparen;
9974 ret->lastcloseparen = r->lastcloseparen;
9975 ret->reganch = r->reganch;
9977 ret->sublen = r->sublen;
9979 if (RX_MATCH_COPIED(ret))
9980 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
9982 ret->subbeg = Nullch;
9983 #ifdef PERL_OLD_COPY_ON_WRITE
9984 ret->saved_copy = Nullsv;
9987 ptr_table_store(PL_ptr_table, r, ret);
9991 /* duplicate a file handle */
9994 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
9998 PERL_UNUSED_ARG(type);
10001 return (PerlIO*)NULL;
10003 /* look for it in the table first */
10004 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10008 /* create anew and remember what it is */
10009 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10010 ptr_table_store(PL_ptr_table, fp, ret);
10014 /* duplicate a directory handle */
10017 Perl_dirp_dup(pTHX_ DIR *dp)
10025 /* duplicate a typeglob */
10028 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
10033 /* look for it in the table first */
10034 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10038 /* create anew and remember what it is */
10040 ptr_table_store(PL_ptr_table, gp, ret);
10043 ret->gp_refcnt = 0; /* must be before any other dups! */
10044 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
10045 ret->gp_io = io_dup_inc(gp->gp_io, param);
10046 ret->gp_form = cv_dup_inc(gp->gp_form, param);
10047 ret->gp_av = av_dup_inc(gp->gp_av, param);
10048 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
10049 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10050 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
10051 ret->gp_cvgen = gp->gp_cvgen;
10052 ret->gp_line = gp->gp_line;
10053 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
10057 /* duplicate a chain of magic */
10060 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
10062 MAGIC *mgprev = (MAGIC*)NULL;
10065 return (MAGIC*)NULL;
10066 /* look for it in the table first */
10067 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
10071 for (; mg; mg = mg->mg_moremagic) {
10073 Newxz(nmg, 1, MAGIC);
10075 mgprev->mg_moremagic = nmg;
10078 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
10079 nmg->mg_private = mg->mg_private;
10080 nmg->mg_type = mg->mg_type;
10081 nmg->mg_flags = mg->mg_flags;
10082 if (mg->mg_type == PERL_MAGIC_qr) {
10083 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
10085 else if(mg->mg_type == PERL_MAGIC_backref) {
10086 const AV * const av = (AV*) mg->mg_obj;
10089 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
10091 for (i = AvFILLp(av); i >= 0; i--) {
10092 if (!svp[i]) continue;
10093 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
10096 else if (mg->mg_type == PERL_MAGIC_symtab) {
10097 nmg->mg_obj = mg->mg_obj;
10100 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
10101 ? sv_dup_inc(mg->mg_obj, param)
10102 : sv_dup(mg->mg_obj, param);
10104 nmg->mg_len = mg->mg_len;
10105 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
10106 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
10107 if (mg->mg_len > 0) {
10108 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
10109 if (mg->mg_type == PERL_MAGIC_overload_table &&
10110 AMT_AMAGIC((AMT*)mg->mg_ptr))
10112 AMT *amtp = (AMT*)mg->mg_ptr;
10113 AMT *namtp = (AMT*)nmg->mg_ptr;
10115 for (i = 1; i < NofAMmeth; i++) {
10116 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
10120 else if (mg->mg_len == HEf_SVKEY)
10121 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
10123 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
10124 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10131 /* create a new pointer-mapping table */
10134 Perl_ptr_table_new(pTHX)
10137 Newxz(tbl, 1, PTR_TBL_t);
10138 tbl->tbl_max = 511;
10139 tbl->tbl_items = 0;
10140 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10145 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
10147 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
10150 #define del_pte(p) del_body_type(p, struct ptr_tbl_ent, pte)
10152 /* map an existing pointer using a table */
10155 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
10157 PTR_TBL_ENT_t *tblent;
10158 const UV hash = PTR_TABLE_HASH(sv);
10160 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10161 for (; tblent; tblent = tblent->next) {
10162 if (tblent->oldval == sv)
10163 return tblent->newval;
10165 return (void*)NULL;
10168 /* add a new entry to a pointer-mapping table */
10171 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
10173 PTR_TBL_ENT_t *tblent, **otblent;
10174 /* XXX this may be pessimal on platforms where pointers aren't good
10175 * hash values e.g. if they grow faster in the most significant
10177 const UV hash = PTR_TABLE_HASH(oldsv);
10181 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
10182 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
10183 if (tblent->oldval == oldsv) {
10184 tblent->newval = newsv;
10188 new_body_inline(tblent, (void**)&PL_pte_arenaroot, (void**)&PL_pte_root,
10189 sizeof(struct ptr_tbl_ent));
10190 tblent->oldval = oldsv;
10191 tblent->newval = newsv;
10192 tblent->next = *otblent;
10195 if (!empty && tbl->tbl_items > tbl->tbl_max)
10196 ptr_table_split(tbl);
10199 /* double the hash bucket size of an existing ptr table */
10202 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
10204 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10205 const UV oldsize = tbl->tbl_max + 1;
10206 UV newsize = oldsize * 2;
10209 Renew(ary, newsize, PTR_TBL_ENT_t*);
10210 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10211 tbl->tbl_max = --newsize;
10212 tbl->tbl_ary = ary;
10213 for (i=0; i < oldsize; i++, ary++) {
10214 PTR_TBL_ENT_t **curentp, **entp, *ent;
10217 curentp = ary + oldsize;
10218 for (entp = ary, ent = *ary; ent; ent = *entp) {
10219 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10221 ent->next = *curentp;
10231 /* remove all the entries from a ptr table */
10234 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
10236 register PTR_TBL_ENT_t **array;
10237 register PTR_TBL_ENT_t *entry;
10241 if (!tbl || !tbl->tbl_items) {
10245 array = tbl->tbl_ary;
10247 max = tbl->tbl_max;
10251 PTR_TBL_ENT_t *oentry = entry;
10252 entry = entry->next;
10256 if (++riter > max) {
10259 entry = array[riter];
10263 tbl->tbl_items = 0;
10266 /* clear and free a ptr table */
10269 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
10274 ptr_table_clear(tbl);
10275 Safefree(tbl->tbl_ary);
10281 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
10284 SvRV_set(dstr, SvWEAKREF(sstr)
10285 ? sv_dup(SvRV(sstr), param)
10286 : sv_dup_inc(SvRV(sstr), param));
10289 else if (SvPVX_const(sstr)) {
10290 /* Has something there */
10292 /* Normal PV - clone whole allocated space */
10293 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
10294 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10295 /* Not that normal - actually sstr is copy on write.
10296 But we are a true, independant SV, so: */
10297 SvREADONLY_off(dstr);
10302 /* Special case - not normally malloced for some reason */
10303 if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
10304 /* A "shared" PV - clone it as "shared" PV */
10306 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
10310 /* Some other special case - random pointer */
10311 SvPV_set(dstr, SvPVX(sstr));
10316 /* Copy the Null */
10317 if (SvTYPE(dstr) == SVt_RV)
10318 SvRV_set(dstr, NULL);
10324 /* duplicate an SV of any type (including AV, HV etc) */
10327 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
10332 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10334 /* look for it in the table first */
10335 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10339 if(param->flags & CLONEf_JOIN_IN) {
10340 /** We are joining here so we don't want do clone
10341 something that is bad **/
10342 const char *hvname;
10344 if(SvTYPE(sstr) == SVt_PVHV &&
10345 (hvname = HvNAME_get(sstr))) {
10346 /** don't clone stashes if they already exist **/
10347 return (SV*)gv_stashpv(hvname,0);
10351 /* create anew and remember what it is */
10354 #ifdef DEBUG_LEAKING_SCALARS
10355 dstr->sv_debug_optype = sstr->sv_debug_optype;
10356 dstr->sv_debug_line = sstr->sv_debug_line;
10357 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10358 dstr->sv_debug_cloned = 1;
10360 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10362 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
10366 ptr_table_store(PL_ptr_table, sstr, dstr);
10369 SvFLAGS(dstr) = SvFLAGS(sstr);
10370 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10371 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10374 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
10375 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10376 PL_watch_pvx, SvPVX_const(sstr));
10379 /* don't clone objects whose class has asked us not to */
10380 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10381 SvFLAGS(dstr) &= ~SVTYPEMASK;
10382 SvOBJECT_off(dstr);
10386 switch (SvTYPE(sstr)) {
10388 SvANY(dstr) = NULL;
10391 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
10392 SvIV_set(dstr, SvIVX(sstr));
10395 SvANY(dstr) = new_XNV();
10396 SvNV_set(dstr, SvNVX(sstr));
10399 SvANY(dstr) = &(dstr->sv_u.svu_rv);
10400 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10404 /* These are all the types that need complex bodies allocating. */
10405 size_t new_body_length;
10406 size_t new_body_offset = 0;
10407 void **new_body_arena;
10408 void **new_body_arenaroot;
10411 switch (SvTYPE(sstr)) {
10413 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]",
10418 new_body = new_XPVIO();
10419 new_body_length = sizeof(XPVIO);
10422 new_body = new_XPVFM();
10423 new_body_length = sizeof(XPVFM);
10427 new_body_arena = (void **) &PL_xpvhv_root;
10428 new_body_arenaroot = (void **) &PL_xpvhv_arenaroot;
10429 new_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill)
10430 - STRUCT_OFFSET(xpvhv_allocated, xhv_fill);
10431 new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash)
10432 + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash)
10436 new_body_arena = (void **) &PL_xpvav_root;
10437 new_body_arenaroot = (void **) &PL_xpvav_arenaroot;
10438 new_body_offset = STRUCT_OFFSET(XPVAV, xav_fill)
10439 - STRUCT_OFFSET(xpvav_allocated, xav_fill);
10440 new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash)
10441 + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash)
10445 new_body_length = sizeof(XPVBM);
10446 new_body_arena = (void **) &PL_xpvbm_root;
10447 new_body_arenaroot = (void **) &PL_xpvbm_arenaroot;
10450 if (GvUNIQUE((GV*)sstr)) {
10451 /* Do sharing here. */
10453 new_body_length = sizeof(XPVGV);
10454 new_body_arena = (void **) &PL_xpvgv_root;
10455 new_body_arenaroot = (void **) &PL_xpvgv_arenaroot;
10458 new_body_length = sizeof(XPVCV);
10459 new_body_arena = (void **) &PL_xpvcv_root;
10460 new_body_arenaroot = (void **) &PL_xpvcv_arenaroot;
10463 new_body_length = sizeof(XPVLV);
10464 new_body_arena = (void **) &PL_xpvlv_root;
10465 new_body_arenaroot = (void **) &PL_xpvlv_arenaroot;
10468 new_body_length = sizeof(XPVMG);
10469 new_body_arena = (void **) &PL_xpvmg_root;
10470 new_body_arenaroot = (void **) &PL_xpvmg_arenaroot;
10473 new_body_length = sizeof(XPVNV);
10474 new_body_arena = (void **) &PL_xpvnv_root;
10475 new_body_arenaroot = (void **) &PL_xpvnv_arenaroot;
10478 new_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
10479 - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
10480 new_body_length = sizeof(XPVIV) - new_body_offset;
10481 new_body_arena = (void **) &PL_xpviv_root;
10482 new_body_arenaroot = (void **) &PL_xpviv_arenaroot;
10485 new_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
10486 - STRUCT_OFFSET(xpv_allocated, xpv_cur);
10487 new_body_length = sizeof(XPV) - new_body_offset;
10488 new_body_arena = (void **) &PL_xpv_root;
10489 new_body_arenaroot = (void **) &PL_xpv_arenaroot;
10491 assert(new_body_length);
10493 new_body_inline(new_body, new_body_arenaroot, new_body_arena,
10495 new_body = (void*)((char*)new_body - new_body_offset);
10497 /* We always allocated the full length item with PURIFY */
10498 new_body_length += new_body_offset;
10499 new_body_offset = 0;
10500 new_body = my_safemalloc(new_body_length);
10504 SvANY(dstr) = new_body;
10506 Copy(((char*)SvANY(sstr)) + new_body_offset,
10507 ((char*)SvANY(dstr)) + new_body_offset,
10508 new_body_length, char);
10510 if (SvTYPE(sstr) != SVt_PVAV && SvTYPE(sstr) != SVt_PVHV)
10511 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10513 /* The Copy above means that all the source (unduplicated) pointers
10514 are now in the destination. We can check the flags and the
10515 pointers in either, but it's possible that there's less cache
10516 missing by always going for the destination.
10517 FIXME - instrument and check that assumption */
10518 if (SvTYPE(sstr) >= SVt_PVMG) {
10520 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
10522 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
10525 switch (SvTYPE(sstr)) {
10537 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
10538 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
10539 LvTARG(dstr) = dstr;
10540 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
10541 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
10543 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
10546 GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr));
10547 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
10548 /* Don't call sv_add_backref here as it's going to be created
10549 as part of the magic cloning of the symbol table. */
10550 GvGP(dstr) = gp_dup(GvGP(dstr), param);
10551 (void)GpREFCNT_inc(GvGP(dstr));
10554 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
10555 if (IoOFP(dstr) == IoIFP(sstr))
10556 IoOFP(dstr) = IoIFP(dstr);
10558 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
10559 /* PL_rsfp_filters entries have fake IoDIRP() */
10560 if (IoDIRP(dstr) && !(IoFLAGS(dstr) & IOf_FAKE_DIRP))
10561 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
10562 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
10563 /* I have no idea why fake dirp (rsfps)
10564 should be treated differently but otherwise
10565 we end up with leaks -- sky*/
10566 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
10567 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
10568 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
10570 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
10571 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
10572 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
10574 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
10575 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
10576 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
10579 if (AvARRAY((AV*)sstr)) {
10580 SV **dst_ary, **src_ary;
10581 SSize_t items = AvFILLp((AV*)sstr) + 1;
10583 src_ary = AvARRAY((AV*)sstr);
10584 Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*);
10585 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10586 SvPV_set(dstr, (char*)dst_ary);
10587 AvALLOC((AV*)dstr) = dst_ary;
10588 if (AvREAL((AV*)sstr)) {
10589 while (items-- > 0)
10590 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10593 while (items-- > 0)
10594 *dst_ary++ = sv_dup(*src_ary++, param);
10596 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10597 while (items-- > 0) {
10598 *dst_ary++ = &PL_sv_undef;
10602 SvPV_set(dstr, Nullch);
10603 AvALLOC((AV*)dstr) = (SV**)NULL;
10610 if (HvARRAY((HV*)sstr)) {
10612 const bool sharekeys = !!HvSHAREKEYS(sstr);
10613 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
10614 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
10616 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
10617 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
10619 HvARRAY(dstr) = (HE**)darray;
10620 while (i <= sxhv->xhv_max) {
10621 const HE *source = HvARRAY(sstr)[i];
10622 HvARRAY(dstr)[i] = source
10623 ? he_dup(source, sharekeys, param) : 0;
10627 struct xpvhv_aux *saux = HvAUX(sstr);
10628 struct xpvhv_aux *daux = HvAUX(dstr);
10629 /* This flag isn't copied. */
10630 /* SvOOK_on(hv) attacks the IV flags. */
10631 SvFLAGS(dstr) |= SVf_OOK;
10633 hvname = saux->xhv_name;
10635 = hvname ? hek_dup(hvname, param) : hvname;
10637 daux->xhv_riter = saux->xhv_riter;
10638 daux->xhv_eiter = saux->xhv_eiter
10639 ? he_dup(saux->xhv_eiter,
10640 (bool)!!HvSHAREKEYS(sstr), param) : 0;
10644 SvPV_set(dstr, Nullch);
10646 /* Record stashes for possible cloning in Perl_clone(). */
10648 av_push(param->stashes, dstr);
10653 /* NOTE: not refcounted */
10654 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
10656 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
10658 if (CvCONST(dstr)) {
10659 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
10660 SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
10661 sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
10663 /* don't dup if copying back - CvGV isn't refcounted, so the
10664 * duped GV may never be freed. A bit of a hack! DAPM */
10665 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
10666 Nullgv : gv_dup(CvGV(dstr), param) ;
10667 if (!(param->flags & CLONEf_COPY_STACKS)) {
10670 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10672 CvWEAKOUTSIDE(sstr)
10673 ? cv_dup( CvOUTSIDE(dstr), param)
10674 : cv_dup_inc(CvOUTSIDE(dstr), param);
10676 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
10682 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10688 /* duplicate a context */
10691 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10693 PERL_CONTEXT *ncxs;
10696 return (PERL_CONTEXT*)NULL;
10698 /* look for it in the table first */
10699 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10703 /* create anew and remember what it is */
10704 Newxz(ncxs, max + 1, PERL_CONTEXT);
10705 ptr_table_store(PL_ptr_table, cxs, ncxs);
10708 PERL_CONTEXT *cx = &cxs[ix];
10709 PERL_CONTEXT *ncx = &ncxs[ix];
10710 ncx->cx_type = cx->cx_type;
10711 if (CxTYPE(cx) == CXt_SUBST) {
10712 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10715 ncx->blk_oldsp = cx->blk_oldsp;
10716 ncx->blk_oldcop = cx->blk_oldcop;
10717 ncx->blk_oldmarksp = cx->blk_oldmarksp;
10718 ncx->blk_oldscopesp = cx->blk_oldscopesp;
10719 ncx->blk_oldpm = cx->blk_oldpm;
10720 ncx->blk_gimme = cx->blk_gimme;
10721 switch (CxTYPE(cx)) {
10723 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
10724 ? cv_dup_inc(cx->blk_sub.cv, param)
10725 : cv_dup(cx->blk_sub.cv,param));
10726 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
10727 ? av_dup_inc(cx->blk_sub.argarray, param)
10729 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
10730 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
10731 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10732 ncx->blk_sub.lval = cx->blk_sub.lval;
10733 ncx->blk_sub.retop = cx->blk_sub.retop;
10736 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
10737 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
10738 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
10739 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
10740 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
10741 ncx->blk_eval.retop = cx->blk_eval.retop;
10744 ncx->blk_loop.label = cx->blk_loop.label;
10745 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
10746 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
10747 ncx->blk_loop.next_op = cx->blk_loop.next_op;
10748 ncx->blk_loop.last_op = cx->blk_loop.last_op;
10749 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
10750 ? cx->blk_loop.iterdata
10751 : gv_dup((GV*)cx->blk_loop.iterdata, param));
10752 ncx->blk_loop.oldcomppad
10753 = (PAD*)ptr_table_fetch(PL_ptr_table,
10754 cx->blk_loop.oldcomppad);
10755 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
10756 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
10757 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
10758 ncx->blk_loop.iterix = cx->blk_loop.iterix;
10759 ncx->blk_loop.itermax = cx->blk_loop.itermax;
10762 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
10763 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
10764 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
10765 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10766 ncx->blk_sub.retop = cx->blk_sub.retop;
10778 /* duplicate a stack info structure */
10781 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10786 return (PERL_SI*)NULL;
10788 /* look for it in the table first */
10789 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10793 /* create anew and remember what it is */
10794 Newxz(nsi, 1, PERL_SI);
10795 ptr_table_store(PL_ptr_table, si, nsi);
10797 nsi->si_stack = av_dup_inc(si->si_stack, param);
10798 nsi->si_cxix = si->si_cxix;
10799 nsi->si_cxmax = si->si_cxmax;
10800 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
10801 nsi->si_type = si->si_type;
10802 nsi->si_prev = si_dup(si->si_prev, param);
10803 nsi->si_next = si_dup(si->si_next, param);
10804 nsi->si_markoff = si->si_markoff;
10809 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
10810 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
10811 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
10812 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
10813 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
10814 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
10815 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
10816 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
10817 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
10818 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
10819 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
10820 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
10821 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
10822 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
10825 #define pv_dup_inc(p) SAVEPV(p)
10826 #define pv_dup(p) SAVEPV(p)
10827 #define svp_dup_inc(p,pp) any_dup(p,pp)
10829 /* map any object to the new equivent - either something in the
10830 * ptr table, or something in the interpreter structure
10834 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
10839 return (void*)NULL;
10841 /* look for it in the table first */
10842 ret = ptr_table_fetch(PL_ptr_table, v);
10846 /* see if it is part of the interpreter structure */
10847 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
10848 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
10856 /* duplicate the save stack */
10859 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
10861 ANY * const ss = proto_perl->Tsavestack;
10862 const I32 max = proto_perl->Tsavestack_max;
10863 I32 ix = proto_perl->Tsavestack_ix;
10875 void (*dptr) (void*);
10876 void (*dxptr) (pTHX_ void*);
10878 Newxz(nss, max, ANY);
10881 I32 i = POPINT(ss,ix);
10882 TOPINT(nss,ix) = i;
10884 case SAVEt_ITEM: /* normal string */
10885 sv = (SV*)POPPTR(ss,ix);
10886 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10887 sv = (SV*)POPPTR(ss,ix);
10888 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10890 case SAVEt_SV: /* scalar reference */
10891 sv = (SV*)POPPTR(ss,ix);
10892 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10893 gv = (GV*)POPPTR(ss,ix);
10894 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10896 case SAVEt_GENERIC_PVREF: /* generic char* */
10897 c = (char*)POPPTR(ss,ix);
10898 TOPPTR(nss,ix) = pv_dup(c);
10899 ptr = POPPTR(ss,ix);
10900 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10902 case SAVEt_SHARED_PVREF: /* char* in shared space */
10903 c = (char*)POPPTR(ss,ix);
10904 TOPPTR(nss,ix) = savesharedpv(c);
10905 ptr = POPPTR(ss,ix);
10906 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10908 case SAVEt_GENERIC_SVREF: /* generic sv */
10909 case SAVEt_SVREF: /* scalar reference */
10910 sv = (SV*)POPPTR(ss,ix);
10911 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10912 ptr = POPPTR(ss,ix);
10913 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
10915 case SAVEt_AV: /* array reference */
10916 av = (AV*)POPPTR(ss,ix);
10917 TOPPTR(nss,ix) = av_dup_inc(av, param);
10918 gv = (GV*)POPPTR(ss,ix);
10919 TOPPTR(nss,ix) = gv_dup(gv, param);
10921 case SAVEt_HV: /* hash reference */
10922 hv = (HV*)POPPTR(ss,ix);
10923 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10924 gv = (GV*)POPPTR(ss,ix);
10925 TOPPTR(nss,ix) = gv_dup(gv, param);
10927 case SAVEt_INT: /* int reference */
10928 ptr = POPPTR(ss,ix);
10929 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10930 intval = (int)POPINT(ss,ix);
10931 TOPINT(nss,ix) = intval;
10933 case SAVEt_LONG: /* long reference */
10934 ptr = POPPTR(ss,ix);
10935 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10936 longval = (long)POPLONG(ss,ix);
10937 TOPLONG(nss,ix) = longval;
10939 case SAVEt_I32: /* I32 reference */
10940 case SAVEt_I16: /* I16 reference */
10941 case SAVEt_I8: /* I8 reference */
10942 ptr = POPPTR(ss,ix);
10943 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10945 TOPINT(nss,ix) = i;
10947 case SAVEt_IV: /* IV reference */
10948 ptr = POPPTR(ss,ix);
10949 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10951 TOPIV(nss,ix) = iv;
10953 case SAVEt_SPTR: /* SV* reference */
10954 ptr = POPPTR(ss,ix);
10955 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10956 sv = (SV*)POPPTR(ss,ix);
10957 TOPPTR(nss,ix) = sv_dup(sv, param);
10959 case SAVEt_VPTR: /* random* reference */
10960 ptr = POPPTR(ss,ix);
10961 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10962 ptr = POPPTR(ss,ix);
10963 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10965 case SAVEt_PPTR: /* char* reference */
10966 ptr = POPPTR(ss,ix);
10967 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10968 c = (char*)POPPTR(ss,ix);
10969 TOPPTR(nss,ix) = pv_dup(c);
10971 case SAVEt_HPTR: /* HV* reference */
10972 ptr = POPPTR(ss,ix);
10973 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10974 hv = (HV*)POPPTR(ss,ix);
10975 TOPPTR(nss,ix) = hv_dup(hv, param);
10977 case SAVEt_APTR: /* AV* reference */
10978 ptr = POPPTR(ss,ix);
10979 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10980 av = (AV*)POPPTR(ss,ix);
10981 TOPPTR(nss,ix) = av_dup(av, param);
10984 gv = (GV*)POPPTR(ss,ix);
10985 TOPPTR(nss,ix) = gv_dup(gv, param);
10987 case SAVEt_GP: /* scalar reference */
10988 gp = (GP*)POPPTR(ss,ix);
10989 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
10990 (void)GpREFCNT_inc(gp);
10991 gv = (GV*)POPPTR(ss,ix);
10992 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10993 c = (char*)POPPTR(ss,ix);
10994 TOPPTR(nss,ix) = pv_dup(c);
10996 TOPIV(nss,ix) = iv;
10998 TOPIV(nss,ix) = iv;
11001 case SAVEt_MORTALIZESV:
11002 sv = (SV*)POPPTR(ss,ix);
11003 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11006 ptr = POPPTR(ss,ix);
11007 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11008 /* these are assumed to be refcounted properly */
11010 switch (((OP*)ptr)->op_type) {
11012 case OP_LEAVESUBLV:
11016 case OP_LEAVEWRITE:
11017 TOPPTR(nss,ix) = ptr;
11022 TOPPTR(nss,ix) = Nullop;
11027 TOPPTR(nss,ix) = Nullop;
11030 c = (char*)POPPTR(ss,ix);
11031 TOPPTR(nss,ix) = pv_dup_inc(c);
11033 case SAVEt_CLEARSV:
11034 longval = POPLONG(ss,ix);
11035 TOPLONG(nss,ix) = longval;
11038 hv = (HV*)POPPTR(ss,ix);
11039 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11040 c = (char*)POPPTR(ss,ix);
11041 TOPPTR(nss,ix) = pv_dup_inc(c);
11043 TOPINT(nss,ix) = i;
11045 case SAVEt_DESTRUCTOR:
11046 ptr = POPPTR(ss,ix);
11047 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11048 dptr = POPDPTR(ss,ix);
11049 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
11050 any_dup(FPTR2DPTR(void *, dptr),
11053 case SAVEt_DESTRUCTOR_X:
11054 ptr = POPPTR(ss,ix);
11055 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11056 dxptr = POPDXPTR(ss,ix);
11057 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
11058 any_dup(FPTR2DPTR(void *, dxptr),
11061 case SAVEt_REGCONTEXT:
11064 TOPINT(nss,ix) = i;
11067 case SAVEt_STACK_POS: /* Position on Perl stack */
11069 TOPINT(nss,ix) = i;
11071 case SAVEt_AELEM: /* array element */
11072 sv = (SV*)POPPTR(ss,ix);
11073 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11075 TOPINT(nss,ix) = i;
11076 av = (AV*)POPPTR(ss,ix);
11077 TOPPTR(nss,ix) = av_dup_inc(av, param);
11079 case SAVEt_HELEM: /* hash element */
11080 sv = (SV*)POPPTR(ss,ix);
11081 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11082 sv = (SV*)POPPTR(ss,ix);
11083 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11084 hv = (HV*)POPPTR(ss,ix);
11085 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11088 ptr = POPPTR(ss,ix);
11089 TOPPTR(nss,ix) = ptr;
11093 TOPINT(nss,ix) = i;
11095 case SAVEt_COMPPAD:
11096 av = (AV*)POPPTR(ss,ix);
11097 TOPPTR(nss,ix) = av_dup(av, param);
11100 longval = (long)POPLONG(ss,ix);
11101 TOPLONG(nss,ix) = longval;
11102 ptr = POPPTR(ss,ix);
11103 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11104 sv = (SV*)POPPTR(ss,ix);
11105 TOPPTR(nss,ix) = sv_dup(sv, param);
11108 ptr = POPPTR(ss,ix);
11109 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11110 longval = (long)POPBOOL(ss,ix);
11111 TOPBOOL(nss,ix) = (bool)longval;
11113 case SAVEt_SET_SVFLAGS:
11115 TOPINT(nss,ix) = i;
11117 TOPINT(nss,ix) = i;
11118 sv = (SV*)POPPTR(ss,ix);
11119 TOPPTR(nss,ix) = sv_dup(sv, param);
11122 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
11130 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11131 * flag to the result. This is done for each stash before cloning starts,
11132 * so we know which stashes want their objects cloned */
11135 do_mark_cloneable_stash(pTHX_ SV *sv)
11137 const HEK * const hvname = HvNAME_HEK((HV*)sv);
11139 GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
11140 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11141 if (cloner && GvCV(cloner)) {
11148 XPUSHs(sv_2mortal(newSVhek(hvname)));
11150 call_sv((SV*)GvCV(cloner), G_SCALAR);
11157 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11165 =for apidoc perl_clone
11167 Create and return a new interpreter by cloning the current one.
11169 perl_clone takes these flags as parameters:
11171 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11172 without it we only clone the data and zero the stacks,
11173 with it we copy the stacks and the new perl interpreter is
11174 ready to run at the exact same point as the previous one.
11175 The pseudo-fork code uses COPY_STACKS while the
11176 threads->new doesn't.
11178 CLONEf_KEEP_PTR_TABLE
11179 perl_clone keeps a ptr_table with the pointer of the old
11180 variable as a key and the new variable as a value,
11181 this allows it to check if something has been cloned and not
11182 clone it again but rather just use the value and increase the
11183 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11184 the ptr_table using the function
11185 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11186 reason to keep it around is if you want to dup some of your own
11187 variable who are outside the graph perl scans, example of this
11188 code is in threads.xs create
11191 This is a win32 thing, it is ignored on unix, it tells perls
11192 win32host code (which is c++) to clone itself, this is needed on
11193 win32 if you want to run two threads at the same time,
11194 if you just want to do some stuff in a separate perl interpreter
11195 and then throw it away and return to the original one,
11196 you don't need to do anything.
11201 /* XXX the above needs expanding by someone who actually understands it ! */
11202 EXTERN_C PerlInterpreter *
11203 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11206 perl_clone(PerlInterpreter *proto_perl, UV flags)
11209 #ifdef PERL_IMPLICIT_SYS
11211 /* perlhost.h so we need to call into it
11212 to clone the host, CPerlHost should have a c interface, sky */
11214 if (flags & CLONEf_CLONE_HOST) {
11215 return perl_clone_host(proto_perl,flags);
11217 return perl_clone_using(proto_perl, flags,
11219 proto_perl->IMemShared,
11220 proto_perl->IMemParse,
11222 proto_perl->IStdIO,
11226 proto_perl->IProc);
11230 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11231 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11232 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11233 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11234 struct IPerlDir* ipD, struct IPerlSock* ipS,
11235 struct IPerlProc* ipP)
11237 /* XXX many of the string copies here can be optimized if they're
11238 * constants; they need to be allocated as common memory and just
11239 * their pointers copied. */
11242 CLONE_PARAMS clone_params;
11243 CLONE_PARAMS* param = &clone_params;
11245 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11246 /* for each stash, determine whether its objects should be cloned */
11247 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11248 PERL_SET_THX(my_perl);
11251 Poison(my_perl, 1, PerlInterpreter);
11253 PL_curcop = (COP *)Nullop;
11257 PL_savestack_ix = 0;
11258 PL_savestack_max = -1;
11259 PL_sig_pending = 0;
11260 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11261 # else /* !DEBUGGING */
11262 Zero(my_perl, 1, PerlInterpreter);
11263 # endif /* DEBUGGING */
11265 /* host pointers */
11267 PL_MemShared = ipMS;
11268 PL_MemParse = ipMP;
11275 #else /* !PERL_IMPLICIT_SYS */
11277 CLONE_PARAMS clone_params;
11278 CLONE_PARAMS* param = &clone_params;
11279 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11280 /* for each stash, determine whether its objects should be cloned */
11281 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11282 PERL_SET_THX(my_perl);
11285 Poison(my_perl, 1, PerlInterpreter);
11287 PL_curcop = (COP *)Nullop;
11291 PL_savestack_ix = 0;
11292 PL_savestack_max = -1;
11293 PL_sig_pending = 0;
11294 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11295 # else /* !DEBUGGING */
11296 Zero(my_perl, 1, PerlInterpreter);
11297 # endif /* DEBUGGING */
11298 #endif /* PERL_IMPLICIT_SYS */
11299 param->flags = flags;
11300 param->proto_perl = proto_perl;
11303 PL_xnv_arenaroot = NULL;
11304 PL_xnv_root = NULL;
11305 PL_xpv_arenaroot = NULL;
11306 PL_xpv_root = NULL;
11307 PL_xpviv_arenaroot = NULL;
11308 PL_xpviv_root = NULL;
11309 PL_xpvnv_arenaroot = NULL;
11310 PL_xpvnv_root = NULL;
11311 PL_xpvcv_arenaroot = NULL;
11312 PL_xpvcv_root = NULL;
11313 PL_xpvav_arenaroot = NULL;
11314 PL_xpvav_root = NULL;
11315 PL_xpvhv_arenaroot = NULL;
11316 PL_xpvhv_root = NULL;
11317 PL_xpvmg_arenaroot = NULL;
11318 PL_xpvmg_root = NULL;
11319 PL_xpvgv_arenaroot = NULL;
11320 PL_xpvgv_root = NULL;
11321 PL_xpvlv_arenaroot = NULL;
11322 PL_xpvlv_root = NULL;
11323 PL_xpvbm_arenaroot = NULL;
11324 PL_xpvbm_root = NULL;
11325 PL_he_arenaroot = NULL;
11327 #if defined(USE_ITHREADS)
11328 PL_pte_arenaroot = NULL;
11329 PL_pte_root = NULL;
11331 PL_nice_chunk = NULL;
11332 PL_nice_chunk_size = 0;
11334 PL_sv_objcount = 0;
11335 PL_sv_root = Nullsv;
11336 PL_sv_arenaroot = Nullsv;
11338 PL_debug = proto_perl->Idebug;
11340 PL_hash_seed = proto_perl->Ihash_seed;
11341 PL_rehash_seed = proto_perl->Irehash_seed;
11343 #ifdef USE_REENTRANT_API
11344 /* XXX: things like -Dm will segfault here in perlio, but doing
11345 * PERL_SET_CONTEXT(proto_perl);
11346 * breaks too many other things
11348 Perl_reentrant_init(aTHX);
11351 /* create SV map for pointer relocation */
11352 PL_ptr_table = ptr_table_new();
11354 /* initialize these special pointers as early as possible */
11355 SvANY(&PL_sv_undef) = NULL;
11356 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11357 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11358 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11360 SvANY(&PL_sv_no) = new_XPVNV();
11361 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11362 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11363 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11364 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
11365 SvCUR_set(&PL_sv_no, 0);
11366 SvLEN_set(&PL_sv_no, 1);
11367 SvIV_set(&PL_sv_no, 0);
11368 SvNV_set(&PL_sv_no, 0);
11369 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11371 SvANY(&PL_sv_yes) = new_XPVNV();
11372 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11373 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11374 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11375 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
11376 SvCUR_set(&PL_sv_yes, 1);
11377 SvLEN_set(&PL_sv_yes, 2);
11378 SvIV_set(&PL_sv_yes, 1);
11379 SvNV_set(&PL_sv_yes, 1);
11380 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11382 /* create (a non-shared!) shared string table */
11383 PL_strtab = newHV();
11384 HvSHAREKEYS_off(PL_strtab);
11385 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
11386 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11388 PL_compiling = proto_perl->Icompiling;
11390 /* These two PVs will be free'd special way so must set them same way op.c does */
11391 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11392 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11394 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11395 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11397 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11398 if (!specialWARN(PL_compiling.cop_warnings))
11399 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
11400 if (!specialCopIO(PL_compiling.cop_io))
11401 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
11402 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
11404 /* pseudo environmental stuff */
11405 PL_origargc = proto_perl->Iorigargc;
11406 PL_origargv = proto_perl->Iorigargv;
11408 param->stashes = newAV(); /* Setup array of objects to call clone on */
11410 /* Set tainting stuff before PerlIO_debug can possibly get called */
11411 PL_tainting = proto_perl->Itainting;
11412 PL_taint_warn = proto_perl->Itaint_warn;
11414 #ifdef PERLIO_LAYERS
11415 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11416 PerlIO_clone(aTHX_ proto_perl, param);
11419 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11420 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11421 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11422 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11423 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11424 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11427 PL_minus_c = proto_perl->Iminus_c;
11428 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11429 PL_localpatches = proto_perl->Ilocalpatches;
11430 PL_splitstr = proto_perl->Isplitstr;
11431 PL_preprocess = proto_perl->Ipreprocess;
11432 PL_minus_n = proto_perl->Iminus_n;
11433 PL_minus_p = proto_perl->Iminus_p;
11434 PL_minus_l = proto_perl->Iminus_l;
11435 PL_minus_a = proto_perl->Iminus_a;
11436 PL_minus_F = proto_perl->Iminus_F;
11437 PL_doswitches = proto_perl->Idoswitches;
11438 PL_dowarn = proto_perl->Idowarn;
11439 PL_doextract = proto_perl->Idoextract;
11440 PL_sawampersand = proto_perl->Isawampersand;
11441 PL_unsafe = proto_perl->Iunsafe;
11442 PL_inplace = SAVEPV(proto_perl->Iinplace);
11443 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11444 PL_perldb = proto_perl->Iperldb;
11445 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11446 PL_exit_flags = proto_perl->Iexit_flags;
11448 /* magical thingies */
11449 /* XXX time(&PL_basetime) when asked for? */
11450 PL_basetime = proto_perl->Ibasetime;
11451 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11453 PL_maxsysfd = proto_perl->Imaxsysfd;
11454 PL_multiline = proto_perl->Imultiline;
11455 PL_statusvalue = proto_perl->Istatusvalue;
11457 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11459 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
11461 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11463 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11464 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11465 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11467 /* Clone the regex array */
11468 PL_regex_padav = newAV();
11470 const I32 len = av_len((AV*)proto_perl->Iregex_padav);
11471 SV** const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11473 av_push(PL_regex_padav,
11474 sv_dup_inc(regexen[0],param));
11475 for(i = 1; i <= len; i++) {
11476 if(SvREPADTMP(regexen[i])) {
11477 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11479 av_push(PL_regex_padav,
11481 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11482 SvIVX(regexen[i])), param)))
11487 PL_regex_pad = AvARRAY(PL_regex_padav);
11489 /* shortcuts to various I/O objects */
11490 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11491 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11492 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11493 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11494 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11495 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11497 /* shortcuts to regexp stuff */
11498 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11500 /* shortcuts to misc objects */
11501 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11503 /* shortcuts to debugging objects */
11504 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11505 PL_DBline = gv_dup(proto_perl->IDBline, param);
11506 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11507 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11508 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11509 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11510 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11511 PL_lineary = av_dup(proto_perl->Ilineary, param);
11512 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11514 /* symbol tables */
11515 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11516 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11517 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11518 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11519 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11521 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11522 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11523 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11524 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11525 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11526 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11528 PL_sub_generation = proto_perl->Isub_generation;
11530 /* funky return mechanisms */
11531 PL_forkprocess = proto_perl->Iforkprocess;
11533 /* subprocess state */
11534 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11536 /* internal state */
11537 PL_maxo = proto_perl->Imaxo;
11538 if (proto_perl->Iop_mask)
11539 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11541 PL_op_mask = Nullch;
11542 /* PL_asserting = proto_perl->Iasserting; */
11544 /* current interpreter roots */
11545 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11546 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11547 PL_main_start = proto_perl->Imain_start;
11548 PL_eval_root = proto_perl->Ieval_root;
11549 PL_eval_start = proto_perl->Ieval_start;
11551 /* runtime control stuff */
11552 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11553 PL_copline = proto_perl->Icopline;
11555 PL_filemode = proto_perl->Ifilemode;
11556 PL_lastfd = proto_perl->Ilastfd;
11557 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11560 PL_gensym = proto_perl->Igensym;
11561 PL_preambled = proto_perl->Ipreambled;
11562 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11563 PL_laststatval = proto_perl->Ilaststatval;
11564 PL_laststype = proto_perl->Ilaststype;
11565 PL_mess_sv = Nullsv;
11567 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11569 /* interpreter atexit processing */
11570 PL_exitlistlen = proto_perl->Iexitlistlen;
11571 if (PL_exitlistlen) {
11572 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11573 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11576 PL_exitlist = (PerlExitListEntry*)NULL;
11577 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11578 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11579 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11581 PL_profiledata = NULL;
11582 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
11583 /* PL_rsfp_filters entries have fake IoDIRP() */
11584 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
11586 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11588 PAD_CLONE_VARS(proto_perl, param);
11590 #ifdef HAVE_INTERP_INTERN
11591 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11594 /* more statics moved here */
11595 PL_generation = proto_perl->Igeneration;
11596 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11598 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11599 PL_in_clean_all = proto_perl->Iin_clean_all;
11601 PL_uid = proto_perl->Iuid;
11602 PL_euid = proto_perl->Ieuid;
11603 PL_gid = proto_perl->Igid;
11604 PL_egid = proto_perl->Iegid;
11605 PL_nomemok = proto_perl->Inomemok;
11606 PL_an = proto_perl->Ian;
11607 PL_evalseq = proto_perl->Ievalseq;
11608 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11609 PL_origalen = proto_perl->Iorigalen;
11610 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11611 PL_osname = SAVEPV(proto_perl->Iosname);
11612 PL_sighandlerp = proto_perl->Isighandlerp;
11614 PL_runops = proto_perl->Irunops;
11616 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11619 PL_cshlen = proto_perl->Icshlen;
11620 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
11623 PL_lex_state = proto_perl->Ilex_state;
11624 PL_lex_defer = proto_perl->Ilex_defer;
11625 PL_lex_expect = proto_perl->Ilex_expect;
11626 PL_lex_formbrack = proto_perl->Ilex_formbrack;
11627 PL_lex_dojoin = proto_perl->Ilex_dojoin;
11628 PL_lex_starts = proto_perl->Ilex_starts;
11629 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
11630 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
11631 PL_lex_op = proto_perl->Ilex_op;
11632 PL_lex_inpat = proto_perl->Ilex_inpat;
11633 PL_lex_inwhat = proto_perl->Ilex_inwhat;
11634 PL_lex_brackets = proto_perl->Ilex_brackets;
11635 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11636 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
11637 PL_lex_casemods = proto_perl->Ilex_casemods;
11638 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11639 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
11641 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11642 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
11643 PL_nexttoke = proto_perl->Inexttoke;
11645 /* XXX This is probably masking the deeper issue of why
11646 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11647 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11648 * (A little debugging with a watchpoint on it may help.)
11650 if (SvANY(proto_perl->Ilinestr)) {
11651 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
11652 i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
11653 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11654 i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
11655 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11656 i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
11657 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11658 i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
11659 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11662 PL_linestr = NEWSV(65,79);
11663 sv_upgrade(PL_linestr,SVt_PVIV);
11664 sv_setpvn(PL_linestr,"",0);
11665 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
11667 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11668 PL_pending_ident = proto_perl->Ipending_ident;
11669 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
11671 PL_expect = proto_perl->Iexpect;
11673 PL_multi_start = proto_perl->Imulti_start;
11674 PL_multi_end = proto_perl->Imulti_end;
11675 PL_multi_open = proto_perl->Imulti_open;
11676 PL_multi_close = proto_perl->Imulti_close;
11678 PL_error_count = proto_perl->Ierror_count;
11679 PL_subline = proto_perl->Isubline;
11680 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
11682 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
11683 if (SvANY(proto_perl->Ilinestr)) {
11684 i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
11685 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11686 i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
11687 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11688 PL_last_lop_op = proto_perl->Ilast_lop_op;
11691 PL_last_uni = SvPVX(PL_linestr);
11692 PL_last_lop = SvPVX(PL_linestr);
11693 PL_last_lop_op = 0;
11695 PL_in_my = proto_perl->Iin_my;
11696 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
11698 PL_cryptseen = proto_perl->Icryptseen;
11701 PL_hints = proto_perl->Ihints;
11703 PL_amagic_generation = proto_perl->Iamagic_generation;
11705 #ifdef USE_LOCALE_COLLATE
11706 PL_collation_ix = proto_perl->Icollation_ix;
11707 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
11708 PL_collation_standard = proto_perl->Icollation_standard;
11709 PL_collxfrm_base = proto_perl->Icollxfrm_base;
11710 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
11711 #endif /* USE_LOCALE_COLLATE */
11713 #ifdef USE_LOCALE_NUMERIC
11714 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
11715 PL_numeric_standard = proto_perl->Inumeric_standard;
11716 PL_numeric_local = proto_perl->Inumeric_local;
11717 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11718 #endif /* !USE_LOCALE_NUMERIC */
11720 /* utf8 character classes */
11721 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11722 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11723 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11724 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11725 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
11726 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11727 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
11728 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
11729 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
11730 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
11731 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
11732 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
11733 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11734 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
11735 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11736 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11737 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11738 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11739 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11740 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11742 /* Did the locale setup indicate UTF-8? */
11743 PL_utf8locale = proto_perl->Iutf8locale;
11744 /* Unicode features (see perlrun/-C) */
11745 PL_unicode = proto_perl->Iunicode;
11747 /* Pre-5.8 signals control */
11748 PL_signals = proto_perl->Isignals;
11750 /* times() ticks per second */
11751 PL_clocktick = proto_perl->Iclocktick;
11753 /* Recursion stopper for PerlIO_find_layer */
11754 PL_in_load_module = proto_perl->Iin_load_module;
11756 /* sort() routine */
11757 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
11759 /* Not really needed/useful since the reenrant_retint is "volatile",
11760 * but do it for consistency's sake. */
11761 PL_reentrant_retint = proto_perl->Ireentrant_retint;
11763 /* Hooks to shared SVs and locks. */
11764 PL_sharehook = proto_perl->Isharehook;
11765 PL_lockhook = proto_perl->Ilockhook;
11766 PL_unlockhook = proto_perl->Iunlockhook;
11767 PL_threadhook = proto_perl->Ithreadhook;
11769 PL_runops_std = proto_perl->Irunops_std;
11770 PL_runops_dbg = proto_perl->Irunops_dbg;
11772 #ifdef THREADS_HAVE_PIDS
11773 PL_ppid = proto_perl->Ippid;
11777 PL_last_swash_hv = Nullhv; /* reinits on demand */
11778 PL_last_swash_klen = 0;
11779 PL_last_swash_key[0]= '\0';
11780 PL_last_swash_tmps = (U8*)NULL;
11781 PL_last_swash_slen = 0;
11783 PL_glob_index = proto_perl->Iglob_index;
11784 PL_srand_called = proto_perl->Isrand_called;
11785 PL_uudmap['M'] = 0; /* reinits on demand */
11786 PL_bitcount = Nullch; /* reinits on demand */
11788 if (proto_perl->Ipsig_pend) {
11789 Newxz(PL_psig_pend, SIG_SIZE, int);
11792 PL_psig_pend = (int*)NULL;
11795 if (proto_perl->Ipsig_ptr) {
11796 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
11797 Newxz(PL_psig_name, SIG_SIZE, SV*);
11798 for (i = 1; i < SIG_SIZE; i++) {
11799 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11800 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11804 PL_psig_ptr = (SV**)NULL;
11805 PL_psig_name = (SV**)NULL;
11808 /* thrdvar.h stuff */
11810 if (flags & CLONEf_COPY_STACKS) {
11811 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11812 PL_tmps_ix = proto_perl->Ttmps_ix;
11813 PL_tmps_max = proto_perl->Ttmps_max;
11814 PL_tmps_floor = proto_perl->Ttmps_floor;
11815 Newxz(PL_tmps_stack, PL_tmps_max, SV*);
11817 while (i <= PL_tmps_ix) {
11818 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
11822 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11823 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
11824 Newxz(PL_markstack, i, I32);
11825 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
11826 - proto_perl->Tmarkstack);
11827 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
11828 - proto_perl->Tmarkstack);
11829 Copy(proto_perl->Tmarkstack, PL_markstack,
11830 PL_markstack_ptr - PL_markstack + 1, I32);
11832 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
11833 * NOTE: unlike the others! */
11834 PL_scopestack_ix = proto_perl->Tscopestack_ix;
11835 PL_scopestack_max = proto_perl->Tscopestack_max;
11836 Newxz(PL_scopestack, PL_scopestack_max, I32);
11837 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
11839 /* NOTE: si_dup() looks at PL_markstack */
11840 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
11842 /* PL_curstack = PL_curstackinfo->si_stack; */
11843 PL_curstack = av_dup(proto_perl->Tcurstack, param);
11844 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
11846 /* next PUSHs() etc. set *(PL_stack_sp+1) */
11847 PL_stack_base = AvARRAY(PL_curstack);
11848 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
11849 - proto_perl->Tstack_base);
11850 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
11852 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
11853 * NOTE: unlike the others! */
11854 PL_savestack_ix = proto_perl->Tsavestack_ix;
11855 PL_savestack_max = proto_perl->Tsavestack_max;
11856 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
11857 PL_savestack = ss_dup(proto_perl, param);
11861 ENTER; /* perl_destruct() wants to LEAVE; */
11864 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
11865 PL_top_env = &PL_start_env;
11867 PL_op = proto_perl->Top;
11870 PL_Xpv = (XPV*)NULL;
11871 PL_na = proto_perl->Tna;
11873 PL_statbuf = proto_perl->Tstatbuf;
11874 PL_statcache = proto_perl->Tstatcache;
11875 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
11876 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
11878 PL_timesbuf = proto_perl->Ttimesbuf;
11881 PL_tainted = proto_perl->Ttainted;
11882 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
11883 PL_rs = sv_dup_inc(proto_perl->Trs, param);
11884 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
11885 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
11886 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
11887 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
11888 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
11889 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
11890 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
11892 PL_restartop = proto_perl->Trestartop;
11893 PL_in_eval = proto_perl->Tin_eval;
11894 PL_delaymagic = proto_perl->Tdelaymagic;
11895 PL_dirty = proto_perl->Tdirty;
11896 PL_localizing = proto_perl->Tlocalizing;
11898 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
11899 PL_hv_fetch_ent_mh = Nullhe;
11900 PL_modcount = proto_perl->Tmodcount;
11901 PL_lastgotoprobe = Nullop;
11902 PL_dumpindent = proto_perl->Tdumpindent;
11904 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
11905 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
11906 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
11907 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
11908 PL_sortcxix = proto_perl->Tsortcxix;
11909 PL_efloatbuf = Nullch; /* reinits on demand */
11910 PL_efloatsize = 0; /* reinits on demand */
11914 PL_screamfirst = NULL;
11915 PL_screamnext = NULL;
11916 PL_maxscream = -1; /* reinits on demand */
11917 PL_lastscream = Nullsv;
11919 PL_watchaddr = NULL;
11920 PL_watchok = Nullch;
11922 PL_regdummy = proto_perl->Tregdummy;
11923 PL_regprecomp = Nullch;
11926 PL_colorset = 0; /* reinits PL_colors[] */
11927 /*PL_colors[6] = {0,0,0,0,0,0};*/
11928 PL_reginput = Nullch;
11929 PL_regbol = Nullch;
11930 PL_regeol = Nullch;
11931 PL_regstartp = (I32*)NULL;
11932 PL_regendp = (I32*)NULL;
11933 PL_reglastparen = (U32*)NULL;
11934 PL_reglastcloseparen = (U32*)NULL;
11935 PL_regtill = Nullch;
11936 PL_reg_start_tmp = (char**)NULL;
11937 PL_reg_start_tmpl = 0;
11938 PL_regdata = (struct reg_data*)NULL;
11941 PL_reg_eval_set = 0;
11943 PL_regprogram = (regnode*)NULL;
11945 PL_regcc = (CURCUR*)NULL;
11946 PL_reg_call_cc = (struct re_cc_state*)NULL;
11947 PL_reg_re = (regexp*)NULL;
11948 PL_reg_ganch = Nullch;
11949 PL_reg_sv = Nullsv;
11950 PL_reg_match_utf8 = FALSE;
11951 PL_reg_magic = (MAGIC*)NULL;
11953 PL_reg_oldcurpm = (PMOP*)NULL;
11954 PL_reg_curpm = (PMOP*)NULL;
11955 PL_reg_oldsaved = Nullch;
11956 PL_reg_oldsavedlen = 0;
11957 #ifdef PERL_OLD_COPY_ON_WRITE
11960 PL_reg_maxiter = 0;
11961 PL_reg_leftiter = 0;
11962 PL_reg_poscache = Nullch;
11963 PL_reg_poscache_size= 0;
11965 /* RE engine - function pointers */
11966 PL_regcompp = proto_perl->Tregcompp;
11967 PL_regexecp = proto_perl->Tregexecp;
11968 PL_regint_start = proto_perl->Tregint_start;
11969 PL_regint_string = proto_perl->Tregint_string;
11970 PL_regfree = proto_perl->Tregfree;
11972 PL_reginterp_cnt = 0;
11973 PL_reg_starttry = 0;
11975 /* Pluggable optimizer */
11976 PL_peepp = proto_perl->Tpeepp;
11978 PL_stashcache = newHV();
11980 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
11981 ptr_table_free(PL_ptr_table);
11982 PL_ptr_table = NULL;
11985 /* Call the ->CLONE method, if it exists, for each of the stashes
11986 identified by sv_dup() above.
11988 while(av_len(param->stashes) != -1) {
11989 HV* const stash = (HV*) av_shift(param->stashes);
11990 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
11991 if (cloner && GvCV(cloner)) {
11996 XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
11998 call_sv((SV*)GvCV(cloner), G_DISCARD);
12004 SvREFCNT_dec(param->stashes);
12006 /* orphaned? eg threads->new inside BEGIN or use */
12007 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
12008 (void)SvREFCNT_inc(PL_compcv);
12009 SAVEFREESV(PL_compcv);
12015 #endif /* USE_ITHREADS */
12018 =head1 Unicode Support
12020 =for apidoc sv_recode_to_utf8
12022 The encoding is assumed to be an Encode object, on entry the PV
12023 of the sv is assumed to be octets in that encoding, and the sv
12024 will be converted into Unicode (and UTF-8).
12026 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12027 is not a reference, nothing is done to the sv. If the encoding is not
12028 an C<Encode::XS> Encoding object, bad things will happen.
12029 (See F<lib/encoding.pm> and L<Encode>).
12031 The PV of the sv is returned.
12036 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12039 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12053 Passing sv_yes is wrong - it needs to be or'ed set of constants
12054 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12055 remove converted chars from source.
12057 Both will default the value - let them.
12059 XPUSHs(&PL_sv_yes);
12062 call_method("decode", G_SCALAR);
12066 s = SvPV_const(uni, len);
12067 if (s != SvPVX_const(sv)) {
12068 SvGROW(sv, len + 1);
12069 Move(s, SvPVX(sv), len + 1, char);
12070 SvCUR_set(sv, len);
12077 return SvPOKp(sv) ? SvPVX(sv) : NULL;
12081 =for apidoc sv_cat_decode
12083 The encoding is assumed to be an Encode object, the PV of the ssv is
12084 assumed to be octets in that encoding and decoding the input starts
12085 from the position which (PV + *offset) pointed to. The dsv will be
12086 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
12087 when the string tstr appears in decoding output or the input ends on
12088 the PV of the ssv. The value which the offset points will be modified
12089 to the last input position on the ssv.
12091 Returns TRUE if the terminator was found, else returns FALSE.
12096 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12097 SV *ssv, int *offset, char *tstr, int tlen)
12101 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12112 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
12113 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
12115 call_method("cat_decode", G_SCALAR);
12117 ret = SvTRUE(TOPs);
12118 *offset = SvIV(offsv);
12124 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12130 * c-indentation-style: bsd
12131 * c-basic-offset: 4
12132 * indent-tabs-mode: t
12135 * ex: set ts=8 sts=4 sw=4 noet: