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_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 are approximately
67 1K chunks of memory parcelled up into N heads or bodies. The first slot
68 in each arena is reserved, and is used to hold a link to the next arena.
69 In the case of heads, the unused first slot also contains some flags and
70 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
75 The following global variables are associated with arenas:
77 PL_sv_arenaroot pointer to list of SV arenas
78 PL_sv_root pointer to list of free SV structures
80 PL_foo_arenaroot pointer to list of foo arenas,
81 PL_foo_root pointer to list of free foo bodies
82 ... for foo in xiv, xnv, xrv, xpv etc.
84 Note that some of the larger and more rarely used body types (eg xpvio)
85 are not allocated using arenas, but are instead just malloc()/free()ed as
86 required. Also, if PURIFY is defined, arenas are abandoned altogether,
87 with all items individually malloc()ed. In addition, a few SV heads are
88 not allocated from an arena, but are instead directly created as static
89 or auto variables, eg PL_sv_undef.
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..."
168 #ifdef DEBUG_LEAKING_SCALARS
170 # define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
172 # define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file)
175 # define FREE_SV_DEBUG_FILE(sv)
178 #define plant_SV(p) \
180 FREE_SV_DEBUG_FILE(p); \
181 SvANY(p) = (void *)PL_sv_root; \
182 SvFLAGS(p) = SVTYPEMASK; \
187 /* sv_mutex must be held while calling uproot_SV() */
188 #define uproot_SV(p) \
191 PL_sv_root = (SV*)SvANY(p); \
196 /* new_SV(): return a new, empty SV head */
198 #ifdef DEBUG_LEAKING_SCALARS
199 /* provide a real function for a debugger to play with */
214 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
215 sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
216 (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
217 sv->sv_debug_inpad = 0;
218 sv->sv_debug_cloned = 0;
220 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
222 sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
227 # define new_SV(p) (p)=S_new_SV(aTHX)
245 /* del_SV(): return an empty SV head to the free list */
260 S_del_sv(pTHX_ SV *p)
267 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
269 svend = &sva[SvREFCNT(sva)];
270 if (p >= sv && p < svend)
274 if (ckWARN_d(WARN_INTERNAL))
275 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
276 "Attempt to free non-arena SV: 0x%"UVxf
277 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
284 #else /* ! DEBUGGING */
286 #define del_SV(p) plant_SV(p)
288 #endif /* DEBUGGING */
292 =head1 SV Manipulation Functions
294 =for apidoc sv_add_arena
296 Given a chunk of memory, link it to the head of the list of arenas,
297 and split it into a list of free SVs.
303 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
309 /* The first SV in an arena isn't an SV. */
310 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
311 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
312 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
314 PL_sv_arenaroot = sva;
315 PL_sv_root = sva + 1;
317 svend = &sva[SvREFCNT(sva) - 1];
320 SvANY(sv) = (void *)(SV*)(sv + 1);
322 SvFLAGS(sv) = SVTYPEMASK;
326 SvFLAGS(sv) = SVTYPEMASK;
329 /* make some more SVs by adding another arena */
331 /* sv_mutex must be held while calling more_sv() */
338 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
339 PL_nice_chunk = Nullch;
340 PL_nice_chunk_size = 0;
343 char *chunk; /* must use New here to match call to Safefree() */
344 New(704,chunk,PERL_ARENA_SIZE,char); /* in sv_free_arenas() */
345 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
351 /* visit(): call the named function for each non-free SV in the arenas
352 * whose flags field matches the flags/mask args. */
355 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
362 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
363 svend = &sva[SvREFCNT(sva)];
364 for (sv = sva + 1; sv < svend; ++sv) {
365 if (SvTYPE(sv) != SVTYPEMASK
366 && (sv->sv_flags & mask) == flags
379 /* called by sv_report_used() for each live SV */
382 do_report_used(pTHX_ SV *sv)
384 if (SvTYPE(sv) != SVTYPEMASK) {
385 PerlIO_printf(Perl_debug_log, "****\n");
392 =for apidoc sv_report_used
394 Dump the contents of all SVs not yet freed. (Debugging aid).
400 Perl_sv_report_used(pTHX)
403 visit(do_report_used, 0, 0);
407 /* called by sv_clean_objs() for each live SV */
410 do_clean_objs(pTHX_ SV *sv)
414 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
415 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
427 /* XXX Might want to check arrays, etc. */
430 /* called by sv_clean_objs() for each live SV */
432 #ifndef DISABLE_DESTRUCTOR_KLUDGE
434 do_clean_named_objs(pTHX_ SV *sv)
436 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
437 if ( SvOBJECT(GvSV(sv)) ||
438 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
439 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
440 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
441 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
443 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
444 SvFLAGS(sv) |= SVf_BREAK;
452 =for apidoc sv_clean_objs
454 Attempt to destroy all objects not yet freed
460 Perl_sv_clean_objs(pTHX)
462 PL_in_clean_objs = TRUE;
463 visit(do_clean_objs, SVf_ROK, SVf_ROK);
464 #ifndef DISABLE_DESTRUCTOR_KLUDGE
465 /* some barnacles may yet remain, clinging to typeglobs */
466 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
468 PL_in_clean_objs = FALSE;
471 /* called by sv_clean_all() for each live SV */
474 do_clean_all(pTHX_ SV *sv)
476 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
477 SvFLAGS(sv) |= SVf_BREAK;
478 if (PL_comppad == (AV*)sv) {
480 PL_curpad = Null(SV**);
486 =for apidoc sv_clean_all
488 Decrement the refcnt of each remaining SV, possibly triggering a
489 cleanup. This function may have to be called multiple times to free
490 SVs which are in complex self-referential hierarchies.
496 Perl_sv_clean_all(pTHX)
499 PL_in_clean_all = TRUE;
500 cleaned = visit(do_clean_all, 0,0);
501 PL_in_clean_all = FALSE;
506 =for apidoc sv_free_arenas
508 Deallocate the memory used by all arenas. Note that all the individual SV
509 heads and bodies within the arenas must already have been freed.
515 Perl_sv_free_arenas(pTHX)
519 XPV *arena, *arenanext;
521 /* Free arenas here, but be careful about fake ones. (We assume
522 contiguity of the fake ones with the corresponding real ones.) */
524 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
525 svanext = (SV*) SvANY(sva);
526 while (svanext && SvFAKE(svanext))
527 svanext = (SV*) SvANY(svanext);
530 Safefree((void *)sva);
533 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
534 arenanext = (XPV*)arena->xpv_pv;
537 PL_xiv_arenaroot = 0;
540 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
541 arenanext = (XPV*)arena->xpv_pv;
544 PL_xnv_arenaroot = 0;
547 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
548 arenanext = (XPV*)arena->xpv_pv;
551 PL_xrv_arenaroot = 0;
554 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
555 arenanext = (XPV*)arena->xpv_pv;
558 PL_xpv_arenaroot = 0;
561 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
562 arenanext = (XPV*)arena->xpv_pv;
565 PL_xpviv_arenaroot = 0;
568 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
569 arenanext = (XPV*)arena->xpv_pv;
572 PL_xpvnv_arenaroot = 0;
575 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
576 arenanext = (XPV*)arena->xpv_pv;
579 PL_xpvcv_arenaroot = 0;
582 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
583 arenanext = (XPV*)arena->xpv_pv;
586 PL_xpvav_arenaroot = 0;
589 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
590 arenanext = (XPV*)arena->xpv_pv;
593 PL_xpvhv_arenaroot = 0;
596 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
597 arenanext = (XPV*)arena->xpv_pv;
600 PL_xpvmg_arenaroot = 0;
603 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
604 arenanext = (XPV*)arena->xpv_pv;
607 PL_xpvlv_arenaroot = 0;
610 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
611 arenanext = (XPV*)arena->xpv_pv;
614 PL_xpvbm_arenaroot = 0;
620 for (he = PL_he_arenaroot; he; he = he_next) {
621 he_next = HeNEXT(he);
629 struct ptr_tbl_ent *pte;
630 struct ptr_tbl_ent *pte_next;
631 for (pte = PL_pte_arenaroot; pte; pte = pte_next) {
632 pte_next = pte->next;
636 PL_pte_arenaroot = 0;
640 Safefree(PL_nice_chunk);
641 PL_nice_chunk = Nullch;
642 PL_nice_chunk_size = 0;
647 /* ---------------------------------------------------------------------
649 * support functions for report_uninit()
652 /* the maxiumum size of array or hash where we will scan looking
653 * for the undefined element that triggered the warning */
655 #define FUV_MAX_SEARCH_SIZE 1000
657 /* Look for an entry in the hash whose value has the same SV as val;
658 * If so, return a mortal copy of the key. */
661 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
668 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
669 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
674 for (i=HvMAX(hv); i>0; i--) {
675 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
676 if (HeVAL(entry) != val)
678 if ( HeVAL(entry) == &PL_sv_undef ||
679 HeVAL(entry) == &PL_sv_placeholder)
683 if (HeKLEN(entry) == HEf_SVKEY)
684 return sv_mortalcopy(HeKEY_sv(entry));
685 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
691 /* Look for an entry in the array whose value has the same SV as val;
692 * If so, return the index, otherwise return -1. */
695 S_find_array_subscript(pTHX_ AV *av, SV* val)
699 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
700 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
704 for (i=AvFILLp(av); i>=0; i--) {
705 if (svp[i] == val && svp[i] != &PL_sv_undef)
711 /* S_varname(): return the name of a variable, optionally with a subscript.
712 * If gv is non-zero, use the name of that global, along with gvtype (one
713 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
714 * targ. Depending on the value of the subscript_type flag, return:
717 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
718 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
719 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
720 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
723 S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ,
724 SV* keyname, I32 aindex, int subscript_type)
730 name = sv_newmortal();
733 /* simulate gv_fullname4(), but add literal '^' for $^FOO names
734 * XXX get rid of all this if gv_fullnameX() ever supports this
738 HV *hv = GvSTASH(gv);
739 sv_setpv(name, gvtype);
742 else if (!(p=HvNAME(hv)))
744 if (strNE(p, "main")) {
746 sv_catpvn(name,"::", 2);
748 if (GvNAMELEN(gv)>= 1 &&
749 ((unsigned int)*GvNAME(gv)) <= 26)
751 Perl_sv_catpvf(aTHX_ name,"^%c", *GvNAME(gv) + 'A' - 1);
752 sv_catpvn(name,GvNAME(gv)+1,GvNAMELEN(gv)-1);
755 sv_catpvn(name,GvNAME(gv),GvNAMELEN(gv));
759 CV *cv = find_runcv(&u);
760 if (!cv || !CvPADLIST(cv))
762 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
763 sv = *av_fetch(av, targ, FALSE);
764 /* SvLEN in a pad name is not to be trusted */
765 sv_setpv(name, SvPV_nolen(sv));
768 if (subscript_type == FUV_SUBSCRIPT_HASH) {
771 Perl_sv_catpvf(aTHX_ name, "{%s}",
772 pv_display(sv,SvPVX(keyname), SvCUR(keyname), 0, 32));
775 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
777 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
779 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
780 sv_insert(name, 0, 0, "within ", 7);
787 =for apidoc find_uninit_var
789 Find the name of the undefined variable (if any) that caused the operator o
790 to issue a "Use of uninitialized value" warning.
791 If match is true, only return a name if it's value matches uninit_sv.
792 So roughly speaking, if a unary operator (such as OP_COS) generates a
793 warning, then following the direct child of the op may yield an
794 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
795 other hand, with OP_ADD there are two branches to follow, so we only print
796 the variable name if we get an exact match.
798 The name is returned as a mortal SV.
800 Assumes that PL_op is the op that originally triggered the error, and that
801 PL_comppad/PL_curpad points to the currently executing pad.
807 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
816 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
817 uninit_sv == &PL_sv_placeholder)))
820 switch (obase->op_type) {
827 bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
828 bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
831 int subscript_type = FUV_SUBSCRIPT_WITHIN;
833 if (pad) { /* @lex, %lex */
834 sv = PAD_SVl(obase->op_targ);
838 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
839 /* @global, %global */
840 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
843 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
845 else /* @{expr}, %{expr} */
846 return find_uninit_var(cUNOPx(obase)->op_first,
850 /* attempt to find a match within the aggregate */
852 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
854 subscript_type = FUV_SUBSCRIPT_HASH;
857 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
859 subscript_type = FUV_SUBSCRIPT_ARRAY;
862 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
865 return S_varname(aTHX_ gv, hash ? "%" : "@", obase->op_targ,
866 keysv, index, subscript_type);
870 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
872 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
873 Nullsv, 0, FUV_SUBSCRIPT_NONE);
876 gv = cGVOPx_gv(obase);
877 if (!gv || (match && GvSV(gv) != uninit_sv))
879 return S_varname(aTHX_ gv, "$", 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
882 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
884 av = (AV*)PAD_SV(obase->op_targ);
885 if (!av || SvRMAGICAL(av))
887 svp = av_fetch(av, (I32)obase->op_private, FALSE);
888 if (!svp || *svp != uninit_sv)
891 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
892 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
895 gv = cGVOPx_gv(obase);
900 if (!av || SvRMAGICAL(av))
902 svp = av_fetch(av, (I32)obase->op_private, FALSE);
903 if (!svp || *svp != uninit_sv)
906 return S_varname(aTHX_ gv, "$", 0,
907 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
912 o = cUNOPx(obase)->op_first;
913 if (!o || o->op_type != OP_NULL ||
914 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
916 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
921 /* $a[uninit_expr] or $h{uninit_expr} */
922 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
925 o = cBINOPx(obase)->op_first;
926 kid = cBINOPx(obase)->op_last;
928 /* get the av or hv, and optionally the gv */
930 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
931 sv = PAD_SV(o->op_targ);
933 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
934 && cUNOPo->op_first->op_type == OP_GV)
936 gv = cGVOPx_gv(cUNOPo->op_first);
939 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
944 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
945 /* index is constant */
949 if (obase->op_type == OP_HELEM) {
950 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
951 if (!he || HeVAL(he) != uninit_sv)
955 svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
956 if (!svp || *svp != uninit_sv)
960 if (obase->op_type == OP_HELEM)
961 return S_varname(aTHX_ gv, "%", o->op_targ,
962 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
964 return S_varname(aTHX_ gv, "@", o->op_targ, Nullsv,
965 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
969 /* index is an expression;
970 * attempt to find a match within the aggregate */
971 if (obase->op_type == OP_HELEM) {
972 SV *keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
974 return S_varname(aTHX_ gv, "%", o->op_targ,
975 keysv, 0, FUV_SUBSCRIPT_HASH);
978 I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
980 return S_varname(aTHX_ gv, "@", o->op_targ,
981 Nullsv, index, FUV_SUBSCRIPT_ARRAY);
985 return S_varname(aTHX_ gv,
986 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
988 o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
994 /* only examine RHS */
995 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
998 o = cUNOPx(obase)->op_first;
999 if (o->op_type == OP_PUSHMARK)
1002 if (!o->op_sibling) {
1003 /* one-arg version of open is highly magical */
1005 if (o->op_type == OP_GV) { /* open FOO; */
1007 if (match && GvSV(gv) != uninit_sv)
1009 return S_varname(aTHX_ gv, "$", 0,
1010 Nullsv, 0, FUV_SUBSCRIPT_NONE);
1012 /* other possibilities not handled are:
1013 * open $x; or open my $x; should return '${*$x}'
1014 * open expr; should return '$'.expr ideally
1020 /* ops where $_ may be an implicit arg */
1024 if ( !(obase->op_flags & OPf_STACKED)) {
1025 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
1026 ? PAD_SVl(obase->op_targ)
1029 sv = sv_newmortal();
1038 /* skip filehandle as it can't produce 'undef' warning */
1039 o = cUNOPx(obase)->op_first;
1040 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
1041 o = o->op_sibling->op_sibling;
1048 match = 1; /* XS or custom code could trigger random warnings */
1053 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
1054 return sv_2mortal(newSVpv("${$/}", 0));
1059 if (!(obase->op_flags & OPf_KIDS))
1061 o = cUNOPx(obase)->op_first;
1067 /* if all except one arg are constant, or have no side-effects,
1068 * or are optimized away, then it's unambiguous */
1070 for (kid=o; kid; kid = kid->op_sibling) {
1072 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
1073 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
1074 || (kid->op_type == OP_PUSHMARK)
1078 if (o2) { /* more than one found */
1085 return find_uninit_var(o2, uninit_sv, match);
1089 sv = find_uninit_var(o, uninit_sv, 1);
1101 =for apidoc report_uninit
1103 Print appropriate "Use of uninitialized variable" warning
1109 Perl_report_uninit(pTHX_ SV* uninit_sv)
1112 SV* varname = Nullsv;
1114 varname = find_uninit_var(PL_op, uninit_sv,0);
1116 sv_insert(varname, 0, 0, " ", 1);
1118 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1119 varname ? SvPV_nolen(varname) : "",
1120 " in ", OP_DESC(PL_op));
1123 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1127 /* grab a new IV body from the free list, allocating more if necessary */
1138 * See comment in more_xiv() -- RAM.
1140 PL_xiv_root = *(IV**)xiv;
1142 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
1145 /* return an IV body to the free list */
1148 S_del_xiv(pTHX_ XPVIV *p)
1150 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
1152 *(IV**)xiv = PL_xiv_root;
1157 /* allocate another arena's worth of IV bodies */
1163 register IV* xivend;
1165 New(705, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV);
1166 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
1167 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
1170 xivend = &xiv[PERL_ARENA_SIZE / sizeof(IV) - 1];
1171 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
1173 while (xiv < xivend) {
1174 *(IV**)xiv = (IV *)(xiv + 1);
1180 /* grab a new NV body from the free list, allocating more if necessary */
1190 PL_xnv_root = *(NV**)xnv;
1192 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
1195 /* return an NV body to the free list */
1198 S_del_xnv(pTHX_ XPVNV *p)
1200 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
1202 *(NV**)xnv = PL_xnv_root;
1207 /* allocate another arena's worth of NV bodies */
1213 register NV* xnvend;
1215 New(711, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV);
1216 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
1217 PL_xnv_arenaroot = ptr;
1220 xnvend = &xnv[PERL_ARENA_SIZE / sizeof(NV) - 1];
1221 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
1223 while (xnv < xnvend) {
1224 *(NV**)xnv = (NV*)(xnv + 1);
1230 /* grab a new struct xrv from the free list, allocating more if necessary */
1240 PL_xrv_root = (XRV*)xrv->xrv_rv;
1245 /* return a struct xrv to the free list */
1248 S_del_xrv(pTHX_ XRV *p)
1251 p->xrv_rv = (SV*)PL_xrv_root;
1256 /* allocate another arena's worth of struct xrv */
1262 register XRV* xrvend;
1264 New(712, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV);
1265 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
1266 PL_xrv_arenaroot = ptr;
1269 xrvend = &xrv[PERL_ARENA_SIZE / sizeof(XRV) - 1];
1270 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
1272 while (xrv < xrvend) {
1273 xrv->xrv_rv = (SV*)(xrv + 1);
1279 /* grab a new struct xpv from the free list, allocating more if necessary */
1289 PL_xpv_root = (XPV*)xpv->xpv_pv;
1294 /* return a struct xpv to the free list */
1297 S_del_xpv(pTHX_ XPV *p)
1300 p->xpv_pv = (char*)PL_xpv_root;
1305 /* allocate another arena's worth of struct xpv */
1311 register XPV* xpvend;
1312 New(713, xpv, PERL_ARENA_SIZE/sizeof(XPV), XPV);
1313 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
1314 PL_xpv_arenaroot = xpv;
1316 xpvend = &xpv[PERL_ARENA_SIZE / sizeof(XPV) - 1];
1317 PL_xpv_root = ++xpv;
1318 while (xpv < xpvend) {
1319 xpv->xpv_pv = (char*)(xpv + 1);
1325 /* grab a new struct xpviv from the free list, allocating more if necessary */
1334 xpviv = PL_xpviv_root;
1335 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
1340 /* return a struct xpviv to the free list */
1343 S_del_xpviv(pTHX_ XPVIV *p)
1346 p->xpv_pv = (char*)PL_xpviv_root;
1351 /* allocate another arena's worth of struct xpviv */
1356 register XPVIV* xpviv;
1357 register XPVIV* xpvivend;
1358 New(714, xpviv, PERL_ARENA_SIZE/sizeof(XPVIV), XPVIV);
1359 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
1360 PL_xpviv_arenaroot = xpviv;
1362 xpvivend = &xpviv[PERL_ARENA_SIZE / sizeof(XPVIV) - 1];
1363 PL_xpviv_root = ++xpviv;
1364 while (xpviv < xpvivend) {
1365 xpviv->xpv_pv = (char*)(xpviv + 1);
1371 /* grab a new struct xpvnv from the free list, allocating more if necessary */
1380 xpvnv = PL_xpvnv_root;
1381 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
1386 /* return a struct xpvnv to the free list */
1389 S_del_xpvnv(pTHX_ XPVNV *p)
1392 p->xpv_pv = (char*)PL_xpvnv_root;
1397 /* allocate another arena's worth of struct xpvnv */
1402 register XPVNV* xpvnv;
1403 register XPVNV* xpvnvend;
1404 New(715, xpvnv, PERL_ARENA_SIZE/sizeof(XPVNV), XPVNV);
1405 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
1406 PL_xpvnv_arenaroot = xpvnv;
1408 xpvnvend = &xpvnv[PERL_ARENA_SIZE / sizeof(XPVNV) - 1];
1409 PL_xpvnv_root = ++xpvnv;
1410 while (xpvnv < xpvnvend) {
1411 xpvnv->xpv_pv = (char*)(xpvnv + 1);
1417 /* grab a new struct xpvcv from the free list, allocating more if necessary */
1426 xpvcv = PL_xpvcv_root;
1427 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
1432 /* return a struct xpvcv to the free list */
1435 S_del_xpvcv(pTHX_ XPVCV *p)
1438 p->xpv_pv = (char*)PL_xpvcv_root;
1443 /* allocate another arena's worth of struct xpvcv */
1448 register XPVCV* xpvcv;
1449 register XPVCV* xpvcvend;
1450 New(716, xpvcv, PERL_ARENA_SIZE/sizeof(XPVCV), XPVCV);
1451 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
1452 PL_xpvcv_arenaroot = xpvcv;
1454 xpvcvend = &xpvcv[PERL_ARENA_SIZE / sizeof(XPVCV) - 1];
1455 PL_xpvcv_root = ++xpvcv;
1456 while (xpvcv < xpvcvend) {
1457 xpvcv->xpv_pv = (char*)(xpvcv + 1);
1463 /* grab a new struct xpvav from the free list, allocating more if necessary */
1472 xpvav = PL_xpvav_root;
1473 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
1478 /* return a struct xpvav to the free list */
1481 S_del_xpvav(pTHX_ XPVAV *p)
1484 p->xav_array = (char*)PL_xpvav_root;
1489 /* allocate another arena's worth of struct xpvav */
1494 register XPVAV* xpvav;
1495 register XPVAV* xpvavend;
1496 New(717, xpvav, PERL_ARENA_SIZE/sizeof(XPVAV), XPVAV);
1497 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
1498 PL_xpvav_arenaroot = xpvav;
1500 xpvavend = &xpvav[PERL_ARENA_SIZE / sizeof(XPVAV) - 1];
1501 PL_xpvav_root = ++xpvav;
1502 while (xpvav < xpvavend) {
1503 xpvav->xav_array = (char*)(xpvav + 1);
1506 xpvav->xav_array = 0;
1509 /* grab a new struct xpvhv from the free list, allocating more if necessary */
1518 xpvhv = PL_xpvhv_root;
1519 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
1524 /* return a struct xpvhv to the free list */
1527 S_del_xpvhv(pTHX_ XPVHV *p)
1530 p->xhv_array = (char*)PL_xpvhv_root;
1535 /* allocate another arena's worth of struct xpvhv */
1540 register XPVHV* xpvhv;
1541 register XPVHV* xpvhvend;
1542 New(718, xpvhv, PERL_ARENA_SIZE/sizeof(XPVHV), XPVHV);
1543 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
1544 PL_xpvhv_arenaroot = xpvhv;
1546 xpvhvend = &xpvhv[PERL_ARENA_SIZE / sizeof(XPVHV) - 1];
1547 PL_xpvhv_root = ++xpvhv;
1548 while (xpvhv < xpvhvend) {
1549 xpvhv->xhv_array = (char*)(xpvhv + 1);
1552 xpvhv->xhv_array = 0;
1555 /* grab a new struct xpvmg from the free list, allocating more if necessary */
1564 xpvmg = PL_xpvmg_root;
1565 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
1570 /* return a struct xpvmg to the free list */
1573 S_del_xpvmg(pTHX_ XPVMG *p)
1576 p->xpv_pv = (char*)PL_xpvmg_root;
1581 /* allocate another arena's worth of struct xpvmg */
1586 register XPVMG* xpvmg;
1587 register XPVMG* xpvmgend;
1588 New(719, xpvmg, PERL_ARENA_SIZE/sizeof(XPVMG), XPVMG);
1589 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
1590 PL_xpvmg_arenaroot = xpvmg;
1592 xpvmgend = &xpvmg[PERL_ARENA_SIZE / sizeof(XPVMG) - 1];
1593 PL_xpvmg_root = ++xpvmg;
1594 while (xpvmg < xpvmgend) {
1595 xpvmg->xpv_pv = (char*)(xpvmg + 1);
1601 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1610 xpvlv = PL_xpvlv_root;
1611 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
1616 /* return a struct xpvlv to the free list */
1619 S_del_xpvlv(pTHX_ XPVLV *p)
1622 p->xpv_pv = (char*)PL_xpvlv_root;
1627 /* allocate another arena's worth of struct xpvlv */
1632 register XPVLV* xpvlv;
1633 register XPVLV* xpvlvend;
1634 New(720, xpvlv, PERL_ARENA_SIZE/sizeof(XPVLV), XPVLV);
1635 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
1636 PL_xpvlv_arenaroot = xpvlv;
1638 xpvlvend = &xpvlv[PERL_ARENA_SIZE / sizeof(XPVLV) - 1];
1639 PL_xpvlv_root = ++xpvlv;
1640 while (xpvlv < xpvlvend) {
1641 xpvlv->xpv_pv = (char*)(xpvlv + 1);
1647 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1656 xpvbm = PL_xpvbm_root;
1657 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
1662 /* return a struct xpvbm to the free list */
1665 S_del_xpvbm(pTHX_ XPVBM *p)
1668 p->xpv_pv = (char*)PL_xpvbm_root;
1673 /* allocate another arena's worth of struct xpvbm */
1678 register XPVBM* xpvbm;
1679 register XPVBM* xpvbmend;
1680 New(721, xpvbm, PERL_ARENA_SIZE/sizeof(XPVBM), XPVBM);
1681 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
1682 PL_xpvbm_arenaroot = xpvbm;
1684 xpvbmend = &xpvbm[PERL_ARENA_SIZE / sizeof(XPVBM) - 1];
1685 PL_xpvbm_root = ++xpvbm;
1686 while (xpvbm < xpvbmend) {
1687 xpvbm->xpv_pv = (char*)(xpvbm + 1);
1693 #define my_safemalloc(s) (void*)safemalloc(s)
1694 #define my_safefree(p) safefree((char*)p)
1698 #define new_XIV() my_safemalloc(sizeof(XPVIV))
1699 #define del_XIV(p) my_safefree(p)
1701 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1702 #define del_XNV(p) my_safefree(p)
1704 #define new_XRV() my_safemalloc(sizeof(XRV))
1705 #define del_XRV(p) my_safefree(p)
1707 #define new_XPV() my_safemalloc(sizeof(XPV))
1708 #define del_XPV(p) my_safefree(p)
1710 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1711 #define del_XPVIV(p) my_safefree(p)
1713 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1714 #define del_XPVNV(p) my_safefree(p)
1716 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1717 #define del_XPVCV(p) my_safefree(p)
1719 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1720 #define del_XPVAV(p) my_safefree(p)
1722 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1723 #define del_XPVHV(p) my_safefree(p)
1725 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1726 #define del_XPVMG(p) my_safefree(p)
1728 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1729 #define del_XPVLV(p) my_safefree(p)
1731 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1732 #define del_XPVBM(p) my_safefree(p)
1736 #define new_XIV() (void*)new_xiv()
1737 #define del_XIV(p) del_xiv((XPVIV*) p)
1739 #define new_XNV() (void*)new_xnv()
1740 #define del_XNV(p) del_xnv((XPVNV*) p)
1742 #define new_XRV() (void*)new_xrv()
1743 #define del_XRV(p) del_xrv((XRV*) p)
1745 #define new_XPV() (void*)new_xpv()
1746 #define del_XPV(p) del_xpv((XPV *)p)
1748 #define new_XPVIV() (void*)new_xpviv()
1749 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
1751 #define new_XPVNV() (void*)new_xpvnv()
1752 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
1754 #define new_XPVCV() (void*)new_xpvcv()
1755 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
1757 #define new_XPVAV() (void*)new_xpvav()
1758 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
1760 #define new_XPVHV() (void*)new_xpvhv()
1761 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
1763 #define new_XPVMG() (void*)new_xpvmg()
1764 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
1766 #define new_XPVLV() (void*)new_xpvlv()
1767 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
1769 #define new_XPVBM() (void*)new_xpvbm()
1770 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
1774 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1775 #define del_XPVGV(p) my_safefree(p)
1777 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1778 #define del_XPVFM(p) my_safefree(p)
1780 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1781 #define del_XPVIO(p) my_safefree(p)
1784 =for apidoc sv_upgrade
1786 Upgrade an SV to a more complex form. Generally adds a new body type to the
1787 SV, then copies across as much information as possible from the old body.
1788 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1794 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1805 if (mt != SVt_PV && SvIsCOW(sv)) {
1806 sv_force_normal_flags(sv, 0);
1809 if (SvTYPE(sv) == mt)
1820 switch (SvTYPE(sv)) {
1828 else if (mt < SVt_PVIV)
1838 pv = (char*)SvRV(sv);
1848 else if (mt == SVt_NV)
1856 del_XPVIV(SvANY(sv));
1864 del_XPVNV(SvANY(sv));
1867 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1868 there's no way that it can be safely upgraded, because perl.c
1869 expects to Safefree(SvANY(PL_mess_sv)) */
1870 assert(sv != PL_mess_sv);
1876 magic = SvMAGIC(sv);
1877 stash = SvSTASH(sv);
1878 del_XPVMG(SvANY(sv));
1881 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1884 SvFLAGS(sv) &= ~SVTYPEMASK;
1889 Perl_croak(aTHX_ "Can't upgrade to undef");
1891 SvANY(sv) = new_XIV();
1895 SvANY(sv) = new_XNV();
1899 SvANY(sv) = new_XRV();
1900 SvRV_set(sv, (SV*)pv);
1903 SvANY(sv) = new_XPVHV();
1910 HvTOTALKEYS(sv) = 0;
1911 HvPLACEHOLDERS(sv) = 0;
1913 /* Fall through... */
1916 SvANY(sv) = new_XPVAV();
1921 AvFLAGS(sv) = AVf_REAL;
1926 /* XXX? Only SVt_NULL is ever upgraded to AV or HV? */
1928 /* FIXME. Should be able to remove all this if()... if the above
1929 assertion is genuinely always true. */
1932 SvFLAGS(sv) &= ~SVf_OOK;
1935 SvPV_set(sv, (char*)0);
1936 SvMAGIC_set(sv, magic);
1937 SvSTASH_set(sv, stash);
1941 SvANY(sv) = new_XPVIO();
1942 Zero(SvANY(sv), 1, XPVIO);
1943 IoPAGE_LEN(sv) = 60;
1944 goto set_magic_common;
1946 SvANY(sv) = new_XPVFM();
1947 Zero(SvANY(sv), 1, XPVFM);
1948 goto set_magic_common;
1950 SvANY(sv) = new_XPVBM();
1954 goto set_magic_common;
1956 SvANY(sv) = new_XPVGV();
1962 goto set_magic_common;
1964 SvANY(sv) = new_XPVCV();
1965 Zero(SvANY(sv), 1, XPVCV);
1966 goto set_magic_common;
1968 SvANY(sv) = new_XPVLV();
1981 SvANY(sv) = new_XPVMG();
1984 SvMAGIC_set(sv, magic);
1985 SvSTASH_set(sv, stash);
1989 SvANY(sv) = new_XPVNV();
1995 SvANY(sv) = new_XPVIV();
2004 SvANY(sv) = new_XPV();
2015 =for apidoc sv_backoff
2017 Remove any string offset. You should normally use the C<SvOOK_off> macro
2024 Perl_sv_backoff(pTHX_ register SV *sv)
2028 char *s = SvPVX(sv);
2029 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
2030 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
2032 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
2034 SvFLAGS(sv) &= ~SVf_OOK;
2041 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
2042 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
2043 Use the C<SvGROW> wrapper instead.
2049 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
2053 #ifdef HAS_64K_LIMIT
2054 if (newlen >= 0x10000) {
2055 PerlIO_printf(Perl_debug_log,
2056 "Allocation too large: %"UVxf"\n", (UV)newlen);
2059 #endif /* HAS_64K_LIMIT */
2062 if (SvTYPE(sv) < SVt_PV) {
2063 sv_upgrade(sv, SVt_PV);
2066 else if (SvOOK(sv)) { /* pv is offset? */
2069 if (newlen > SvLEN(sv))
2070 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
2071 #ifdef HAS_64K_LIMIT
2072 if (newlen >= 0x10000)
2079 if (newlen > SvLEN(sv)) { /* need more room? */
2080 if (SvLEN(sv) && s) {
2082 STRLEN l = malloced_size((void*)SvPVX(sv));
2088 Renew(s,newlen,char);
2091 New(703, s, newlen, char);
2092 if (SvPVX(sv) && SvCUR(sv)) {
2093 Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
2097 SvLEN_set(sv, newlen);
2103 =for apidoc sv_setiv
2105 Copies an integer into the given SV, upgrading first if necessary.
2106 Does not handle 'set' magic. See also C<sv_setiv_mg>.
2112 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
2114 SV_CHECK_THINKFIRST_COW_DROP(sv);
2115 switch (SvTYPE(sv)) {
2117 sv_upgrade(sv, SVt_IV);
2120 sv_upgrade(sv, SVt_PVNV);
2124 sv_upgrade(sv, SVt_PVIV);
2133 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
2136 (void)SvIOK_only(sv); /* validate number */
2142 =for apidoc sv_setiv_mg
2144 Like C<sv_setiv>, but also handles 'set' magic.
2150 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
2157 =for apidoc sv_setuv
2159 Copies an unsigned integer into the given SV, upgrading first if necessary.
2160 Does not handle 'set' magic. See also C<sv_setuv_mg>.
2166 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
2168 /* With these two if statements:
2169 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2172 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2174 If you wish to remove them, please benchmark to see what the effect is
2176 if (u <= (UV)IV_MAX) {
2177 sv_setiv(sv, (IV)u);
2186 =for apidoc sv_setuv_mg
2188 Like C<sv_setuv>, but also handles 'set' magic.
2194 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
2196 /* With these two if statements:
2197 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2200 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2202 If you wish to remove them, please benchmark to see what the effect is
2204 if (u <= (UV)IV_MAX) {
2205 sv_setiv(sv, (IV)u);
2215 =for apidoc sv_setnv
2217 Copies a double into the given SV, upgrading first if necessary.
2218 Does not handle 'set' magic. See also C<sv_setnv_mg>.
2224 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
2226 SV_CHECK_THINKFIRST_COW_DROP(sv);
2227 switch (SvTYPE(sv)) {
2230 sv_upgrade(sv, SVt_NV);
2235 sv_upgrade(sv, SVt_PVNV);
2244 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
2248 (void)SvNOK_only(sv); /* validate number */
2253 =for apidoc sv_setnv_mg
2255 Like C<sv_setnv>, but also handles 'set' magic.
2261 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
2267 /* Print an "isn't numeric" warning, using a cleaned-up,
2268 * printable version of the offending string
2272 S_not_a_number(pTHX_ SV *sv)
2279 dsv = sv_2mortal(newSVpv("", 0));
2280 pv = sv_uni_display(dsv, sv, 10, 0);
2283 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
2284 /* each *s can expand to 4 chars + "...\0",
2285 i.e. need room for 8 chars */
2288 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
2290 if (ch & 128 && !isPRINT_LC(ch)) {
2299 else if (ch == '\r') {
2303 else if (ch == '\f') {
2307 else if (ch == '\\') {
2311 else if (ch == '\0') {
2315 else if (isPRINT_LC(ch))
2332 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2333 "Argument \"%s\" isn't numeric in %s", pv,
2336 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2337 "Argument \"%s\" isn't numeric", pv);
2341 =for apidoc looks_like_number
2343 Test if the content of an SV looks like a number (or is a number).
2344 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
2345 non-numeric warning), even if your atof() doesn't grok them.
2351 Perl_looks_like_number(pTHX_ SV *sv)
2353 register char *sbegin;
2360 else if (SvPOKp(sv))
2361 sbegin = SvPV(sv, len);
2363 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
2364 return grok_number(sbegin, len, NULL);
2367 /* Actually, ISO C leaves conversion of UV to IV undefined, but
2368 until proven guilty, assume that things are not that bad... */
2373 As 64 bit platforms often have an NV that doesn't preserve all bits of
2374 an IV (an assumption perl has been based on to date) it becomes necessary
2375 to remove the assumption that the NV always carries enough precision to
2376 recreate the IV whenever needed, and that the NV is the canonical form.
2377 Instead, IV/UV and NV need to be given equal rights. So as to not lose
2378 precision as a side effect of conversion (which would lead to insanity
2379 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
2380 1) to distinguish between IV/UV/NV slots that have cached a valid
2381 conversion where precision was lost and IV/UV/NV slots that have a
2382 valid conversion which has lost no precision
2383 2) to ensure that if a numeric conversion to one form is requested that
2384 would lose precision, the precise conversion (or differently
2385 imprecise conversion) is also performed and cached, to prevent
2386 requests for different numeric formats on the same SV causing
2387 lossy conversion chains. (lossless conversion chains are perfectly
2392 SvIOKp is true if the IV slot contains a valid value
2393 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
2394 SvNOKp is true if the NV slot contains a valid value
2395 SvNOK is true only if the NV value is accurate
2398 while converting from PV to NV, check to see if converting that NV to an
2399 IV(or UV) would lose accuracy over a direct conversion from PV to
2400 IV(or UV). If it would, cache both conversions, return NV, but mark
2401 SV as IOK NOKp (ie not NOK).
2403 While converting from PV to IV, check to see if converting that IV to an
2404 NV would lose accuracy over a direct conversion from PV to NV. If it
2405 would, cache both conversions, flag similarly.
2407 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2408 correctly because if IV & NV were set NV *always* overruled.
2409 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2410 changes - now IV and NV together means that the two are interchangeable:
2411 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
2413 The benefit of this is that operations such as pp_add know that if
2414 SvIOK is true for both left and right operands, then integer addition
2415 can be used instead of floating point (for cases where the result won't
2416 overflow). Before, floating point was always used, which could lead to
2417 loss of precision compared with integer addition.
2419 * making IV and NV equal status should make maths accurate on 64 bit
2421 * may speed up maths somewhat if pp_add and friends start to use
2422 integers when possible instead of fp. (Hopefully the overhead in
2423 looking for SvIOK and checking for overflow will not outweigh the
2424 fp to integer speedup)
2425 * will slow down integer operations (callers of SvIV) on "inaccurate"
2426 values, as the change from SvIOK to SvIOKp will cause a call into
2427 sv_2iv each time rather than a macro access direct to the IV slot
2428 * should speed up number->string conversion on integers as IV is
2429 favoured when IV and NV are equally accurate
2431 ####################################################################
2432 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2433 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2434 On the other hand, SvUOK is true iff UV.
2435 ####################################################################
2437 Your mileage will vary depending your CPU's relative fp to integer
2441 #ifndef NV_PRESERVES_UV
2442 # define IS_NUMBER_UNDERFLOW_IV 1
2443 # define IS_NUMBER_UNDERFLOW_UV 2
2444 # define IS_NUMBER_IV_AND_UV 2
2445 # define IS_NUMBER_OVERFLOW_IV 4
2446 # define IS_NUMBER_OVERFLOW_UV 5
2448 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2450 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2452 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2454 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
2455 if (SvNVX(sv) < (NV)IV_MIN) {
2456 (void)SvIOKp_on(sv);
2458 SvIV_set(sv, IV_MIN);
2459 return IS_NUMBER_UNDERFLOW_IV;
2461 if (SvNVX(sv) > (NV)UV_MAX) {
2462 (void)SvIOKp_on(sv);
2465 SvUV_set(sv, UV_MAX);
2466 return IS_NUMBER_OVERFLOW_UV;
2468 (void)SvIOKp_on(sv);
2470 /* Can't use strtol etc to convert this string. (See truth table in
2472 if (SvNVX(sv) <= (UV)IV_MAX) {
2473 SvIV_set(sv, I_V(SvNVX(sv)));
2474 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2475 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2477 /* Integer is imprecise. NOK, IOKp */
2479 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2482 SvUV_set(sv, U_V(SvNVX(sv)));
2483 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2484 if (SvUVX(sv) == UV_MAX) {
2485 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2486 possibly be preserved by NV. Hence, it must be overflow.
2488 return IS_NUMBER_OVERFLOW_UV;
2490 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2492 /* Integer is imprecise. NOK, IOKp */
2494 return IS_NUMBER_OVERFLOW_IV;
2496 #endif /* !NV_PRESERVES_UV*/
2498 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
2499 * this function provided for binary compatibility only
2503 Perl_sv_2iv(pTHX_ register SV *sv)
2505 return sv_2iv_flags(sv, SV_GMAGIC);
2509 =for apidoc sv_2iv_flags
2511 Return the integer value of an SV, doing any necessary string
2512 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2513 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2519 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2523 if (SvGMAGICAL(sv)) {
2524 if (flags & SV_GMAGIC)
2529 return I_V(SvNVX(sv));
2531 if (SvPOKp(sv) && SvLEN(sv))
2534 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2535 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2541 if (SvTHINKFIRST(sv)) {
2544 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2545 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2546 return SvIV(tmpstr);
2547 return PTR2IV(SvRV(sv));
2550 sv_force_normal_flags(sv, 0);
2552 if (SvREADONLY(sv) && !SvOK(sv)) {
2553 if (ckWARN(WARN_UNINITIALIZED))
2560 return (IV)(SvUVX(sv));
2567 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2568 * without also getting a cached IV/UV from it at the same time
2569 * (ie PV->NV conversion should detect loss of accuracy and cache
2570 * IV or UV at same time to avoid this. NWC */
2572 if (SvTYPE(sv) == SVt_NV)
2573 sv_upgrade(sv, SVt_PVNV);
2575 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2576 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2577 certainly cast into the IV range at IV_MAX, whereas the correct
2578 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2580 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2581 SvIV_set(sv, I_V(SvNVX(sv)));
2582 if (SvNVX(sv) == (NV) SvIVX(sv)
2583 #ifndef NV_PRESERVES_UV
2584 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2585 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2586 /* Don't flag it as "accurately an integer" if the number
2587 came from a (by definition imprecise) NV operation, and
2588 we're outside the range of NV integer precision */
2591 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2592 DEBUG_c(PerlIO_printf(Perl_debug_log,
2593 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2599 /* IV not precise. No need to convert from PV, as NV
2600 conversion would already have cached IV if it detected
2601 that PV->IV would be better than PV->NV->IV
2602 flags already correct - don't set public IOK. */
2603 DEBUG_c(PerlIO_printf(Perl_debug_log,
2604 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2609 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2610 but the cast (NV)IV_MIN rounds to a the value less (more
2611 negative) than IV_MIN which happens to be equal to SvNVX ??
2612 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2613 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2614 (NV)UVX == NVX are both true, but the values differ. :-(
2615 Hopefully for 2s complement IV_MIN is something like
2616 0x8000000000000000 which will be exact. NWC */
2619 SvUV_set(sv, U_V(SvNVX(sv)));
2621 (SvNVX(sv) == (NV) SvUVX(sv))
2622 #ifndef NV_PRESERVES_UV
2623 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2624 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2625 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2626 /* Don't flag it as "accurately an integer" if the number
2627 came from a (by definition imprecise) NV operation, and
2628 we're outside the range of NV integer precision */
2634 DEBUG_c(PerlIO_printf(Perl_debug_log,
2635 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2639 return (IV)SvUVX(sv);
2642 else if (SvPOKp(sv) && SvLEN(sv)) {
2644 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2645 /* We want to avoid a possible problem when we cache an IV which
2646 may be later translated to an NV, and the resulting NV is not
2647 the same as the direct translation of the initial string
2648 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2649 be careful to ensure that the value with the .456 is around if the
2650 NV value is requested in the future).
2652 This means that if we cache such an IV, we need to cache the
2653 NV as well. Moreover, we trade speed for space, and do not
2654 cache the NV if we are sure it's not needed.
2657 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2658 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2659 == IS_NUMBER_IN_UV) {
2660 /* It's definitely an integer, only upgrade to PVIV */
2661 if (SvTYPE(sv) < SVt_PVIV)
2662 sv_upgrade(sv, SVt_PVIV);
2664 } else if (SvTYPE(sv) < SVt_PVNV)
2665 sv_upgrade(sv, SVt_PVNV);
2667 /* If NV preserves UV then we only use the UV value if we know that
2668 we aren't going to call atof() below. If NVs don't preserve UVs
2669 then the value returned may have more precision than atof() will
2670 return, even though value isn't perfectly accurate. */
2671 if ((numtype & (IS_NUMBER_IN_UV
2672 #ifdef NV_PRESERVES_UV
2675 )) == IS_NUMBER_IN_UV) {
2676 /* This won't turn off the public IOK flag if it was set above */
2677 (void)SvIOKp_on(sv);
2679 if (!(numtype & IS_NUMBER_NEG)) {
2681 if (value <= (UV)IV_MAX) {
2682 SvIV_set(sv, (IV)value);
2684 SvUV_set(sv, value);
2688 /* 2s complement assumption */
2689 if (value <= (UV)IV_MIN) {
2690 SvIV_set(sv, -(IV)value);
2692 /* Too negative for an IV. This is a double upgrade, but
2693 I'm assuming it will be rare. */
2694 if (SvTYPE(sv) < SVt_PVNV)
2695 sv_upgrade(sv, SVt_PVNV);
2699 SvNV_set(sv, -(NV)value);
2700 SvIV_set(sv, IV_MIN);
2704 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2705 will be in the previous block to set the IV slot, and the next
2706 block to set the NV slot. So no else here. */
2708 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2709 != IS_NUMBER_IN_UV) {
2710 /* It wasn't an (integer that doesn't overflow the UV). */
2711 SvNV_set(sv, Atof(SvPVX(sv)));
2713 if (! numtype && ckWARN(WARN_NUMERIC))
2716 #if defined(USE_LONG_DOUBLE)
2717 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2718 PTR2UV(sv), SvNVX(sv)));
2720 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2721 PTR2UV(sv), SvNVX(sv)));
2725 #ifdef NV_PRESERVES_UV
2726 (void)SvIOKp_on(sv);
2728 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2729 SvIV_set(sv, I_V(SvNVX(sv)));
2730 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2733 /* Integer is imprecise. NOK, IOKp */
2735 /* UV will not work better than IV */
2737 if (SvNVX(sv) > (NV)UV_MAX) {
2739 /* Integer is inaccurate. NOK, IOKp, is UV */
2740 SvUV_set(sv, UV_MAX);
2743 SvUV_set(sv, U_V(SvNVX(sv)));
2744 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2745 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2749 /* Integer is imprecise. NOK, IOKp, is UV */
2755 #else /* NV_PRESERVES_UV */
2756 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2757 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2758 /* The IV slot will have been set from value returned by
2759 grok_number above. The NV slot has just been set using
2762 assert (SvIOKp(sv));
2764 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2765 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2766 /* Small enough to preserve all bits. */
2767 (void)SvIOKp_on(sv);
2769 SvIV_set(sv, I_V(SvNVX(sv)));
2770 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2772 /* Assumption: first non-preserved integer is < IV_MAX,
2773 this NV is in the preserved range, therefore: */
2774 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2776 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);
2780 0 0 already failed to read UV.
2781 0 1 already failed to read UV.
2782 1 0 you won't get here in this case. IV/UV
2783 slot set, public IOK, Atof() unneeded.
2784 1 1 already read UV.
2785 so there's no point in sv_2iuv_non_preserve() attempting
2786 to use atol, strtol, strtoul etc. */
2787 if (sv_2iuv_non_preserve (sv, numtype)
2788 >= IS_NUMBER_OVERFLOW_IV)
2792 #endif /* NV_PRESERVES_UV */
2795 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2797 if (SvTYPE(sv) < SVt_IV)
2798 /* Typically the caller expects that sv_any is not NULL now. */
2799 sv_upgrade(sv, SVt_IV);
2802 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2803 PTR2UV(sv),SvIVX(sv)));
2804 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2807 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2808 * this function provided for binary compatibility only
2812 Perl_sv_2uv(pTHX_ register SV *sv)
2814 return sv_2uv_flags(sv, SV_GMAGIC);
2818 =for apidoc sv_2uv_flags
2820 Return the unsigned integer value of an SV, doing any necessary string
2821 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2822 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2828 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2832 if (SvGMAGICAL(sv)) {
2833 if (flags & SV_GMAGIC)
2838 return U_V(SvNVX(sv));
2839 if (SvPOKp(sv) && SvLEN(sv))
2842 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2843 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2849 if (SvTHINKFIRST(sv)) {
2852 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2853 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2854 return SvUV(tmpstr);
2855 return PTR2UV(SvRV(sv));
2858 sv_force_normal_flags(sv, 0);
2860 if (SvREADONLY(sv) && !SvOK(sv)) {
2861 if (ckWARN(WARN_UNINITIALIZED))
2871 return (UV)SvIVX(sv);
2875 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2876 * without also getting a cached IV/UV from it at the same time
2877 * (ie PV->NV conversion should detect loss of accuracy and cache
2878 * IV or UV at same time to avoid this. */
2879 /* IV-over-UV optimisation - choose to cache IV if possible */
2881 if (SvTYPE(sv) == SVt_NV)
2882 sv_upgrade(sv, SVt_PVNV);
2884 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2885 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2886 SvIV_set(sv, I_V(SvNVX(sv)));
2887 if (SvNVX(sv) == (NV) SvIVX(sv)
2888 #ifndef NV_PRESERVES_UV
2889 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2890 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2891 /* Don't flag it as "accurately an integer" if the number
2892 came from a (by definition imprecise) NV operation, and
2893 we're outside the range of NV integer precision */
2896 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2897 DEBUG_c(PerlIO_printf(Perl_debug_log,
2898 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2904 /* IV not precise. No need to convert from PV, as NV
2905 conversion would already have cached IV if it detected
2906 that PV->IV would be better than PV->NV->IV
2907 flags already correct - don't set public IOK. */
2908 DEBUG_c(PerlIO_printf(Perl_debug_log,
2909 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2914 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2915 but the cast (NV)IV_MIN rounds to a the value less (more
2916 negative) than IV_MIN which happens to be equal to SvNVX ??
2917 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2918 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2919 (NV)UVX == NVX are both true, but the values differ. :-(
2920 Hopefully for 2s complement IV_MIN is something like
2921 0x8000000000000000 which will be exact. NWC */
2924 SvUV_set(sv, U_V(SvNVX(sv)));
2926 (SvNVX(sv) == (NV) SvUVX(sv))
2927 #ifndef NV_PRESERVES_UV
2928 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2929 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2930 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2931 /* Don't flag it as "accurately an integer" if the number
2932 came from a (by definition imprecise) NV operation, and
2933 we're outside the range of NV integer precision */
2938 DEBUG_c(PerlIO_printf(Perl_debug_log,
2939 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2945 else if (SvPOKp(sv) && SvLEN(sv)) {
2947 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2949 /* We want to avoid a possible problem when we cache a UV which
2950 may be later translated to an NV, and the resulting NV is not
2951 the translation of the initial data.
2953 This means that if we cache such a UV, we need to cache the
2954 NV as well. Moreover, we trade speed for space, and do not
2955 cache the NV if not needed.
2958 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2959 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2960 == IS_NUMBER_IN_UV) {
2961 /* It's definitely an integer, only upgrade to PVIV */
2962 if (SvTYPE(sv) < SVt_PVIV)
2963 sv_upgrade(sv, SVt_PVIV);
2965 } else if (SvTYPE(sv) < SVt_PVNV)
2966 sv_upgrade(sv, SVt_PVNV);
2968 /* If NV preserves UV then we only use the UV value if we know that
2969 we aren't going to call atof() below. If NVs don't preserve UVs
2970 then the value returned may have more precision than atof() will
2971 return, even though it isn't accurate. */
2972 if ((numtype & (IS_NUMBER_IN_UV
2973 #ifdef NV_PRESERVES_UV
2976 )) == IS_NUMBER_IN_UV) {
2977 /* This won't turn off the public IOK flag if it was set above */
2978 (void)SvIOKp_on(sv);
2980 if (!(numtype & IS_NUMBER_NEG)) {
2982 if (value <= (UV)IV_MAX) {
2983 SvIV_set(sv, (IV)value);
2985 /* it didn't overflow, and it was positive. */
2986 SvUV_set(sv, value);
2990 /* 2s complement assumption */
2991 if (value <= (UV)IV_MIN) {
2992 SvIV_set(sv, -(IV)value);
2994 /* Too negative for an IV. This is a double upgrade, but
2995 I'm assuming it will be rare. */
2996 if (SvTYPE(sv) < SVt_PVNV)
2997 sv_upgrade(sv, SVt_PVNV);
3001 SvNV_set(sv, -(NV)value);
3002 SvIV_set(sv, IV_MIN);
3007 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3008 != IS_NUMBER_IN_UV) {
3009 /* It wasn't an integer, or it overflowed the UV. */
3010 SvNV_set(sv, Atof(SvPVX(sv)));
3012 if (! numtype && ckWARN(WARN_NUMERIC))
3015 #if defined(USE_LONG_DOUBLE)
3016 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
3017 PTR2UV(sv), SvNVX(sv)));
3019 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
3020 PTR2UV(sv), SvNVX(sv)));
3023 #ifdef NV_PRESERVES_UV
3024 (void)SvIOKp_on(sv);
3026 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3027 SvIV_set(sv, I_V(SvNVX(sv)));
3028 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
3031 /* Integer is imprecise. NOK, IOKp */
3033 /* UV will not work better than IV */
3035 if (SvNVX(sv) > (NV)UV_MAX) {
3037 /* Integer is inaccurate. NOK, IOKp, is UV */
3038 SvUV_set(sv, UV_MAX);
3041 SvUV_set(sv, U_V(SvNVX(sv)));
3042 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
3043 NV preservse UV so can do correct comparison. */
3044 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
3048 /* Integer is imprecise. NOK, IOKp, is UV */
3053 #else /* NV_PRESERVES_UV */
3054 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3055 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
3056 /* The UV slot will have been set from value returned by
3057 grok_number above. The NV slot has just been set using
3060 assert (SvIOKp(sv));
3062 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3063 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3064 /* Small enough to preserve all bits. */
3065 (void)SvIOKp_on(sv);
3067 SvIV_set(sv, I_V(SvNVX(sv)));
3068 if ((NV)(SvIVX(sv)) == SvNVX(sv))
3070 /* Assumption: first non-preserved integer is < IV_MAX,
3071 this NV is in the preserved range, therefore: */
3072 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
3074 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);
3077 sv_2iuv_non_preserve (sv, numtype);
3079 #endif /* NV_PRESERVES_UV */
3083 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3084 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3087 if (SvTYPE(sv) < SVt_IV)
3088 /* Typically the caller expects that sv_any is not NULL now. */
3089 sv_upgrade(sv, SVt_IV);
3093 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
3094 PTR2UV(sv),SvUVX(sv)));
3095 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
3101 Return the num value of an SV, doing any necessary string or integer
3102 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
3109 Perl_sv_2nv(pTHX_ register SV *sv)
3113 if (SvGMAGICAL(sv)) {
3117 if (SvPOKp(sv) && SvLEN(sv)) {
3118 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
3119 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
3121 return Atof(SvPVX(sv));
3125 return (NV)SvUVX(sv);
3127 return (NV)SvIVX(sv);
3130 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3131 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3137 if (SvTHINKFIRST(sv)) {
3140 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
3141 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
3142 return SvNV(tmpstr);
3143 return PTR2NV(SvRV(sv));
3146 sv_force_normal_flags(sv, 0);
3148 if (SvREADONLY(sv) && !SvOK(sv)) {
3149 if (ckWARN(WARN_UNINITIALIZED))
3154 if (SvTYPE(sv) < SVt_NV) {
3155 if (SvTYPE(sv) == SVt_IV)
3156 sv_upgrade(sv, SVt_PVNV);
3158 sv_upgrade(sv, SVt_NV);
3159 #ifdef USE_LONG_DOUBLE
3161 STORE_NUMERIC_LOCAL_SET_STANDARD();
3162 PerlIO_printf(Perl_debug_log,
3163 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
3164 PTR2UV(sv), SvNVX(sv));
3165 RESTORE_NUMERIC_LOCAL();
3169 STORE_NUMERIC_LOCAL_SET_STANDARD();
3170 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
3171 PTR2UV(sv), SvNVX(sv));
3172 RESTORE_NUMERIC_LOCAL();
3176 else if (SvTYPE(sv) < SVt_PVNV)
3177 sv_upgrade(sv, SVt_PVNV);
3182 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
3183 #ifdef NV_PRESERVES_UV
3186 /* Only set the public NV OK flag if this NV preserves the IV */
3187 /* Check it's not 0xFFFFFFFFFFFFFFFF */
3188 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
3189 : (SvIVX(sv) == I_V(SvNVX(sv))))
3195 else if (SvPOKp(sv) && SvLEN(sv)) {
3197 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3198 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
3200 #ifdef NV_PRESERVES_UV
3201 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3202 == IS_NUMBER_IN_UV) {
3203 /* It's definitely an integer */
3204 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
3206 SvNV_set(sv, Atof(SvPVX(sv)));
3209 SvNV_set(sv, Atof(SvPVX(sv)));
3210 /* Only set the public NV OK flag if this NV preserves the value in
3211 the PV at least as well as an IV/UV would.
3212 Not sure how to do this 100% reliably. */
3213 /* if that shift count is out of range then Configure's test is
3214 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
3216 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3217 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3218 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
3219 } else if (!(numtype & IS_NUMBER_IN_UV)) {
3220 /* Can't use strtol etc to convert this string, so don't try.
3221 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
3224 /* value has been set. It may not be precise. */
3225 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
3226 /* 2s complement assumption for (UV)IV_MIN */
3227 SvNOK_on(sv); /* Integer is too negative. */
3232 if (numtype & IS_NUMBER_NEG) {
3233 SvIV_set(sv, -(IV)value);
3234 } else if (value <= (UV)IV_MAX) {
3235 SvIV_set(sv, (IV)value);
3237 SvUV_set(sv, value);
3241 if (numtype & IS_NUMBER_NOT_INT) {
3242 /* I believe that even if the original PV had decimals,
3243 they are lost beyond the limit of the FP precision.
3244 However, neither is canonical, so both only get p
3245 flags. NWC, 2000/11/25 */
3246 /* Both already have p flags, so do nothing */
3249 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3250 if (SvIVX(sv) == I_V(nv)) {
3255 /* It had no "." so it must be integer. */
3258 /* between IV_MAX and NV(UV_MAX).
3259 Could be slightly > UV_MAX */
3261 if (numtype & IS_NUMBER_NOT_INT) {
3262 /* UV and NV both imprecise. */
3264 UV nv_as_uv = U_V(nv);
3266 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
3277 #endif /* NV_PRESERVES_UV */
3280 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3282 if (SvTYPE(sv) < SVt_NV)
3283 /* Typically the caller expects that sv_any is not NULL now. */
3284 /* XXX Ilya implies that this is a bug in callers that assume this
3285 and ideally should be fixed. */
3286 sv_upgrade(sv, SVt_NV);
3289 #if defined(USE_LONG_DOUBLE)
3291 STORE_NUMERIC_LOCAL_SET_STANDARD();
3292 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
3293 PTR2UV(sv), SvNVX(sv));
3294 RESTORE_NUMERIC_LOCAL();
3298 STORE_NUMERIC_LOCAL_SET_STANDARD();
3299 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
3300 PTR2UV(sv), SvNVX(sv));
3301 RESTORE_NUMERIC_LOCAL();
3307 /* asIV(): extract an integer from the string value of an SV.
3308 * Caller must validate PVX */
3311 S_asIV(pTHX_ SV *sv)
3314 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3316 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3317 == IS_NUMBER_IN_UV) {
3318 /* It's definitely an integer */
3319 if (numtype & IS_NUMBER_NEG) {
3320 if (value < (UV)IV_MIN)
3323 if (value < (UV)IV_MAX)
3328 if (ckWARN(WARN_NUMERIC))
3331 return I_V(Atof(SvPVX(sv)));
3334 /* asUV(): extract an unsigned integer from the string value of an SV
3335 * Caller must validate PVX */
3338 S_asUV(pTHX_ SV *sv)
3341 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3343 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3344 == IS_NUMBER_IN_UV) {
3345 /* It's definitely an integer */
3346 if (!(numtype & IS_NUMBER_NEG))
3350 if (ckWARN(WARN_NUMERIC))
3353 return U_V(Atof(SvPVX(sv)));
3357 =for apidoc sv_2pv_nolen
3359 Like C<sv_2pv()>, but doesn't return the length too. You should usually
3360 use the macro wrapper C<SvPV_nolen(sv)> instead.
3365 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
3368 return sv_2pv(sv, &n_a);
3371 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
3372 * UV as a string towards the end of buf, and return pointers to start and
3375 * We assume that buf is at least TYPE_CHARS(UV) long.
3379 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
3381 char *ptr = buf + TYPE_CHARS(UV);
3395 *--ptr = '0' + (char)(uv % 10);
3403 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
3404 * this function provided for binary compatibility only
3408 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
3410 return sv_2pv_flags(sv, lp, SV_GMAGIC);
3414 =for apidoc sv_2pv_flags
3416 Returns a pointer to the string value of an SV, and sets *lp to its length.
3417 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
3419 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
3420 usually end up here too.
3426 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3431 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3432 char *tmpbuf = tbuf;
3438 if (SvGMAGICAL(sv)) {
3439 if (flags & SV_GMAGIC)
3447 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
3449 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3454 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3459 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3460 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3467 if (SvTHINKFIRST(sv)) {
3470 register const char *typestr;
3471 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3472 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3473 char *pv = SvPV(tmpstr, *lp);
3483 typestr = "NULLREF";
3487 switch (SvTYPE(sv)) {
3489 if ( ((SvFLAGS(sv) &
3490 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3491 == (SVs_OBJECT|SVs_SMG))
3492 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3493 const regexp *re = (regexp *)mg->mg_obj;
3496 const char *fptr = "msix";
3501 char need_newline = 0;
3502 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3504 while((ch = *fptr++)) {
3506 reflags[left++] = ch;
3509 reflags[right--] = ch;
3514 reflags[left] = '-';
3518 mg->mg_len = re->prelen + 4 + left;
3520 * If /x was used, we have to worry about a regex
3521 * ending with a comment later being embedded
3522 * within another regex. If so, we don't want this
3523 * regex's "commentization" to leak out to the
3524 * right part of the enclosing regex, we must cap
3525 * it with a newline.
3527 * So, if /x was used, we scan backwards from the
3528 * end of the regex. If we find a '#' before we
3529 * find a newline, we need to add a newline
3530 * ourself. If we find a '\n' first (or if we
3531 * don't find '#' or '\n'), we don't need to add
3532 * anything. -jfriedl
3534 if (PMf_EXTENDED & re->reganch)
3536 const char *endptr = re->precomp + re->prelen;
3537 while (endptr >= re->precomp)
3539 const char c = *(endptr--);
3541 break; /* don't need another */
3543 /* we end while in a comment, so we
3545 mg->mg_len++; /* save space for it */
3546 need_newline = 1; /* note to add it */
3552 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3553 Copy("(?", mg->mg_ptr, 2, char);
3554 Copy(reflags, mg->mg_ptr+2, left, char);
3555 Copy(":", mg->mg_ptr+left+2, 1, char);
3556 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3558 mg->mg_ptr[mg->mg_len - 2] = '\n';
3559 mg->mg_ptr[mg->mg_len - 1] = ')';
3560 mg->mg_ptr[mg->mg_len] = 0;
3562 PL_reginterp_cnt += re->program[0].next_off;
3564 if (re->reganch & ROPT_UTF8)
3579 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3580 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3581 /* tied lvalues should appear to be
3582 * scalars for backwards compatitbility */
3583 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3584 ? "SCALAR" : "LVALUE"; break;
3585 case SVt_PVAV: typestr = "ARRAY"; break;
3586 case SVt_PVHV: typestr = "HASH"; break;
3587 case SVt_PVCV: typestr = "CODE"; break;
3588 case SVt_PVGV: typestr = "GLOB"; break;
3589 case SVt_PVFM: typestr = "FORMAT"; break;
3590 case SVt_PVIO: typestr = "IO"; break;
3591 default: typestr = "UNKNOWN"; break;
3595 const char *name = HvNAME(SvSTASH(sv));
3596 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3597 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3600 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3603 *lp = strlen(typestr);
3604 return (char *)typestr;
3606 if (SvREADONLY(sv) && !SvOK(sv)) {
3607 if (ckWARN(WARN_UNINITIALIZED))
3613 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3614 /* I'm assuming that if both IV and NV are equally valid then
3615 converting the IV is going to be more efficient */
3616 const U32 isIOK = SvIOK(sv);
3617 const U32 isUIOK = SvIsUV(sv);
3618 char buf[TYPE_CHARS(UV)];
3621 if (SvTYPE(sv) < SVt_PVIV)
3622 sv_upgrade(sv, SVt_PVIV);
3624 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3626 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3627 SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */
3628 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3629 SvCUR_set(sv, ebuf - ptr);
3639 else if (SvNOKp(sv)) {
3640 if (SvTYPE(sv) < SVt_PVNV)
3641 sv_upgrade(sv, SVt_PVNV);
3642 /* The +20 is pure guesswork. Configure test needed. --jhi */
3643 SvGROW(sv, NV_DIG + 20);
3645 olderrno = errno; /* some Xenix systems wipe out errno here */
3647 if (SvNVX(sv) == 0.0)
3648 (void)strcpy(s,"0");
3652 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3655 #ifdef FIXNEGATIVEZERO
3656 if (*s == '-' && s[1] == '0' && !s[2])
3666 if (ckWARN(WARN_UNINITIALIZED)
3667 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3670 if (SvTYPE(sv) < SVt_PV)
3671 /* Typically the caller expects that sv_any is not NULL now. */
3672 sv_upgrade(sv, SVt_PV);
3675 *lp = s - SvPVX(sv);
3678 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3679 PTR2UV(sv),SvPVX(sv)));
3683 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3684 /* Sneaky stuff here */
3688 tsv = newSVpv(tmpbuf, 0);
3705 len = strlen(tmpbuf);
3707 #ifdef FIXNEGATIVEZERO
3708 if (len == 2 && t[0] == '-' && t[1] == '0') {
3713 (void)SvUPGRADE(sv, SVt_PV);
3715 s = SvGROW(sv, len + 1);
3718 return strcpy(s, t);
3723 =for apidoc sv_copypv
3725 Copies a stringified representation of the source SV into the
3726 destination SV. Automatically performs any necessary mg_get and
3727 coercion of numeric values into strings. Guaranteed to preserve
3728 UTF-8 flag even from overloaded objects. Similar in nature to
3729 sv_2pv[_flags] but operates directly on an SV instead of just the
3730 string. Mostly uses sv_2pv_flags to do its work, except when that
3731 would lose the UTF-8'ness of the PV.
3737 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3742 sv_setpvn(dsv,s,len);
3750 =for apidoc sv_2pvbyte_nolen
3752 Return a pointer to the byte-encoded representation of the SV.
3753 May cause the SV to be downgraded from UTF-8 as a side-effect.
3755 Usually accessed via the C<SvPVbyte_nolen> macro.
3761 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3764 return sv_2pvbyte(sv, &n_a);
3768 =for apidoc sv_2pvbyte
3770 Return a pointer to the byte-encoded representation of the SV, and set *lp
3771 to its length. May cause the SV to be downgraded from UTF-8 as a
3774 Usually accessed via the C<SvPVbyte> macro.
3780 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3782 sv_utf8_downgrade(sv,0);
3783 return SvPV(sv,*lp);
3787 =for apidoc sv_2pvutf8_nolen
3789 Return a pointer to the UTF-8-encoded representation of the SV.
3790 May cause the SV to be upgraded to UTF-8 as a side-effect.
3792 Usually accessed via the C<SvPVutf8_nolen> macro.
3798 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3801 return sv_2pvutf8(sv, &n_a);
3805 =for apidoc sv_2pvutf8
3807 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3808 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3810 Usually accessed via the C<SvPVutf8> macro.
3816 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3818 sv_utf8_upgrade(sv);
3819 return SvPV(sv,*lp);
3823 =for apidoc sv_2bool
3825 This function is only called on magical items, and is only used by
3826 sv_true() or its macro equivalent.
3832 Perl_sv_2bool(pTHX_ register SV *sv)
3841 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3842 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3843 return (bool)SvTRUE(tmpsv);
3844 return SvRV(sv) != 0;
3847 register XPV* Xpvtmp;
3848 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3849 (*Xpvtmp->xpv_pv > '0' ||
3850 Xpvtmp->xpv_cur > 1 ||
3851 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3858 return SvIVX(sv) != 0;
3861 return SvNVX(sv) != 0.0;
3868 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3869 * this function provided for binary compatibility only
3874 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3876 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3880 =for apidoc sv_utf8_upgrade
3882 Converts the PV of an SV to its UTF-8-encoded form.
3883 Forces the SV to string form if it is not already.
3884 Always sets the SvUTF8 flag to avoid future validity checks even
3885 if all the bytes have hibit clear.
3887 This is not as a general purpose byte encoding to Unicode interface:
3888 use the Encode extension for that.
3890 =for apidoc sv_utf8_upgrade_flags
3892 Converts the PV of an SV to its UTF-8-encoded form.
3893 Forces the SV to string form if it is not already.
3894 Always sets the SvUTF8 flag to avoid future validity checks even
3895 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3896 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3897 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3899 This is not as a general purpose byte encoding to Unicode interface:
3900 use the Encode extension for that.
3906 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3908 if (sv == &PL_sv_undef)
3912 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3913 (void) sv_2pv_flags(sv,&len, flags);
3917 (void) SvPV_force(sv,len);
3926 sv_force_normal_flags(sv, 0);
3929 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3930 sv_recode_to_utf8(sv, PL_encoding);
3931 else { /* Assume Latin-1/EBCDIC */
3932 /* This function could be much more efficient if we
3933 * had a FLAG in SVs to signal if there are any hibit
3934 * chars in the PV. Given that there isn't such a flag
3935 * make the loop as fast as possible. */
3936 U8 *s = (U8 *) SvPVX(sv);
3937 U8 *e = (U8 *) SvEND(sv);
3943 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3947 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3948 s = bytes_to_utf8((U8*)s, &len);
3950 SvPV_free(sv); /* No longer using what was there before. */
3952 SvPV_set(sv, (char*)s);
3953 SvCUR_set(sv, len - 1);
3954 SvLEN_set(sv, len); /* No longer know the real size. */
3956 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3963 =for apidoc sv_utf8_downgrade
3965 Attempts to convert the PV of an SV from characters to bytes.
3966 If the PV contains a character beyond byte, this conversion will fail;
3967 in this case, either returns false or, if C<fail_ok> is not
3970 This is not as a general purpose Unicode to byte encoding interface:
3971 use the Encode extension for that.
3977 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3979 if (SvPOKp(sv) && SvUTF8(sv)) {
3985 sv_force_normal_flags(sv, 0);
3987 s = (U8 *) SvPV(sv, len);
3988 if (!utf8_to_bytes(s, &len)) {
3993 Perl_croak(aTHX_ "Wide character in %s",
3996 Perl_croak(aTHX_ "Wide character");
4007 =for apidoc sv_utf8_encode
4009 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
4010 flag off so that it looks like octets again.
4016 Perl_sv_utf8_encode(pTHX_ register SV *sv)
4018 (void) sv_utf8_upgrade(sv);
4020 sv_force_normal_flags(sv, 0);
4022 if (SvREADONLY(sv)) {
4023 Perl_croak(aTHX_ PL_no_modify);
4029 =for apidoc sv_utf8_decode
4031 If the PV of the SV is an octet sequence in UTF-8
4032 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
4033 so that it looks like a character. If the PV contains only single-byte
4034 characters, the C<SvUTF8> flag stays being off.
4035 Scans PV for validity and returns false if the PV is invalid UTF-8.
4041 Perl_sv_utf8_decode(pTHX_ register SV *sv)
4047 /* The octets may have got themselves encoded - get them back as
4050 if (!sv_utf8_downgrade(sv, TRUE))
4053 /* it is actually just a matter of turning the utf8 flag on, but
4054 * we want to make sure everything inside is valid utf8 first.
4056 c = (U8 *) SvPVX(sv);
4057 if (!is_utf8_string(c, SvCUR(sv)+1))
4059 e = (U8 *) SvEND(sv);
4062 if (!UTF8_IS_INVARIANT(ch)) {
4071 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
4072 * this function provided for binary compatibility only
4076 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
4078 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
4082 =for apidoc sv_setsv
4084 Copies the contents of the source SV C<ssv> into the destination SV
4085 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4086 function if the source SV needs to be reused. Does not handle 'set' magic.
4087 Loosely speaking, it performs a copy-by-value, obliterating any previous
4088 content of the destination.
4090 You probably want to use one of the assortment of wrappers, such as
4091 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4092 C<SvSetMagicSV_nosteal>.
4094 =for apidoc sv_setsv_flags
4096 Copies the contents of the source SV C<ssv> into the destination SV
4097 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4098 function if the source SV needs to be reused. Does not handle 'set' magic.
4099 Loosely speaking, it performs a copy-by-value, obliterating any previous
4100 content of the destination.
4101 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
4102 C<ssv> if appropriate, else not. If the C<flags> parameter has the
4103 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
4104 and C<sv_setsv_nomg> are implemented in terms of this function.
4106 You probably want to use one of the assortment of wrappers, such as
4107 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4108 C<SvSetMagicSV_nosteal>.
4110 This is the primary function for copying scalars, and most other
4111 copy-ish functions and macros use this underneath.
4117 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
4119 register U32 sflags;
4125 SV_CHECK_THINKFIRST_COW_DROP(dstr);
4127 sstr = &PL_sv_undef;
4128 stype = SvTYPE(sstr);
4129 dtype = SvTYPE(dstr);
4134 /* need to nuke the magic */
4136 SvRMAGICAL_off(dstr);
4139 /* There's a lot of redundancy below but we're going for speed here */
4144 if (dtype != SVt_PVGV) {
4145 (void)SvOK_off(dstr);
4153 sv_upgrade(dstr, SVt_IV);
4156 sv_upgrade(dstr, SVt_PVNV);
4160 sv_upgrade(dstr, SVt_PVIV);
4163 (void)SvIOK_only(dstr);
4164 SvIV_set(dstr, SvIVX(sstr));
4167 if (SvTAINTED(sstr))
4178 sv_upgrade(dstr, SVt_NV);
4183 sv_upgrade(dstr, SVt_PVNV);
4186 SvNV_set(dstr, SvNVX(sstr));
4187 (void)SvNOK_only(dstr);
4188 if (SvTAINTED(sstr))
4196 sv_upgrade(dstr, SVt_RV);
4197 else if (dtype == SVt_PVGV &&
4198 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
4201 if (GvIMPORTED(dstr) != GVf_IMPORTED
4202 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4204 GvIMPORTED_on(dstr);
4213 #ifdef PERL_COPY_ON_WRITE
4214 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
4215 if (dtype < SVt_PVIV)
4216 sv_upgrade(dstr, SVt_PVIV);
4223 sv_upgrade(dstr, SVt_PV);
4226 if (dtype < SVt_PVIV)
4227 sv_upgrade(dstr, SVt_PVIV);
4230 if (dtype < SVt_PVNV)
4231 sv_upgrade(dstr, SVt_PVNV);
4238 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
4241 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
4245 if (dtype <= SVt_PVGV) {
4247 if (dtype != SVt_PVGV) {
4248 char *name = GvNAME(sstr);
4249 STRLEN len = GvNAMELEN(sstr);
4250 /* don't upgrade SVt_PVLV: it can hold a glob */
4251 if (dtype != SVt_PVLV)
4252 sv_upgrade(dstr, SVt_PVGV);
4253 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
4254 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
4255 GvNAME(dstr) = savepvn(name, len);
4256 GvNAMELEN(dstr) = len;
4257 SvFAKE_on(dstr); /* can coerce to non-glob */
4259 /* ahem, death to those who redefine active sort subs */
4260 else if (PL_curstackinfo->si_type == PERLSI_SORT
4261 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
4262 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
4265 #ifdef GV_UNIQUE_CHECK
4266 if (GvUNIQUE((GV*)dstr)) {
4267 Perl_croak(aTHX_ PL_no_modify);
4271 (void)SvOK_off(dstr);
4272 GvINTRO_off(dstr); /* one-shot flag */
4274 GvGP(dstr) = gp_ref(GvGP(sstr));
4275 if (SvTAINTED(sstr))
4277 if (GvIMPORTED(dstr) != GVf_IMPORTED
4278 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4280 GvIMPORTED_on(dstr);
4288 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4290 if ((int)SvTYPE(sstr) != stype) {
4291 stype = SvTYPE(sstr);
4292 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
4296 if (stype == SVt_PVLV)
4297 (void)SvUPGRADE(dstr, SVt_PVNV);
4299 (void)SvUPGRADE(dstr, (U32)stype);
4302 sflags = SvFLAGS(sstr);
4304 if (sflags & SVf_ROK) {
4305 if (dtype >= SVt_PV) {
4306 if (dtype == SVt_PVGV) {
4307 SV *sref = SvREFCNT_inc(SvRV(sstr));
4309 int intro = GvINTRO(dstr);
4311 #ifdef GV_UNIQUE_CHECK
4312 if (GvUNIQUE((GV*)dstr)) {
4313 Perl_croak(aTHX_ PL_no_modify);
4318 GvINTRO_off(dstr); /* one-shot flag */
4319 GvLINE(dstr) = CopLINE(PL_curcop);
4320 GvEGV(dstr) = (GV*)dstr;
4323 switch (SvTYPE(sref)) {
4326 SAVEGENERICSV(GvAV(dstr));
4328 dref = (SV*)GvAV(dstr);
4329 GvAV(dstr) = (AV*)sref;
4330 if (!GvIMPORTED_AV(dstr)
4331 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4333 GvIMPORTED_AV_on(dstr);
4338 SAVEGENERICSV(GvHV(dstr));
4340 dref = (SV*)GvHV(dstr);
4341 GvHV(dstr) = (HV*)sref;
4342 if (!GvIMPORTED_HV(dstr)
4343 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4345 GvIMPORTED_HV_on(dstr);
4350 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
4351 SvREFCNT_dec(GvCV(dstr));
4352 GvCV(dstr) = Nullcv;
4353 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4354 PL_sub_generation++;
4356 SAVEGENERICSV(GvCV(dstr));
4359 dref = (SV*)GvCV(dstr);
4360 if (GvCV(dstr) != (CV*)sref) {
4361 CV* cv = GvCV(dstr);
4363 if (!GvCVGEN((GV*)dstr) &&
4364 (CvROOT(cv) || CvXSUB(cv)))
4366 /* ahem, death to those who redefine
4367 * active sort subs */
4368 if (PL_curstackinfo->si_type == PERLSI_SORT &&
4369 PL_sortcop == CvSTART(cv))
4371 "Can't redefine active sort subroutine %s",
4372 GvENAME((GV*)dstr));
4373 /* Redefining a sub - warning is mandatory if
4374 it was a const and its value changed. */
4375 if (ckWARN(WARN_REDEFINE)
4377 && (!CvCONST((CV*)sref)
4378 || sv_cmp(cv_const_sv(cv),
4379 cv_const_sv((CV*)sref)))))
4381 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4383 ? "Constant subroutine %s::%s redefined"
4384 : "Subroutine %s::%s redefined",
4385 HvNAME(GvSTASH((GV*)dstr)),
4386 GvENAME((GV*)dstr));
4390 cv_ckproto(cv, (GV*)dstr,
4391 SvPOK(sref) ? SvPVX(sref) : Nullch);
4393 GvCV(dstr) = (CV*)sref;
4394 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4395 GvASSUMECV_on(dstr);
4396 PL_sub_generation++;
4398 if (!GvIMPORTED_CV(dstr)
4399 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4401 GvIMPORTED_CV_on(dstr);
4406 SAVEGENERICSV(GvIOp(dstr));
4408 dref = (SV*)GvIOp(dstr);
4409 GvIOp(dstr) = (IO*)sref;
4413 SAVEGENERICSV(GvFORM(dstr));
4415 dref = (SV*)GvFORM(dstr);
4416 GvFORM(dstr) = (CV*)sref;
4420 SAVEGENERICSV(GvSV(dstr));
4422 dref = (SV*)GvSV(dstr);
4424 if (!GvIMPORTED_SV(dstr)
4425 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4427 GvIMPORTED_SV_on(dstr);
4433 if (SvTAINTED(sstr))
4443 (void)SvOK_off(dstr);
4444 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4446 if (sflags & SVp_NOK) {
4448 /* Only set the public OK flag if the source has public OK. */
4449 if (sflags & SVf_NOK)
4450 SvFLAGS(dstr) |= SVf_NOK;
4451 SvNV_set(dstr, SvNVX(sstr));
4453 if (sflags & SVp_IOK) {
4454 (void)SvIOKp_on(dstr);
4455 if (sflags & SVf_IOK)
4456 SvFLAGS(dstr) |= SVf_IOK;
4457 if (sflags & SVf_IVisUV)
4459 SvIV_set(dstr, SvIVX(sstr));
4461 if (SvAMAGIC(sstr)) {
4465 else if (sflags & SVp_POK) {
4469 * Check to see if we can just swipe the string. If so, it's a
4470 * possible small lose on short strings, but a big win on long ones.
4471 * It might even be a win on short strings if SvPVX(dstr)
4472 * has to be allocated and SvPVX(sstr) has to be freed.
4475 /* Whichever path we take through the next code, we want this true,
4476 and doing it now facilitates the COW check. */
4477 (void)SvPOK_only(dstr);
4480 #ifdef PERL_COPY_ON_WRITE
4481 (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4485 (sflags & SVs_TEMP) && /* slated for free anyway? */
4486 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4487 (!(flags & SV_NOSTEAL)) &&
4488 /* and we're allowed to steal temps */
4489 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4490 SvLEN(sstr) && /* and really is a string */
4491 /* and won't be needed again, potentially */
4492 !(PL_op && PL_op->op_type == OP_AASSIGN))
4493 #ifdef PERL_COPY_ON_WRITE
4494 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4495 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4496 && SvTYPE(sstr) >= SVt_PVIV)
4499 /* Failed the swipe test, and it's not a shared hash key either.
4500 Have to copy the string. */
4501 STRLEN len = SvCUR(sstr);
4502 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4503 Move(SvPVX(sstr),SvPVX(dstr),len,char);
4504 SvCUR_set(dstr, len);
4505 *SvEND(dstr) = '\0';
4507 /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
4509 #ifdef PERL_COPY_ON_WRITE
4510 /* Either it's a shared hash key, or it's suitable for
4511 copy-on-write or we can swipe the string. */
4513 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4518 /* I believe I should acquire a global SV mutex if
4519 it's a COW sv (not a shared hash key) to stop
4520 it going un copy-on-write.
4521 If the source SV has gone un copy on write between up there
4522 and down here, then (assert() that) it is of the correct
4523 form to make it copy on write again */
4524 if ((sflags & (SVf_FAKE | SVf_READONLY))
4525 != (SVf_FAKE | SVf_READONLY)) {
4526 SvREADONLY_on(sstr);
4528 /* Make the source SV into a loop of 1.
4529 (about to become 2) */
4530 SV_COW_NEXT_SV_SET(sstr, sstr);
4534 /* Initial code is common. */
4535 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
4537 SvFLAGS(dstr) &= ~SVf_OOK;
4538 Safefree(SvPVX(dstr) - SvIVX(dstr));
4540 else if (SvLEN(dstr))
4541 Safefree(SvPVX(dstr));
4544 #ifdef PERL_COPY_ON_WRITE
4546 /* making another shared SV. */
4547 STRLEN cur = SvCUR(sstr);
4548 STRLEN len = SvLEN(sstr);
4549 assert (SvTYPE(dstr) >= SVt_PVIV);
4551 /* SvIsCOW_normal */
4552 /* splice us in between source and next-after-source. */
4553 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4554 SV_COW_NEXT_SV_SET(sstr, dstr);
4555 SvPV_set(dstr, SvPVX(sstr));
4557 /* SvIsCOW_shared_hash */
4558 UV hash = SvUVX(sstr);
4559 DEBUG_C(PerlIO_printf(Perl_debug_log,
4560 "Copy on write: Sharing hash\n"));
4562 sharepvn(SvPVX(sstr),
4563 (sflags & SVf_UTF8?-cur:cur), hash));
4564 SvUV_set(dstr, hash);
4566 SvLEN_set(dstr, len);
4567 SvCUR_set(dstr, cur);
4568 SvREADONLY_on(dstr);
4570 /* Relesase a global SV mutex. */
4574 { /* Passes the swipe test. */
4575 SvPV_set(dstr, SvPVX(sstr));
4576 SvLEN_set(dstr, SvLEN(sstr));
4577 SvCUR_set(dstr, SvCUR(sstr));
4580 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4581 SvPV_set(sstr, Nullch);
4587 if (sflags & SVf_UTF8)
4590 if (sflags & SVp_NOK) {
4592 if (sflags & SVf_NOK)
4593 SvFLAGS(dstr) |= SVf_NOK;
4594 SvNV_set(dstr, SvNVX(sstr));
4596 if (sflags & SVp_IOK) {
4597 (void)SvIOKp_on(dstr);
4598 if (sflags & SVf_IOK)
4599 SvFLAGS(dstr) |= SVf_IOK;
4600 if (sflags & SVf_IVisUV)
4602 SvIV_set(dstr, SvIVX(sstr));
4605 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4606 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4607 smg->mg_ptr, smg->mg_len);
4608 SvRMAGICAL_on(dstr);
4611 else if (sflags & SVp_IOK) {
4612 if (sflags & SVf_IOK)
4613 (void)SvIOK_only(dstr);
4615 (void)SvOK_off(dstr);
4616 (void)SvIOKp_on(dstr);
4618 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4619 if (sflags & SVf_IVisUV)
4621 SvIV_set(dstr, SvIVX(sstr));
4622 if (sflags & SVp_NOK) {
4623 if (sflags & SVf_NOK)
4624 (void)SvNOK_on(dstr);
4626 (void)SvNOKp_on(dstr);
4627 SvNV_set(dstr, SvNVX(sstr));
4630 else if (sflags & SVp_NOK) {
4631 if (sflags & SVf_NOK)
4632 (void)SvNOK_only(dstr);
4634 (void)SvOK_off(dstr);
4637 SvNV_set(dstr, SvNVX(sstr));
4640 if (dtype == SVt_PVGV) {
4641 if (ckWARN(WARN_MISC))
4642 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4645 (void)SvOK_off(dstr);
4647 if (SvTAINTED(sstr))
4652 =for apidoc sv_setsv_mg
4654 Like C<sv_setsv>, but also handles 'set' magic.
4660 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4662 sv_setsv(dstr,sstr);
4666 #ifdef PERL_COPY_ON_WRITE
4668 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4670 STRLEN cur = SvCUR(sstr);
4671 STRLEN len = SvLEN(sstr);
4672 register char *new_pv;
4675 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4683 if (SvTHINKFIRST(dstr))
4684 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4685 else if (SvPVX(dstr))
4686 Safefree(SvPVX(dstr));
4690 (void)SvUPGRADE (dstr, SVt_PVIV);
4692 assert (SvPOK(sstr));
4693 assert (SvPOKp(sstr));
4694 assert (!SvIOK(sstr));
4695 assert (!SvIOKp(sstr));
4696 assert (!SvNOK(sstr));
4697 assert (!SvNOKp(sstr));
4699 if (SvIsCOW(sstr)) {
4701 if (SvLEN(sstr) == 0) {
4702 /* source is a COW shared hash key. */
4703 UV hash = SvUVX(sstr);
4704 DEBUG_C(PerlIO_printf(Perl_debug_log,
4705 "Fast copy on write: Sharing hash\n"));
4706 SvUV_set(dstr, hash);
4707 new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash);
4710 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4712 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4713 (void)SvUPGRADE (sstr, SVt_PVIV);
4714 SvREADONLY_on(sstr);
4716 DEBUG_C(PerlIO_printf(Perl_debug_log,
4717 "Fast copy on write: Converting sstr to COW\n"));
4718 SV_COW_NEXT_SV_SET(dstr, sstr);
4720 SV_COW_NEXT_SV_SET(sstr, dstr);
4721 new_pv = SvPVX(sstr);
4724 SvPV_set(dstr, new_pv);
4725 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4728 SvLEN_set(dstr, len);
4729 SvCUR_set(dstr, cur);
4738 =for apidoc sv_setpvn
4740 Copies a string into an SV. The C<len> parameter indicates the number of
4741 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4742 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4748 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4750 register char *dptr;
4752 SV_CHECK_THINKFIRST_COW_DROP(sv);
4758 /* len is STRLEN which is unsigned, need to copy to signed */
4761 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4763 (void)SvUPGRADE(sv, SVt_PV);
4765 SvGROW(sv, len + 1);
4767 Move(ptr,dptr,len,char);
4770 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4775 =for apidoc sv_setpvn_mg
4777 Like C<sv_setpvn>, but also handles 'set' magic.
4783 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4785 sv_setpvn(sv,ptr,len);
4790 =for apidoc sv_setpv
4792 Copies a string into an SV. The string must be null-terminated. Does not
4793 handle 'set' magic. See C<sv_setpv_mg>.
4799 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4801 register STRLEN len;
4803 SV_CHECK_THINKFIRST_COW_DROP(sv);
4809 (void)SvUPGRADE(sv, SVt_PV);
4811 SvGROW(sv, len + 1);
4812 Move(ptr,SvPVX(sv),len+1,char);
4814 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4819 =for apidoc sv_setpv_mg
4821 Like C<sv_setpv>, but also handles 'set' magic.
4827 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4834 =for apidoc sv_usepvn
4836 Tells an SV to use C<ptr> to find its string value. Normally the string is
4837 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4838 The C<ptr> should point to memory that was allocated by C<malloc>. The
4839 string length, C<len>, must be supplied. This function will realloc the
4840 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4841 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4842 See C<sv_usepvn_mg>.
4848 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4850 SV_CHECK_THINKFIRST_COW_DROP(sv);
4851 (void)SvUPGRADE(sv, SVt_PV);
4858 Renew(ptr, len+1, char);
4861 SvLEN_set(sv, len+1);
4863 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4868 =for apidoc sv_usepvn_mg
4870 Like C<sv_usepvn>, but also handles 'set' magic.
4876 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4878 sv_usepvn(sv,ptr,len);
4882 #ifdef PERL_COPY_ON_WRITE
4883 /* Need to do this *after* making the SV normal, as we need the buffer
4884 pointer to remain valid until after we've copied it. If we let go too early,
4885 another thread could invalidate it by unsharing last of the same hash key
4886 (which it can do by means other than releasing copy-on-write Svs)
4887 or by changing the other copy-on-write SVs in the loop. */
4889 S_sv_release_COW(pTHX_ register SV *sv, char *pvx, STRLEN cur, STRLEN len,
4890 U32 hash, SV *after)
4892 if (len) { /* this SV was SvIsCOW_normal(sv) */
4893 /* we need to find the SV pointing to us. */
4894 SV *current = SV_COW_NEXT_SV(after);
4896 if (current == sv) {
4897 /* The SV we point to points back to us (there were only two of us
4899 Hence other SV is no longer copy on write either. */
4901 SvREADONLY_off(after);
4903 /* We need to follow the pointers around the loop. */
4905 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4908 /* don't loop forever if the structure is bust, and we have
4909 a pointer into a closed loop. */
4910 assert (current != after);
4911 assert (SvPVX(current) == pvx);
4913 /* Make the SV before us point to the SV after us. */
4914 SV_COW_NEXT_SV_SET(current, after);
4917 unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash);
4922 Perl_sv_release_IVX(pTHX_ register SV *sv)
4925 sv_force_normal_flags(sv, 0);
4931 =for apidoc sv_force_normal_flags
4933 Undo various types of fakery on an SV: if the PV is a shared string, make
4934 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4935 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4936 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4937 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4938 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4939 set to some other value.) In addition, the C<flags> parameter gets passed to
4940 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4941 with flags set to 0.
4947 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4949 #ifdef PERL_COPY_ON_WRITE
4950 if (SvREADONLY(sv)) {
4951 /* At this point I believe I should acquire a global SV mutex. */
4953 char *pvx = SvPVX(sv);
4954 STRLEN len = SvLEN(sv);
4955 STRLEN cur = SvCUR(sv);
4956 U32 hash = SvUVX(sv);
4957 SV *next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
4959 PerlIO_printf(Perl_debug_log,
4960 "Copy on write: Force normal %ld\n",
4966 /* This SV doesn't own the buffer, so need to New() a new one: */
4967 SvPV_set(sv, (char*)0);
4969 if (flags & SV_COW_DROP_PV) {
4970 /* OK, so we don't need to copy our buffer. */
4973 SvGROW(sv, cur + 1);
4974 Move(pvx,SvPVX(sv),cur,char);
4978 sv_release_COW(sv, pvx, cur, len, hash, next);
4983 else if (IN_PERL_RUNTIME)
4984 Perl_croak(aTHX_ PL_no_modify);
4985 /* At this point I believe that I can drop the global SV mutex. */
4988 if (SvREADONLY(sv)) {
4990 char *pvx = SvPVX(sv);
4991 int is_utf8 = SvUTF8(sv);
4992 STRLEN len = SvCUR(sv);
4993 U32 hash = SvUVX(sv);
4996 SvPV_set(sv, (char*)0);
4998 SvGROW(sv, len + 1);
4999 Move(pvx,SvPVX(sv),len,char);
5001 unsharepvn(pvx, is_utf8 ? -(I32)len : len, hash);
5003 else if (IN_PERL_RUNTIME)
5004 Perl_croak(aTHX_ PL_no_modify);
5008 sv_unref_flags(sv, flags);
5009 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
5014 =for apidoc sv_force_normal
5016 Undo various types of fakery on an SV: if the PV is a shared string, make
5017 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5018 an xpvmg. See also C<sv_force_normal_flags>.
5024 Perl_sv_force_normal(pTHX_ register SV *sv)
5026 sv_force_normal_flags(sv, 0);
5032 Efficient removal of characters from the beginning of the string buffer.
5033 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
5034 the string buffer. The C<ptr> becomes the first character of the adjusted
5035 string. Uses the "OOK hack".
5036 Beware: after this function returns, C<ptr> and SvPVX(sv) may no longer
5037 refer to the same chunk of data.
5043 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
5045 register STRLEN delta;
5046 if (!ptr || !SvPOKp(sv))
5048 delta = ptr - SvPVX(sv);
5049 SV_CHECK_THINKFIRST(sv);
5050 if (SvTYPE(sv) < SVt_PVIV)
5051 sv_upgrade(sv,SVt_PVIV);
5054 if (!SvLEN(sv)) { /* make copy of shared string */
5055 char *pvx = SvPVX(sv);
5056 STRLEN len = SvCUR(sv);
5057 SvGROW(sv, len + 1);
5058 Move(pvx,SvPVX(sv),len,char);
5062 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
5063 and we do that anyway inside the SvNIOK_off
5065 SvFLAGS(sv) |= SVf_OOK;
5068 SvLEN_set(sv, SvLEN(sv) - delta);
5069 SvCUR_set(sv, SvCUR(sv) - delta);
5070 SvPV_set(sv, SvPVX(sv) + delta);
5071 SvIV_set(sv, SvIVX(sv) + delta);
5074 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
5075 * this function provided for binary compatibility only
5079 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
5081 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
5085 =for apidoc sv_catpvn
5087 Concatenates the string onto the end of the string which is in the SV. The
5088 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5089 status set, then the bytes appended should be valid UTF-8.
5090 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
5092 =for apidoc sv_catpvn_flags
5094 Concatenates the string onto the end of the string which is in the SV. The
5095 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5096 status set, then the bytes appended should be valid UTF-8.
5097 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
5098 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5099 in terms of this function.
5105 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
5110 dstr = SvPV_force_flags(dsv, dlen, flags);
5111 SvGROW(dsv, dlen + slen + 1);
5114 Move(sstr, SvPVX(dsv) + dlen, slen, char);
5115 SvCUR_set(dsv, SvCUR(dsv) + slen);
5117 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
5122 =for apidoc sv_catpvn_mg
5124 Like C<sv_catpvn>, but also handles 'set' magic.
5130 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
5132 sv_catpvn(sv,ptr,len);
5136 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
5137 * this function provided for binary compatibility only
5141 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
5143 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
5147 =for apidoc sv_catsv
5149 Concatenates the string from SV C<ssv> onto the end of the string in
5150 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
5151 not 'set' magic. See C<sv_catsv_mg>.
5153 =for apidoc sv_catsv_flags
5155 Concatenates the string from SV C<ssv> onto the end of the string in
5156 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
5157 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
5158 and C<sv_catsv_nomg> are implemented in terms of this function.
5163 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
5169 if ((spv = SvPV(ssv, slen))) {
5170 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
5171 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
5172 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
5173 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
5174 dsv->sv_flags doesn't have that bit set.
5175 Andy Dougherty 12 Oct 2001
5177 I32 sutf8 = DO_UTF8(ssv);
5180 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
5182 dutf8 = DO_UTF8(dsv);
5184 if (dutf8 != sutf8) {
5186 /* Not modifying source SV, so taking a temporary copy. */
5187 SV* csv = sv_2mortal(newSVpvn(spv, slen));
5189 sv_utf8_upgrade(csv);
5190 spv = SvPV(csv, slen);
5193 sv_utf8_upgrade_nomg(dsv);
5195 sv_catpvn_nomg(dsv, spv, slen);
5200 =for apidoc sv_catsv_mg
5202 Like C<sv_catsv>, but also handles 'set' magic.
5208 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
5215 =for apidoc sv_catpv
5217 Concatenates the string onto the end of the string which is in the SV.
5218 If the SV has the UTF-8 status set, then the bytes appended should be
5219 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
5224 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
5226 register STRLEN len;
5232 junk = SvPV_force(sv, tlen);
5234 SvGROW(sv, tlen + len + 1);
5237 Move(ptr,SvPVX(sv)+tlen,len+1,char);
5238 SvCUR_set(sv, SvCUR(sv) + len);
5239 (void)SvPOK_only_UTF8(sv); /* validate pointer */
5244 =for apidoc sv_catpv_mg
5246 Like C<sv_catpv>, but also handles 'set' magic.
5252 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
5261 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
5262 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
5269 Perl_newSV(pTHX_ STRLEN len)
5275 sv_upgrade(sv, SVt_PV);
5276 SvGROW(sv, len + 1);
5281 =for apidoc sv_magicext
5283 Adds magic to an SV, upgrading it if necessary. Applies the
5284 supplied vtable and returns a pointer to the magic added.
5286 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5287 In particular, you can add magic to SvREADONLY SVs, and add more than
5288 one instance of the same 'how'.
5290 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5291 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5292 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5293 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5295 (This is now used as a subroutine by C<sv_magic>.)
5300 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
5301 const char* name, I32 namlen)
5305 if (SvTYPE(sv) < SVt_PVMG) {
5306 (void)SvUPGRADE(sv, SVt_PVMG);
5308 Newz(702,mg, 1, MAGIC);
5309 mg->mg_moremagic = SvMAGIC(sv);
5310 SvMAGIC_set(sv, mg);
5312 /* Sometimes a magic contains a reference loop, where the sv and
5313 object refer to each other. To prevent a reference loop that
5314 would prevent such objects being freed, we look for such loops
5315 and if we find one we avoid incrementing the object refcount.
5317 Note we cannot do this to avoid self-tie loops as intervening RV must
5318 have its REFCNT incremented to keep it in existence.
5321 if (!obj || obj == sv ||
5322 how == PERL_MAGIC_arylen ||
5323 how == PERL_MAGIC_qr ||
5324 (SvTYPE(obj) == SVt_PVGV &&
5325 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
5326 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
5327 GvFORM(obj) == (CV*)sv)))
5332 mg->mg_obj = SvREFCNT_inc(obj);
5333 mg->mg_flags |= MGf_REFCOUNTED;
5336 /* Normal self-ties simply pass a null object, and instead of
5337 using mg_obj directly, use the SvTIED_obj macro to produce a
5338 new RV as needed. For glob "self-ties", we are tieing the PVIO
5339 with an RV obj pointing to the glob containing the PVIO. In
5340 this case, to avoid a reference loop, we need to weaken the
5344 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5345 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
5351 mg->mg_len = namlen;
5354 mg->mg_ptr = savepvn(name, namlen);
5355 else if (namlen == HEf_SVKEY)
5356 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
5358 mg->mg_ptr = (char *) name;
5360 mg->mg_virtual = vtable;
5364 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5369 =for apidoc sv_magic
5371 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
5372 then adds a new magic item of type C<how> to the head of the magic list.
5374 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5375 handling of the C<name> and C<namlen> arguments.
5377 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5378 to add more than one instance of the same 'how'.
5384 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
5386 const MGVTBL *vtable = 0;
5389 #ifdef PERL_COPY_ON_WRITE
5391 sv_force_normal_flags(sv, 0);
5393 if (SvREADONLY(sv)) {
5395 && how != PERL_MAGIC_regex_global
5396 && how != PERL_MAGIC_bm
5397 && how != PERL_MAGIC_fm
5398 && how != PERL_MAGIC_sv
5399 && how != PERL_MAGIC_backref
5402 Perl_croak(aTHX_ PL_no_modify);
5405 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5406 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5407 /* sv_magic() refuses to add a magic of the same 'how' as an
5410 if (how == PERL_MAGIC_taint)
5418 vtable = &PL_vtbl_sv;
5420 case PERL_MAGIC_overload:
5421 vtable = &PL_vtbl_amagic;
5423 case PERL_MAGIC_overload_elem:
5424 vtable = &PL_vtbl_amagicelem;
5426 case PERL_MAGIC_overload_table:
5427 vtable = &PL_vtbl_ovrld;
5430 vtable = &PL_vtbl_bm;
5432 case PERL_MAGIC_regdata:
5433 vtable = &PL_vtbl_regdata;
5435 case PERL_MAGIC_regdatum:
5436 vtable = &PL_vtbl_regdatum;
5438 case PERL_MAGIC_env:
5439 vtable = &PL_vtbl_env;
5442 vtable = &PL_vtbl_fm;
5444 case PERL_MAGIC_envelem:
5445 vtable = &PL_vtbl_envelem;
5447 case PERL_MAGIC_regex_global:
5448 vtable = &PL_vtbl_mglob;
5450 case PERL_MAGIC_isa:
5451 vtable = &PL_vtbl_isa;
5453 case PERL_MAGIC_isaelem:
5454 vtable = &PL_vtbl_isaelem;
5456 case PERL_MAGIC_nkeys:
5457 vtable = &PL_vtbl_nkeys;
5459 case PERL_MAGIC_dbfile:
5462 case PERL_MAGIC_dbline:
5463 vtable = &PL_vtbl_dbline;
5465 #ifdef USE_LOCALE_COLLATE
5466 case PERL_MAGIC_collxfrm:
5467 vtable = &PL_vtbl_collxfrm;
5469 #endif /* USE_LOCALE_COLLATE */
5470 case PERL_MAGIC_tied:
5471 vtable = &PL_vtbl_pack;
5473 case PERL_MAGIC_tiedelem:
5474 case PERL_MAGIC_tiedscalar:
5475 vtable = &PL_vtbl_packelem;
5478 vtable = &PL_vtbl_regexp;
5480 case PERL_MAGIC_sig:
5481 vtable = &PL_vtbl_sig;
5483 case PERL_MAGIC_sigelem:
5484 vtable = &PL_vtbl_sigelem;
5486 case PERL_MAGIC_taint:
5487 vtable = &PL_vtbl_taint;
5489 case PERL_MAGIC_uvar:
5490 vtable = &PL_vtbl_uvar;
5492 case PERL_MAGIC_vec:
5493 vtable = &PL_vtbl_vec;
5495 case PERL_MAGIC_vstring:
5498 case PERL_MAGIC_utf8:
5499 vtable = &PL_vtbl_utf8;
5501 case PERL_MAGIC_substr:
5502 vtable = &PL_vtbl_substr;
5504 case PERL_MAGIC_defelem:
5505 vtable = &PL_vtbl_defelem;
5507 case PERL_MAGIC_glob:
5508 vtable = &PL_vtbl_glob;
5510 case PERL_MAGIC_arylen:
5511 vtable = &PL_vtbl_arylen;
5513 case PERL_MAGIC_pos:
5514 vtable = &PL_vtbl_pos;
5516 case PERL_MAGIC_backref:
5517 vtable = &PL_vtbl_backref;
5519 case PERL_MAGIC_ext:
5520 /* Reserved for use by extensions not perl internals. */
5521 /* Useful for attaching extension internal data to perl vars. */
5522 /* Note that multiple extensions may clash if magical scalars */
5523 /* etc holding private data from one are passed to another. */
5526 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5529 /* Rest of work is done else where */
5530 mg = sv_magicext(sv,obj,how,(MGVTBL*)vtable,name,namlen);
5533 case PERL_MAGIC_taint:
5536 case PERL_MAGIC_ext:
5537 case PERL_MAGIC_dbfile:
5544 =for apidoc sv_unmagic
5546 Removes all magic of type C<type> from an SV.
5552 Perl_sv_unmagic(pTHX_ SV *sv, int type)
5556 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5559 for (mg = *mgp; mg; mg = *mgp) {
5560 if (mg->mg_type == type) {
5561 const MGVTBL* const vtbl = mg->mg_virtual;
5562 *mgp = mg->mg_moremagic;
5563 if (vtbl && vtbl->svt_free)
5564 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5565 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5567 Safefree(mg->mg_ptr);
5568 else if (mg->mg_len == HEf_SVKEY)
5569 SvREFCNT_dec((SV*)mg->mg_ptr);
5570 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
5571 Safefree(mg->mg_ptr);
5573 if (mg->mg_flags & MGf_REFCOUNTED)
5574 SvREFCNT_dec(mg->mg_obj);
5578 mgp = &mg->mg_moremagic;
5582 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5589 =for apidoc sv_rvweaken
5591 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5592 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5593 push a back-reference to this RV onto the array of backreferences
5594 associated with that magic.
5600 Perl_sv_rvweaken(pTHX_ SV *sv)
5603 if (!SvOK(sv)) /* let undefs pass */
5606 Perl_croak(aTHX_ "Can't weaken a nonreference");
5607 else if (SvWEAKREF(sv)) {
5608 if (ckWARN(WARN_MISC))
5609 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5613 sv_add_backref(tsv, sv);
5619 /* Give tsv backref magic if it hasn't already got it, then push a
5620 * back-reference to sv onto the array associated with the backref magic.
5624 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
5628 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
5629 av = (AV*)mg->mg_obj;
5632 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5633 /* av now has a refcnt of 2, which avoids it getting freed
5634 * before us during global cleanup. The extra ref is removed
5635 * by magic_killbackrefs() when tsv is being freed */
5637 if (AvFILLp(av) >= AvMAX(av)) {
5639 SV **svp = AvARRAY(av);
5640 for (i = AvFILLp(av); i >= 0; i--)
5642 svp[i] = sv; /* reuse the slot */
5645 av_extend(av, AvFILLp(av)+1);
5647 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5650 /* delete a back-reference to ourselves from the backref magic associated
5651 * with the SV we point to.
5655 S_sv_del_backref(pTHX_ SV *sv)
5662 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
5663 Perl_croak(aTHX_ "panic: del_backref");
5664 av = (AV *)mg->mg_obj;
5666 for (i = AvFILLp(av); i >= 0; i--)
5667 if (svp[i] == sv) svp[i] = Nullsv;
5671 =for apidoc sv_insert
5673 Inserts a string at the specified offset/length within the SV. Similar to
5674 the Perl substr() function.
5680 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
5684 register char *midend;
5685 register char *bigend;
5691 Perl_croak(aTHX_ "Can't modify non-existent substring");
5692 SvPV_force(bigstr, curlen);
5693 (void)SvPOK_only_UTF8(bigstr);
5694 if (offset + len > curlen) {
5695 SvGROW(bigstr, offset+len+1);
5696 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5697 SvCUR_set(bigstr, offset+len);
5701 i = littlelen - len;
5702 if (i > 0) { /* string might grow */
5703 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5704 mid = big + offset + len;
5705 midend = bigend = big + SvCUR(bigstr);
5708 while (midend > mid) /* shove everything down */
5709 *--bigend = *--midend;
5710 Move(little,big+offset,littlelen,char);
5711 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5716 Move(little,SvPVX(bigstr)+offset,len,char);
5721 big = SvPVX(bigstr);
5724 bigend = big + SvCUR(bigstr);
5726 if (midend > bigend)
5727 Perl_croak(aTHX_ "panic: sv_insert");
5729 if (mid - big > bigend - midend) { /* faster to shorten from end */
5731 Move(little, mid, littlelen,char);
5734 i = bigend - midend;
5736 Move(midend, mid, i,char);
5740 SvCUR_set(bigstr, mid - big);
5743 else if ((i = mid - big)) { /* faster from front */
5744 midend -= littlelen;
5746 sv_chop(bigstr,midend-i);
5751 Move(little, mid, littlelen,char);
5753 else if (littlelen) {
5754 midend -= littlelen;
5755 sv_chop(bigstr,midend);
5756 Move(little,midend,littlelen,char);
5759 sv_chop(bigstr,midend);
5765 =for apidoc sv_replace
5767 Make the first argument a copy of the second, then delete the original.
5768 The target SV physically takes over ownership of the body of the source SV
5769 and inherits its flags; however, the target keeps any magic it owns,
5770 and any magic in the source is discarded.
5771 Note that this is a rather specialist SV copying operation; most of the
5772 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5778 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5780 U32 refcnt = SvREFCNT(sv);
5781 SV_CHECK_THINKFIRST_COW_DROP(sv);
5782 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
5783 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
5784 if (SvMAGICAL(sv)) {
5788 sv_upgrade(nsv, SVt_PVMG);
5789 SvMAGIC_set(nsv, SvMAGIC(sv));
5790 SvFLAGS(nsv) |= SvMAGICAL(sv);
5792 SvMAGIC_set(sv, NULL);
5796 assert(!SvREFCNT(sv));
5797 #ifdef DEBUG_LEAKING_SCALARS
5798 sv->sv_flags = nsv->sv_flags;
5799 sv->sv_any = nsv->sv_any;
5800 sv->sv_refcnt = nsv->sv_refcnt;
5802 StructCopy(nsv,sv,SV);
5805 #ifdef PERL_COPY_ON_WRITE
5806 if (SvIsCOW_normal(nsv)) {
5807 /* We need to follow the pointers around the loop to make the
5808 previous SV point to sv, rather than nsv. */
5811 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5814 assert(SvPVX(current) == SvPVX(nsv));
5816 /* Make the SV before us point to the SV after us. */
5818 PerlIO_printf(Perl_debug_log, "previous is\n");
5820 PerlIO_printf(Perl_debug_log,
5821 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5822 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5824 SV_COW_NEXT_SV_SET(current, sv);
5827 SvREFCNT(sv) = refcnt;
5828 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5834 =for apidoc sv_clear
5836 Clear an SV: call any destructors, free up any memory used by the body,
5837 and free the body itself. The SV's head is I<not> freed, although
5838 its type is set to all 1's so that it won't inadvertently be assumed
5839 to be live during global destruction etc.
5840 This function should only be called when REFCNT is zero. Most of the time
5841 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5848 Perl_sv_clear(pTHX_ register SV *sv)
5853 assert(SvREFCNT(sv) == 0);
5856 if (PL_defstash) { /* Still have a symbol table? */
5863 stash = SvSTASH(sv);
5864 destructor = StashHANDLER(stash,DESTROY);
5866 SV* tmpref = newRV(sv);
5867 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5869 PUSHSTACKi(PERLSI_DESTROY);
5874 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5880 if(SvREFCNT(tmpref) < 2) {
5881 /* tmpref is not kept alive! */
5883 SvRV_set(tmpref, NULL);
5886 SvREFCNT_dec(tmpref);
5888 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5892 if (PL_in_clean_objs)
5893 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5895 /* DESTROY gave object new lease on life */
5901 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5902 SvOBJECT_off(sv); /* Curse the object. */
5903 if (SvTYPE(sv) != SVt_PVIO)
5904 --PL_sv_objcount; /* XXX Might want something more general */
5907 if (SvTYPE(sv) >= SVt_PVMG) {
5910 if (SvFLAGS(sv) & SVpad_TYPED)
5911 SvREFCNT_dec(SvSTASH(sv));
5914 switch (SvTYPE(sv)) {
5917 IoIFP(sv) != PerlIO_stdin() &&
5918 IoIFP(sv) != PerlIO_stdout() &&
5919 IoIFP(sv) != PerlIO_stderr())
5921 io_close((IO*)sv, FALSE);
5923 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5924 PerlDir_close(IoDIRP(sv));
5925 IoDIRP(sv) = (DIR*)NULL;
5926 Safefree(IoTOP_NAME(sv));
5927 Safefree(IoFMT_NAME(sv));
5928 Safefree(IoBOTTOM_NAME(sv));
5943 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5944 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5945 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5946 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5948 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5949 SvREFCNT_dec(LvTARG(sv));
5953 Safefree(GvNAME(sv));
5954 /* cannot decrease stash refcount yet, as we might recursively delete
5955 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
5956 of stash until current sv is completely gone.
5957 -- JohnPC, 27 Mar 1998 */
5958 stash = GvSTASH(sv);
5964 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5966 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
5967 /* Don't even bother with turning off the OOK flag. */
5976 SvREFCNT_dec(SvRV(sv));
5978 #ifdef PERL_COPY_ON_WRITE
5979 else if (SvPVX(sv)) {
5981 /* I believe I need to grab the global SV mutex here and
5982 then recheck the COW status. */
5984 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5987 sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(sv),
5988 SvUVX(sv), SV_COW_NEXT_SV(sv));
5989 /* And drop it here. */
5991 } else if (SvLEN(sv)) {
5992 Safefree(SvPVX(sv));
5996 else if (SvPVX(sv) && SvLEN(sv))
5997 Safefree(SvPVX(sv));
5998 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5999 unsharepvn(SvPVX(sv),
6000 SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
6014 switch (SvTYPE(sv)) {
6030 del_XPVIV(SvANY(sv));
6033 del_XPVNV(SvANY(sv));
6036 del_XPVMG(SvANY(sv));
6039 del_XPVLV(SvANY(sv));
6042 del_XPVAV(SvANY(sv));
6045 del_XPVHV(SvANY(sv));
6048 del_XPVCV(SvANY(sv));
6051 del_XPVGV(SvANY(sv));
6052 /* code duplication for increased performance. */
6053 SvFLAGS(sv) &= SVf_BREAK;
6054 SvFLAGS(sv) |= SVTYPEMASK;
6055 /* decrease refcount of the stash that owns this GV, if any */
6057 SvREFCNT_dec(stash);
6058 return; /* not break, SvFLAGS reset already happened */
6060 del_XPVBM(SvANY(sv));
6063 del_XPVFM(SvANY(sv));
6066 del_XPVIO(SvANY(sv));
6069 SvFLAGS(sv) &= SVf_BREAK;
6070 SvFLAGS(sv) |= SVTYPEMASK;
6074 =for apidoc sv_newref
6076 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
6083 Perl_sv_newref(pTHX_ SV *sv)
6093 Decrement an SV's reference count, and if it drops to zero, call
6094 C<sv_clear> to invoke destructors and free up any memory used by
6095 the body; finally, deallocate the SV's head itself.
6096 Normally called via a wrapper macro C<SvREFCNT_dec>.
6102 Perl_sv_free(pTHX_ SV *sv)
6107 if (SvREFCNT(sv) == 0) {
6108 if (SvFLAGS(sv) & SVf_BREAK)
6109 /* this SV's refcnt has been artificially decremented to
6110 * trigger cleanup */
6112 if (PL_in_clean_all) /* All is fair */
6114 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6115 /* make sure SvREFCNT(sv)==0 happens very seldom */
6116 SvREFCNT(sv) = (~(U32)0)/2;
6119 if (ckWARN_d(WARN_INTERNAL))
6120 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6121 "Attempt to free unreferenced scalar: SV 0x%"UVxf
6122 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6125 if (--(SvREFCNT(sv)) > 0)
6127 Perl_sv_free2(aTHX_ sv);
6131 Perl_sv_free2(pTHX_ SV *sv)
6136 if (ckWARN_d(WARN_DEBUGGING))
6137 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
6138 "Attempt to free temp prematurely: SV 0x%"UVxf
6139 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6143 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6144 /* make sure SvREFCNT(sv)==0 happens very seldom */
6145 SvREFCNT(sv) = (~(U32)0)/2;
6156 Returns the length of the string in the SV. Handles magic and type
6157 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
6163 Perl_sv_len(pTHX_ register SV *sv)
6171 len = mg_length(sv);
6173 (void)SvPV(sv, len);
6178 =for apidoc sv_len_utf8
6180 Returns the number of characters in the string in an SV, counting wide
6181 UTF-8 bytes as a single character. Handles magic and type coercion.
6187 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
6188 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
6189 * (Note that the mg_len is not the length of the mg_ptr field.)
6194 Perl_sv_len_utf8(pTHX_ register SV *sv)
6200 return mg_length(sv);
6204 U8 *s = (U8*)SvPV(sv, len);
6205 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
6207 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
6209 #ifdef PERL_UTF8_CACHE_ASSERT
6210 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
6214 ulen = Perl_utf8_length(aTHX_ s, s + len);
6215 if (!mg && !SvREADONLY(sv)) {
6216 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6217 mg = mg_find(sv, PERL_MAGIC_utf8);
6227 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
6228 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
6229 * between UTF-8 and byte offsets. There are two (substr offset and substr
6230 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
6231 * and byte offset) cache positions.
6233 * The mg_len field is used by sv_len_utf8(), see its comments.
6234 * Note that the mg_len is not the length of the mg_ptr field.
6238 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, U8 *s, U8 *start)
6242 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6244 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
6248 *cachep = (STRLEN *) (*mgp)->mg_ptr;
6250 Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6251 (*mgp)->mg_ptr = (char *) *cachep;
6255 (*cachep)[i] = *offsetp;
6256 (*cachep)[i+1] = s - start;
6264 * S_utf8_mg_pos() is used to query and update mg_ptr field of
6265 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
6266 * between UTF-8 and byte offsets. See also the comments of
6267 * S_utf8_mg_pos_init().
6271 S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, U8 **sp, U8 *start, U8 *send)
6275 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6277 *mgp = mg_find(sv, PERL_MAGIC_utf8);
6278 if (*mgp && (*mgp)->mg_ptr) {
6279 *cachep = (STRLEN *) (*mgp)->mg_ptr;
6280 ASSERT_UTF8_CACHE(*cachep);
6281 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
6283 else { /* We will skip to the right spot. */
6288 /* The assumption is that going backward is half
6289 * the speed of going forward (that's where the
6290 * 2 * backw in the below comes from). (The real
6291 * figure of course depends on the UTF-8 data.) */
6293 if ((*cachep)[i] > (STRLEN)uoff) {
6295 backw = (*cachep)[i] - (STRLEN)uoff;
6297 if (forw < 2 * backw)
6300 p = start + (*cachep)[i+1];
6302 /* Try this only for the substr offset (i == 0),
6303 * not for the substr length (i == 2). */
6304 else if (i == 0) { /* (*cachep)[i] < uoff */
6305 STRLEN ulen = sv_len_utf8(sv);
6307 if ((STRLEN)uoff < ulen) {
6308 forw = (STRLEN)uoff - (*cachep)[i];
6309 backw = ulen - (STRLEN)uoff;
6311 if (forw < 2 * backw)
6312 p = start + (*cachep)[i+1];
6317 /* If the string is not long enough for uoff,
6318 * we could extend it, but not at this low a level. */
6322 if (forw < 2 * backw) {
6329 while (UTF8_IS_CONTINUATION(*p))
6334 /* Update the cache. */
6335 (*cachep)[i] = (STRLEN)uoff;
6336 (*cachep)[i+1] = p - start;
6338 /* Drop the stale "length" cache */
6347 if (found) { /* Setup the return values. */
6348 *offsetp = (*cachep)[i+1];
6349 *sp = start + *offsetp;
6352 *offsetp = send - start;
6354 else if (*sp < start) {
6360 #ifdef PERL_UTF8_CACHE_ASSERT
6365 while (n-- && s < send)
6369 assert(*offsetp == s - start);
6370 assert((*cachep)[0] == (STRLEN)uoff);
6371 assert((*cachep)[1] == *offsetp);
6373 ASSERT_UTF8_CACHE(*cachep);
6382 =for apidoc sv_pos_u2b
6384 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6385 the start of the string, to a count of the equivalent number of bytes; if
6386 lenp is non-zero, it does the same to lenp, but this time starting from
6387 the offset, rather than from the start of the string. Handles magic and
6394 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6395 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6396 * byte offsets. See also the comments of S_utf8_mg_pos().
6401 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
6412 start = s = (U8*)SvPV(sv, len);
6414 I32 uoffset = *offsetp;
6419 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
6421 if (!found && uoffset > 0) {
6422 while (s < send && uoffset--)
6426 if (utf8_mg_pos_init(sv, &mg, &cache, 0, offsetp, s, start))
6428 *offsetp = s - start;
6433 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) {
6437 if (!found && *lenp > 0) {
6440 while (s < send && ulen--)
6444 utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start);
6448 ASSERT_UTF8_CACHE(cache);
6460 =for apidoc sv_pos_b2u
6462 Converts the value pointed to by offsetp from a count of bytes from the
6463 start of the string, to a count of the equivalent number of UTF-8 chars.
6464 Handles magic and type coercion.
6470 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6471 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6472 * byte offsets. See also the comments of S_utf8_mg_pos().
6477 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
6485 s = (U8*)SvPV(sv, len);
6486 if ((I32)len < *offsetp)
6487 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6489 U8* send = s + *offsetp;
6491 STRLEN *cache = NULL;
6495 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6496 mg = mg_find(sv, PERL_MAGIC_utf8);
6497 if (mg && mg->mg_ptr) {
6498 cache = (STRLEN *) mg->mg_ptr;
6499 if (cache[1] == (STRLEN)*offsetp) {
6500 /* An exact match. */
6501 *offsetp = cache[0];
6505 else if (cache[1] < (STRLEN)*offsetp) {
6506 /* We already know part of the way. */
6509 /* Let the below loop do the rest. */
6511 else { /* cache[1] > *offsetp */
6512 /* We already know all of the way, now we may
6513 * be able to walk back. The same assumption
6514 * is made as in S_utf8_mg_pos(), namely that
6515 * walking backward is twice slower than
6516 * walking forward. */
6517 STRLEN forw = *offsetp;
6518 STRLEN backw = cache[1] - *offsetp;
6520 if (!(forw < 2 * backw)) {
6521 U8 *p = s + cache[1];
6528 while (UTF8_IS_CONTINUATION(*p)) {
6536 *offsetp = cache[0];
6538 /* Drop the stale "length" cache */
6546 ASSERT_UTF8_CACHE(cache);
6552 /* Call utf8n_to_uvchr() to validate the sequence
6553 * (unless a simple non-UTF character) */
6554 if (!UTF8_IS_INVARIANT(*s))
6555 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
6564 if (!SvREADONLY(sv)) {
6566 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6567 mg = mg_find(sv, PERL_MAGIC_utf8);
6572 Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6573 mg->mg_ptr = (char *) cache;
6578 cache[1] = *offsetp;
6579 /* Drop the stale "length" cache */
6592 Returns a boolean indicating whether the strings in the two SVs are
6593 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6594 coerce its args to strings if necessary.
6600 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6608 SV* svrecode = Nullsv;
6615 pv1 = SvPV(sv1, cur1);
6622 pv2 = SvPV(sv2, cur2);
6624 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6625 /* Differing utf8ness.
6626 * Do not UTF8size the comparands as a side-effect. */
6629 svrecode = newSVpvn(pv2, cur2);
6630 sv_recode_to_utf8(svrecode, PL_encoding);
6631 pv2 = SvPV(svrecode, cur2);
6634 svrecode = newSVpvn(pv1, cur1);
6635 sv_recode_to_utf8(svrecode, PL_encoding);
6636 pv1 = SvPV(svrecode, cur1);
6638 /* Now both are in UTF-8. */
6640 SvREFCNT_dec(svrecode);
6645 bool is_utf8 = TRUE;
6648 /* sv1 is the UTF-8 one,
6649 * if is equal it must be downgrade-able */
6650 char *pv = (char*)bytes_from_utf8((const U8*)pv1,
6656 /* sv2 is the UTF-8 one,
6657 * if is equal it must be downgrade-able */
6658 char *pv = (char *)bytes_from_utf8((const U8*)pv2,
6664 /* Downgrade not possible - cannot be eq */
6672 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6675 SvREFCNT_dec(svrecode);
6686 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6687 string in C<sv1> is less than, equal to, or greater than the string in
6688 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6689 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6695 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6698 const char *pv1, *pv2;
6701 SV *svrecode = Nullsv;
6708 pv1 = SvPV(sv1, cur1);
6715 pv2 = SvPV(sv2, cur2);
6717 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6718 /* Differing utf8ness.
6719 * Do not UTF8size the comparands as a side-effect. */
6722 svrecode = newSVpvn(pv2, cur2);
6723 sv_recode_to_utf8(svrecode, PL_encoding);
6724 pv2 = SvPV(svrecode, cur2);
6727 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6732 svrecode = newSVpvn(pv1, cur1);
6733 sv_recode_to_utf8(svrecode, PL_encoding);
6734 pv1 = SvPV(svrecode, cur1);
6737 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6743 cmp = cur2 ? -1 : 0;
6747 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6750 cmp = retval < 0 ? -1 : 1;
6751 } else if (cur1 == cur2) {
6754 cmp = cur1 < cur2 ? -1 : 1;
6759 SvREFCNT_dec(svrecode);
6768 =for apidoc sv_cmp_locale
6770 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6771 'use bytes' aware, handles get magic, and will coerce its args to strings
6772 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6778 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6780 #ifdef USE_LOCALE_COLLATE
6786 if (PL_collation_standard)
6790 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6792 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6794 if (!pv1 || !len1) {
6805 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6808 return retval < 0 ? -1 : 1;
6811 * When the result of collation is equality, that doesn't mean
6812 * that there are no differences -- some locales exclude some
6813 * characters from consideration. So to avoid false equalities,
6814 * we use the raw string as a tiebreaker.
6820 #endif /* USE_LOCALE_COLLATE */
6822 return sv_cmp(sv1, sv2);
6826 #ifdef USE_LOCALE_COLLATE
6829 =for apidoc sv_collxfrm
6831 Add Collate Transform magic to an SV if it doesn't already have it.
6833 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6834 scalar data of the variable, but transformed to such a format that a normal
6835 memory comparison can be used to compare the data according to the locale
6842 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6846 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6847 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6852 Safefree(mg->mg_ptr);
6854 if ((xf = mem_collxfrm(s, len, &xlen))) {
6855 if (SvREADONLY(sv)) {
6858 return xf + sizeof(PL_collation_ix);
6861 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6862 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6875 if (mg && mg->mg_ptr) {
6877 return mg->mg_ptr + sizeof(PL_collation_ix);
6885 #endif /* USE_LOCALE_COLLATE */
6890 Get a line from the filehandle and store it into the SV, optionally
6891 appending to the currently-stored string.
6897 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6901 register STDCHAR rslast;
6902 register STDCHAR *bp;
6908 if (SvTHINKFIRST(sv))
6909 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6910 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6912 However, perlbench says it's slower, because the existing swipe code
6913 is faster than copy on write.
6914 Swings and roundabouts. */
6915 (void)SvUPGRADE(sv, SVt_PV);
6920 if (PerlIO_isutf8(fp)) {
6922 sv_utf8_upgrade_nomg(sv);
6923 sv_pos_u2b(sv,&append,0);
6925 } else if (SvUTF8(sv)) {
6926 SV *tsv = NEWSV(0,0);
6927 sv_gets(tsv, fp, 0);
6928 sv_utf8_upgrade_nomg(tsv);
6929 SvCUR_set(sv,append);
6932 goto return_string_or_null;
6937 if (PerlIO_isutf8(fp))
6940 if (IN_PERL_COMPILETIME) {
6941 /* we always read code in line mode */
6945 else if (RsSNARF(PL_rs)) {
6946 /* If it is a regular disk file use size from stat() as estimate
6947 of amount we are going to read - may result in malloc-ing
6948 more memory than we realy need if layers bellow reduce
6949 size we read (e.g. CRLF or a gzip layer)
6952 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6953 Off_t offset = PerlIO_tell(fp);
6954 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6955 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6961 else if (RsRECORD(PL_rs)) {
6965 /* Grab the size of the record we're getting */
6966 recsize = SvIV(SvRV(PL_rs));
6967 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6970 /* VMS wants read instead of fread, because fread doesn't respect */
6971 /* RMS record boundaries. This is not necessarily a good thing to be */
6972 /* doing, but we've got no other real choice - except avoid stdio
6973 as implementation - perhaps write a :vms layer ?
6975 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6977 bytesread = PerlIO_read(fp, buffer, recsize);
6981 SvCUR_set(sv, bytesread += append);
6982 buffer[bytesread] = '\0';
6983 goto return_string_or_null;
6985 else if (RsPARA(PL_rs)) {
6991 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6992 if (PerlIO_isutf8(fp)) {
6993 rsptr = SvPVutf8(PL_rs, rslen);
6996 if (SvUTF8(PL_rs)) {
6997 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6998 Perl_croak(aTHX_ "Wide character in $/");
7001 rsptr = SvPV(PL_rs, rslen);
7005 rslast = rslen ? rsptr[rslen - 1] : '\0';
7007 if (rspara) { /* have to do this both before and after */
7008 do { /* to make sure file boundaries work right */
7011 i = PerlIO_getc(fp);
7015 PerlIO_ungetc(fp,i);
7021 /* See if we know enough about I/O mechanism to cheat it ! */
7023 /* This used to be #ifdef test - it is made run-time test for ease
7024 of abstracting out stdio interface. One call should be cheap
7025 enough here - and may even be a macro allowing compile
7029 if (PerlIO_fast_gets(fp)) {
7032 * We're going to steal some values from the stdio struct
7033 * and put EVERYTHING in the innermost loop into registers.
7035 register STDCHAR *ptr;
7039 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7040 /* An ungetc()d char is handled separately from the regular
7041 * buffer, so we getc() it back out and stuff it in the buffer.
7043 i = PerlIO_getc(fp);
7044 if (i == EOF) return 0;
7045 *(--((*fp)->_ptr)) = (unsigned char) i;
7049 /* Here is some breathtakingly efficient cheating */
7051 cnt = PerlIO_get_cnt(fp); /* get count into register */
7052 /* make sure we have the room */
7053 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7054 /* Not room for all of it
7055 if we are looking for a separator and room for some
7057 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7058 /* just process what we have room for */
7059 shortbuffered = cnt - SvLEN(sv) + append + 1;
7060 cnt -= shortbuffered;
7064 /* remember that cnt can be negative */
7065 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7070 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
7071 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7072 DEBUG_P(PerlIO_printf(Perl_debug_log,
7073 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7074 DEBUG_P(PerlIO_printf(Perl_debug_log,
7075 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7076 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7077 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7082 while (cnt > 0) { /* this | eat */
7084 if ((*bp++ = *ptr++) == rslast) /* really | dust */
7085 goto thats_all_folks; /* screams | sed :-) */
7089 Copy(ptr, bp, cnt, char); /* this | eat */
7090 bp += cnt; /* screams | dust */
7091 ptr += cnt; /* louder | sed :-) */
7096 if (shortbuffered) { /* oh well, must extend */
7097 cnt = shortbuffered;
7099 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
7101 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7102 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
7106 DEBUG_P(PerlIO_printf(Perl_debug_log,
7107 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7108 PTR2UV(ptr),(long)cnt));
7109 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7111 DEBUG_P(PerlIO_printf(Perl_debug_log,
7112 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7113 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7114 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7116 /* This used to call 'filbuf' in stdio form, but as that behaves like
7117 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7118 another abstraction. */
7119 i = PerlIO_getc(fp); /* get more characters */
7121 DEBUG_P(PerlIO_printf(Perl_debug_log,
7122 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7123 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7124 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7126 cnt = PerlIO_get_cnt(fp);
7127 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
7128 DEBUG_P(PerlIO_printf(Perl_debug_log,
7129 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7131 if (i == EOF) /* all done for ever? */
7132 goto thats_really_all_folks;
7134 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
7136 SvGROW(sv, bpx + cnt + 2);
7137 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
7139 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
7141 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
7142 goto thats_all_folks;
7146 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) ||
7147 memNE((char*)bp - rslen, rsptr, rslen))
7148 goto screamer; /* go back to the fray */
7149 thats_really_all_folks:
7151 cnt += shortbuffered;
7152 DEBUG_P(PerlIO_printf(Perl_debug_log,
7153 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7154 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
7155 DEBUG_P(PerlIO_printf(Perl_debug_log,
7156 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7157 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7158 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7160 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
7161 DEBUG_P(PerlIO_printf(Perl_debug_log,
7162 "Screamer: done, len=%ld, string=|%.*s|\n",
7163 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
7167 /*The big, slow, and stupid way. */
7168 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
7170 New(0, buf, 8192, STDCHAR);
7178 const register STDCHAR *bpe = buf + sizeof(buf);
7180 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7181 ; /* keep reading */
7185 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7186 /* Accomodate broken VAXC compiler, which applies U8 cast to
7187 * both args of ?: operator, causing EOF to change into 255
7190 i = (U8)buf[cnt - 1];
7196 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
7198 sv_catpvn(sv, (char *) buf, cnt);
7200 sv_setpvn(sv, (char *) buf, cnt);
7202 if (i != EOF && /* joy */
7204 SvCUR(sv) < rslen ||
7205 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7209 * If we're reading from a TTY and we get a short read,
7210 * indicating that the user hit his EOF character, we need
7211 * to notice it now, because if we try to read from the TTY
7212 * again, the EOF condition will disappear.
7214 * The comparison of cnt to sizeof(buf) is an optimization
7215 * that prevents unnecessary calls to feof().
7219 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
7223 #ifdef USE_HEAP_INSTEAD_OF_STACK
7228 if (rspara) { /* have to do this both before and after */
7229 while (i != EOF) { /* to make sure file boundaries work right */
7230 i = PerlIO_getc(fp);
7232 PerlIO_ungetc(fp,i);
7238 return_string_or_null:
7239 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
7245 Auto-increment of the value in the SV, doing string to numeric conversion
7246 if necessary. Handles 'get' magic.
7252 Perl_sv_inc(pTHX_ register SV *sv)
7261 if (SvTHINKFIRST(sv)) {
7263 sv_force_normal_flags(sv, 0);
7264 if (SvREADONLY(sv)) {
7265 if (IN_PERL_RUNTIME)
7266 Perl_croak(aTHX_ PL_no_modify);
7270 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7272 i = PTR2IV(SvRV(sv));
7277 flags = SvFLAGS(sv);
7278 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7279 /* It's (privately or publicly) a float, but not tested as an
7280 integer, so test it to see. */
7282 flags = SvFLAGS(sv);
7284 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7285 /* It's publicly an integer, or privately an integer-not-float */
7286 #ifdef PERL_PRESERVE_IVUV
7290 if (SvUVX(sv) == UV_MAX)
7291 sv_setnv(sv, UV_MAX_P1);
7293 (void)SvIOK_only_UV(sv);
7294 SvUV_set(sv, SvUVX(sv) + 1);
7296 if (SvIVX(sv) == IV_MAX)
7297 sv_setuv(sv, (UV)IV_MAX + 1);
7299 (void)SvIOK_only(sv);
7300 SvIV_set(sv, SvIVX(sv) + 1);
7305 if (flags & SVp_NOK) {
7306 (void)SvNOK_only(sv);
7307 SvNV_set(sv, SvNVX(sv) + 1.0);
7311 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
7312 if ((flags & SVTYPEMASK) < SVt_PVIV)
7313 sv_upgrade(sv, SVt_IV);
7314 (void)SvIOK_only(sv);
7319 while (isALPHA(*d)) d++;
7320 while (isDIGIT(*d)) d++;
7322 #ifdef PERL_PRESERVE_IVUV
7323 /* Got to punt this as an integer if needs be, but we don't issue
7324 warnings. Probably ought to make the sv_iv_please() that does
7325 the conversion if possible, and silently. */
7326 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
7327 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7328 /* Need to try really hard to see if it's an integer.
7329 9.22337203685478e+18 is an integer.
7330 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7331 so $a="9.22337203685478e+18"; $a+0; $a++
7332 needs to be the same as $a="9.22337203685478e+18"; $a++
7339 /* sv_2iv *should* have made this an NV */
7340 if (flags & SVp_NOK) {
7341 (void)SvNOK_only(sv);
7342 SvNV_set(sv, SvNVX(sv) + 1.0);
7345 /* I don't think we can get here. Maybe I should assert this
7346 And if we do get here I suspect that sv_setnv will croak. NWC
7348 #if defined(USE_LONG_DOUBLE)
7349 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",
7350 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7352 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7353 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7356 #endif /* PERL_PRESERVE_IVUV */
7357 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
7361 while (d >= SvPVX(sv)) {
7369 /* MKS: The original code here died if letters weren't consecutive.
7370 * at least it didn't have to worry about non-C locales. The
7371 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7372 * arranged in order (although not consecutively) and that only
7373 * [A-Za-z] are accepted by isALPHA in the C locale.
7375 if (*d != 'z' && *d != 'Z') {
7376 do { ++*d; } while (!isALPHA(*d));
7379 *(d--) -= 'z' - 'a';
7384 *(d--) -= 'z' - 'a' + 1;
7388 /* oh,oh, the number grew */
7389 SvGROW(sv, SvCUR(sv) + 2);
7390 SvCUR_set(sv, SvCUR(sv) + 1);
7391 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
7402 Auto-decrement of the value in the SV, doing string to numeric conversion
7403 if necessary. Handles 'get' magic.
7409 Perl_sv_dec(pTHX_ register SV *sv)
7417 if (SvTHINKFIRST(sv)) {
7419 sv_force_normal_flags(sv, 0);
7420 if (SvREADONLY(sv)) {
7421 if (IN_PERL_RUNTIME)
7422 Perl_croak(aTHX_ PL_no_modify);
7426 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7428 i = PTR2IV(SvRV(sv));
7433 /* Unlike sv_inc we don't have to worry about string-never-numbers
7434 and keeping them magic. But we mustn't warn on punting */
7435 flags = SvFLAGS(sv);
7436 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7437 /* It's publicly an integer, or privately an integer-not-float */
7438 #ifdef PERL_PRESERVE_IVUV
7442 if (SvUVX(sv) == 0) {
7443 (void)SvIOK_only(sv);
7447 (void)SvIOK_only_UV(sv);
7448 SvUV_set(sv, SvUVX(sv) + 1);
7451 if (SvIVX(sv) == IV_MIN)
7452 sv_setnv(sv, (NV)IV_MIN - 1.0);
7454 (void)SvIOK_only(sv);
7455 SvIV_set(sv, SvIVX(sv) - 1);
7460 if (flags & SVp_NOK) {
7461 SvNV_set(sv, SvNVX(sv) - 1.0);
7462 (void)SvNOK_only(sv);
7465 if (!(flags & SVp_POK)) {
7466 if ((flags & SVTYPEMASK) < SVt_PVNV)
7467 sv_upgrade(sv, SVt_NV);
7469 (void)SvNOK_only(sv);
7472 #ifdef PERL_PRESERVE_IVUV
7474 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
7475 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7476 /* Need to try really hard to see if it's an integer.
7477 9.22337203685478e+18 is an integer.
7478 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7479 so $a="9.22337203685478e+18"; $a+0; $a--
7480 needs to be the same as $a="9.22337203685478e+18"; $a--
7487 /* sv_2iv *should* have made this an NV */
7488 if (flags & SVp_NOK) {
7489 (void)SvNOK_only(sv);
7490 SvNV_set(sv, SvNVX(sv) - 1.0);
7493 /* I don't think we can get here. Maybe I should assert this
7494 And if we do get here I suspect that sv_setnv will croak. NWC
7496 #if defined(USE_LONG_DOUBLE)
7497 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",
7498 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7500 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7501 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7505 #endif /* PERL_PRESERVE_IVUV */
7506 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
7510 =for apidoc sv_mortalcopy
7512 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7513 The new SV is marked as mortal. It will be destroyed "soon", either by an
7514 explicit call to FREETMPS, or by an implicit call at places such as
7515 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7520 /* Make a string that will exist for the duration of the expression
7521 * evaluation. Actually, it may have to last longer than that, but
7522 * hopefully we won't free it until it has been assigned to a
7523 * permanent location. */
7526 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
7531 sv_setsv(sv,oldstr);
7533 PL_tmps_stack[++PL_tmps_ix] = sv;
7539 =for apidoc sv_newmortal
7541 Creates a new null SV which is mortal. The reference count of the SV is
7542 set to 1. It will be destroyed "soon", either by an explicit call to
7543 FREETMPS, or by an implicit call at places such as statement boundaries.
7544 See also C<sv_mortalcopy> and C<sv_2mortal>.
7550 Perl_sv_newmortal(pTHX)
7555 SvFLAGS(sv) = SVs_TEMP;
7557 PL_tmps_stack[++PL_tmps_ix] = sv;
7562 =for apidoc sv_2mortal
7564 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7565 by an explicit call to FREETMPS, or by an implicit call at places such as
7566 statement boundaries. SvTEMP() is turned on which means that the SV's
7567 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7568 and C<sv_mortalcopy>.
7574 Perl_sv_2mortal(pTHX_ register SV *sv)
7579 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7582 PL_tmps_stack[++PL_tmps_ix] = sv;
7590 Creates a new SV and copies a string into it. The reference count for the
7591 SV is set to 1. If C<len> is zero, Perl will compute the length using
7592 strlen(). For efficiency, consider using C<newSVpvn> instead.
7598 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
7605 sv_setpvn(sv,s,len);
7610 =for apidoc newSVpvn
7612 Creates a new SV and copies a string into it. The reference count for the
7613 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7614 string. You are responsible for ensuring that the source string is at least
7615 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7621 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7626 sv_setpvn(sv,s,len);
7631 =for apidoc newSVpvn_share
7633 Creates a new SV with its SvPVX pointing to a shared string in the string
7634 table. If the string does not already exist in the table, it is created
7635 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
7636 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
7637 otherwise the hash is computed. The idea here is that as the string table
7638 is used for shared hash keys these strings will have SvPVX == HeKEY and
7639 hash lookup will avoid string compare.
7645 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7648 bool is_utf8 = FALSE;
7650 STRLEN tmplen = -len;
7652 /* See the note in hv.c:hv_fetch() --jhi */
7653 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7657 PERL_HASH(hash, src, len);
7659 sv_upgrade(sv, SVt_PVIV);
7660 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7673 #if defined(PERL_IMPLICIT_CONTEXT)
7675 /* pTHX_ magic can't cope with varargs, so this is a no-context
7676 * version of the main function, (which may itself be aliased to us).
7677 * Don't access this version directly.
7681 Perl_newSVpvf_nocontext(const char* pat, ...)
7686 va_start(args, pat);
7687 sv = vnewSVpvf(pat, &args);
7694 =for apidoc newSVpvf
7696 Creates a new SV and initializes it with the string formatted like
7703 Perl_newSVpvf(pTHX_ const char* pat, ...)
7707 va_start(args, pat);
7708 sv = vnewSVpvf(pat, &args);
7713 /* backend for newSVpvf() and newSVpvf_nocontext() */
7716 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7720 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7727 Creates a new SV and copies a floating point value into it.
7728 The reference count for the SV is set to 1.
7734 Perl_newSVnv(pTHX_ NV n)
7746 Creates a new SV and copies an integer into it. The reference count for the
7753 Perl_newSViv(pTHX_ IV i)
7765 Creates a new SV and copies an unsigned integer into it.
7766 The reference count for the SV is set to 1.
7772 Perl_newSVuv(pTHX_ UV u)
7782 =for apidoc newRV_noinc
7784 Creates an RV wrapper for an SV. The reference count for the original
7785 SV is B<not> incremented.
7791 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7796 sv_upgrade(sv, SVt_RV);
7798 SvRV_set(sv, tmpRef);
7803 /* newRV_inc is the official function name to use now.
7804 * newRV_inc is in fact #defined to newRV in sv.h
7808 Perl_newRV(pTHX_ SV *tmpRef)
7810 return newRV_noinc(SvREFCNT_inc(tmpRef));
7816 Creates a new SV which is an exact duplicate of the original SV.
7823 Perl_newSVsv(pTHX_ register SV *old)
7829 if (SvTYPE(old) == SVTYPEMASK) {
7830 if (ckWARN_d(WARN_INTERNAL))
7831 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7835 /* SV_GMAGIC is the default for sv_setv()
7836 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7837 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7838 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7843 =for apidoc sv_reset
7845 Underlying implementation for the C<reset> Perl function.
7846 Note that the perl-level function is vaguely deprecated.
7852 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
7861 char todo[PERL_UCHAR_MAX+1];
7866 if (!*s) { /* reset ?? searches */
7867 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
7868 pm->op_pmdynflags &= ~PMdf_USED;
7873 /* reset variables */
7875 if (!HvARRAY(stash))
7878 Zero(todo, 256, char);
7880 i = (unsigned char)*s;
7884 max = (unsigned char)*s++;
7885 for ( ; i <= max; i++) {
7888 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7889 for (entry = HvARRAY(stash)[i];
7891 entry = HeNEXT(entry))
7893 if (!todo[(U8)*HeKEY(entry)])
7895 gv = (GV*)HeVAL(entry);
7897 if (SvTHINKFIRST(sv)) {
7898 if (!SvREADONLY(sv) && SvROK(sv))
7903 if (SvTYPE(sv) >= SVt_PV) {
7905 if (SvPVX(sv) != Nullch)
7912 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
7915 #ifdef USE_ENVIRON_ARRAY
7917 # ifdef USE_ITHREADS
7918 && PL_curinterp == aTHX
7922 environ[0] = Nullch;
7925 #endif /* !PERL_MICRO */
7935 Using various gambits, try to get an IO from an SV: the IO slot if its a
7936 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7937 named after the PV if we're a string.
7943 Perl_sv_2io(pTHX_ SV *sv)
7948 switch (SvTYPE(sv)) {
7956 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7960 Perl_croak(aTHX_ PL_no_usym, "filehandle");
7962 return sv_2io(SvRV(sv));
7963 gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
7969 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
7978 Using various gambits, try to get a CV from an SV; in addition, try if
7979 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7985 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7992 return *gvp = Nullgv, Nullcv;
7993 switch (SvTYPE(sv)) {
8012 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
8013 tryAMAGICunDEREF(to_cv);
8016 if (SvTYPE(sv) == SVt_PVCV) {
8025 Perl_croak(aTHX_ "Not a subroutine reference");
8030 gv = gv_fetchsv(sv, lref, SVt_PVCV);
8036 if (lref && !GvCVu(gv)) {
8039 tmpsv = NEWSV(704,0);
8040 gv_efullname3(tmpsv, gv, Nullch);
8041 /* XXX this is probably not what they think they're getting.
8042 * It has the same effect as "sub name;", i.e. just a forward
8044 newSUB(start_subparse(FALSE, 0),
8045 newSVOP(OP_CONST, 0, tmpsv),
8050 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8060 Returns true if the SV has a true value by Perl's rules.
8061 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8062 instead use an in-line version.
8068 Perl_sv_true(pTHX_ register SV *sv)
8073 const register XPV* tXpv;
8074 if ((tXpv = (XPV*)SvANY(sv)) &&
8075 (tXpv->xpv_cur > 1 ||
8076 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
8083 return SvIVX(sv) != 0;
8086 return SvNVX(sv) != 0.0;
8088 return sv_2bool(sv);
8096 A private implementation of the C<SvIVx> macro for compilers which can't
8097 cope with complex macro expressions. Always use the macro instead.
8103 Perl_sv_iv(pTHX_ register SV *sv)
8107 return (IV)SvUVX(sv);
8116 A private implementation of the C<SvUVx> macro for compilers which can't
8117 cope with complex macro expressions. Always use the macro instead.
8123 Perl_sv_uv(pTHX_ register SV *sv)
8128 return (UV)SvIVX(sv);
8136 A private implementation of the C<SvNVx> macro for compilers which can't
8137 cope with complex macro expressions. Always use the macro instead.
8143 Perl_sv_nv(pTHX_ register SV *sv)
8150 /* sv_pv() is now a macro using SvPV_nolen();
8151 * this function provided for binary compatibility only
8155 Perl_sv_pv(pTHX_ SV *sv)
8162 return sv_2pv(sv, &n_a);
8168 Use the C<SvPV_nolen> macro instead
8172 A private implementation of the C<SvPV> macro for compilers which can't
8173 cope with complex macro expressions. Always use the macro instead.
8179 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
8185 return sv_2pv(sv, lp);
8190 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
8196 return sv_2pv_flags(sv, lp, 0);
8199 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
8200 * this function provided for binary compatibility only
8204 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
8206 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
8210 =for apidoc sv_pvn_force
8212 Get a sensible string out of the SV somehow.
8213 A private implementation of the C<SvPV_force> macro for compilers which
8214 can't cope with complex macro expressions. Always use the macro instead.
8216 =for apidoc sv_pvn_force_flags
8218 Get a sensible string out of the SV somehow.
8219 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8220 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8221 implemented in terms of this function.
8222 You normally want to use the various wrapper macros instead: see
8223 C<SvPV_force> and C<SvPV_force_nomg>
8229 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
8233 if (SvTHINKFIRST(sv) && !SvROK(sv))
8234 sv_force_normal_flags(sv, 0);
8240 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
8241 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8245 s = sv_2pv_flags(sv, lp, flags);
8246 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
8251 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
8252 SvGROW(sv, len + 1);
8253 Move(s,SvPVX(sv),len,char);
8258 SvPOK_on(sv); /* validate pointer */
8260 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8261 PTR2UV(sv),SvPVX(sv)));
8267 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
8268 * this function provided for binary compatibility only
8272 Perl_sv_pvbyte(pTHX_ SV *sv)
8274 sv_utf8_downgrade(sv,0);
8279 =for apidoc sv_pvbyte
8281 Use C<SvPVbyte_nolen> instead.
8283 =for apidoc sv_pvbyten
8285 A private implementation of the C<SvPVbyte> macro for compilers
8286 which can't cope with complex macro expressions. Always use the macro
8293 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
8295 sv_utf8_downgrade(sv,0);
8296 return sv_pvn(sv,lp);
8300 =for apidoc sv_pvbyten_force
8302 A private implementation of the C<SvPVbytex_force> macro for compilers
8303 which can't cope with complex macro expressions. Always use the macro
8310 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
8312 sv_pvn_force(sv,lp);
8313 sv_utf8_downgrade(sv,0);
8318 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
8319 * this function provided for binary compatibility only
8323 Perl_sv_pvutf8(pTHX_ SV *sv)
8325 sv_utf8_upgrade(sv);
8330 =for apidoc sv_pvutf8
8332 Use the C<SvPVutf8_nolen> macro instead
8334 =for apidoc sv_pvutf8n
8336 A private implementation of the C<SvPVutf8> macro for compilers
8337 which can't cope with complex macro expressions. Always use the macro
8344 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
8346 sv_utf8_upgrade(sv);
8347 return sv_pvn(sv,lp);
8351 =for apidoc sv_pvutf8n_force
8353 A private implementation of the C<SvPVutf8_force> macro for compilers
8354 which can't cope with complex macro expressions. Always use the macro
8361 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
8363 sv_pvn_force(sv,lp);
8364 sv_utf8_upgrade(sv);
8370 =for apidoc sv_reftype
8372 Returns a string describing what the SV is a reference to.
8378 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
8380 /* The fact that I don't need to downcast to char * everywhere, only in ?:
8381 inside return suggests a const propagation bug in g++. */
8382 if (ob && SvOBJECT(sv)) {
8383 char *name = HvNAME(SvSTASH(sv));
8384 return name ? name : (char *) "__ANON__";
8387 switch (SvTYPE(sv)) {
8404 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
8405 /* tied lvalues should appear to be
8406 * scalars for backwards compatitbility */
8407 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8408 ? "SCALAR" : "LVALUE");
8409 case SVt_PVAV: return "ARRAY";
8410 case SVt_PVHV: return "HASH";
8411 case SVt_PVCV: return "CODE";
8412 case SVt_PVGV: return "GLOB";
8413 case SVt_PVFM: return "FORMAT";
8414 case SVt_PVIO: return "IO";
8415 default: return "UNKNOWN";
8421 =for apidoc sv_isobject
8423 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8424 object. If the SV is not an RV, or if the object is not blessed, then this
8431 Perl_sv_isobject(pTHX_ SV *sv)
8448 Returns a boolean indicating whether the SV is blessed into the specified
8449 class. This does not check for subtypes; use C<sv_derived_from> to verify
8450 an inheritance relationship.
8456 Perl_sv_isa(pTHX_ SV *sv, const char *name)
8467 if (!HvNAME(SvSTASH(sv)))
8470 return strEQ(HvNAME(SvSTASH(sv)), name);
8476 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
8477 it will be upgraded to one. If C<classname> is non-null then the new SV will
8478 be blessed in the specified package. The new SV is returned and its
8479 reference count is 1.
8485 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
8491 SV_CHECK_THINKFIRST_COW_DROP(rv);
8494 if (SvTYPE(rv) >= SVt_PVMG) {
8495 U32 refcnt = SvREFCNT(rv);
8499 SvREFCNT(rv) = refcnt;
8502 if (SvTYPE(rv) < SVt_RV)
8503 sv_upgrade(rv, SVt_RV);
8504 else if (SvTYPE(rv) > SVt_RV) {
8515 HV* stash = gv_stashpv(classname, TRUE);
8516 (void)sv_bless(rv, stash);
8522 =for apidoc sv_setref_pv
8524 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
8525 argument will be upgraded to an RV. That RV will be modified to point to
8526 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8527 into the SV. The C<classname> argument indicates the package for the
8528 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8529 will have a reference count of 1, and the RV will be returned.
8531 Do not use with other Perl types such as HV, AV, SV, CV, because those
8532 objects will become corrupted by the pointer copy process.
8534 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8540 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
8543 sv_setsv(rv, &PL_sv_undef);
8547 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8552 =for apidoc sv_setref_iv
8554 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
8555 argument will be upgraded to an RV. That RV will be modified to point to
8556 the new SV. The C<classname> argument indicates the package for the
8557 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8558 will have a reference count of 1, and the RV will be returned.
8564 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
8566 sv_setiv(newSVrv(rv,classname), iv);
8571 =for apidoc sv_setref_uv
8573 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
8574 argument will be upgraded to an RV. That RV will be modified to point to
8575 the new SV. The C<classname> argument indicates the package for the
8576 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8577 will have a reference count of 1, and the RV will be returned.
8583 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
8585 sv_setuv(newSVrv(rv,classname), uv);
8590 =for apidoc sv_setref_nv
8592 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8593 argument will be upgraded to an RV. That RV will be modified to point to
8594 the new SV. The C<classname> argument indicates the package for the
8595 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8596 will have a reference count of 1, and the RV will be returned.
8602 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
8604 sv_setnv(newSVrv(rv,classname), nv);
8609 =for apidoc sv_setref_pvn
8611 Copies a string into a new SV, optionally blessing the SV. The length of the
8612 string must be specified with C<n>. The C<rv> argument will be upgraded to
8613 an RV. That RV will be modified to point to the new SV. The C<classname>
8614 argument indicates the package for the blessing. Set C<classname> to
8615 C<Nullch> to avoid the blessing. The new SV will have a reference count
8616 of 1, and the RV will be returned.
8618 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8624 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
8626 sv_setpvn(newSVrv(rv,classname), pv, n);
8631 =for apidoc sv_bless
8633 Blesses an SV into a specified package. The SV must be an RV. The package
8634 must be designated by its stash (see C<gv_stashpv()>). The reference count
8635 of the SV is unaffected.
8641 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8645 Perl_croak(aTHX_ "Can't bless non-reference value");
8647 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8648 if (SvREADONLY(tmpRef))
8649 Perl_croak(aTHX_ PL_no_modify);
8650 if (SvOBJECT(tmpRef)) {
8651 if (SvTYPE(tmpRef) != SVt_PVIO)
8653 SvREFCNT_dec(SvSTASH(tmpRef));
8656 SvOBJECT_on(tmpRef);
8657 if (SvTYPE(tmpRef) != SVt_PVIO)
8659 (void)SvUPGRADE(tmpRef, SVt_PVMG);
8660 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
8667 if(SvSMAGICAL(tmpRef))
8668 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8676 /* Downgrades a PVGV to a PVMG.
8680 S_sv_unglob(pTHX_ SV *sv)
8684 assert(SvTYPE(sv) == SVt_PVGV);
8689 SvREFCNT_dec(GvSTASH(sv));
8690 GvSTASH(sv) = Nullhv;
8692 sv_unmagic(sv, PERL_MAGIC_glob);
8693 Safefree(GvNAME(sv));
8696 /* need to keep SvANY(sv) in the right arena */
8697 xpvmg = new_XPVMG();
8698 StructCopy(SvANY(sv), xpvmg, XPVMG);
8699 del_XPVGV(SvANY(sv));
8702 SvFLAGS(sv) &= ~SVTYPEMASK;
8703 SvFLAGS(sv) |= SVt_PVMG;
8707 =for apidoc sv_unref_flags
8709 Unsets the RV status of the SV, and decrements the reference count of
8710 whatever was being referenced by the RV. This can almost be thought of
8711 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8712 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8713 (otherwise the decrementing is conditional on the reference count being
8714 different from one or the reference being a readonly SV).
8721 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
8725 if (SvWEAKREF(sv)) {
8733 /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
8734 assigned to as BEGIN {$a = \"Foo"} will fail. */
8735 if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
8737 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8738 sv_2mortal(rv); /* Schedule for freeing later */
8742 =for apidoc sv_unref
8744 Unsets the RV status of the SV, and decrements the reference count of
8745 whatever was being referenced by the RV. This can almost be thought of
8746 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
8747 being zero. See C<SvROK_off>.
8753 Perl_sv_unref(pTHX_ SV *sv)
8755 sv_unref_flags(sv, 0);
8759 =for apidoc sv_taint
8761 Taint an SV. Use C<SvTAINTED_on> instead.
8766 Perl_sv_taint(pTHX_ SV *sv)
8768 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
8772 =for apidoc sv_untaint
8774 Untaint an SV. Use C<SvTAINTED_off> instead.
8779 Perl_sv_untaint(pTHX_ SV *sv)
8781 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8782 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8789 =for apidoc sv_tainted
8791 Test an SV for taintedness. Use C<SvTAINTED> instead.
8796 Perl_sv_tainted(pTHX_ SV *sv)
8798 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8799 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8800 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
8807 =for apidoc sv_setpviv
8809 Copies an integer into the given SV, also updating its string value.
8810 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8816 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8818 char buf[TYPE_CHARS(UV)];
8820 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8822 sv_setpvn(sv, ptr, ebuf - ptr);
8826 =for apidoc sv_setpviv_mg
8828 Like C<sv_setpviv>, but also handles 'set' magic.
8834 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8836 char buf[TYPE_CHARS(UV)];
8838 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8840 sv_setpvn(sv, ptr, ebuf - ptr);
8844 #if defined(PERL_IMPLICIT_CONTEXT)
8846 /* pTHX_ magic can't cope with varargs, so this is a no-context
8847 * version of the main function, (which may itself be aliased to us).
8848 * Don't access this version directly.
8852 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8856 va_start(args, pat);
8857 sv_vsetpvf(sv, pat, &args);
8861 /* pTHX_ magic can't cope with varargs, so this is a no-context
8862 * version of the main function, (which may itself be aliased to us).
8863 * Don't access this version directly.
8867 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8871 va_start(args, pat);
8872 sv_vsetpvf_mg(sv, pat, &args);
8878 =for apidoc sv_setpvf
8880 Works like C<sv_catpvf> but copies the text into the SV instead of
8881 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8887 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8890 va_start(args, pat);
8891 sv_vsetpvf(sv, pat, &args);
8896 =for apidoc sv_vsetpvf
8898 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8899 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8901 Usually used via its frontend C<sv_setpvf>.
8907 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8909 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8913 =for apidoc sv_setpvf_mg
8915 Like C<sv_setpvf>, but also handles 'set' magic.
8921 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8924 va_start(args, pat);
8925 sv_vsetpvf_mg(sv, pat, &args);
8930 =for apidoc sv_vsetpvf_mg
8932 Like C<sv_vsetpvf>, but also handles 'set' magic.
8934 Usually used via its frontend C<sv_setpvf_mg>.
8940 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8942 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8946 #if defined(PERL_IMPLICIT_CONTEXT)
8948 /* pTHX_ magic can't cope with varargs, so this is a no-context
8949 * version of the main function, (which may itself be aliased to us).
8950 * Don't access this version directly.
8954 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8958 va_start(args, pat);
8959 sv_vcatpvf(sv, pat, &args);
8963 /* pTHX_ magic can't cope with varargs, so this is a no-context
8964 * version of the main function, (which may itself be aliased to us).
8965 * Don't access this version directly.
8969 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8973 va_start(args, pat);
8974 sv_vcatpvf_mg(sv, pat, &args);
8980 =for apidoc sv_catpvf
8982 Processes its arguments like C<sprintf> and appends the formatted
8983 output to an SV. If the appended data contains "wide" characters
8984 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8985 and characters >255 formatted with %c), the original SV might get
8986 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
8987 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
8988 valid UTF-8; if the original SV was bytes, the pattern should be too.
8993 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8996 va_start(args, pat);
8997 sv_vcatpvf(sv, pat, &args);
9002 =for apidoc sv_vcatpvf
9004 Processes its arguments like C<vsprintf> and appends the formatted output
9005 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
9007 Usually used via its frontend C<sv_catpvf>.
9013 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
9015 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9019 =for apidoc sv_catpvf_mg
9021 Like C<sv_catpvf>, but also handles 'set' magic.
9027 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
9030 va_start(args, pat);
9031 sv_vcatpvf_mg(sv, pat, &args);
9036 =for apidoc sv_vcatpvf_mg
9038 Like C<sv_vcatpvf>, but also handles 'set' magic.
9040 Usually used via its frontend C<sv_catpvf_mg>.
9046 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
9048 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9053 =for apidoc sv_vsetpvfn
9055 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9058 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9064 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
9066 sv_setpvn(sv, "", 0);
9067 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9070 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
9073 S_expect_number(pTHX_ char** pattern)
9076 switch (**pattern) {
9077 case '1': case '2': case '3':
9078 case '4': case '5': case '6':
9079 case '7': case '8': case '9':
9080 while (isDIGIT(**pattern))
9081 var = var * 10 + (*(*pattern)++ - '0');
9085 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
9088 F0convert(NV nv, char *endbuf, STRLEN *len)
9099 if (uv & 1 && uv == nv)
9100 uv--; /* Round to even */
9102 unsigned dig = uv % 10;
9115 =for apidoc sv_vcatpvfn
9117 Processes its arguments like C<vsprintf> and appends the formatted output
9118 to an SV. Uses an array of SVs if the C style variable argument list is
9119 missing (NULL). When running with taint checks enabled, indicates via
9120 C<maybe_tainted> if results are untrustworthy (often due to the use of
9123 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9128 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9131 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
9138 static const char nullstr[] = "(null)";
9140 bool has_utf8; /* has the result utf8? */
9141 bool pat_utf8; /* the pattern is in utf8? */
9143 /* Times 4: a decimal digit takes more than 3 binary digits.
9144 * NV_DIG: mantissa takes than many decimal digits.
9145 * Plus 32: Playing safe. */
9146 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9147 /* large enough for "%#.#f" --chip */
9148 /* what about long double NVs? --jhi */
9150 has_utf8 = pat_utf8 = DO_UTF8(sv);
9152 /* no matter what, this is a string now */
9153 (void)SvPV_force(sv, origlen);
9155 /* special-case "", "%s", and "%_" */
9158 if (patlen == 2 && pat[0] == '%') {
9162 const char *s = va_arg(*args, char*);
9163 sv_catpv(sv, s ? s : nullstr);
9165 else if (svix < svmax) {
9166 sv_catsv(sv, *svargs);
9167 if (DO_UTF8(*svargs))
9173 argsv = va_arg(*args, SV*);
9174 sv_catsv(sv, argsv);
9179 /* See comment on '_' below */
9184 #ifndef USE_LONG_DOUBLE
9185 /* special-case "%.<number>[gf]" */
9186 if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9187 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9188 unsigned digits = 0;
9192 while (*pp >= '0' && *pp <= '9')
9193 digits = 10 * digits + (*pp++ - '0');
9194 if (pp - pat == (int)patlen - 1) {
9198 nv = (NV)va_arg(*args, double);
9199 else if (svix < svmax)
9204 /* Add check for digits != 0 because it seems that some
9205 gconverts are buggy in this case, and we don't yet have
9206 a Configure test for this. */
9207 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9208 /* 0, point, slack */
9209 Gconvert(nv, (int)digits, 0, ebuf);
9211 if (*ebuf) /* May return an empty string for digits==0 */
9214 } else if (!digits) {
9217 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9218 sv_catpvn(sv, p, l);
9224 #endif /* !USE_LONG_DOUBLE */
9226 if (!args && svix < svmax && DO_UTF8(*svargs))
9229 patend = (char*)pat + patlen;
9230 for (p = (char*)pat; p < patend; p = q) {
9233 bool vectorize = FALSE;
9234 bool vectorarg = FALSE;
9235 bool vec_utf8 = FALSE;
9241 bool has_precis = FALSE;
9244 bool is_utf8 = FALSE; /* is this item utf8? */
9245 #ifdef HAS_LDBL_SPRINTF_BUG
9246 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9247 with sfio - Allen <allens@cpan.org> */
9248 bool fix_ldbl_sprintf_bug = FALSE;
9252 U8 utf8buf[UTF8_MAXBYTES+1];
9253 STRLEN esignlen = 0;
9255 char *eptr = Nullch;
9258 U8 *vecstr = Null(U8*);
9265 /* we need a long double target in case HAS_LONG_DOUBLE but
9268 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9276 const char *dotstr = ".";
9277 STRLEN dotstrlen = 1;
9278 I32 efix = 0; /* explicit format parameter index */
9279 I32 ewix = 0; /* explicit width index */
9280 I32 epix = 0; /* explicit precision index */
9281 I32 evix = 0; /* explicit vector index */
9282 bool asterisk = FALSE;
9284 /* echo everything up to the next format specification */
9285 for (q = p; q < patend && *q != '%'; ++q) ;
9287 if (has_utf8 && !pat_utf8)
9288 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9290 sv_catpvn(sv, p, q - p);
9297 We allow format specification elements in this order:
9298 \d+\$ explicit format parameter index
9300 v|\*(\d+\$)?v vector with optional (optionally specified) arg
9301 0 flag (as above): repeated to allow "v02"
9302 \d+|\*(\d+\$)? width using optional (optionally specified) arg
9303 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9305 [%bcdefginopsux_DFOUX] format (mandatory)
9307 if (EXPECT_NUMBER(q, width)) {
9348 if (EXPECT_NUMBER(q, ewix))
9357 if ((vectorarg = asterisk)) {
9369 EXPECT_NUMBER(q, width);
9374 vecsv = va_arg(*args, SV*);
9376 vecsv = (evix ? evix <= svmax : svix < svmax) ?
9377 svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
9378 dotstr = SvPVx(vecsv, dotstrlen);
9383 vecsv = va_arg(*args, SV*);
9384 vecstr = (U8*)SvPVx(vecsv,veclen);
9385 vec_utf8 = DO_UTF8(vecsv);
9387 else if (efix ? efix <= svmax : svix < svmax) {
9388 vecsv = svargs[efix ? efix-1 : svix++];
9389 vecstr = (U8*)SvPVx(vecsv,veclen);
9390 vec_utf8 = DO_UTF8(vecsv);
9391 /* if this is a version object, we need to return the
9392 * stringified representation (which the SvPVX has
9393 * already done for us), but not vectorize the args
9395 if ( *q == 'd' && sv_derived_from(vecsv,"version") )
9397 q++; /* skip past the rest of the %vd format */
9398 eptr = (char *) vecstr;
9399 elen = strlen(eptr);
9412 i = va_arg(*args, int);
9414 i = (ewix ? ewix <= svmax : svix < svmax) ?
9415 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9417 width = (i < 0) ? -i : i;
9427 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
9429 /* XXX: todo, support specified precision parameter */
9433 i = va_arg(*args, int);
9435 i = (ewix ? ewix <= svmax : svix < svmax)
9436 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9437 precis = (i < 0) ? 0 : i;
9442 precis = precis * 10 + (*q++ - '0');
9451 case 'I': /* Ix, I32x, and I64x */
9453 if (q[1] == '6' && q[2] == '4') {
9459 if (q[1] == '3' && q[2] == '2') {
9469 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9480 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9481 if (*(q + 1) == 'l') { /* lld, llf */
9506 argsv = (efix ? efix <= svmax : svix < svmax) ?
9507 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
9514 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
9516 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9518 eptr = (char*)utf8buf;
9519 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9530 if (args && !vectorize) {
9531 eptr = va_arg(*args, char*);
9533 #ifdef MACOS_TRADITIONAL
9534 /* On MacOS, %#s format is used for Pascal strings */
9539 elen = strlen(eptr);
9541 eptr = (char *)nullstr;
9542 elen = sizeof nullstr - 1;
9546 eptr = SvPVx(argsv, elen);
9547 if (DO_UTF8(argsv)) {
9548 if (has_precis && precis < elen) {
9550 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9553 if (width) { /* fudge width (can't fudge elen) */
9554 width += elen - sv_len_utf8(argsv);
9566 * The "%_" hack might have to be changed someday,
9567 * if ISO or ANSI decide to use '_' for something.
9568 * So we keep it hidden from users' code.
9570 if (!args || vectorize)
9572 argsv = va_arg(*args, SV*);
9573 eptr = SvPVx(argsv, elen);
9579 if (has_precis && elen > precis)
9590 goto format_sv; /* %-p -> %_ */
9594 goto format_sv; /* %-Np -> %.N_ */
9597 if (alt || vectorize)
9599 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9617 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9626 esignbuf[esignlen++] = plus;
9630 case 'h': iv = (short)va_arg(*args, int); break;
9631 case 'l': iv = va_arg(*args, long); break;
9632 case 'V': iv = va_arg(*args, IV); break;
9633 default: iv = va_arg(*args, int); break;
9635 case 'q': iv = va_arg(*args, Quad_t); break;
9640 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
9642 case 'h': iv = (short)tiv; break;
9643 case 'l': iv = (long)tiv; break;
9645 default: iv = tiv; break;
9647 case 'q': iv = (Quad_t)tiv; break;
9651 if ( !vectorize ) /* we already set uv above */
9656 esignbuf[esignlen++] = plus;
9660 esignbuf[esignlen++] = '-';
9703 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9714 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9715 case 'l': uv = va_arg(*args, unsigned long); break;
9716 case 'V': uv = va_arg(*args, UV); break;
9717 default: uv = va_arg(*args, unsigned); break;
9719 case 'q': uv = va_arg(*args, Uquad_t); break;
9724 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9726 case 'h': uv = (unsigned short)tuv; break;
9727 case 'l': uv = (unsigned long)tuv; break;
9729 default: uv = tuv; break;
9731 case 'q': uv = (Uquad_t)tuv; break;
9737 eptr = ebuf + sizeof ebuf;
9743 p = (char*)((c == 'X')
9744 ? "0123456789ABCDEF" : "0123456789abcdef");
9750 esignbuf[esignlen++] = '0';
9751 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9757 *--eptr = '0' + dig;
9759 if (alt && *eptr != '0')
9765 *--eptr = '0' + dig;
9768 esignbuf[esignlen++] = '0';
9769 esignbuf[esignlen++] = 'b';
9772 default: /* it had better be ten or less */
9775 *--eptr = '0' + dig;
9776 } while (uv /= base);
9779 elen = (ebuf + sizeof ebuf) - eptr;
9782 zeros = precis - elen;
9783 else if (precis == 0 && elen == 1 && *eptr == '0')
9788 /* FLOATING POINT */
9791 c = 'f'; /* maybe %F isn't supported here */
9797 /* This is evil, but floating point is even more evil */
9799 /* for SV-style calling, we can only get NV
9800 for C-style calling, we assume %f is double;
9801 for simplicity we allow any of %Lf, %llf, %qf for long double
9805 #if defined(USE_LONG_DOUBLE)
9809 /* [perl #20339] - we should accept and ignore %lf rather than die */
9813 #if defined(USE_LONG_DOUBLE)
9814 intsize = args ? 0 : 'q';
9818 #if defined(HAS_LONG_DOUBLE)
9827 /* now we need (long double) if intsize == 'q', else (double) */
9828 nv = (args && !vectorize) ?
9829 #if LONG_DOUBLESIZE > DOUBLESIZE
9831 va_arg(*args, long double) :
9832 va_arg(*args, double)
9834 va_arg(*args, double)
9840 if (c != 'e' && c != 'E') {
9842 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9843 will cast our (long double) to (double) */
9844 (void)Perl_frexp(nv, &i);
9845 if (i == PERL_INT_MIN)
9846 Perl_die(aTHX_ "panic: frexp");
9848 need = BIT_DIGITS(i);
9850 need += has_precis ? precis : 6; /* known default */
9855 #ifdef HAS_LDBL_SPRINTF_BUG
9856 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9857 with sfio - Allen <allens@cpan.org> */
9860 # define MY_DBL_MAX DBL_MAX
9861 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9862 # if DOUBLESIZE >= 8
9863 # define MY_DBL_MAX 1.7976931348623157E+308L
9865 # define MY_DBL_MAX 3.40282347E+38L
9869 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9870 # define MY_DBL_MAX_BUG 1L
9872 # define MY_DBL_MAX_BUG MY_DBL_MAX
9876 # define MY_DBL_MIN DBL_MIN
9877 # else /* XXX guessing! -Allen */
9878 # if DOUBLESIZE >= 8
9879 # define MY_DBL_MIN 2.2250738585072014E-308L
9881 # define MY_DBL_MIN 1.17549435E-38L
9885 if ((intsize == 'q') && (c == 'f') &&
9886 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9888 /* it's going to be short enough that
9889 * long double precision is not needed */
9891 if ((nv <= 0L) && (nv >= -0L))
9892 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9894 /* would use Perl_fp_class as a double-check but not
9895 * functional on IRIX - see perl.h comments */
9897 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9898 /* It's within the range that a double can represent */
9899 #if defined(DBL_MAX) && !defined(DBL_MIN)
9900 if ((nv >= ((long double)1/DBL_MAX)) ||
9901 (nv <= (-(long double)1/DBL_MAX)))
9903 fix_ldbl_sprintf_bug = TRUE;
9906 if (fix_ldbl_sprintf_bug == TRUE) {
9916 # undef MY_DBL_MAX_BUG
9919 #endif /* HAS_LDBL_SPRINTF_BUG */
9921 need += 20; /* fudge factor */
9922 if (PL_efloatsize < need) {
9923 Safefree(PL_efloatbuf);
9924 PL_efloatsize = need + 20; /* more fudge */
9925 New(906, PL_efloatbuf, PL_efloatsize, char);
9926 PL_efloatbuf[0] = '\0';
9929 if ( !(width || left || plus || alt) && fill != '0'
9930 && has_precis && intsize != 'q' ) { /* Shortcuts */
9931 /* See earlier comment about buggy Gconvert when digits,
9933 if ( c == 'g' && precis) {
9934 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9935 if (*PL_efloatbuf) /* May return an empty string for digits==0 */
9936 goto float_converted;
9937 } else if ( c == 'f' && !precis) {
9938 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9942 eptr = ebuf + sizeof ebuf;
9945 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9946 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9947 if (intsize == 'q') {
9948 /* Copy the one or more characters in a long double
9949 * format before the 'base' ([efgEFG]) character to
9950 * the format string. */
9951 static char const prifldbl[] = PERL_PRIfldbl;
9952 char const *p = prifldbl + sizeof(prifldbl) - 3;
9953 while (p >= prifldbl) { *--eptr = *p--; }
9958 do { *--eptr = '0' + (base % 10); } while (base /= 10);
9963 do { *--eptr = '0' + (base % 10); } while (base /= 10);
9975 /* No taint. Otherwise we are in the strange situation
9976 * where printf() taints but print($float) doesn't.
9978 #if defined(HAS_LONG_DOUBLE)
9980 (void)sprintf(PL_efloatbuf, eptr, nv);
9982 (void)sprintf(PL_efloatbuf, eptr, (double)nv);
9984 (void)sprintf(PL_efloatbuf, eptr, nv);
9987 eptr = PL_efloatbuf;
9988 elen = strlen(PL_efloatbuf);
9994 i = SvCUR(sv) - origlen;
9995 if (args && !vectorize) {
9997 case 'h': *(va_arg(*args, short*)) = i; break;
9998 default: *(va_arg(*args, int*)) = i; break;
9999 case 'l': *(va_arg(*args, long*)) = i; break;
10000 case 'V': *(va_arg(*args, IV*)) = i; break;
10002 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
10007 sv_setuv_mg(argsv, (UV)i);
10009 continue; /* not "break" */
10015 if (!args && ckWARN(WARN_PRINTF) &&
10016 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
10017 SV *msg = sv_newmortal();
10018 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10019 (PL_op->op_type == OP_PRTF) ? "" : "s");
10022 Perl_sv_catpvf(aTHX_ msg,
10023 "\"%%%c\"", c & 0xFF);
10025 Perl_sv_catpvf(aTHX_ msg,
10026 "\"%%\\%03"UVof"\"",
10029 sv_catpv(msg, "end of string");
10030 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
10033 /* output mangled stuff ... */
10039 /* ... right here, because formatting flags should not apply */
10040 SvGROW(sv, SvCUR(sv) + elen + 1);
10042 Copy(eptr, p, elen, char);
10045 SvCUR_set(sv, p - SvPVX(sv));
10047 continue; /* not "break" */
10050 /* calculate width before utf8_upgrade changes it */
10051 have = esignlen + zeros + elen;
10053 if (is_utf8 != has_utf8) {
10056 sv_utf8_upgrade(sv);
10059 SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
10060 sv_utf8_upgrade(nsv);
10064 SvGROW(sv, SvCUR(sv) + elen + 1);
10069 need = (have > width ? have : width);
10072 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10074 if (esignlen && fill == '0') {
10075 for (i = 0; i < (int)esignlen; i++)
10076 *p++ = esignbuf[i];
10078 if (gap && !left) {
10079 memset(p, fill, gap);
10082 if (esignlen && fill != '0') {
10083 for (i = 0; i < (int)esignlen; i++)
10084 *p++ = esignbuf[i];
10087 for (i = zeros; i; i--)
10091 Copy(eptr, p, elen, char);
10095 memset(p, ' ', gap);
10100 Copy(dotstr, p, dotstrlen, char);
10104 vectorize = FALSE; /* done iterating over vecstr */
10111 SvCUR_set(sv, p - SvPVX(sv));
10119 /* =========================================================================
10121 =head1 Cloning an interpreter
10123 All the macros and functions in this section are for the private use of
10124 the main function, perl_clone().
10126 The foo_dup() functions make an exact copy of an existing foo thinngy.
10127 During the course of a cloning, a hash table is used to map old addresses
10128 to new addresses. The table is created and manipulated with the
10129 ptr_table_* functions.
10133 ============================================================================*/
10136 #if defined(USE_ITHREADS)
10138 #ifndef GpREFCNT_inc
10139 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10143 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10144 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
10145 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10146 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
10147 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10148 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
10149 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10150 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
10151 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
10152 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
10153 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10154 #define SAVEPV(p) (p ? savepv(p) : Nullch)
10155 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
10158 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
10159 regcomp.c. AMS 20010712 */
10162 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
10167 struct reg_substr_datum *s;
10170 return (REGEXP *)NULL;
10172 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
10175 len = r->offsets[0];
10176 npar = r->nparens+1;
10178 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
10179 Copy(r->program, ret->program, len+1, regnode);
10181 New(0, ret->startp, npar, I32);
10182 Copy(r->startp, ret->startp, npar, I32);
10183 New(0, ret->endp, npar, I32);
10184 Copy(r->startp, ret->startp, npar, I32);
10186 New(0, ret->substrs, 1, struct reg_substr_data);
10187 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
10188 s->min_offset = r->substrs->data[i].min_offset;
10189 s->max_offset = r->substrs->data[i].max_offset;
10190 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
10191 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
10194 ret->regstclass = NULL;
10196 struct reg_data *d;
10197 const int count = r->data->count;
10199 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
10200 char, struct reg_data);
10201 New(0, d->what, count, U8);
10204 for (i = 0; i < count; i++) {
10205 d->what[i] = r->data->what[i];
10206 switch (d->what[i]) {
10207 /* legal options are one of: sfpont
10208 see also regcomp.h and pregfree() */
10210 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
10213 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
10216 /* This is cheating. */
10217 New(0, d->data[i], 1, struct regnode_charclass_class);
10218 StructCopy(r->data->data[i], d->data[i],
10219 struct regnode_charclass_class);
10220 ret->regstclass = (regnode*)d->data[i];
10223 /* Compiled op trees are readonly, and can thus be
10224 shared without duplication. */
10226 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
10230 d->data[i] = r->data->data[i];
10233 d->data[i] = r->data->data[i];
10235 ((reg_trie_data*)d->data[i])->refcount++;
10239 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
10248 New(0, ret->offsets, 2*len+1, U32);
10249 Copy(r->offsets, ret->offsets, 2*len+1, U32);
10251 ret->precomp = SAVEPVN(r->precomp, r->prelen);
10252 ret->refcnt = r->refcnt;
10253 ret->minlen = r->minlen;
10254 ret->prelen = r->prelen;
10255 ret->nparens = r->nparens;
10256 ret->lastparen = r->lastparen;
10257 ret->lastcloseparen = r->lastcloseparen;
10258 ret->reganch = r->reganch;
10260 ret->sublen = r->sublen;
10262 if (RX_MATCH_COPIED(ret))
10263 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
10265 ret->subbeg = Nullch;
10266 #ifdef PERL_COPY_ON_WRITE
10267 ret->saved_copy = Nullsv;
10270 ptr_table_store(PL_ptr_table, r, ret);
10274 /* duplicate a file handle */
10277 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
10283 return (PerlIO*)NULL;
10285 /* look for it in the table first */
10286 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10290 /* create anew and remember what it is */
10291 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10292 ptr_table_store(PL_ptr_table, fp, ret);
10296 /* duplicate a directory handle */
10299 Perl_dirp_dup(pTHX_ DIR *dp)
10307 /* duplicate a typeglob */
10310 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
10315 /* look for it in the table first */
10316 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10320 /* create anew and remember what it is */
10321 Newz(0, ret, 1, GP);
10322 ptr_table_store(PL_ptr_table, gp, ret);
10325 ret->gp_refcnt = 0; /* must be before any other dups! */
10326 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
10327 ret->gp_io = io_dup_inc(gp->gp_io, param);
10328 ret->gp_form = cv_dup_inc(gp->gp_form, param);
10329 ret->gp_av = av_dup_inc(gp->gp_av, param);
10330 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
10331 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10332 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
10333 ret->gp_cvgen = gp->gp_cvgen;
10334 ret->gp_flags = gp->gp_flags;
10335 ret->gp_line = gp->gp_line;
10336 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
10340 /* duplicate a chain of magic */
10343 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
10345 MAGIC *mgprev = (MAGIC*)NULL;
10348 return (MAGIC*)NULL;
10349 /* look for it in the table first */
10350 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
10354 for (; mg; mg = mg->mg_moremagic) {
10356 Newz(0, nmg, 1, MAGIC);
10358 mgprev->mg_moremagic = nmg;
10361 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
10362 nmg->mg_private = mg->mg_private;
10363 nmg->mg_type = mg->mg_type;
10364 nmg->mg_flags = mg->mg_flags;
10365 if (mg->mg_type == PERL_MAGIC_qr) {
10366 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
10368 else if(mg->mg_type == PERL_MAGIC_backref) {
10369 const AV * const av = (AV*) mg->mg_obj;
10372 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
10374 for (i = AvFILLp(av); i >= 0; i--) {
10375 if (!svp[i]) continue;
10376 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
10380 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
10381 ? sv_dup_inc(mg->mg_obj, param)
10382 : sv_dup(mg->mg_obj, param);
10384 nmg->mg_len = mg->mg_len;
10385 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
10386 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
10387 if (mg->mg_len > 0) {
10388 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
10389 if (mg->mg_type == PERL_MAGIC_overload_table &&
10390 AMT_AMAGIC((AMT*)mg->mg_ptr))
10392 AMT *amtp = (AMT*)mg->mg_ptr;
10393 AMT *namtp = (AMT*)nmg->mg_ptr;
10395 for (i = 1; i < NofAMmeth; i++) {
10396 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
10400 else if (mg->mg_len == HEf_SVKEY)
10401 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
10403 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
10404 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10411 /* create a new pointer-mapping table */
10414 Perl_ptr_table_new(pTHX)
10417 Newz(0, tbl, 1, PTR_TBL_t);
10418 tbl->tbl_max = 511;
10419 tbl->tbl_items = 0;
10420 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10425 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
10427 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
10435 register struct ptr_tbl_ent* pte;
10436 register struct ptr_tbl_ent* pteend;
10437 New(0, ptr, PERL_ARENA_SIZE/sizeof(struct ptr_tbl_ent), struct ptr_tbl_ent);
10438 ptr->next = PL_pte_arenaroot;
10439 PL_pte_arenaroot = ptr;
10441 pteend = &pte[PERL_ARENA_SIZE / sizeof(struct ptr_tbl_ent) - 1];
10442 PL_pte_root = ++pte;
10443 while (pte < pteend) {
10444 pte->next = pte + 1;
10450 STATIC struct ptr_tbl_ent*
10453 struct ptr_tbl_ent* pte;
10457 PL_pte_root = pte->next;
10462 S_del_pte(pTHX_ struct ptr_tbl_ent*p)
10464 p->next = PL_pte_root;
10468 /* map an existing pointer using a table */
10471 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
10473 PTR_TBL_ENT_t *tblent;
10474 UV hash = PTR_TABLE_HASH(sv);
10476 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10477 for (; tblent; tblent = tblent->next) {
10478 if (tblent->oldval == sv)
10479 return tblent->newval;
10481 return (void*)NULL;
10484 /* add a new entry to a pointer-mapping table */
10487 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
10489 PTR_TBL_ENT_t *tblent, **otblent;
10490 /* XXX this may be pessimal on platforms where pointers aren't good
10491 * hash values e.g. if they grow faster in the most significant
10493 UV hash = PTR_TABLE_HASH(oldv);
10497 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
10498 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
10499 if (tblent->oldval == oldv) {
10500 tblent->newval = newv;
10504 tblent = S_new_pte(aTHX);
10505 tblent->oldval = oldv;
10506 tblent->newval = newv;
10507 tblent->next = *otblent;
10510 if (!empty && tbl->tbl_items > tbl->tbl_max)
10511 ptr_table_split(tbl);
10514 /* double the hash bucket size of an existing ptr table */
10517 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
10519 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10520 UV oldsize = tbl->tbl_max + 1;
10521 UV newsize = oldsize * 2;
10524 Renew(ary, newsize, PTR_TBL_ENT_t*);
10525 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10526 tbl->tbl_max = --newsize;
10527 tbl->tbl_ary = ary;
10528 for (i=0; i < oldsize; i++, ary++) {
10529 PTR_TBL_ENT_t **curentp, **entp, *ent;
10532 curentp = ary + oldsize;
10533 for (entp = ary, ent = *ary; ent; ent = *entp) {
10534 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10536 ent->next = *curentp;
10546 /* remove all the entries from a ptr table */
10549 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
10551 register PTR_TBL_ENT_t **array;
10552 register PTR_TBL_ENT_t *entry;
10553 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
10557 if (!tbl || !tbl->tbl_items) {
10561 array = tbl->tbl_ary;
10563 max = tbl->tbl_max;
10568 entry = entry->next;
10569 S_del_pte(aTHX_ oentry);
10572 if (++riter > max) {
10575 entry = array[riter];
10579 tbl->tbl_items = 0;
10582 /* clear and free a ptr table */
10585 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
10590 ptr_table_clear(tbl);
10591 Safefree(tbl->tbl_ary);
10595 /* attempt to make everything in the typeglob readonly */
10598 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
10600 GV *gv = (GV*)sstr;
10601 SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */
10603 if (GvIO(gv) || GvFORM(gv)) {
10604 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
10606 else if (!GvCV(gv)) {
10607 GvCV(gv) = (CV*)sv;
10610 /* CvPADLISTs cannot be shared */
10611 if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
10616 if (!GvUNIQUE(gv)) {
10618 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
10619 HvNAME(GvSTASH(gv)), GvNAME(gv));
10625 * write attempts will die with
10626 * "Modification of a read-only value attempted"
10632 SvREADONLY_on(GvSV(gv));
10636 GvAV(gv) = (AV*)sv;
10639 SvREADONLY_on(GvAV(gv));
10643 GvHV(gv) = (HV*)sv;
10646 SvREADONLY_on(GvHV(gv));
10649 return sstr; /* he_dup() will SvREFCNT_inc() */
10652 /* duplicate an SV of any type (including AV, HV etc) */
10655 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
10658 SvRV_set(dstr, SvWEAKREF(sstr)
10659 ? sv_dup(SvRV(sstr), param)
10660 : sv_dup_inc(SvRV(sstr), param));
10663 else if (SvPVX(sstr)) {
10664 /* Has something there */
10666 /* Normal PV - clone whole allocated space */
10667 SvPV_set(dstr, SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1));
10668 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10669 /* Not that normal - actually sstr is copy on write.
10670 But we are a true, independant SV, so: */
10671 SvREADONLY_off(dstr);
10676 /* Special case - not normally malloced for some reason */
10677 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10678 /* A "shared" PV - clone it as unshared string */
10679 if(SvPADTMP(sstr)) {
10680 /* However, some of them live in the pad
10681 and they should not have these flags
10684 SvPV_set(dstr, sharepvn(SvPVX(sstr), SvCUR(sstr),
10686 SvUV_set(dstr, SvUVX(sstr));
10689 SvPV_set(dstr, SAVEPVN(SvPVX(sstr), SvCUR(sstr)));
10691 SvREADONLY_off(dstr);
10695 /* Some other special case - random pointer */
10696 SvPV_set(dstr, SvPVX(sstr));
10701 /* Copy the Null */
10702 if (SvTYPE(dstr) == SVt_RV)
10703 SvRV_set(dstr, NULL);
10710 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
10715 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10717 /* look for it in the table first */
10718 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10722 if(param->flags & CLONEf_JOIN_IN) {
10723 /** We are joining here so we don't want do clone
10724 something that is bad **/
10726 if(SvTYPE(sstr) == SVt_PVHV &&
10728 /** don't clone stashes if they already exist **/
10729 HV* old_stash = gv_stashpv(HvNAME(sstr),0);
10730 return (SV*) old_stash;
10734 /* create anew and remember what it is */
10737 #ifdef DEBUG_LEAKING_SCALARS
10738 dstr->sv_debug_optype = sstr->sv_debug_optype;
10739 dstr->sv_debug_line = sstr->sv_debug_line;
10740 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10741 dstr->sv_debug_cloned = 1;
10743 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10745 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
10749 ptr_table_store(PL_ptr_table, sstr, dstr);
10752 SvFLAGS(dstr) = SvFLAGS(sstr);
10753 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10754 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10757 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
10758 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10759 PL_watch_pvx, SvPVX(sstr));
10762 /* don't clone objects whose class has asked us not to */
10763 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10764 SvFLAGS(dstr) &= ~SVTYPEMASK;
10765 SvOBJECT_off(dstr);
10769 switch (SvTYPE(sstr)) {
10771 SvANY(dstr) = NULL;
10774 SvANY(dstr) = new_XIV();
10775 SvIV_set(dstr, SvIVX(sstr));
10778 SvANY(dstr) = new_XNV();
10779 SvNV_set(dstr, SvNVX(sstr));
10782 SvANY(dstr) = new_XRV();
10783 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10786 SvANY(dstr) = new_XPV();
10787 SvCUR_set(dstr, SvCUR(sstr));
10788 SvLEN_set(dstr, SvLEN(sstr));
10789 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10792 SvANY(dstr) = new_XPVIV();
10793 SvCUR_set(dstr, SvCUR(sstr));
10794 SvLEN_set(dstr, SvLEN(sstr));
10795 SvIV_set(dstr, SvIVX(sstr));
10796 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10799 SvANY(dstr) = new_XPVNV();
10800 SvCUR_set(dstr, SvCUR(sstr));
10801 SvLEN_set(dstr, SvLEN(sstr));
10802 SvIV_set(dstr, SvIVX(sstr));
10803 SvNV_set(dstr, SvNVX(sstr));
10804 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10807 SvANY(dstr) = new_XPVMG();
10808 SvCUR_set(dstr, SvCUR(sstr));
10809 SvLEN_set(dstr, SvLEN(sstr));
10810 SvIV_set(dstr, SvIVX(sstr));
10811 SvNV_set(dstr, SvNVX(sstr));
10812 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10813 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10814 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10817 SvANY(dstr) = new_XPVBM();
10818 SvCUR_set(dstr, SvCUR(sstr));
10819 SvLEN_set(dstr, SvLEN(sstr));
10820 SvIV_set(dstr, SvIVX(sstr));
10821 SvNV_set(dstr, SvNVX(sstr));
10822 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10823 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10824 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10825 BmRARE(dstr) = BmRARE(sstr);
10826 BmUSEFUL(dstr) = BmUSEFUL(sstr);
10827 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
10830 SvANY(dstr) = new_XPVLV();
10831 SvCUR_set(dstr, SvCUR(sstr));
10832 SvLEN_set(dstr, SvLEN(sstr));
10833 SvIV_set(dstr, SvIVX(sstr));
10834 SvNV_set(dstr, SvNVX(sstr));
10835 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10836 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10837 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10838 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
10839 LvTARGLEN(dstr) = LvTARGLEN(sstr);
10840 if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */
10841 LvTARG(dstr) = dstr;
10842 else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */
10843 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param);
10845 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
10846 LvTYPE(dstr) = LvTYPE(sstr);
10849 if (GvUNIQUE((GV*)sstr)) {
10851 if ((share = gv_share(sstr, param))) {
10854 ptr_table_store(PL_ptr_table, sstr, dstr);
10856 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
10857 HvNAME(GvSTASH(share)), GvNAME(share));
10862 SvANY(dstr) = new_XPVGV();
10863 SvCUR_set(dstr, SvCUR(sstr));
10864 SvLEN_set(dstr, SvLEN(sstr));
10865 SvIV_set(dstr, SvIVX(sstr));
10866 SvNV_set(dstr, SvNVX(sstr));
10867 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10868 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10869 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10870 GvNAMELEN(dstr) = GvNAMELEN(sstr);
10871 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
10872 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
10873 GvFLAGS(dstr) = GvFLAGS(sstr);
10874 GvGP(dstr) = gp_dup(GvGP(sstr), param);
10875 (void)GpREFCNT_inc(GvGP(dstr));
10878 SvANY(dstr) = new_XPVIO();
10879 SvCUR_set(dstr, SvCUR(sstr));
10880 SvLEN_set(dstr, SvLEN(sstr));
10881 SvIV_set(dstr, SvIVX(sstr));
10882 SvNV_set(dstr, SvNVX(sstr));
10883 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10884 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10885 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10886 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
10887 if (IoOFP(sstr) == IoIFP(sstr))
10888 IoOFP(dstr) = IoIFP(dstr);
10890 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
10891 /* PL_rsfp_filters entries have fake IoDIRP() */
10892 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
10893 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
10895 IoDIRP(dstr) = IoDIRP(sstr);
10896 IoLINES(dstr) = IoLINES(sstr);
10897 IoPAGE(dstr) = IoPAGE(sstr);
10898 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
10899 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
10900 if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
10901 /* I have no idea why fake dirp (rsfps)
10902 should be treaded differently but otherwise
10903 we end up with leaks -- sky*/
10904 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(sstr), param);
10905 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(sstr), param);
10906 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(sstr), param);
10908 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
10909 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
10910 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
10912 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
10913 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
10914 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
10915 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
10916 IoTYPE(dstr) = IoTYPE(sstr);
10917 IoFLAGS(dstr) = IoFLAGS(sstr);
10920 SvANY(dstr) = new_XPVAV();
10921 SvCUR_set(dstr, SvCUR(sstr));
10922 SvLEN_set(dstr, SvLEN(sstr));
10923 SvIV_set(dstr, SvIVX(sstr));
10924 SvNV_set(dstr, SvNVX(sstr));
10925 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10926 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10927 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
10928 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
10929 if (AvARRAY((AV*)sstr)) {
10930 SV **dst_ary, **src_ary;
10931 SSize_t items = AvFILLp((AV*)sstr) + 1;
10933 src_ary = AvARRAY((AV*)sstr);
10934 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
10935 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10936 SvPV_set(dstr, (char*)dst_ary);
10937 AvALLOC((AV*)dstr) = dst_ary;
10938 if (AvREAL((AV*)sstr)) {
10939 while (items-- > 0)
10940 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10943 while (items-- > 0)
10944 *dst_ary++ = sv_dup(*src_ary++, param);
10946 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10947 while (items-- > 0) {
10948 *dst_ary++ = &PL_sv_undef;
10952 SvPV_set(dstr, Nullch);
10953 AvALLOC((AV*)dstr) = (SV**)NULL;
10957 SvANY(dstr) = new_XPVHV();
10958 SvCUR_set(dstr, SvCUR(sstr));
10959 SvLEN_set(dstr, SvLEN(sstr));
10960 SvIV_set(dstr, SvIVX(sstr));
10961 SvNV_set(dstr, SvNVX(sstr));
10962 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10963 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10964 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
10965 if (HvARRAY((HV*)sstr)) {
10967 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
10968 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
10969 Newz(0, dxhv->xhv_array,
10970 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
10971 while (i <= sxhv->xhv_max) {
10972 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
10973 (bool)!!HvSHAREKEYS(sstr),
10977 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
10978 (bool)!!HvSHAREKEYS(sstr), param);
10981 SvPV_set(dstr, Nullch);
10982 HvEITER((HV*)dstr) = (HE*)NULL;
10984 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
10985 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
10986 /* Record stashes for possible cloning in Perl_clone(). */
10987 if(HvNAME((HV*)dstr))
10988 av_push(param->stashes, dstr);
10991 SvANY(dstr) = new_XPVFM();
10992 FmLINES(dstr) = FmLINES(sstr);
10996 SvANY(dstr) = new_XPVCV();
10998 SvCUR_set(dstr, SvCUR(sstr));
10999 SvLEN_set(dstr, SvLEN(sstr));
11000 SvIV_set(dstr, SvIVX(sstr));
11001 SvNV_set(dstr, SvNVX(sstr));
11002 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
11003 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
11004 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11005 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
11006 CvSTART(dstr) = CvSTART(sstr);
11008 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
11010 CvXSUB(dstr) = CvXSUB(sstr);
11011 CvXSUBANY(dstr) = CvXSUBANY(sstr);
11012 if (CvCONST(sstr)) {
11013 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
11014 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
11015 sv_dup_inc((SV *)CvXSUBANY(sstr).any_ptr, param);
11017 /* don't dup if copying back - CvGV isn't refcounted, so the
11018 * duped GV may never be freed. A bit of a hack! DAPM */
11019 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
11020 Nullgv : gv_dup(CvGV(sstr), param) ;
11021 if (param->flags & CLONEf_COPY_STACKS) {
11022 CvDEPTH(dstr) = CvDEPTH(sstr);
11026 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
11027 CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
11029 CvWEAKOUTSIDE(sstr)
11030 ? cv_dup( CvOUTSIDE(sstr), param)
11031 : cv_dup_inc(CvOUTSIDE(sstr), param);
11032 CvFLAGS(dstr) = CvFLAGS(sstr);
11033 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
11036 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11040 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
11046 /* duplicate a context */
11049 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
11051 PERL_CONTEXT *ncxs;
11054 return (PERL_CONTEXT*)NULL;
11056 /* look for it in the table first */
11057 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
11061 /* create anew and remember what it is */
11062 Newz(56, ncxs, max + 1, PERL_CONTEXT);
11063 ptr_table_store(PL_ptr_table, cxs, ncxs);
11066 PERL_CONTEXT *cx = &cxs[ix];
11067 PERL_CONTEXT *ncx = &ncxs[ix];
11068 ncx->cx_type = cx->cx_type;
11069 if (CxTYPE(cx) == CXt_SUBST) {
11070 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
11073 ncx->blk_oldsp = cx->blk_oldsp;
11074 ncx->blk_oldcop = cx->blk_oldcop;
11075 ncx->blk_oldmarksp = cx->blk_oldmarksp;
11076 ncx->blk_oldscopesp = cx->blk_oldscopesp;
11077 ncx->blk_oldpm = cx->blk_oldpm;
11078 ncx->blk_gimme = cx->blk_gimme;
11079 switch (CxTYPE(cx)) {
11081 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
11082 ? cv_dup_inc(cx->blk_sub.cv, param)
11083 : cv_dup(cx->blk_sub.cv,param));
11084 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
11085 ? av_dup_inc(cx->blk_sub.argarray, param)
11087 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
11088 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
11089 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
11090 ncx->blk_sub.lval = cx->blk_sub.lval;
11091 ncx->blk_sub.retop = cx->blk_sub.retop;
11094 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
11095 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
11096 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
11097 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
11098 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
11099 ncx->blk_eval.retop = cx->blk_eval.retop;
11102 ncx->blk_loop.label = cx->blk_loop.label;
11103 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
11104 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
11105 ncx->blk_loop.next_op = cx->blk_loop.next_op;
11106 ncx->blk_loop.last_op = cx->blk_loop.last_op;
11107 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
11108 ? cx->blk_loop.iterdata
11109 : gv_dup((GV*)cx->blk_loop.iterdata, param));
11110 ncx->blk_loop.oldcomppad
11111 = (PAD*)ptr_table_fetch(PL_ptr_table,
11112 cx->blk_loop.oldcomppad);
11113 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
11114 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
11115 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
11116 ncx->blk_loop.iterix = cx->blk_loop.iterix;
11117 ncx->blk_loop.itermax = cx->blk_loop.itermax;
11120 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
11121 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
11122 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
11123 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
11124 ncx->blk_sub.retop = cx->blk_sub.retop;
11136 /* duplicate a stack info structure */
11139 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11144 return (PERL_SI*)NULL;
11146 /* look for it in the table first */
11147 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11151 /* create anew and remember what it is */
11152 Newz(56, nsi, 1, PERL_SI);
11153 ptr_table_store(PL_ptr_table, si, nsi);
11155 nsi->si_stack = av_dup_inc(si->si_stack, param);
11156 nsi->si_cxix = si->si_cxix;
11157 nsi->si_cxmax = si->si_cxmax;
11158 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11159 nsi->si_type = si->si_type;
11160 nsi->si_prev = si_dup(si->si_prev, param);
11161 nsi->si_next = si_dup(si->si_next, param);
11162 nsi->si_markoff = si->si_markoff;
11167 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
11168 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
11169 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
11170 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
11171 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
11172 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
11173 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
11174 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
11175 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
11176 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
11177 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
11178 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
11179 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11180 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11183 #define pv_dup_inc(p) SAVEPV(p)
11184 #define pv_dup(p) SAVEPV(p)
11185 #define svp_dup_inc(p,pp) any_dup(p,pp)
11187 /* map any object to the new equivent - either something in the
11188 * ptr table, or something in the interpreter structure
11192 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
11197 return (void*)NULL;
11199 /* look for it in the table first */
11200 ret = ptr_table_fetch(PL_ptr_table, v);
11204 /* see if it is part of the interpreter structure */
11205 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11206 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11214 /* duplicate the save stack */
11217 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11219 ANY *ss = proto_perl->Tsavestack;
11220 I32 ix = proto_perl->Tsavestack_ix;
11221 I32 max = proto_perl->Tsavestack_max;
11234 void (*dptr) (void*);
11235 void (*dxptr) (pTHX_ void*);
11238 Newz(54, nss, max, ANY);
11242 TOPINT(nss,ix) = i;
11244 case SAVEt_ITEM: /* normal string */
11245 sv = (SV*)POPPTR(ss,ix);
11246 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11247 sv = (SV*)POPPTR(ss,ix);
11248 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11250 case SAVEt_SV: /* scalar reference */
11251 sv = (SV*)POPPTR(ss,ix);
11252 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11253 gv = (GV*)POPPTR(ss,ix);
11254 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11256 case SAVEt_GENERIC_PVREF: /* generic char* */
11257 c = (char*)POPPTR(ss,ix);
11258 TOPPTR(nss,ix) = pv_dup(c);
11259 ptr = POPPTR(ss,ix);
11260 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11262 case SAVEt_SHARED_PVREF: /* char* in shared space */
11263 c = (char*)POPPTR(ss,ix);
11264 TOPPTR(nss,ix) = savesharedpv(c);
11265 ptr = POPPTR(ss,ix);
11266 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11268 case SAVEt_GENERIC_SVREF: /* generic sv */
11269 case SAVEt_SVREF: /* scalar reference */
11270 sv = (SV*)POPPTR(ss,ix);
11271 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11272 ptr = POPPTR(ss,ix);
11273 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11275 case SAVEt_AV: /* array reference */
11276 av = (AV*)POPPTR(ss,ix);
11277 TOPPTR(nss,ix) = av_dup_inc(av, param);
11278 gv = (GV*)POPPTR(ss,ix);
11279 TOPPTR(nss,ix) = gv_dup(gv, param);
11281 case SAVEt_HV: /* hash reference */
11282 hv = (HV*)POPPTR(ss,ix);
11283 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11284 gv = (GV*)POPPTR(ss,ix);
11285 TOPPTR(nss,ix) = gv_dup(gv, param);
11287 case SAVEt_INT: /* int reference */
11288 ptr = POPPTR(ss,ix);
11289 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11290 intval = (int)POPINT(ss,ix);
11291 TOPINT(nss,ix) = intval;
11293 case SAVEt_LONG: /* long reference */
11294 ptr = POPPTR(ss,ix);
11295 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11296 longval = (long)POPLONG(ss,ix);
11297 TOPLONG(nss,ix) = longval;
11299 case SAVEt_I32: /* I32 reference */
11300 case SAVEt_I16: /* I16 reference */
11301 case SAVEt_I8: /* I8 reference */
11302 ptr = POPPTR(ss,ix);
11303 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11305 TOPINT(nss,ix) = i;
11307 case SAVEt_IV: /* IV reference */
11308 ptr = POPPTR(ss,ix);
11309 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11311 TOPIV(nss,ix) = iv;
11313 case SAVEt_SPTR: /* SV* reference */
11314 ptr = POPPTR(ss,ix);
11315 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11316 sv = (SV*)POPPTR(ss,ix);
11317 TOPPTR(nss,ix) = sv_dup(sv, param);
11319 case SAVEt_VPTR: /* random* reference */
11320 ptr = POPPTR(ss,ix);
11321 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11322 ptr = POPPTR(ss,ix);
11323 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11325 case SAVEt_PPTR: /* char* reference */
11326 ptr = POPPTR(ss,ix);
11327 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11328 c = (char*)POPPTR(ss,ix);
11329 TOPPTR(nss,ix) = pv_dup(c);
11331 case SAVEt_HPTR: /* HV* reference */
11332 ptr = POPPTR(ss,ix);
11333 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11334 hv = (HV*)POPPTR(ss,ix);
11335 TOPPTR(nss,ix) = hv_dup(hv, param);
11337 case SAVEt_APTR: /* AV* reference */
11338 ptr = POPPTR(ss,ix);
11339 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11340 av = (AV*)POPPTR(ss,ix);
11341 TOPPTR(nss,ix) = av_dup(av, param);
11344 gv = (GV*)POPPTR(ss,ix);
11345 TOPPTR(nss,ix) = gv_dup(gv, param);
11347 case SAVEt_GP: /* scalar reference */
11348 gp = (GP*)POPPTR(ss,ix);
11349 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11350 (void)GpREFCNT_inc(gp);
11351 gv = (GV*)POPPTR(ss,ix);
11352 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11353 c = (char*)POPPTR(ss,ix);
11354 TOPPTR(nss,ix) = pv_dup(c);
11356 TOPIV(nss,ix) = iv;
11358 TOPIV(nss,ix) = iv;
11361 case SAVEt_MORTALIZESV:
11362 sv = (SV*)POPPTR(ss,ix);
11363 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11366 ptr = POPPTR(ss,ix);
11367 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11368 /* these are assumed to be refcounted properly */
11369 switch (((OP*)ptr)->op_type) {
11371 case OP_LEAVESUBLV:
11375 case OP_LEAVEWRITE:
11376 TOPPTR(nss,ix) = ptr;
11381 TOPPTR(nss,ix) = Nullop;
11386 TOPPTR(nss,ix) = Nullop;
11389 c = (char*)POPPTR(ss,ix);
11390 TOPPTR(nss,ix) = pv_dup_inc(c);
11392 case SAVEt_CLEARSV:
11393 longval = POPLONG(ss,ix);
11394 TOPLONG(nss,ix) = longval;
11397 hv = (HV*)POPPTR(ss,ix);
11398 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11399 c = (char*)POPPTR(ss,ix);
11400 TOPPTR(nss,ix) = pv_dup_inc(c);
11402 TOPINT(nss,ix) = i;
11404 case SAVEt_DESTRUCTOR:
11405 ptr = POPPTR(ss,ix);
11406 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11407 dptr = POPDPTR(ss,ix);
11408 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
11410 case SAVEt_DESTRUCTOR_X:
11411 ptr = POPPTR(ss,ix);
11412 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11413 dxptr = POPDXPTR(ss,ix);
11414 TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
11416 case SAVEt_REGCONTEXT:
11419 TOPINT(nss,ix) = i;
11422 case SAVEt_STACK_POS: /* Position on Perl stack */
11424 TOPINT(nss,ix) = i;
11426 case SAVEt_AELEM: /* array element */
11427 sv = (SV*)POPPTR(ss,ix);
11428 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11430 TOPINT(nss,ix) = i;
11431 av = (AV*)POPPTR(ss,ix);
11432 TOPPTR(nss,ix) = av_dup_inc(av, param);
11434 case SAVEt_HELEM: /* hash element */
11435 sv = (SV*)POPPTR(ss,ix);
11436 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11437 sv = (SV*)POPPTR(ss,ix);
11438 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11439 hv = (HV*)POPPTR(ss,ix);
11440 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11443 ptr = POPPTR(ss,ix);
11444 TOPPTR(nss,ix) = ptr;
11448 TOPINT(nss,ix) = i;
11450 case SAVEt_COMPPAD:
11451 av = (AV*)POPPTR(ss,ix);
11452 TOPPTR(nss,ix) = av_dup(av, param);
11455 longval = (long)POPLONG(ss,ix);
11456 TOPLONG(nss,ix) = longval;
11457 ptr = POPPTR(ss,ix);
11458 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11459 sv = (SV*)POPPTR(ss,ix);
11460 TOPPTR(nss,ix) = sv_dup(sv, param);
11463 ptr = POPPTR(ss,ix);
11464 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11465 longval = (long)POPBOOL(ss,ix);
11466 TOPBOOL(nss,ix) = (bool)longval;
11468 case SAVEt_SET_SVFLAGS:
11470 TOPINT(nss,ix) = i;
11472 TOPINT(nss,ix) = i;
11473 sv = (SV*)POPPTR(ss,ix);
11474 TOPPTR(nss,ix) = sv_dup(sv, param);
11477 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
11485 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11486 * flag to the result. This is done for each stash before cloning starts,
11487 * so we know which stashes want their objects cloned */
11490 do_mark_cloneable_stash(pTHX_ SV *sv)
11492 if (HvNAME((HV*)sv)) {
11493 GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
11494 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11495 if (cloner && GvCV(cloner)) {
11502 XPUSHs(sv_2mortal(newSVpv(HvNAME((HV*)sv), 0)));
11504 call_sv((SV*)GvCV(cloner), G_SCALAR);
11511 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11519 =for apidoc perl_clone
11521 Create and return a new interpreter by cloning the current one.
11523 perl_clone takes these flags as parameters:
11525 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11526 without it we only clone the data and zero the stacks,
11527 with it we copy the stacks and the new perl interpreter is
11528 ready to run at the exact same point as the previous one.
11529 The pseudo-fork code uses COPY_STACKS while the
11530 threads->new doesn't.
11532 CLONEf_KEEP_PTR_TABLE
11533 perl_clone keeps a ptr_table with the pointer of the old
11534 variable as a key and the new variable as a value,
11535 this allows it to check if something has been cloned and not
11536 clone it again but rather just use the value and increase the
11537 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11538 the ptr_table using the function
11539 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11540 reason to keep it around is if you want to dup some of your own
11541 variable who are outside the graph perl scans, example of this
11542 code is in threads.xs create
11545 This is a win32 thing, it is ignored on unix, it tells perls
11546 win32host code (which is c++) to clone itself, this is needed on
11547 win32 if you want to run two threads at the same time,
11548 if you just want to do some stuff in a separate perl interpreter
11549 and then throw it away and return to the original one,
11550 you don't need to do anything.
11555 /* XXX the above needs expanding by someone who actually understands it ! */
11556 EXTERN_C PerlInterpreter *
11557 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11560 perl_clone(PerlInterpreter *proto_perl, UV flags)
11563 #ifdef PERL_IMPLICIT_SYS
11565 /* perlhost.h so we need to call into it
11566 to clone the host, CPerlHost should have a c interface, sky */
11568 if (flags & CLONEf_CLONE_HOST) {
11569 return perl_clone_host(proto_perl,flags);
11571 return perl_clone_using(proto_perl, flags,
11573 proto_perl->IMemShared,
11574 proto_perl->IMemParse,
11576 proto_perl->IStdIO,
11580 proto_perl->IProc);
11584 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11585 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11586 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11587 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11588 struct IPerlDir* ipD, struct IPerlSock* ipS,
11589 struct IPerlProc* ipP)
11591 /* XXX many of the string copies here can be optimized if they're
11592 * constants; they need to be allocated as common memory and just
11593 * their pointers copied. */
11596 CLONE_PARAMS clone_params;
11597 CLONE_PARAMS* param = &clone_params;
11599 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11600 /* for each stash, determine whether its objects should be cloned */
11601 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11602 PERL_SET_THX(my_perl);
11605 Poison(my_perl, 1, PerlInterpreter);
11607 PL_curcop = (COP *)Nullop;
11611 PL_savestack_ix = 0;
11612 PL_savestack_max = -1;
11613 PL_sig_pending = 0;
11614 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11615 # else /* !DEBUGGING */
11616 Zero(my_perl, 1, PerlInterpreter);
11617 # endif /* DEBUGGING */
11619 /* host pointers */
11621 PL_MemShared = ipMS;
11622 PL_MemParse = ipMP;
11629 #else /* !PERL_IMPLICIT_SYS */
11631 CLONE_PARAMS clone_params;
11632 CLONE_PARAMS* param = &clone_params;
11633 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11634 /* for each stash, determine whether its objects should be cloned */
11635 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11636 PERL_SET_THX(my_perl);
11639 Poison(my_perl, 1, PerlInterpreter);
11641 PL_curcop = (COP *)Nullop;
11645 PL_savestack_ix = 0;
11646 PL_savestack_max = -1;
11647 PL_sig_pending = 0;
11648 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11649 # else /* !DEBUGGING */
11650 Zero(my_perl, 1, PerlInterpreter);
11651 # endif /* DEBUGGING */
11652 #endif /* PERL_IMPLICIT_SYS */
11653 param->flags = flags;
11654 param->proto_perl = proto_perl;
11657 PL_xiv_arenaroot = NULL;
11658 PL_xiv_root = NULL;
11659 PL_xnv_arenaroot = NULL;
11660 PL_xnv_root = NULL;
11661 PL_xrv_arenaroot = NULL;
11662 PL_xrv_root = NULL;
11663 PL_xpv_arenaroot = NULL;
11664 PL_xpv_root = NULL;
11665 PL_xpviv_arenaroot = NULL;
11666 PL_xpviv_root = NULL;
11667 PL_xpvnv_arenaroot = NULL;
11668 PL_xpvnv_root = NULL;
11669 PL_xpvcv_arenaroot = NULL;
11670 PL_xpvcv_root = NULL;
11671 PL_xpvav_arenaroot = NULL;
11672 PL_xpvav_root = NULL;
11673 PL_xpvhv_arenaroot = NULL;
11674 PL_xpvhv_root = NULL;
11675 PL_xpvmg_arenaroot = NULL;
11676 PL_xpvmg_root = NULL;
11677 PL_xpvlv_arenaroot = NULL;
11678 PL_xpvlv_root = NULL;
11679 PL_xpvbm_arenaroot = NULL;
11680 PL_xpvbm_root = NULL;
11681 PL_he_arenaroot = NULL;
11683 PL_pte_arenaroot = NULL;
11684 PL_pte_root = NULL;
11685 PL_nice_chunk = NULL;
11686 PL_nice_chunk_size = 0;
11688 PL_sv_objcount = 0;
11689 PL_sv_root = Nullsv;
11690 PL_sv_arenaroot = Nullsv;
11692 PL_debug = proto_perl->Idebug;
11694 #ifdef USE_REENTRANT_API
11695 /* XXX: things like -Dm will segfault here in perlio, but doing
11696 * PERL_SET_CONTEXT(proto_perl);
11697 * breaks too many other things
11699 Perl_reentrant_init(aTHX);
11702 /* create SV map for pointer relocation */
11703 PL_ptr_table = ptr_table_new();
11705 /* initialize these special pointers as early as possible */
11706 SvANY(&PL_sv_undef) = NULL;
11707 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11708 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11709 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11711 SvANY(&PL_sv_no) = new_XPVNV();
11712 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11713 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11714 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11715 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
11716 SvCUR_set(&PL_sv_no, 0);
11717 SvLEN_set(&PL_sv_no, 1);
11718 SvIV_set(&PL_sv_no, 0);
11719 SvNV_set(&PL_sv_no, 0);
11720 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11722 SvANY(&PL_sv_yes) = new_XPVNV();
11723 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11724 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11725 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11726 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
11727 SvCUR_set(&PL_sv_yes, 1);
11728 SvLEN_set(&PL_sv_yes, 2);
11729 SvIV_set(&PL_sv_yes, 1);
11730 SvNV_set(&PL_sv_yes, 1);
11731 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11733 /* create (a non-shared!) shared string table */
11734 PL_strtab = newHV();
11735 HvSHAREKEYS_off(PL_strtab);
11736 hv_ksplit(PL_strtab, 512);
11737 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11739 PL_compiling = proto_perl->Icompiling;
11741 /* These two PVs will be free'd special way so must set them same way op.c does */
11742 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11743 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11745 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11746 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11748 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11749 if (!specialWARN(PL_compiling.cop_warnings))
11750 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
11751 if (!specialCopIO(PL_compiling.cop_io))
11752 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
11753 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
11755 /* pseudo environmental stuff */
11756 PL_origargc = proto_perl->Iorigargc;
11757 PL_origargv = proto_perl->Iorigargv;
11759 param->stashes = newAV(); /* Setup array of objects to call clone on */
11761 #ifdef PERLIO_LAYERS
11762 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11763 PerlIO_clone(aTHX_ proto_perl, param);
11766 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11767 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11768 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11769 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11770 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11771 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11774 PL_minus_c = proto_perl->Iminus_c;
11775 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11776 PL_localpatches = proto_perl->Ilocalpatches;
11777 PL_splitstr = proto_perl->Isplitstr;
11778 PL_preprocess = proto_perl->Ipreprocess;
11779 PL_minus_n = proto_perl->Iminus_n;
11780 PL_minus_p = proto_perl->Iminus_p;
11781 PL_minus_l = proto_perl->Iminus_l;
11782 PL_minus_a = proto_perl->Iminus_a;
11783 PL_minus_F = proto_perl->Iminus_F;
11784 PL_doswitches = proto_perl->Idoswitches;
11785 PL_dowarn = proto_perl->Idowarn;
11786 PL_doextract = proto_perl->Idoextract;
11787 PL_sawampersand = proto_perl->Isawampersand;
11788 PL_unsafe = proto_perl->Iunsafe;
11789 PL_inplace = SAVEPV(proto_perl->Iinplace);
11790 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11791 PL_perldb = proto_perl->Iperldb;
11792 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11793 PL_exit_flags = proto_perl->Iexit_flags;
11795 /* magical thingies */
11796 /* XXX time(&PL_basetime) when asked for? */
11797 PL_basetime = proto_perl->Ibasetime;
11798 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11800 PL_maxsysfd = proto_perl->Imaxsysfd;
11801 PL_multiline = proto_perl->Imultiline;
11802 PL_statusvalue = proto_perl->Istatusvalue;
11804 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11806 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11808 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11809 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11810 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11812 /* Clone the regex array */
11813 PL_regex_padav = newAV();
11815 I32 len = av_len((AV*)proto_perl->Iregex_padav);
11816 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11817 av_push(PL_regex_padav,
11818 sv_dup_inc(regexen[0],param));
11819 for(i = 1; i <= len; i++) {
11820 if(SvREPADTMP(regexen[i])) {
11821 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11823 av_push(PL_regex_padav,
11825 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11826 SvIVX(regexen[i])), param)))
11831 PL_regex_pad = AvARRAY(PL_regex_padav);
11833 /* shortcuts to various I/O objects */
11834 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11835 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11836 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11837 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11838 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11839 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11841 /* shortcuts to regexp stuff */
11842 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11844 /* shortcuts to misc objects */
11845 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11847 /* shortcuts to debugging objects */
11848 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11849 PL_DBline = gv_dup(proto_perl->IDBline, param);
11850 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11851 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11852 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11853 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11854 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11855 PL_lineary = av_dup(proto_perl->Ilineary, param);
11856 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11858 /* symbol tables */
11859 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11860 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11861 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11862 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11863 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11865 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11866 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11867 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11868 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11869 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11870 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11872 PL_sub_generation = proto_perl->Isub_generation;
11874 /* funky return mechanisms */
11875 PL_forkprocess = proto_perl->Iforkprocess;
11877 /* subprocess state */
11878 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11880 /* internal state */
11881 PL_tainting = proto_perl->Itainting;
11882 PL_taint_warn = proto_perl->Itaint_warn;
11883 PL_maxo = proto_perl->Imaxo;
11884 if (proto_perl->Iop_mask)
11885 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11887 PL_op_mask = Nullch;
11888 /* PL_asserting = proto_perl->Iasserting; */
11890 /* current interpreter roots */
11891 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11892 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11893 PL_main_start = proto_perl->Imain_start;
11894 PL_eval_root = proto_perl->Ieval_root;
11895 PL_eval_start = proto_perl->Ieval_start;
11897 /* runtime control stuff */
11898 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11899 PL_copline = proto_perl->Icopline;
11901 PL_filemode = proto_perl->Ifilemode;
11902 PL_lastfd = proto_perl->Ilastfd;
11903 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11906 PL_gensym = proto_perl->Igensym;
11907 PL_preambled = proto_perl->Ipreambled;
11908 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11909 PL_laststatval = proto_perl->Ilaststatval;
11910 PL_laststype = proto_perl->Ilaststype;
11911 PL_mess_sv = Nullsv;
11913 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11914 PL_ofmt = SAVEPV(proto_perl->Iofmt);
11916 /* interpreter atexit processing */
11917 PL_exitlistlen = proto_perl->Iexitlistlen;
11918 if (PL_exitlistlen) {
11919 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11920 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11923 PL_exitlist = (PerlExitListEntry*)NULL;
11924 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11925 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11926 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11928 PL_profiledata = NULL;
11929 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
11930 /* PL_rsfp_filters entries have fake IoDIRP() */
11931 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
11933 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11935 PAD_CLONE_VARS(proto_perl, param);
11937 #ifdef HAVE_INTERP_INTERN
11938 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11941 /* more statics moved here */
11942 PL_generation = proto_perl->Igeneration;
11943 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11945 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11946 PL_in_clean_all = proto_perl->Iin_clean_all;
11948 PL_uid = proto_perl->Iuid;
11949 PL_euid = proto_perl->Ieuid;
11950 PL_gid = proto_perl->Igid;
11951 PL_egid = proto_perl->Iegid;
11952 PL_nomemok = proto_perl->Inomemok;
11953 PL_an = proto_perl->Ian;
11954 PL_evalseq = proto_perl->Ievalseq;
11955 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11956 PL_origalen = proto_perl->Iorigalen;
11957 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11958 PL_osname = SAVEPV(proto_perl->Iosname);
11959 PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */
11960 PL_sighandlerp = proto_perl->Isighandlerp;
11963 PL_runops = proto_perl->Irunops;
11965 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11968 PL_cshlen = proto_perl->Icshlen;
11969 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
11972 PL_lex_state = proto_perl->Ilex_state;
11973 PL_lex_defer = proto_perl->Ilex_defer;
11974 PL_lex_expect = proto_perl->Ilex_expect;
11975 PL_lex_formbrack = proto_perl->Ilex_formbrack;
11976 PL_lex_dojoin = proto_perl->Ilex_dojoin;
11977 PL_lex_starts = proto_perl->Ilex_starts;
11978 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
11979 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
11980 PL_lex_op = proto_perl->Ilex_op;
11981 PL_lex_inpat = proto_perl->Ilex_inpat;
11982 PL_lex_inwhat = proto_perl->Ilex_inwhat;
11983 PL_lex_brackets = proto_perl->Ilex_brackets;
11984 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11985 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
11986 PL_lex_casemods = proto_perl->Ilex_casemods;
11987 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11988 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
11990 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11991 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
11992 PL_nexttoke = proto_perl->Inexttoke;
11994 /* XXX This is probably masking the deeper issue of why
11995 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11996 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11997 * (A little debugging with a watchpoint on it may help.)
11999 if (SvANY(proto_perl->Ilinestr)) {
12000 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
12001 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
12002 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12003 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
12004 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12005 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
12006 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12007 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
12008 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12011 PL_linestr = NEWSV(65,79);
12012 sv_upgrade(PL_linestr,SVt_PVIV);
12013 sv_setpvn(PL_linestr,"",0);
12014 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
12016 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12017 PL_pending_ident = proto_perl->Ipending_ident;
12018 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
12020 PL_expect = proto_perl->Iexpect;
12022 PL_multi_start = proto_perl->Imulti_start;
12023 PL_multi_end = proto_perl->Imulti_end;
12024 PL_multi_open = proto_perl->Imulti_open;
12025 PL_multi_close = proto_perl->Imulti_close;
12027 PL_error_count = proto_perl->Ierror_count;
12028 PL_subline = proto_perl->Isubline;
12029 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
12031 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
12032 if (SvANY(proto_perl->Ilinestr)) {
12033 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
12034 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12035 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
12036 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12037 PL_last_lop_op = proto_perl->Ilast_lop_op;
12040 PL_last_uni = SvPVX(PL_linestr);
12041 PL_last_lop = SvPVX(PL_linestr);
12042 PL_last_lop_op = 0;
12044 PL_in_my = proto_perl->Iin_my;
12045 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
12047 PL_cryptseen = proto_perl->Icryptseen;
12050 PL_hints = proto_perl->Ihints;
12052 PL_amagic_generation = proto_perl->Iamagic_generation;
12054 #ifdef USE_LOCALE_COLLATE
12055 PL_collation_ix = proto_perl->Icollation_ix;
12056 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
12057 PL_collation_standard = proto_perl->Icollation_standard;
12058 PL_collxfrm_base = proto_perl->Icollxfrm_base;
12059 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
12060 #endif /* USE_LOCALE_COLLATE */
12062 #ifdef USE_LOCALE_NUMERIC
12063 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
12064 PL_numeric_standard = proto_perl->Inumeric_standard;
12065 PL_numeric_local = proto_perl->Inumeric_local;
12066 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12067 #endif /* !USE_LOCALE_NUMERIC */
12069 /* utf8 character classes */
12070 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12071 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
12072 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12073 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12074 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
12075 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12076 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
12077 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
12078 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
12079 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
12080 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
12081 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
12082 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12083 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
12084 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
12085 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
12086 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
12087 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
12088 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
12089 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
12091 /* Did the locale setup indicate UTF-8? */
12092 PL_utf8locale = proto_perl->Iutf8locale;
12093 /* Unicode features (see perlrun/-C) */
12094 PL_unicode = proto_perl->Iunicode;
12096 /* Pre-5.8 signals control */
12097 PL_signals = proto_perl->Isignals;
12099 /* times() ticks per second */
12100 PL_clocktick = proto_perl->Iclocktick;
12102 /* Recursion stopper for PerlIO_find_layer */
12103 PL_in_load_module = proto_perl->Iin_load_module;
12105 /* sort() routine */
12106 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
12108 /* Not really needed/useful since the reenrant_retint is "volatile",
12109 * but do it for consistency's sake. */
12110 PL_reentrant_retint = proto_perl->Ireentrant_retint;
12112 /* Hooks to shared SVs and locks. */
12113 PL_sharehook = proto_perl->Isharehook;
12114 PL_lockhook = proto_perl->Ilockhook;
12115 PL_unlockhook = proto_perl->Iunlockhook;
12116 PL_threadhook = proto_perl->Ithreadhook;
12118 PL_runops_std = proto_perl->Irunops_std;
12119 PL_runops_dbg = proto_perl->Irunops_dbg;
12121 #ifdef THREADS_HAVE_PIDS
12122 PL_ppid = proto_perl->Ippid;
12126 PL_last_swash_hv = Nullhv; /* reinits on demand */
12127 PL_last_swash_klen = 0;
12128 PL_last_swash_key[0]= '\0';
12129 PL_last_swash_tmps = (U8*)NULL;
12130 PL_last_swash_slen = 0;
12132 PL_glob_index = proto_perl->Iglob_index;
12133 PL_srand_called = proto_perl->Isrand_called;
12134 PL_hash_seed = proto_perl->Ihash_seed;
12135 PL_rehash_seed = proto_perl->Irehash_seed;
12136 PL_uudmap['M'] = 0; /* reinits on demand */
12137 PL_bitcount = Nullch; /* reinits on demand */
12139 if (proto_perl->Ipsig_pend) {
12140 Newz(0, PL_psig_pend, SIG_SIZE, int);
12143 PL_psig_pend = (int*)NULL;
12146 if (proto_perl->Ipsig_ptr) {
12147 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
12148 Newz(0, PL_psig_name, SIG_SIZE, SV*);
12149 for (i = 1; i < SIG_SIZE; i++) {
12150 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
12151 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
12155 PL_psig_ptr = (SV**)NULL;
12156 PL_psig_name = (SV**)NULL;
12159 /* thrdvar.h stuff */
12161 if (flags & CLONEf_COPY_STACKS) {
12162 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12163 PL_tmps_ix = proto_perl->Ttmps_ix;
12164 PL_tmps_max = proto_perl->Ttmps_max;
12165 PL_tmps_floor = proto_perl->Ttmps_floor;
12166 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
12168 while (i <= PL_tmps_ix) {
12169 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
12173 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12174 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
12175 Newz(54, PL_markstack, i, I32);
12176 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
12177 - proto_perl->Tmarkstack);
12178 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
12179 - proto_perl->Tmarkstack);
12180 Copy(proto_perl->Tmarkstack, PL_markstack,
12181 PL_markstack_ptr - PL_markstack + 1, I32);
12183 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12184 * NOTE: unlike the others! */
12185 PL_scopestack_ix = proto_perl->Tscopestack_ix;
12186 PL_scopestack_max = proto_perl->Tscopestack_max;
12187 Newz(54, PL_scopestack, PL_scopestack_max, I32);
12188 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
12190 /* NOTE: si_dup() looks at PL_markstack */
12191 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
12193 /* PL_curstack = PL_curstackinfo->si_stack; */
12194 PL_curstack = av_dup(proto_perl->Tcurstack, param);
12195 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
12197 /* next PUSHs() etc. set *(PL_stack_sp+1) */
12198 PL_stack_base = AvARRAY(PL_curstack);
12199 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
12200 - proto_perl->Tstack_base);
12201 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
12203 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12204 * NOTE: unlike the others! */
12205 PL_savestack_ix = proto_perl->Tsavestack_ix;
12206 PL_savestack_max = proto_perl->Tsavestack_max;
12207 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
12208 PL_savestack = ss_dup(proto_perl, param);
12212 ENTER; /* perl_destruct() wants to LEAVE; */
12215 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
12216 PL_top_env = &PL_start_env;
12218 PL_op = proto_perl->Top;
12221 PL_Xpv = (XPV*)NULL;
12222 PL_na = proto_perl->Tna;
12224 PL_statbuf = proto_perl->Tstatbuf;
12225 PL_statcache = proto_perl->Tstatcache;
12226 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
12227 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
12229 PL_timesbuf = proto_perl->Ttimesbuf;
12232 PL_tainted = proto_perl->Ttainted;
12233 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
12234 PL_rs = sv_dup_inc(proto_perl->Trs, param);
12235 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
12236 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
12237 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
12238 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
12239 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
12240 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
12241 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
12243 PL_restartop = proto_perl->Trestartop;
12244 PL_in_eval = proto_perl->Tin_eval;
12245 PL_delaymagic = proto_perl->Tdelaymagic;
12246 PL_dirty = proto_perl->Tdirty;
12247 PL_localizing = proto_perl->Tlocalizing;
12249 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
12250 PL_hv_fetch_ent_mh = Nullhe;
12251 PL_modcount = proto_perl->Tmodcount;
12252 PL_lastgotoprobe = Nullop;
12253 PL_dumpindent = proto_perl->Tdumpindent;
12255 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
12256 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
12257 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
12258 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
12259 PL_sortcxix = proto_perl->Tsortcxix;
12260 PL_efloatbuf = Nullch; /* reinits on demand */
12261 PL_efloatsize = 0; /* reinits on demand */
12265 PL_screamfirst = NULL;
12266 PL_screamnext = NULL;
12267 PL_maxscream = -1; /* reinits on demand */
12268 PL_lastscream = Nullsv;
12270 PL_watchaddr = NULL;
12271 PL_watchok = Nullch;
12273 PL_regdummy = proto_perl->Tregdummy;
12274 PL_regprecomp = Nullch;
12277 PL_colorset = 0; /* reinits PL_colors[] */
12278 /*PL_colors[6] = {0,0,0,0,0,0};*/
12279 PL_reginput = Nullch;
12280 PL_regbol = Nullch;
12281 PL_regeol = Nullch;
12282 PL_regstartp = (I32*)NULL;
12283 PL_regendp = (I32*)NULL;
12284 PL_reglastparen = (U32*)NULL;
12285 PL_reglastcloseparen = (U32*)NULL;
12286 PL_regtill = Nullch;
12287 PL_reg_start_tmp = (char**)NULL;
12288 PL_reg_start_tmpl = 0;
12289 PL_regdata = (struct reg_data*)NULL;
12292 PL_reg_eval_set = 0;
12294 PL_regprogram = (regnode*)NULL;
12296 PL_regcc = (CURCUR*)NULL;
12297 PL_reg_call_cc = (struct re_cc_state*)NULL;
12298 PL_reg_re = (regexp*)NULL;
12299 PL_reg_ganch = Nullch;
12300 PL_reg_sv = Nullsv;
12301 PL_reg_match_utf8 = FALSE;
12302 PL_reg_magic = (MAGIC*)NULL;
12304 PL_reg_oldcurpm = (PMOP*)NULL;
12305 PL_reg_curpm = (PMOP*)NULL;
12306 PL_reg_oldsaved = Nullch;
12307 PL_reg_oldsavedlen = 0;
12308 #ifdef PERL_COPY_ON_WRITE
12311 PL_reg_maxiter = 0;
12312 PL_reg_leftiter = 0;
12313 PL_reg_poscache = Nullch;
12314 PL_reg_poscache_size= 0;
12316 /* RE engine - function pointers */
12317 PL_regcompp = proto_perl->Tregcompp;
12318 PL_regexecp = proto_perl->Tregexecp;
12319 PL_regint_start = proto_perl->Tregint_start;
12320 PL_regint_string = proto_perl->Tregint_string;
12321 PL_regfree = proto_perl->Tregfree;
12323 PL_reginterp_cnt = 0;
12324 PL_reg_starttry = 0;
12326 /* Pluggable optimizer */
12327 PL_peepp = proto_perl->Tpeepp;
12329 PL_stashcache = newHV();
12331 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12332 ptr_table_free(PL_ptr_table);
12333 PL_ptr_table = NULL;
12336 /* Call the ->CLONE method, if it exists, for each of the stashes
12337 identified by sv_dup() above.
12339 while(av_len(param->stashes) != -1) {
12340 HV* stash = (HV*) av_shift(param->stashes);
12341 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12342 if (cloner && GvCV(cloner)) {
12347 XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
12349 call_sv((SV*)GvCV(cloner), G_DISCARD);
12355 SvREFCNT_dec(param->stashes);
12360 #endif /* USE_ITHREADS */
12363 =head1 Unicode Support
12365 =for apidoc sv_recode_to_utf8
12367 The encoding is assumed to be an Encode object, on entry the PV
12368 of the sv is assumed to be octets in that encoding, and the sv
12369 will be converted into Unicode (and UTF-8).
12371 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12372 is not a reference, nothing is done to the sv. If the encoding is not
12373 an C<Encode::XS> Encoding object, bad things will happen.
12374 (See F<lib/encoding.pm> and L<Encode>).
12376 The PV of the sv is returned.
12381 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12384 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12398 Passing sv_yes is wrong - it needs to be or'ed set of constants
12399 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12400 remove converted chars from source.
12402 Both will default the value - let them.
12404 XPUSHs(&PL_sv_yes);
12407 call_method("decode", G_SCALAR);
12411 s = SvPV(uni, len);
12412 if (s != SvPVX(sv)) {
12413 SvGROW(sv, len + 1);
12414 Move(s, SvPVX(sv), len, char);
12415 SvCUR_set(sv, len);
12416 SvPVX(sv)[len] = 0;
12423 return SvPOKp(sv) ? SvPVX(sv) : NULL;
12427 =for apidoc sv_cat_decode
12429 The encoding is assumed to be an Encode object, the PV of the ssv is
12430 assumed to be octets in that encoding and decoding the input starts
12431 from the position which (PV + *offset) pointed to. The dsv will be
12432 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
12433 when the string tstr appears in decoding output or the input ends on
12434 the PV of the ssv. The value which the offset points will be modified
12435 to the last input position on the ssv.
12437 Returns TRUE if the terminator was found, else returns FALSE.
12442 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12443 SV *ssv, int *offset, char *tstr, int tlen)
12447 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12458 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
12459 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
12461 call_method("cat_decode", G_SCALAR);
12463 ret = SvTRUE(TOPs);
12464 *offset = SvIV(offsv);
12470 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12476 * c-indentation-style: bsd
12477 * c-basic-offset: 4
12478 * indent-tabs-mode: t
12481 * vim: shiftwidth=4: