3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
9 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
12 * This file contains the code that creates, manipulates and destroys
13 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
14 * structure of an SV, so their creation and destruction is handled
15 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
16 * level functions (eg. substr, split, join) for each of the types are
28 /* Missing proto on LynxOS */
29 char *gconvert(double, int, int, char *);
32 #ifdef PERL_UTF8_CACHE_ASSERT
33 /* The cache element 0 is the Unicode offset;
34 * the cache element 1 is the byte offset of the element 0;
35 * the cache element 2 is the Unicode length of the substring;
36 * the cache element 3 is the byte length of the substring;
37 * The checking of the substring side would be good
38 * but substr() has enough code paths to make my head spin;
39 * if adding more checks watch out for the following tests:
40 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
41 * lib/utf8.t lib/Unicode/Collate/t/index.t
44 #define ASSERT_UTF8_CACHE(cache) \
45 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
47 #define ASSERT_UTF8_CACHE(cache) NOOP
50 #ifdef PERL_OLD_COPY_ON_WRITE
51 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
52 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
53 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
57 /* ============================================================================
59 =head1 Allocation and deallocation of SVs.
61 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
62 av, hv...) contains type and reference count information, as well as a
63 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
64 specific to each type.
66 Normally, this allocation is done using arenas, which by default are
67 approximately 4K chunks of memory parcelled up into N heads or bodies. The
68 first slot in each arena is reserved, and is used to hold a link to the next
69 arena. In the case of heads, the unused first slot also contains some flags
70 and a note of the number of slots. Snaked through each arena chain is a
71 linked list of free items; when this becomes empty, an extra arena is
72 allocated and divided up into N items which are threaded into the free list.
74 The following global variables are associated with arenas:
76 PL_sv_arenaroot pointer to list of SV arenas
77 PL_sv_root pointer to list of free SV structures
79 PL_foo_arenaroot pointer to list of foo arenas,
80 PL_foo_root pointer to list of free foo bodies
81 ... for foo in xiv, xnv, xrv, xpv etc.
83 Note that some of the larger and more rarely used body types (eg xpvio)
84 are not allocated using arenas, but are instead just malloc()/free()ed as
85 required. Also, if PURIFY is defined, arenas are abandoned altogether,
86 with all items individually malloc()ed. In addition, a few SV heads are
87 not allocated from an arena, but are instead directly created as static
88 or auto variables, eg PL_sv_undef. The size of arenas can be changed from
89 the default by setting PERL_ARENA_SIZE appropriately at compile time.
91 The SV arena serves the secondary purpose of allowing still-live SVs
92 to be located and destroyed during final cleanup.
94 At the lowest level, the macros new_SV() and del_SV() grab and free
95 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
96 to return the SV to the free list with error checking.) new_SV() calls
97 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
98 SVs in the free list have their SvTYPE field set to all ones.
100 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
101 that allocate and return individual body types. Normally these are mapped
102 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
103 instead mapped directly to malloc()/free() if PURIFY is defined. The
104 new/del functions remove from, or add to, the appropriate PL_foo_root
105 list, and call more_xiv() etc to add a new arena if the list is empty.
107 At the time of very final cleanup, sv_free_arenas() is called from
108 perl_destruct() to physically free all the arenas allocated since the
109 start of the interpreter. Note that this also clears PL_he_arenaroot,
110 which is otherwise dealt with in hv.c.
112 Manipulation of any of the PL_*root pointers is protected by enclosing
113 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
114 if threads are enabled.
116 The function visit() scans the SV arenas list, and calls a specified
117 function for each SV it finds which is still live - ie which has an SvTYPE
118 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
119 following functions (specified as [function that calls visit()] / [function
120 called by visit() for each SV]):
122 sv_report_used() / do_report_used()
123 dump all remaining SVs (debugging aid)
125 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
126 Attempt to free all objects pointed to by RVs,
127 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
128 try to do the same for all objects indirectly
129 referenced by typeglobs too. Called once from
130 perl_destruct(), prior to calling sv_clean_all()
133 sv_clean_all() / do_clean_all()
134 SvREFCNT_dec(sv) each remaining SV, possibly
135 triggering an sv_free(). It also sets the
136 SVf_BREAK flag on the SV to indicate that the
137 refcnt has been artificially lowered, and thus
138 stopping sv_free() from giving spurious warnings
139 about SVs which unexpectedly have a refcnt
140 of zero. called repeatedly from perl_destruct()
141 until there are no SVs left.
145 Private API to rest of sv.c
149 new_XIV(), del_XIV(),
150 new_XNV(), del_XNV(),
155 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
160 ============================================================================ */
165 * "A time to plant, and a time to uproot what was planted..."
169 #ifdef DEBUG_LEAKING_SCALARS
171 # define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
173 # define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file)
176 # define FREE_SV_DEBUG_FILE(sv)
179 #define plant_SV(p) \
181 FREE_SV_DEBUG_FILE(p); \
182 SvANY(p) = (void *)PL_sv_root; \
183 SvFLAGS(p) = SVTYPEMASK; \
188 /* sv_mutex must be held while calling uproot_SV() */
189 #define uproot_SV(p) \
192 PL_sv_root = (SV*)SvANY(p); \
197 /* make some more SVs by adding another arena */
199 /* sv_mutex must be held while calling more_sv() */
206 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
207 PL_nice_chunk = Nullch;
208 PL_nice_chunk_size = 0;
211 char *chunk; /* must use New here to match call to */
212 New(704,chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
213 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
219 /* new_SV(): return a new, empty SV head */
221 #ifdef DEBUG_LEAKING_SCALARS
222 /* provide a real function for a debugger to play with */
232 sv = S_more_sv(aTHX);
237 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
238 sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
239 (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
240 sv->sv_debug_inpad = 0;
241 sv->sv_debug_cloned = 0;
243 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
245 sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
250 # define new_SV(p) (p)=S_new_SV(aTHX)
259 (p) = S_more_sv(aTHX); \
268 /* del_SV(): return an empty SV head to the free list */
283 S_del_sv(pTHX_ SV *p)
288 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
290 SV *svend = &sva[SvREFCNT(sva)];
291 if (p >= sv && p < svend) {
297 if (ckWARN_d(WARN_INTERNAL))
298 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
299 "Attempt to free non-arena SV: 0x%"UVxf
300 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
307 #else /* ! DEBUGGING */
309 #define del_SV(p) plant_SV(p)
311 #endif /* DEBUGGING */
315 =head1 SV Manipulation Functions
317 =for apidoc sv_add_arena
319 Given a chunk of memory, link it to the head of the list of arenas,
320 and split it into a list of free SVs.
326 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
332 /* The first SV in an arena isn't an SV. */
333 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
334 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
335 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
337 PL_sv_arenaroot = sva;
338 PL_sv_root = sva + 1;
340 svend = &sva[SvREFCNT(sva) - 1];
343 SvANY(sv) = (void *)(SV*)(sv + 1);
347 /* Must always set typemask because it's awlays checked in on cleanup
348 when the arenas are walked looking for objects. */
349 SvFLAGS(sv) = SVTYPEMASK;
356 SvFLAGS(sv) = SVTYPEMASK;
359 /* visit(): call the named function for each non-free SV in the arenas
360 * whose flags field matches the flags/mask args. */
363 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
368 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
369 register SV * const svend = &sva[SvREFCNT(sva)];
371 for (sv = sva + 1; sv < svend; ++sv) {
372 if (SvTYPE(sv) != SVTYPEMASK
373 && (sv->sv_flags & mask) == flags
386 /* called by sv_report_used() for each live SV */
389 do_report_used(pTHX_ SV *sv)
391 if (SvTYPE(sv) != SVTYPEMASK) {
392 PerlIO_printf(Perl_debug_log, "****\n");
399 =for apidoc sv_report_used
401 Dump the contents of all SVs not yet freed. (Debugging aid).
407 Perl_sv_report_used(pTHX)
410 visit(do_report_used, 0, 0);
414 /* called by sv_clean_objs() for each live SV */
417 do_clean_objs(pTHX_ SV *sv)
421 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
422 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
434 /* XXX Might want to check arrays, etc. */
437 /* called by sv_clean_objs() for each live SV */
439 #ifndef DISABLE_DESTRUCTOR_KLUDGE
441 do_clean_named_objs(pTHX_ SV *sv)
443 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
444 if ( SvOBJECT(GvSV(sv)) ||
445 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
446 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
447 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
448 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
450 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
451 SvFLAGS(sv) |= SVf_BREAK;
459 =for apidoc sv_clean_objs
461 Attempt to destroy all objects not yet freed
467 Perl_sv_clean_objs(pTHX)
469 PL_in_clean_objs = TRUE;
470 visit(do_clean_objs, SVf_ROK, SVf_ROK);
471 #ifndef DISABLE_DESTRUCTOR_KLUDGE
472 /* some barnacles may yet remain, clinging to typeglobs */
473 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
475 PL_in_clean_objs = FALSE;
478 /* called by sv_clean_all() for each live SV */
481 do_clean_all(pTHX_ SV *sv)
483 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
484 SvFLAGS(sv) |= SVf_BREAK;
485 if (PL_comppad == (AV*)sv) {
487 PL_curpad = Null(SV**);
493 =for apidoc sv_clean_all
495 Decrement the refcnt of each remaining SV, possibly triggering a
496 cleanup. This function may have to be called multiple times to free
497 SVs which are in complex self-referential hierarchies.
503 Perl_sv_clean_all(pTHX)
506 PL_in_clean_all = TRUE;
507 cleaned = visit(do_clean_all, 0,0);
508 PL_in_clean_all = FALSE;
513 =for apidoc sv_free_arenas
515 Deallocate the memory used by all arenas. Note that all the individual SV
516 heads and bodies within the arenas must already have been freed.
522 Perl_sv_free_arenas(pTHX)
526 void *arena, *arenanext;
528 /* Free arenas here, but be careful about fake ones. (We assume
529 contiguity of the fake ones with the corresponding real ones.) */
531 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
532 svanext = (SV*) SvANY(sva);
533 while (svanext && SvFAKE(svanext))
534 svanext = (SV*) SvANY(svanext);
540 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
541 arenanext = *(void **)arena;
544 PL_xnv_arenaroot = 0;
547 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
548 arenanext = *(void **)arena;
551 PL_xpv_arenaroot = 0;
554 for (arena = PL_xpviv_arenaroot; arena; arena = arenanext) {
555 arenanext = *(void **)arena;
558 PL_xpviv_arenaroot = 0;
561 for (arena = PL_xpvnv_arenaroot; arena; arena = arenanext) {
562 arenanext = *(void **)arena;
565 PL_xpvnv_arenaroot = 0;
568 for (arena = PL_xpvcv_arenaroot; arena; arena = arenanext) {
569 arenanext = *(void **)arena;
572 PL_xpvcv_arenaroot = 0;
575 for (arena = PL_xpvav_arenaroot; arena; arena = arenanext) {
576 arenanext = *(void **)arena;
579 PL_xpvav_arenaroot = 0;
582 for (arena = PL_xpvhv_arenaroot; arena; arena = arenanext) {
583 arenanext = *(void **)arena;
586 PL_xpvhv_arenaroot = 0;
589 for (arena = PL_xpvmg_arenaroot; arena; arena = arenanext) {
590 arenanext = *(void **)arena;
593 PL_xpvmg_arenaroot = 0;
596 for (arena = PL_xpvgv_arenaroot; arena; arena = arenanext) {
597 arenanext = *(void **)arena;
600 PL_xpvgv_arenaroot = 0;
603 for (arena = PL_xpvlv_arenaroot; arena; arena = arenanext) {
604 arenanext = *(void **)arena;
607 PL_xpvlv_arenaroot = 0;
610 for (arena = PL_xpvbm_arenaroot; arena; arena = arenanext) {
611 arenanext = *(void **)arena;
614 PL_xpvbm_arenaroot = 0;
620 for (he = PL_he_arenaroot; he; he = he_next) {
621 he_next = HeNEXT(he);
628 #if defined(USE_ITHREADS)
630 struct ptr_tbl_ent *pte;
631 struct ptr_tbl_ent *pte_next;
632 for (pte = PL_pte_arenaroot; pte; pte = pte_next) {
633 pte_next = pte->next;
637 PL_pte_arenaroot = 0;
642 Safefree(PL_nice_chunk);
643 PL_nice_chunk = Nullch;
644 PL_nice_chunk_size = 0;
649 /* ---------------------------------------------------------------------
651 * support functions for report_uninit()
654 /* the maxiumum size of array or hash where we will scan looking
655 * for the undefined element that triggered the warning */
657 #define FUV_MAX_SEARCH_SIZE 1000
659 /* Look for an entry in the hash whose value has the same SV as val;
660 * If so, return a mortal copy of the key. */
663 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
669 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
670 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
675 for (i=HvMAX(hv); i>0; i--) {
677 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
678 if (HeVAL(entry) != val)
680 if ( HeVAL(entry) == &PL_sv_undef ||
681 HeVAL(entry) == &PL_sv_placeholder)
685 if (HeKLEN(entry) == HEf_SVKEY)
686 return sv_mortalcopy(HeKEY_sv(entry));
687 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
693 /* Look for an entry in the array whose value has the same SV as val;
694 * If so, return the index, otherwise return -1. */
697 S_find_array_subscript(pTHX_ AV *av, SV* val)
701 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
702 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
706 for (i=AvFILLp(av); i>=0; i--) {
707 if (svp[i] == val && svp[i] != &PL_sv_undef)
713 /* S_varname(): return the name of a variable, optionally with a subscript.
714 * If gv is non-zero, use the name of that global, along with gvtype (one
715 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
716 * targ. Depending on the value of the subscript_type flag, return:
719 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
720 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
721 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
722 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
725 S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ,
726 SV* keyname, I32 aindex, int subscript_type)
731 SV * const name = sv_newmortal();
734 /* simulate gv_fullname4(), but add literal '^' for $^FOO names
735 * XXX get rid of all this if gv_fullnameX() ever supports this
739 HV *hv = GvSTASH(gv);
740 sv_setpv(name, gvtype);
743 else if (!(p=HvNAME_get(hv)))
745 if (strNE(p, "main")) {
747 sv_catpvn(name,"::", 2);
749 if (GvNAMELEN(gv)>= 1 &&
750 ((unsigned int)*GvNAME(gv)) <= 26)
752 Perl_sv_catpvf(aTHX_ name,"^%c", *GvNAME(gv) + 'A' - 1);
753 sv_catpvn(name,GvNAME(gv)+1,GvNAMELEN(gv)-1);
756 sv_catpvn(name,GvNAME(gv),GvNAMELEN(gv));
760 CV *cv = find_runcv(&u);
761 if (!cv || !CvPADLIST(cv))
763 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
764 sv = *av_fetch(av, targ, FALSE);
765 /* SvLEN in a pad name is not to be trusted */
766 sv_setpv(name, SvPV_nolen_const(sv));
769 if (subscript_type == FUV_SUBSCRIPT_HASH) {
772 Perl_sv_catpvf(aTHX_ name, "{%s}",
773 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
776 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
778 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
780 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
781 sv_insert(name, 0, 0, "within ", 7);
788 =for apidoc find_uninit_var
790 Find the name of the undefined variable (if any) that caused the operator o
791 to issue a "Use of uninitialized value" warning.
792 If match is true, only return a name if it's value matches uninit_sv.
793 So roughly speaking, if a unary operator (such as OP_COS) generates a
794 warning, then following the direct child of the op may yield an
795 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
796 other hand, with OP_ADD there are two branches to follow, so we only print
797 the variable name if we get an exact match.
799 The name is returned as a mortal SV.
801 Assumes that PL_op is the op that originally triggered the error, and that
802 PL_comppad/PL_curpad points to the currently executing pad.
808 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
817 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
818 uninit_sv == &PL_sv_placeholder)))
821 switch (obase->op_type) {
828 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
829 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
832 int subscript_type = FUV_SUBSCRIPT_WITHIN;
834 if (pad) { /* @lex, %lex */
835 sv = PAD_SVl(obase->op_targ);
839 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
840 /* @global, %global */
841 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
844 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
846 else /* @{expr}, %{expr} */
847 return find_uninit_var(cUNOPx(obase)->op_first,
851 /* attempt to find a match within the aggregate */
853 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
855 subscript_type = FUV_SUBSCRIPT_HASH;
858 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
860 subscript_type = FUV_SUBSCRIPT_ARRAY;
863 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
866 return S_varname(aTHX_ gv, hash ? "%" : "@", obase->op_targ,
867 keysv, index, subscript_type);
871 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
873 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
874 Nullsv, 0, FUV_SUBSCRIPT_NONE);
877 gv = cGVOPx_gv(obase);
878 if (!gv || (match && GvSV(gv) != uninit_sv))
880 return S_varname(aTHX_ gv, "$", 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
883 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
885 av = (AV*)PAD_SV(obase->op_targ);
886 if (!av || SvRMAGICAL(av))
888 svp = av_fetch(av, (I32)obase->op_private, FALSE);
889 if (!svp || *svp != uninit_sv)
892 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
893 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
896 gv = cGVOPx_gv(obase);
901 if (!av || SvRMAGICAL(av))
903 svp = av_fetch(av, (I32)obase->op_private, FALSE);
904 if (!svp || *svp != uninit_sv)
907 return S_varname(aTHX_ gv, "$", 0,
908 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
913 o = cUNOPx(obase)->op_first;
914 if (!o || o->op_type != OP_NULL ||
915 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
917 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
922 /* $a[uninit_expr] or $h{uninit_expr} */
923 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
926 o = cBINOPx(obase)->op_first;
927 kid = cBINOPx(obase)->op_last;
929 /* get the av or hv, and optionally the gv */
931 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
932 sv = PAD_SV(o->op_targ);
934 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
935 && cUNOPo->op_first->op_type == OP_GV)
937 gv = cGVOPx_gv(cUNOPo->op_first);
940 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
945 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
946 /* index is constant */
950 if (obase->op_type == OP_HELEM) {
951 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
952 if (!he || HeVAL(he) != uninit_sv)
956 svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
957 if (!svp || *svp != uninit_sv)
961 if (obase->op_type == OP_HELEM)
962 return S_varname(aTHX_ gv, "%", o->op_targ,
963 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
965 return S_varname(aTHX_ gv, "@", o->op_targ, Nullsv,
966 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
970 /* index is an expression;
971 * attempt to find a match within the aggregate */
972 if (obase->op_type == OP_HELEM) {
973 SV *keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
975 return S_varname(aTHX_ gv, "%", o->op_targ,
976 keysv, 0, FUV_SUBSCRIPT_HASH);
979 const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
981 return S_varname(aTHX_ gv, "@", o->op_targ,
982 Nullsv, index, FUV_SUBSCRIPT_ARRAY);
986 return S_varname(aTHX_ gv,
987 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
989 o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
995 /* only examine RHS */
996 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
999 o = cUNOPx(obase)->op_first;
1000 if (o->op_type == OP_PUSHMARK)
1003 if (!o->op_sibling) {
1004 /* one-arg version of open is highly magical */
1006 if (o->op_type == OP_GV) { /* open FOO; */
1008 if (match && GvSV(gv) != uninit_sv)
1010 return S_varname(aTHX_ gv, "$", 0,
1011 Nullsv, 0, FUV_SUBSCRIPT_NONE);
1013 /* other possibilities not handled are:
1014 * open $x; or open my $x; should return '${*$x}'
1015 * open expr; should return '$'.expr ideally
1021 /* ops where $_ may be an implicit arg */
1025 if ( !(obase->op_flags & OPf_STACKED)) {
1026 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
1027 ? PAD_SVl(obase->op_targ)
1030 sv = sv_newmortal();
1031 sv_setpvn(sv, "$_", 2);
1039 /* skip filehandle as it can't produce 'undef' warning */
1040 o = cUNOPx(obase)->op_first;
1041 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
1042 o = o->op_sibling->op_sibling;
1049 match = 1; /* XS or custom code could trigger random warnings */
1054 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
1055 return sv_2mortal(newSVpv("${$/}", 0));
1060 if (!(obase->op_flags & OPf_KIDS))
1062 o = cUNOPx(obase)->op_first;
1068 /* if all except one arg are constant, or have no side-effects,
1069 * or are optimized away, then it's unambiguous */
1071 for (kid=o; kid; kid = kid->op_sibling) {
1073 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
1074 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
1075 || (kid->op_type == OP_PUSHMARK)
1079 if (o2) { /* more than one found */
1086 return find_uninit_var(o2, uninit_sv, match);
1090 sv = find_uninit_var(o, uninit_sv, 1);
1102 =for apidoc report_uninit
1104 Print appropriate "Use of uninitialized variable" warning
1110 Perl_report_uninit(pTHX_ SV* uninit_sv)
1113 SV* varname = Nullsv;
1115 varname = find_uninit_var(PL_op, uninit_sv,0);
1117 sv_insert(varname, 0, 0, " ", 1);
1119 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1120 varname ? SvPV_nolen_const(varname) : "",
1121 " in ", OP_DESC(PL_op));
1124 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1129 S_more_bodies (pTHX_ void **arena_root, void **root, size_t size)
1133 size_t count = PERL_ARENA_SIZE/size;
1134 New(0, start, count*size, char);
1135 *((void **) start) = *arena_root;
1136 *arena_root = (void *)start;
1138 end = start + (count-1) * size;
1140 /* The initial slot is used to link the arenas together, so it isn't to be
1141 linked into the list of ready-to-use bodies. */
1145 *root = (void *)start;
1147 while (start < end) {
1148 char *next = start + size;
1149 *(void**) start = (void *)next;
1152 *(void **)start = 0;
1157 /* grab a new thing from the free list, allocating more if necessary */
1160 S_new_body(pTHX_ void **arena_root, void **root, size_t size, size_t offset)
1164 xpv = *root ? *root : S_more_bodies(aTHX_ arena_root, root, size);
1165 *root = *(void**)xpv;
1167 return (void*)((char*)xpv - offset);
1170 /* return a thing to the free list */
1173 S_del_body(pTHX_ void *thing, void **root, size_t offset)
1175 void **real_thing = (void**)((char *)thing + offset);
1177 *real_thing = *root;
1178 *root = (void*)real_thing;
1182 /* Conventionally we simply malloc() a big block of memory, then divide it
1183 up into lots of the thing that we're allocating.
1185 This macro will expand to call to S_new_body. So for XPVBM (with ithreads),
1188 S_new_body(my_perl, (void**)&(my_perl->Ixpvbm_arenaroot),
1189 (void**)&(my_perl->Ixpvbm_root), sizeof(XPVBM), 0)
1192 #define new_body(TYPE,lctype) \
1193 S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \
1194 (void**)&PL_ ## lctype ## _root, \
1198 /* But for some types, we cheat. The type starts with some members that are
1199 never accessed. So we allocate the substructure, starting at the first used
1200 member, then adjust the pointer back in memory by the size of the bit not
1201 allocated, so it's as if we allocated the full structure.
1202 (But things will all go boom if you write to the part that is "not there",
1203 because you'll be overwriting the last members of the preceding structure
1206 We calculate the correction using the STRUCT_OFFSET macro. For example, if
1207 xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
1208 and the pointer is unchanged. If the allocated structure is smaller (no
1209 initial NV actually allocated) then the net effect is to subtract the size
1210 of the NV from the pointer, to return a new pointer as if an initial NV were
1213 This is the same trick as was used for NV and IV bodies. Ironically it
1214 doesn't need to be used for NV bodies any more, because NV is now at the
1215 start of the structure. IV bodies don't need it either, because they are
1216 no longer allocated. */
1218 #define new_body_allocated(TYPE,lctype,member) \
1219 S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \
1220 (void**)&PL_ ## lctype ## _root, \
1221 sizeof(lctype ## _allocated), \
1222 STRUCT_OFFSET(TYPE, member) \
1223 - STRUCT_OFFSET(lctype ## _allocated, member))
1226 #define del_body(p,TYPE,lctype) \
1227 S_del_body(aTHX_ (void*)p, (void**)&PL_ ## lctype ## _root, 0)
1229 #define del_body_allocated(p,TYPE,lctype,member) \
1230 S_del_body(aTHX_ (void*)p, (void**)&PL_ ## lctype ## _root, \
1231 STRUCT_OFFSET(TYPE, member) \
1232 - STRUCT_OFFSET(lctype ## _allocated, member))
1234 #define my_safemalloc(s) (void*)safemalloc(s)
1235 #define my_safefree(p) safefree((char*)p)
1239 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1240 #define del_XNV(p) my_safefree(p)
1242 #define new_XPV() my_safemalloc(sizeof(XPV))
1243 #define del_XPV(p) my_safefree(p)
1245 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1246 #define del_XPVIV(p) my_safefree(p)
1248 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1249 #define del_XPVNV(p) my_safefree(p)
1251 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1252 #define del_XPVCV(p) my_safefree(p)
1254 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1255 #define del_XPVAV(p) my_safefree(p)
1257 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1258 #define del_XPVHV(p) my_safefree(p)
1260 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1261 #define del_XPVMG(p) my_safefree(p)
1263 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1264 #define del_XPVGV(p) my_safefree(p)
1266 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1267 #define del_XPVLV(p) my_safefree(p)
1269 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1270 #define del_XPVBM(p) my_safefree(p)
1274 #define new_XNV() new_body(NV, xnv)
1275 #define del_XNV(p) del_body(p, NV, xnv)
1277 #define new_XPV() new_body_allocated(XPV, xpv, xpv_cur)
1278 #define del_XPV(p) del_body_allocated(p, XPV, xpv, xpv_cur)
1280 #define new_XPVIV() new_body_allocated(XPVIV, xpviv, xpv_cur)
1281 #define del_XPVIV(p) del_body_allocated(p, XPVIV, xpviv, xpv_cur)
1283 #define new_XPVNV() new_body(XPVNV, xpvnv)
1284 #define del_XPVNV(p) del_body(p, XPVNV, xpvnv)
1286 #define new_XPVCV() new_body(XPVCV, xpvcv)
1287 #define del_XPVCV(p) del_body(p, XPVCV, xpvcv)
1289 #define new_XPVAV() new_body_allocated(XPVAV, xpvav, xav_fill)
1290 #define del_XPVAV(p) del_body_allocated(p, XPVAV, xpvav, xav_fill)
1292 #define new_XPVHV() new_body_allocated(XPVHV, xpvhv, xhv_fill)
1293 #define del_XPVHV(p) del_body_allocated(p, XPVHV, xpvhv, xhv_fill)
1295 #define new_XPVMG() new_body(XPVMG, xpvmg)
1296 #define del_XPVMG(p) del_body(p, XPVMG, xpvmg)
1298 #define new_XPVGV() new_body(XPVGV, xpvgv)
1299 #define del_XPVGV(p) del_body(p, XPVGV, xpvgv)
1301 #define new_XPVLV() new_body(XPVLV, xpvlv)
1302 #define del_XPVLV(p) del_body(p, XPVLV, xpvlv)
1304 #define new_XPVBM() new_body(XPVBM, xpvbm)
1305 #define del_XPVBM(p) del_body(p, XPVBM, xpvbm)
1309 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1310 #define del_XPVFM(p) my_safefree(p)
1312 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1313 #define del_XPVIO(p) my_safefree(p)
1316 =for apidoc sv_upgrade
1318 Upgrade an SV to a more complex form. Generally adds a new body type to the
1319 SV, then copies across as much information as possible from the old body.
1320 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1326 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1336 void** old_body_arena;
1337 size_t old_body_offset;
1338 size_t old_body_length; /* Well, the length to copy. */
1340 bool zero_nv = TRUE;
1342 U32 old_type = SvTYPE(sv);
1345 if (mt != SVt_PV && SvIsCOW(sv)) {
1346 sv_force_normal_flags(sv, 0);
1349 if (SvTYPE(sv) == mt)
1352 if (SvTYPE(sv) > mt)
1353 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1354 (int)SvTYPE(sv), (int)mt);
1364 old_body = SvANY(sv);
1366 old_body_offset = 0;
1367 old_body_length = 0;
1369 switch (SvTYPE(sv)) {
1376 else if (mt < SVt_PVIV)
1378 old_body_offset = STRUCT_OFFSET(XPVIV, xiv_iv);
1379 old_body_length = sizeof(IV);
1383 old_body_arena = (void **) &PL_xnv_root;
1384 old_body_length = sizeof(NV);
1391 pv = (char*)SvRV(sv);
1394 pv = SvPVX_mutable(sv);
1397 old_body_arena = (void **) &PL_xpv_root;
1398 old_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
1399 - STRUCT_OFFSET(xpv_allocated, xpv_cur);
1400 old_body_length = sizeof(XPV) - old_body_offset;
1403 else if (mt == SVt_NV)
1407 pv = SvPVX_mutable(sv);
1411 old_body_arena = (void **) &PL_xpviv_root;
1412 old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
1413 - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
1414 old_body_length = sizeof(XPVIV) - old_body_offset;
1417 pv = SvPVX_mutable(sv);
1422 old_body_arena = (void **) &PL_xpvnv_root;
1423 old_body_length = sizeof(XPVNV);
1427 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1428 there's no way that it can be safely upgraded, because perl.c
1429 expects to Safefree(SvANY(PL_mess_sv)) */
1430 assert(sv != PL_mess_sv);
1431 /* This flag bit is used to mean other things in other scalar types.
1432 Given that it only has meaning inside the pad, it shouldn't be set
1433 on anything that can get upgraded. */
1434 assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
1435 pv = SvPVX_mutable(sv);
1440 magic = SvMAGIC(sv);
1441 stash = SvSTASH(sv);
1442 old_body_arena = (void **) &PL_xpvmg_root;
1443 old_body_length = sizeof(XPVMG);
1447 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1450 SvFLAGS(sv) &= ~SVTYPEMASK;
1455 Perl_croak(aTHX_ "Can't upgrade to undef");
1457 assert(old_type == SVt_NULL);
1458 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1462 assert(old_type == SVt_NULL);
1463 SvANY(sv) = new_XNV();
1467 assert(old_type == SVt_NULL);
1468 SvANY(sv) = &sv->sv_u.svu_rv;
1469 SvRV_set(sv, (SV*)pv);
1472 SvANY(sv) = new_XPVHV();
1475 HvTOTALKEYS(sv) = 0;
1477 /* Fall through... */
1480 SvANY(sv) = new_XPVAV();
1487 /* XXX? Only SVt_NULL is ever upgraded to AV or HV? */
1489 /* FIXME. Should be able to remove all this if()... if the above
1490 assertion is genuinely always true. */
1493 SvFLAGS(sv) &= ~SVf_OOK;
1496 SvPV_set(sv, (char*)0);
1497 SvMAGIC_set(sv, magic);
1498 SvSTASH_set(sv, stash);
1502 SvANY(sv) = new_XPVIO();
1503 Zero(SvANY(sv), 1, XPVIO);
1504 IoPAGE_LEN(sv) = 60;
1505 goto set_magic_common;
1507 SvANY(sv) = new_XPVFM();
1508 Zero(SvANY(sv), 1, XPVFM);
1509 goto set_magic_common;
1511 SvANY(sv) = new_XPVBM();
1515 goto set_magic_common;
1517 SvANY(sv) = new_XPVGV();
1523 goto set_magic_common;
1525 SvANY(sv) = new_XPVCV();
1526 Zero(SvANY(sv), 1, XPVCV);
1527 goto set_magic_common;
1529 SvANY(sv) = new_XPVLV();
1542 SvANY(sv) = new_XPVMG();
1545 SvMAGIC_set(sv, magic);
1546 SvSTASH_set(sv, stash);
1550 SvANY(sv) = new_XPVNV();
1556 SvANY(sv) = new_XPVIV();
1565 SvANY(sv) = new_XPV();
1574 if (old_body_arena) {
1576 my_safefree(old_body);
1578 S_del_body(aTHX_ old_body, old_body_arena, old_body_offset);
1584 =for apidoc sv_backoff
1586 Remove any string offset. You should normally use the C<SvOOK_off> macro
1593 Perl_sv_backoff(pTHX_ register SV *sv)
1596 assert(SvTYPE(sv) != SVt_PVHV);
1597 assert(SvTYPE(sv) != SVt_PVAV);
1599 const char *s = SvPVX_const(sv);
1600 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1601 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1603 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1605 SvFLAGS(sv) &= ~SVf_OOK;
1612 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1613 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1614 Use the C<SvGROW> wrapper instead.
1620 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1624 #ifdef HAS_64K_LIMIT
1625 if (newlen >= 0x10000) {
1626 PerlIO_printf(Perl_debug_log,
1627 "Allocation too large: %"UVxf"\n", (UV)newlen);
1630 #endif /* HAS_64K_LIMIT */
1633 if (SvTYPE(sv) < SVt_PV) {
1634 sv_upgrade(sv, SVt_PV);
1635 s = SvPVX_mutable(sv);
1637 else if (SvOOK(sv)) { /* pv is offset? */
1639 s = SvPVX_mutable(sv);
1640 if (newlen > SvLEN(sv))
1641 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1642 #ifdef HAS_64K_LIMIT
1643 if (newlen >= 0x10000)
1648 s = SvPVX_mutable(sv);
1650 if (newlen > SvLEN(sv)) { /* need more room? */
1651 newlen = PERL_STRLEN_ROUNDUP(newlen);
1652 if (SvLEN(sv) && s) {
1654 const STRLEN l = malloced_size((void*)SvPVX_const(sv));
1660 s = saferealloc(s, newlen);
1663 s = safemalloc(newlen);
1664 if (SvPVX_const(sv) && SvCUR(sv)) {
1665 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1669 SvLEN_set(sv, newlen);
1675 =for apidoc sv_setiv
1677 Copies an integer into the given SV, upgrading first if necessary.
1678 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1684 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1686 SV_CHECK_THINKFIRST_COW_DROP(sv);
1687 switch (SvTYPE(sv)) {
1689 sv_upgrade(sv, SVt_IV);
1692 sv_upgrade(sv, SVt_PVNV);
1696 sv_upgrade(sv, SVt_PVIV);
1705 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1708 (void)SvIOK_only(sv); /* validate number */
1714 =for apidoc sv_setiv_mg
1716 Like C<sv_setiv>, but also handles 'set' magic.
1722 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1729 =for apidoc sv_setuv
1731 Copies an unsigned integer into the given SV, upgrading first if necessary.
1732 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1738 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1740 /* With these two if statements:
1741 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1744 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1746 If you wish to remove them, please benchmark to see what the effect is
1748 if (u <= (UV)IV_MAX) {
1749 sv_setiv(sv, (IV)u);
1758 =for apidoc sv_setuv_mg
1760 Like C<sv_setuv>, but also handles 'set' magic.
1766 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1768 /* With these two if statements:
1769 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1772 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1774 If you wish to remove them, please benchmark to see what the effect is
1776 if (u <= (UV)IV_MAX) {
1777 sv_setiv(sv, (IV)u);
1787 =for apidoc sv_setnv
1789 Copies a double into the given SV, upgrading first if necessary.
1790 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1796 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1798 SV_CHECK_THINKFIRST_COW_DROP(sv);
1799 switch (SvTYPE(sv)) {
1802 sv_upgrade(sv, SVt_NV);
1807 sv_upgrade(sv, SVt_PVNV);
1816 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1820 (void)SvNOK_only(sv); /* validate number */
1825 =for apidoc sv_setnv_mg
1827 Like C<sv_setnv>, but also handles 'set' magic.
1833 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1839 /* Print an "isn't numeric" warning, using a cleaned-up,
1840 * printable version of the offending string
1844 S_not_a_number(pTHX_ SV *sv)
1851 dsv = sv_2mortal(newSVpv("", 0));
1852 pv = sv_uni_display(dsv, sv, 10, 0);
1855 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1856 /* each *s can expand to 4 chars + "...\0",
1857 i.e. need room for 8 chars */
1859 const char *s, *end;
1860 for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit;
1863 if (ch & 128 && !isPRINT_LC(ch)) {
1872 else if (ch == '\r') {
1876 else if (ch == '\f') {
1880 else if (ch == '\\') {
1884 else if (ch == '\0') {
1888 else if (isPRINT_LC(ch))
1905 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1906 "Argument \"%s\" isn't numeric in %s", pv,
1909 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1910 "Argument \"%s\" isn't numeric", pv);
1914 =for apidoc looks_like_number
1916 Test if the content of an SV looks like a number (or is a number).
1917 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1918 non-numeric warning), even if your atof() doesn't grok them.
1924 Perl_looks_like_number(pTHX_ SV *sv)
1926 register const char *sbegin;
1930 sbegin = SvPVX_const(sv);
1933 else if (SvPOKp(sv))
1934 sbegin = SvPV_const(sv, len);
1936 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1937 return grok_number(sbegin, len, NULL);
1940 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1941 until proven guilty, assume that things are not that bad... */
1946 As 64 bit platforms often have an NV that doesn't preserve all bits of
1947 an IV (an assumption perl has been based on to date) it becomes necessary
1948 to remove the assumption that the NV always carries enough precision to
1949 recreate the IV whenever needed, and that the NV is the canonical form.
1950 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1951 precision as a side effect of conversion (which would lead to insanity
1952 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1953 1) to distinguish between IV/UV/NV slots that have cached a valid
1954 conversion where precision was lost and IV/UV/NV slots that have a
1955 valid conversion which has lost no precision
1956 2) to ensure that if a numeric conversion to one form is requested that
1957 would lose precision, the precise conversion (or differently
1958 imprecise conversion) is also performed and cached, to prevent
1959 requests for different numeric formats on the same SV causing
1960 lossy conversion chains. (lossless conversion chains are perfectly
1965 SvIOKp is true if the IV slot contains a valid value
1966 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1967 SvNOKp is true if the NV slot contains a valid value
1968 SvNOK is true only if the NV value is accurate
1971 while converting from PV to NV, check to see if converting that NV to an
1972 IV(or UV) would lose accuracy over a direct conversion from PV to
1973 IV(or UV). If it would, cache both conversions, return NV, but mark
1974 SV as IOK NOKp (ie not NOK).
1976 While converting from PV to IV, check to see if converting that IV to an
1977 NV would lose accuracy over a direct conversion from PV to NV. If it
1978 would, cache both conversions, flag similarly.
1980 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1981 correctly because if IV & NV were set NV *always* overruled.
1982 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1983 changes - now IV and NV together means that the two are interchangeable:
1984 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1986 The benefit of this is that operations such as pp_add know that if
1987 SvIOK is true for both left and right operands, then integer addition
1988 can be used instead of floating point (for cases where the result won't
1989 overflow). Before, floating point was always used, which could lead to
1990 loss of precision compared with integer addition.
1992 * making IV and NV equal status should make maths accurate on 64 bit
1994 * may speed up maths somewhat if pp_add and friends start to use
1995 integers when possible instead of fp. (Hopefully the overhead in
1996 looking for SvIOK and checking for overflow will not outweigh the
1997 fp to integer speedup)
1998 * will slow down integer operations (callers of SvIV) on "inaccurate"
1999 values, as the change from SvIOK to SvIOKp will cause a call into
2000 sv_2iv each time rather than a macro access direct to the IV slot
2001 * should speed up number->string conversion on integers as IV is
2002 favoured when IV and NV are equally accurate
2004 ####################################################################
2005 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2006 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2007 On the other hand, SvUOK is true iff UV.
2008 ####################################################################
2010 Your mileage will vary depending your CPU's relative fp to integer
2014 #ifndef NV_PRESERVES_UV
2015 # define IS_NUMBER_UNDERFLOW_IV 1
2016 # define IS_NUMBER_UNDERFLOW_UV 2
2017 # define IS_NUMBER_IV_AND_UV 2
2018 # define IS_NUMBER_OVERFLOW_IV 4
2019 # define IS_NUMBER_OVERFLOW_UV 5
2021 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2023 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2025 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2027 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
2028 if (SvNVX(sv) < (NV)IV_MIN) {
2029 (void)SvIOKp_on(sv);
2031 SvIV_set(sv, IV_MIN);
2032 return IS_NUMBER_UNDERFLOW_IV;
2034 if (SvNVX(sv) > (NV)UV_MAX) {
2035 (void)SvIOKp_on(sv);
2038 SvUV_set(sv, UV_MAX);
2039 return IS_NUMBER_OVERFLOW_UV;
2041 (void)SvIOKp_on(sv);
2043 /* Can't use strtol etc to convert this string. (See truth table in
2045 if (SvNVX(sv) <= (UV)IV_MAX) {
2046 SvIV_set(sv, I_V(SvNVX(sv)));
2047 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2048 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2050 /* Integer is imprecise. NOK, IOKp */
2052 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2055 SvUV_set(sv, U_V(SvNVX(sv)));
2056 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2057 if (SvUVX(sv) == UV_MAX) {
2058 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2059 possibly be preserved by NV. Hence, it must be overflow.
2061 return IS_NUMBER_OVERFLOW_UV;
2063 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2065 /* Integer is imprecise. NOK, IOKp */
2067 return IS_NUMBER_OVERFLOW_IV;
2069 #endif /* !NV_PRESERVES_UV*/
2071 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
2072 * this function provided for binary compatibility only
2076 Perl_sv_2iv(pTHX_ register SV *sv)
2078 return sv_2iv_flags(sv, SV_GMAGIC);
2082 =for apidoc sv_2iv_flags
2084 Return the integer value of an SV, doing any necessary string
2085 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2086 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2092 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2096 if (SvGMAGICAL(sv)) {
2097 if (flags & SV_GMAGIC)
2102 return I_V(SvNVX(sv));
2104 if (SvPOKp(sv) && SvLEN(sv))
2107 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2108 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2114 if (SvTHINKFIRST(sv)) {
2117 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2118 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2119 return SvIV(tmpstr);
2120 return PTR2IV(SvRV(sv));
2123 sv_force_normal_flags(sv, 0);
2125 if (SvREADONLY(sv) && !SvOK(sv)) {
2126 if (ckWARN(WARN_UNINITIALIZED))
2133 return (IV)(SvUVX(sv));
2140 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2141 * without also getting a cached IV/UV from it at the same time
2142 * (ie PV->NV conversion should detect loss of accuracy and cache
2143 * IV or UV at same time to avoid this. NWC */
2145 if (SvTYPE(sv) == SVt_NV)
2146 sv_upgrade(sv, SVt_PVNV);
2148 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2149 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2150 certainly cast into the IV range at IV_MAX, whereas the correct
2151 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2153 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2154 SvIV_set(sv, I_V(SvNVX(sv)));
2155 if (SvNVX(sv) == (NV) SvIVX(sv)
2156 #ifndef NV_PRESERVES_UV
2157 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2158 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2159 /* Don't flag it as "accurately an integer" if the number
2160 came from a (by definition imprecise) NV operation, and
2161 we're outside the range of NV integer precision */
2164 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2165 DEBUG_c(PerlIO_printf(Perl_debug_log,
2166 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2172 /* IV not precise. No need to convert from PV, as NV
2173 conversion would already have cached IV if it detected
2174 that PV->IV would be better than PV->NV->IV
2175 flags already correct - don't set public IOK. */
2176 DEBUG_c(PerlIO_printf(Perl_debug_log,
2177 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2182 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2183 but the cast (NV)IV_MIN rounds to a the value less (more
2184 negative) than IV_MIN which happens to be equal to SvNVX ??
2185 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2186 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2187 (NV)UVX == NVX are both true, but the values differ. :-(
2188 Hopefully for 2s complement IV_MIN is something like
2189 0x8000000000000000 which will be exact. NWC */
2192 SvUV_set(sv, U_V(SvNVX(sv)));
2194 (SvNVX(sv) == (NV) SvUVX(sv))
2195 #ifndef NV_PRESERVES_UV
2196 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2197 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2198 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2199 /* Don't flag it as "accurately an integer" if the number
2200 came from a (by definition imprecise) NV operation, and
2201 we're outside the range of NV integer precision */
2207 DEBUG_c(PerlIO_printf(Perl_debug_log,
2208 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2212 return (IV)SvUVX(sv);
2215 else if (SvPOKp(sv) && SvLEN(sv)) {
2217 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2218 /* We want to avoid a possible problem when we cache an IV which
2219 may be later translated to an NV, and the resulting NV is not
2220 the same as the direct translation of the initial string
2221 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2222 be careful to ensure that the value with the .456 is around if the
2223 NV value is requested in the future).
2225 This means that if we cache such an IV, we need to cache the
2226 NV as well. Moreover, we trade speed for space, and do not
2227 cache the NV if we are sure it's not needed.
2230 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2231 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2232 == IS_NUMBER_IN_UV) {
2233 /* It's definitely an integer, only upgrade to PVIV */
2234 if (SvTYPE(sv) < SVt_PVIV)
2235 sv_upgrade(sv, SVt_PVIV);
2237 } else if (SvTYPE(sv) < SVt_PVNV)
2238 sv_upgrade(sv, SVt_PVNV);
2240 /* If NV preserves UV then we only use the UV value if we know that
2241 we aren't going to call atof() below. If NVs don't preserve UVs
2242 then the value returned may have more precision than atof() will
2243 return, even though value isn't perfectly accurate. */
2244 if ((numtype & (IS_NUMBER_IN_UV
2245 #ifdef NV_PRESERVES_UV
2248 )) == IS_NUMBER_IN_UV) {
2249 /* This won't turn off the public IOK flag if it was set above */
2250 (void)SvIOKp_on(sv);
2252 if (!(numtype & IS_NUMBER_NEG)) {
2254 if (value <= (UV)IV_MAX) {
2255 SvIV_set(sv, (IV)value);
2257 SvUV_set(sv, value);
2261 /* 2s complement assumption */
2262 if (value <= (UV)IV_MIN) {
2263 SvIV_set(sv, -(IV)value);
2265 /* Too negative for an IV. This is a double upgrade, but
2266 I'm assuming it will be rare. */
2267 if (SvTYPE(sv) < SVt_PVNV)
2268 sv_upgrade(sv, SVt_PVNV);
2272 SvNV_set(sv, -(NV)value);
2273 SvIV_set(sv, IV_MIN);
2277 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2278 will be in the previous block to set the IV slot, and the next
2279 block to set the NV slot. So no else here. */
2281 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2282 != IS_NUMBER_IN_UV) {
2283 /* It wasn't an (integer that doesn't overflow the UV). */
2284 SvNV_set(sv, Atof(SvPVX_const(sv)));
2286 if (! numtype && ckWARN(WARN_NUMERIC))
2289 #if defined(USE_LONG_DOUBLE)
2290 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2291 PTR2UV(sv), SvNVX(sv)));
2293 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2294 PTR2UV(sv), SvNVX(sv)));
2298 #ifdef NV_PRESERVES_UV
2299 (void)SvIOKp_on(sv);
2301 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2302 SvIV_set(sv, I_V(SvNVX(sv)));
2303 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2306 /* Integer is imprecise. NOK, IOKp */
2308 /* UV will not work better than IV */
2310 if (SvNVX(sv) > (NV)UV_MAX) {
2312 /* Integer is inaccurate. NOK, IOKp, is UV */
2313 SvUV_set(sv, UV_MAX);
2316 SvUV_set(sv, U_V(SvNVX(sv)));
2317 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2318 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2322 /* Integer is imprecise. NOK, IOKp, is UV */
2328 #else /* NV_PRESERVES_UV */
2329 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2330 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2331 /* The IV slot will have been set from value returned by
2332 grok_number above. The NV slot has just been set using
2335 assert (SvIOKp(sv));
2337 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2338 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2339 /* Small enough to preserve all bits. */
2340 (void)SvIOKp_on(sv);
2342 SvIV_set(sv, I_V(SvNVX(sv)));
2343 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2345 /* Assumption: first non-preserved integer is < IV_MAX,
2346 this NV is in the preserved range, therefore: */
2347 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2349 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);
2353 0 0 already failed to read UV.
2354 0 1 already failed to read UV.
2355 1 0 you won't get here in this case. IV/UV
2356 slot set, public IOK, Atof() unneeded.
2357 1 1 already read UV.
2358 so there's no point in sv_2iuv_non_preserve() attempting
2359 to use atol, strtol, strtoul etc. */
2360 if (sv_2iuv_non_preserve (sv, numtype)
2361 >= IS_NUMBER_OVERFLOW_IV)
2365 #endif /* NV_PRESERVES_UV */
2368 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2370 if (SvTYPE(sv) < SVt_IV)
2371 /* Typically the caller expects that sv_any is not NULL now. */
2372 sv_upgrade(sv, SVt_IV);
2375 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2376 PTR2UV(sv),SvIVX(sv)));
2377 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2380 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2381 * this function provided for binary compatibility only
2385 Perl_sv_2uv(pTHX_ register SV *sv)
2387 return sv_2uv_flags(sv, SV_GMAGIC);
2391 =for apidoc sv_2uv_flags
2393 Return the unsigned integer value of an SV, doing any necessary string
2394 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2395 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2401 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2405 if (SvGMAGICAL(sv)) {
2406 if (flags & SV_GMAGIC)
2411 return U_V(SvNVX(sv));
2412 if (SvPOKp(sv) && SvLEN(sv))
2415 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2416 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2422 if (SvTHINKFIRST(sv)) {
2425 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2426 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2427 return SvUV(tmpstr);
2428 return PTR2UV(SvRV(sv));
2431 sv_force_normal_flags(sv, 0);
2433 if (SvREADONLY(sv) && !SvOK(sv)) {
2434 if (ckWARN(WARN_UNINITIALIZED))
2444 return (UV)SvIVX(sv);
2448 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2449 * without also getting a cached IV/UV from it at the same time
2450 * (ie PV->NV conversion should detect loss of accuracy and cache
2451 * IV or UV at same time to avoid this. */
2452 /* IV-over-UV optimisation - choose to cache IV if possible */
2454 if (SvTYPE(sv) == SVt_NV)
2455 sv_upgrade(sv, SVt_PVNV);
2457 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2458 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2459 SvIV_set(sv, I_V(SvNVX(sv)));
2460 if (SvNVX(sv) == (NV) SvIVX(sv)
2461 #ifndef NV_PRESERVES_UV
2462 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2463 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2464 /* Don't flag it as "accurately an integer" if the number
2465 came from a (by definition imprecise) NV operation, and
2466 we're outside the range of NV integer precision */
2469 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2470 DEBUG_c(PerlIO_printf(Perl_debug_log,
2471 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2477 /* IV not precise. No need to convert from PV, as NV
2478 conversion would already have cached IV if it detected
2479 that PV->IV would be better than PV->NV->IV
2480 flags already correct - don't set public IOK. */
2481 DEBUG_c(PerlIO_printf(Perl_debug_log,
2482 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2487 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2488 but the cast (NV)IV_MIN rounds to a the value less (more
2489 negative) than IV_MIN which happens to be equal to SvNVX ??
2490 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2491 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2492 (NV)UVX == NVX are both true, but the values differ. :-(
2493 Hopefully for 2s complement IV_MIN is something like
2494 0x8000000000000000 which will be exact. NWC */
2497 SvUV_set(sv, U_V(SvNVX(sv)));
2499 (SvNVX(sv) == (NV) SvUVX(sv))
2500 #ifndef NV_PRESERVES_UV
2501 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2502 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2503 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2504 /* Don't flag it as "accurately an integer" if the number
2505 came from a (by definition imprecise) NV operation, and
2506 we're outside the range of NV integer precision */
2511 DEBUG_c(PerlIO_printf(Perl_debug_log,
2512 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2518 else if (SvPOKp(sv) && SvLEN(sv)) {
2520 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2522 /* We want to avoid a possible problem when we cache a UV which
2523 may be later translated to an NV, and the resulting NV is not
2524 the translation of the initial data.
2526 This means that if we cache such a UV, we need to cache the
2527 NV as well. Moreover, we trade speed for space, and do not
2528 cache the NV if not needed.
2531 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2532 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2533 == IS_NUMBER_IN_UV) {
2534 /* It's definitely an integer, only upgrade to PVIV */
2535 if (SvTYPE(sv) < SVt_PVIV)
2536 sv_upgrade(sv, SVt_PVIV);
2538 } else if (SvTYPE(sv) < SVt_PVNV)
2539 sv_upgrade(sv, SVt_PVNV);
2541 /* If NV preserves UV then we only use the UV value if we know that
2542 we aren't going to call atof() below. If NVs don't preserve UVs
2543 then the value returned may have more precision than atof() will
2544 return, even though it isn't accurate. */
2545 if ((numtype & (IS_NUMBER_IN_UV
2546 #ifdef NV_PRESERVES_UV
2549 )) == IS_NUMBER_IN_UV) {
2550 /* This won't turn off the public IOK flag if it was set above */
2551 (void)SvIOKp_on(sv);
2553 if (!(numtype & IS_NUMBER_NEG)) {
2555 if (value <= (UV)IV_MAX) {
2556 SvIV_set(sv, (IV)value);
2558 /* it didn't overflow, and it was positive. */
2559 SvUV_set(sv, value);
2563 /* 2s complement assumption */
2564 if (value <= (UV)IV_MIN) {
2565 SvIV_set(sv, -(IV)value);
2567 /* Too negative for an IV. This is a double upgrade, but
2568 I'm assuming it will be rare. */
2569 if (SvTYPE(sv) < SVt_PVNV)
2570 sv_upgrade(sv, SVt_PVNV);
2574 SvNV_set(sv, -(NV)value);
2575 SvIV_set(sv, IV_MIN);
2580 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2581 != IS_NUMBER_IN_UV) {
2582 /* It wasn't an integer, or it overflowed the UV. */
2583 SvNV_set(sv, Atof(SvPVX_const(sv)));
2585 if (! numtype && ckWARN(WARN_NUMERIC))
2588 #if defined(USE_LONG_DOUBLE)
2589 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2590 PTR2UV(sv), SvNVX(sv)));
2592 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2593 PTR2UV(sv), SvNVX(sv)));
2596 #ifdef NV_PRESERVES_UV
2597 (void)SvIOKp_on(sv);
2599 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2600 SvIV_set(sv, I_V(SvNVX(sv)));
2601 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2604 /* Integer is imprecise. NOK, IOKp */
2606 /* UV will not work better than IV */
2608 if (SvNVX(sv) > (NV)UV_MAX) {
2610 /* Integer is inaccurate. NOK, IOKp, is UV */
2611 SvUV_set(sv, UV_MAX);
2614 SvUV_set(sv, U_V(SvNVX(sv)));
2615 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2616 NV preservse UV so can do correct comparison. */
2617 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2621 /* Integer is imprecise. NOK, IOKp, is UV */
2626 #else /* NV_PRESERVES_UV */
2627 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2628 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2629 /* The UV slot will have been set from value returned by
2630 grok_number above. The NV slot has just been set using
2633 assert (SvIOKp(sv));
2635 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2636 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2637 /* Small enough to preserve all bits. */
2638 (void)SvIOKp_on(sv);
2640 SvIV_set(sv, I_V(SvNVX(sv)));
2641 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2643 /* Assumption: first non-preserved integer is < IV_MAX,
2644 this NV is in the preserved range, therefore: */
2645 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2647 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);
2650 sv_2iuv_non_preserve (sv, numtype);
2652 #endif /* NV_PRESERVES_UV */
2656 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2657 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2660 if (SvTYPE(sv) < SVt_IV)
2661 /* Typically the caller expects that sv_any is not NULL now. */
2662 sv_upgrade(sv, SVt_IV);
2666 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2667 PTR2UV(sv),SvUVX(sv)));
2668 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2674 Return the num value of an SV, doing any necessary string or integer
2675 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2682 Perl_sv_2nv(pTHX_ register SV *sv)
2686 if (SvGMAGICAL(sv)) {
2690 if (SvPOKp(sv) && SvLEN(sv)) {
2691 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2692 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2694 return Atof(SvPVX_const(sv));
2698 return (NV)SvUVX(sv);
2700 return (NV)SvIVX(sv);
2703 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2704 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2710 if (SvTHINKFIRST(sv)) {
2713 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2714 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2715 return SvNV(tmpstr);
2716 return PTR2NV(SvRV(sv));
2719 sv_force_normal_flags(sv, 0);
2721 if (SvREADONLY(sv) && !SvOK(sv)) {
2722 if (ckWARN(WARN_UNINITIALIZED))
2727 if (SvTYPE(sv) < SVt_NV) {
2728 if (SvTYPE(sv) == SVt_IV)
2729 sv_upgrade(sv, SVt_PVNV);
2731 sv_upgrade(sv, SVt_NV);
2732 #ifdef USE_LONG_DOUBLE
2734 STORE_NUMERIC_LOCAL_SET_STANDARD();
2735 PerlIO_printf(Perl_debug_log,
2736 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2737 PTR2UV(sv), SvNVX(sv));
2738 RESTORE_NUMERIC_LOCAL();
2742 STORE_NUMERIC_LOCAL_SET_STANDARD();
2743 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2744 PTR2UV(sv), SvNVX(sv));
2745 RESTORE_NUMERIC_LOCAL();
2749 else if (SvTYPE(sv) < SVt_PVNV)
2750 sv_upgrade(sv, SVt_PVNV);
2755 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2756 #ifdef NV_PRESERVES_UV
2759 /* Only set the public NV OK flag if this NV preserves the IV */
2760 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2761 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2762 : (SvIVX(sv) == I_V(SvNVX(sv))))
2768 else if (SvPOKp(sv) && SvLEN(sv)) {
2770 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2771 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2773 #ifdef NV_PRESERVES_UV
2774 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2775 == IS_NUMBER_IN_UV) {
2776 /* It's definitely an integer */
2777 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2779 SvNV_set(sv, Atof(SvPVX_const(sv)));
2782 SvNV_set(sv, Atof(SvPVX_const(sv)));
2783 /* Only set the public NV OK flag if this NV preserves the value in
2784 the PV at least as well as an IV/UV would.
2785 Not sure how to do this 100% reliably. */
2786 /* if that shift count is out of range then Configure's test is
2787 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2789 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2790 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2791 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2792 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2793 /* Can't use strtol etc to convert this string, so don't try.
2794 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2797 /* value has been set. It may not be precise. */
2798 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2799 /* 2s complement assumption for (UV)IV_MIN */
2800 SvNOK_on(sv); /* Integer is too negative. */
2805 if (numtype & IS_NUMBER_NEG) {
2806 SvIV_set(sv, -(IV)value);
2807 } else if (value <= (UV)IV_MAX) {
2808 SvIV_set(sv, (IV)value);
2810 SvUV_set(sv, value);
2814 if (numtype & IS_NUMBER_NOT_INT) {
2815 /* I believe that even if the original PV had decimals,
2816 they are lost beyond the limit of the FP precision.
2817 However, neither is canonical, so both only get p
2818 flags. NWC, 2000/11/25 */
2819 /* Both already have p flags, so do nothing */
2821 const NV nv = SvNVX(sv);
2822 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2823 if (SvIVX(sv) == I_V(nv)) {
2828 /* It had no "." so it must be integer. */
2831 /* between IV_MAX and NV(UV_MAX).
2832 Could be slightly > UV_MAX */
2834 if (numtype & IS_NUMBER_NOT_INT) {
2835 /* UV and NV both imprecise. */
2837 const UV nv_as_uv = U_V(nv);
2839 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2850 #endif /* NV_PRESERVES_UV */
2853 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2855 if (SvTYPE(sv) < SVt_NV)
2856 /* Typically the caller expects that sv_any is not NULL now. */
2857 /* XXX Ilya implies that this is a bug in callers that assume this
2858 and ideally should be fixed. */
2859 sv_upgrade(sv, SVt_NV);
2862 #if defined(USE_LONG_DOUBLE)
2864 STORE_NUMERIC_LOCAL_SET_STANDARD();
2865 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2866 PTR2UV(sv), SvNVX(sv));
2867 RESTORE_NUMERIC_LOCAL();
2871 STORE_NUMERIC_LOCAL_SET_STANDARD();
2872 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2873 PTR2UV(sv), SvNVX(sv));
2874 RESTORE_NUMERIC_LOCAL();
2880 /* asIV(): extract an integer from the string value of an SV.
2881 * Caller must validate PVX */
2884 S_asIV(pTHX_ SV *sv)
2887 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2889 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2890 == IS_NUMBER_IN_UV) {
2891 /* It's definitely an integer */
2892 if (numtype & IS_NUMBER_NEG) {
2893 if (value < (UV)IV_MIN)
2896 if (value < (UV)IV_MAX)
2901 if (ckWARN(WARN_NUMERIC))
2904 return I_V(Atof(SvPVX_const(sv)));
2907 /* asUV(): extract an unsigned integer from the string value of an SV
2908 * Caller must validate PVX */
2911 S_asUV(pTHX_ SV *sv)
2914 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2916 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2917 == IS_NUMBER_IN_UV) {
2918 /* It's definitely an integer */
2919 if (!(numtype & IS_NUMBER_NEG))
2923 if (ckWARN(WARN_NUMERIC))
2926 return U_V(Atof(SvPVX_const(sv)));
2930 =for apidoc sv_2pv_nolen
2932 Like C<sv_2pv()>, but doesn't return the length too. You should usually
2933 use the macro wrapper C<SvPV_nolen(sv)> instead.
2938 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2940 return sv_2pv(sv, 0);
2943 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2944 * UV as a string towards the end of buf, and return pointers to start and
2947 * We assume that buf is at least TYPE_CHARS(UV) long.
2951 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2953 char *ptr = buf + TYPE_CHARS(UV);
2967 *--ptr = '0' + (char)(uv % 10);
2975 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
2976 * this function provided for binary compatibility only
2980 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2982 return sv_2pv_flags(sv, lp, SV_GMAGIC);
2986 =for apidoc sv_2pv_flags
2988 Returns a pointer to the string value of an SV, and sets *lp to its length.
2989 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2991 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2992 usually end up here too.
2998 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3003 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3004 char *tmpbuf = tbuf;
3011 if (SvGMAGICAL(sv)) {
3012 if (flags & SV_GMAGIC)
3017 if (flags & SV_MUTABLE_RETURN)
3018 return SvPVX_mutable(sv);
3019 if (flags & SV_CONST_RETURN)
3020 return (char *)SvPVX_const(sv);
3025 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
3027 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3032 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3037 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3038 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3046 if (SvTHINKFIRST(sv)) {
3049 register const char *typestr;
3050 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3051 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3053 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
3056 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
3057 if (flags & SV_CONST_RETURN) {
3058 pv = (char *) SvPVX_const(tmpstr);
3060 pv = (flags & SV_MUTABLE_RETURN)
3061 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
3064 *lp = SvCUR(tmpstr);
3066 pv = sv_2pv_flags(tmpstr, lp, flags);
3077 typestr = "NULLREF";
3081 switch (SvTYPE(sv)) {
3083 if ( ((SvFLAGS(sv) &
3084 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3085 == (SVs_OBJECT|SVs_SMG))
3086 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3087 const regexp *re = (regexp *)mg->mg_obj;
3090 const char *fptr = "msix";
3095 char need_newline = 0;
3096 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3098 while((ch = *fptr++)) {
3100 reflags[left++] = ch;
3103 reflags[right--] = ch;
3108 reflags[left] = '-';
3112 mg->mg_len = re->prelen + 4 + left;
3114 * If /x was used, we have to worry about a regex
3115 * ending with a comment later being embedded
3116 * within another regex. If so, we don't want this
3117 * regex's "commentization" to leak out to the
3118 * right part of the enclosing regex, we must cap
3119 * it with a newline.
3121 * So, if /x was used, we scan backwards from the
3122 * end of the regex. If we find a '#' before we
3123 * find a newline, we need to add a newline
3124 * ourself. If we find a '\n' first (or if we
3125 * don't find '#' or '\n'), we don't need to add
3126 * anything. -jfriedl
3128 if (PMf_EXTENDED & re->reganch)
3130 const char *endptr = re->precomp + re->prelen;
3131 while (endptr >= re->precomp)
3133 const char c = *(endptr--);
3135 break; /* don't need another */
3137 /* we end while in a comment, so we
3139 mg->mg_len++; /* save space for it */
3140 need_newline = 1; /* note to add it */
3146 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3147 Copy("(?", mg->mg_ptr, 2, char);
3148 Copy(reflags, mg->mg_ptr+2, left, char);
3149 Copy(":", mg->mg_ptr+left+2, 1, char);
3150 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3152 mg->mg_ptr[mg->mg_len - 2] = '\n';
3153 mg->mg_ptr[mg->mg_len - 1] = ')';
3154 mg->mg_ptr[mg->mg_len] = 0;
3156 PL_reginterp_cnt += re->program[0].next_off;
3158 if (re->reganch & ROPT_UTF8)
3174 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3175 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3176 /* tied lvalues should appear to be
3177 * scalars for backwards compatitbility */
3178 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3179 ? "SCALAR" : "LVALUE"; break;
3180 case SVt_PVAV: typestr = "ARRAY"; break;
3181 case SVt_PVHV: typestr = "HASH"; break;
3182 case SVt_PVCV: typestr = "CODE"; break;
3183 case SVt_PVGV: typestr = "GLOB"; break;
3184 case SVt_PVFM: typestr = "FORMAT"; break;
3185 case SVt_PVIO: typestr = "IO"; break;
3186 default: typestr = "UNKNOWN"; break;
3190 const char *name = HvNAME_get(SvSTASH(sv));
3191 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3192 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3195 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3199 *lp = strlen(typestr);
3200 return (char *)typestr;
3202 if (SvREADONLY(sv) && !SvOK(sv)) {
3203 if (ckWARN(WARN_UNINITIALIZED))
3210 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3211 /* I'm assuming that if both IV and NV are equally valid then
3212 converting the IV is going to be more efficient */
3213 const U32 isIOK = SvIOK(sv);
3214 const U32 isUIOK = SvIsUV(sv);
3215 char buf[TYPE_CHARS(UV)];
3218 if (SvTYPE(sv) < SVt_PVIV)
3219 sv_upgrade(sv, SVt_PVIV);
3221 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3223 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3224 /* inlined from sv_setpvn */
3225 SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
3226 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
3227 SvCUR_set(sv, ebuf - ptr);
3237 else if (SvNOKp(sv)) {
3238 if (SvTYPE(sv) < SVt_PVNV)
3239 sv_upgrade(sv, SVt_PVNV);
3240 /* The +20 is pure guesswork. Configure test needed. --jhi */
3241 s = SvGROW_mutable(sv, NV_DIG + 20);
3242 olderrno = errno; /* some Xenix systems wipe out errno here */
3244 if (SvNVX(sv) == 0.0)
3245 (void)strcpy(s,"0");
3249 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3252 #ifdef FIXNEGATIVEZERO
3253 if (*s == '-' && s[1] == '0' && !s[2])
3263 if (ckWARN(WARN_UNINITIALIZED)
3264 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3268 if (SvTYPE(sv) < SVt_PV)
3269 /* Typically the caller expects that sv_any is not NULL now. */
3270 sv_upgrade(sv, SVt_PV);
3274 STRLEN len = s - SvPVX_const(sv);
3280 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3281 PTR2UV(sv),SvPVX_const(sv)));
3282 if (flags & SV_CONST_RETURN)
3283 return (char *)SvPVX_const(sv);
3284 if (flags & SV_MUTABLE_RETURN)
3285 return SvPVX_mutable(sv);
3289 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3290 /* Sneaky stuff here */
3294 tsv = newSVpv(tmpbuf, 0);
3307 t = SvPVX_const(tsv);
3312 len = strlen(tmpbuf);
3314 #ifdef FIXNEGATIVEZERO
3315 if (len == 2 && t[0] == '-' && t[1] == '0') {
3320 SvUPGRADE(sv, SVt_PV);
3323 s = SvGROW_mutable(sv, len + 1);
3326 return strcpy(s, t);
3331 =for apidoc sv_copypv
3333 Copies a stringified representation of the source SV into the
3334 destination SV. Automatically performs any necessary mg_get and
3335 coercion of numeric values into strings. Guaranteed to preserve
3336 UTF-8 flag even from overloaded objects. Similar in nature to
3337 sv_2pv[_flags] but operates directly on an SV instead of just the
3338 string. Mostly uses sv_2pv_flags to do its work, except when that
3339 would lose the UTF-8'ness of the PV.
3345 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3349 s = SvPV_const(ssv,len);
3350 sv_setpvn(dsv,s,len);
3358 =for apidoc sv_2pvbyte_nolen
3360 Return a pointer to the byte-encoded representation of the SV.
3361 May cause the SV to be downgraded from UTF-8 as a side-effect.
3363 Usually accessed via the C<SvPVbyte_nolen> macro.
3369 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3371 return sv_2pvbyte(sv, 0);
3375 =for apidoc sv_2pvbyte
3377 Return a pointer to the byte-encoded representation of the SV, and set *lp
3378 to its length. May cause the SV to be downgraded from UTF-8 as a
3381 Usually accessed via the C<SvPVbyte> macro.
3387 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3389 sv_utf8_downgrade(sv,0);
3390 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3394 =for apidoc sv_2pvutf8_nolen
3396 Return a pointer to the UTF-8-encoded representation of the SV.
3397 May cause the SV to be upgraded to UTF-8 as a side-effect.
3399 Usually accessed via the C<SvPVutf8_nolen> macro.
3405 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3407 return sv_2pvutf8(sv, 0);
3411 =for apidoc sv_2pvutf8
3413 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3414 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3416 Usually accessed via the C<SvPVutf8> macro.
3422 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3424 sv_utf8_upgrade(sv);
3425 return SvPV(sv,*lp);
3429 =for apidoc sv_2bool
3431 This function is only called on magical items, and is only used by
3432 sv_true() or its macro equivalent.
3438 Perl_sv_2bool(pTHX_ register SV *sv)
3447 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3448 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3449 return (bool)SvTRUE(tmpsv);
3450 return SvRV(sv) != 0;
3453 register XPV* Xpvtmp;
3454 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3455 (*sv->sv_u.svu_pv > '0' ||
3456 Xpvtmp->xpv_cur > 1 ||
3457 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3464 return SvIVX(sv) != 0;
3467 return SvNVX(sv) != 0.0;
3474 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3475 * this function provided for binary compatibility only
3480 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3482 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3486 =for apidoc sv_utf8_upgrade
3488 Converts the PV of an SV to its UTF-8-encoded form.
3489 Forces the SV to string form if it is not already.
3490 Always sets the SvUTF8 flag to avoid future validity checks even
3491 if all the bytes have hibit clear.
3493 This is not as a general purpose byte encoding to Unicode interface:
3494 use the Encode extension for that.
3496 =for apidoc sv_utf8_upgrade_flags
3498 Converts the PV of an SV to its UTF-8-encoded form.
3499 Forces the SV to string form if it is not already.
3500 Always sets the SvUTF8 flag to avoid future validity checks even
3501 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3502 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3503 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3505 This is not as a general purpose byte encoding to Unicode interface:
3506 use the Encode extension for that.
3512 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3514 if (sv == &PL_sv_undef)
3518 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3519 (void) sv_2pv_flags(sv,&len, flags);
3523 (void) SvPV_force(sv,len);
3532 sv_force_normal_flags(sv, 0);
3535 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3536 sv_recode_to_utf8(sv, PL_encoding);
3537 else { /* Assume Latin-1/EBCDIC */
3538 /* This function could be much more efficient if we
3539 * had a FLAG in SVs to signal if there are any hibit
3540 * chars in the PV. Given that there isn't such a flag
3541 * make the loop as fast as possible. */
3542 const U8 *s = (U8 *) SvPVX_const(sv);
3543 const U8 *e = (U8 *) SvEND(sv);
3549 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3553 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3554 U8 *recoded = bytes_to_utf8((U8*)s, &len);
3556 SvPV_free(sv); /* No longer using what was there before. */
3558 SvPV_set(sv, (char*)recoded);
3559 SvCUR_set(sv, len - 1);
3560 SvLEN_set(sv, len); /* No longer know the real size. */
3562 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3569 =for apidoc sv_utf8_downgrade
3571 Attempts to convert the PV of an SV from characters to bytes.
3572 If the PV contains a character beyond byte, this conversion will fail;
3573 in this case, either returns false or, if C<fail_ok> is not
3576 This is not as a general purpose Unicode to byte encoding interface:
3577 use the Encode extension for that.
3583 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3585 if (SvPOKp(sv) && SvUTF8(sv)) {
3591 sv_force_normal_flags(sv, 0);
3593 s = (U8 *) SvPV(sv, len);
3594 if (!utf8_to_bytes(s, &len)) {
3599 Perl_croak(aTHX_ "Wide character in %s",
3602 Perl_croak(aTHX_ "Wide character");
3613 =for apidoc sv_utf8_encode
3615 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3616 flag off so that it looks like octets again.
3622 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3624 (void) sv_utf8_upgrade(sv);
3626 sv_force_normal_flags(sv, 0);
3628 if (SvREADONLY(sv)) {
3629 Perl_croak(aTHX_ PL_no_modify);
3635 =for apidoc sv_utf8_decode
3637 If the PV of the SV is an octet sequence in UTF-8
3638 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3639 so that it looks like a character. If the PV contains only single-byte
3640 characters, the C<SvUTF8> flag stays being off.
3641 Scans PV for validity and returns false if the PV is invalid UTF-8.
3647 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3653 /* The octets may have got themselves encoded - get them back as
3656 if (!sv_utf8_downgrade(sv, TRUE))
3659 /* it is actually just a matter of turning the utf8 flag on, but
3660 * we want to make sure everything inside is valid utf8 first.
3662 c = (const U8 *) SvPVX_const(sv);
3663 if (!is_utf8_string(c, SvCUR(sv)+1))
3665 e = (const U8 *) SvEND(sv);
3668 if (!UTF8_IS_INVARIANT(ch)) {
3677 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
3678 * this function provided for binary compatibility only
3682 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3684 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3688 =for apidoc sv_setsv
3690 Copies the contents of the source SV C<ssv> into the destination SV
3691 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3692 function if the source SV needs to be reused. Does not handle 'set' magic.
3693 Loosely speaking, it performs a copy-by-value, obliterating any previous
3694 content of the destination.
3696 You probably want to use one of the assortment of wrappers, such as
3697 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3698 C<SvSetMagicSV_nosteal>.
3700 =for apidoc sv_setsv_flags
3702 Copies the contents of the source SV C<ssv> into the destination SV
3703 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3704 function if the source SV needs to be reused. Does not handle 'set' magic.
3705 Loosely speaking, it performs a copy-by-value, obliterating any previous
3706 content of the destination.
3707 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3708 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3709 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3710 and C<sv_setsv_nomg> are implemented in terms of this function.
3712 You probably want to use one of the assortment of wrappers, such as
3713 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3714 C<SvSetMagicSV_nosteal>.
3716 This is the primary function for copying scalars, and most other
3717 copy-ish functions and macros use this underneath.
3723 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3725 register U32 sflags;
3731 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3733 sstr = &PL_sv_undef;
3734 stype = SvTYPE(sstr);
3735 dtype = SvTYPE(dstr);
3740 /* need to nuke the magic */
3742 SvRMAGICAL_off(dstr);
3745 /* There's a lot of redundancy below but we're going for speed here */
3750 if (dtype != SVt_PVGV) {
3751 (void)SvOK_off(dstr);
3759 sv_upgrade(dstr, SVt_IV);
3762 sv_upgrade(dstr, SVt_PVNV);
3766 sv_upgrade(dstr, SVt_PVIV);
3769 (void)SvIOK_only(dstr);
3770 SvIV_set(dstr, SvIVX(sstr));
3773 if (SvTAINTED(sstr))
3784 sv_upgrade(dstr, SVt_NV);
3789 sv_upgrade(dstr, SVt_PVNV);
3792 SvNV_set(dstr, SvNVX(sstr));
3793 (void)SvNOK_only(dstr);
3794 if (SvTAINTED(sstr))
3802 sv_upgrade(dstr, SVt_RV);
3803 else if (dtype == SVt_PVGV &&
3804 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3807 if (GvIMPORTED(dstr) != GVf_IMPORTED
3808 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3810 GvIMPORTED_on(dstr);
3819 #ifdef PERL_OLD_COPY_ON_WRITE
3820 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3821 if (dtype < SVt_PVIV)
3822 sv_upgrade(dstr, SVt_PVIV);
3829 sv_upgrade(dstr, SVt_PV);
3832 if (dtype < SVt_PVIV)
3833 sv_upgrade(dstr, SVt_PVIV);
3836 if (dtype < SVt_PVNV)
3837 sv_upgrade(dstr, SVt_PVNV);
3844 const char * const type = sv_reftype(sstr,0);
3846 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3848 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3853 if (dtype <= SVt_PVGV) {
3855 if (dtype != SVt_PVGV) {
3856 const char * const name = GvNAME(sstr);
3857 const STRLEN len = GvNAMELEN(sstr);
3858 /* don't upgrade SVt_PVLV: it can hold a glob */
3859 if (dtype != SVt_PVLV)
3860 sv_upgrade(dstr, SVt_PVGV);
3861 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3862 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3863 GvNAME(dstr) = savepvn(name, len);
3864 GvNAMELEN(dstr) = len;
3865 SvFAKE_on(dstr); /* can coerce to non-glob */
3867 /* ahem, death to those who redefine active sort subs */
3868 else if (PL_curstackinfo->si_type == PERLSI_SORT
3869 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3870 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3873 #ifdef GV_UNIQUE_CHECK
3874 if (GvUNIQUE((GV*)dstr)) {
3875 Perl_croak(aTHX_ PL_no_modify);
3879 (void)SvOK_off(dstr);
3880 GvINTRO_off(dstr); /* one-shot flag */
3882 GvGP(dstr) = gp_ref(GvGP(sstr));
3883 if (SvTAINTED(sstr))
3885 if (GvIMPORTED(dstr) != GVf_IMPORTED
3886 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3888 GvIMPORTED_on(dstr);
3896 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3898 if ((int)SvTYPE(sstr) != stype) {
3899 stype = SvTYPE(sstr);
3900 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3904 if (stype == SVt_PVLV)
3905 SvUPGRADE(dstr, SVt_PVNV);
3907 SvUPGRADE(dstr, (U32)stype);
3910 sflags = SvFLAGS(sstr);
3912 if (sflags & SVf_ROK) {
3913 if (dtype >= SVt_PV) {
3914 if (dtype == SVt_PVGV) {
3915 SV *sref = SvREFCNT_inc(SvRV(sstr));
3917 const int intro = GvINTRO(dstr);
3919 #ifdef GV_UNIQUE_CHECK
3920 if (GvUNIQUE((GV*)dstr)) {
3921 Perl_croak(aTHX_ PL_no_modify);
3926 GvINTRO_off(dstr); /* one-shot flag */
3927 GvLINE(dstr) = CopLINE(PL_curcop);
3928 GvEGV(dstr) = (GV*)dstr;
3931 switch (SvTYPE(sref)) {
3934 SAVEGENERICSV(GvAV(dstr));
3936 dref = (SV*)GvAV(dstr);
3937 GvAV(dstr) = (AV*)sref;
3938 if (!GvIMPORTED_AV(dstr)
3939 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3941 GvIMPORTED_AV_on(dstr);
3946 SAVEGENERICSV(GvHV(dstr));
3948 dref = (SV*)GvHV(dstr);
3949 GvHV(dstr) = (HV*)sref;
3950 if (!GvIMPORTED_HV(dstr)
3951 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3953 GvIMPORTED_HV_on(dstr);
3958 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3959 SvREFCNT_dec(GvCV(dstr));
3960 GvCV(dstr) = Nullcv;
3961 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3962 PL_sub_generation++;
3964 SAVEGENERICSV(GvCV(dstr));
3967 dref = (SV*)GvCV(dstr);
3968 if (GvCV(dstr) != (CV*)sref) {
3969 CV* cv = GvCV(dstr);
3971 if (!GvCVGEN((GV*)dstr) &&
3972 (CvROOT(cv) || CvXSUB(cv)))
3974 /* ahem, death to those who redefine
3975 * active sort subs */
3976 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3977 PL_sortcop == CvSTART(cv))
3979 "Can't redefine active sort subroutine %s",
3980 GvENAME((GV*)dstr));
3981 /* Redefining a sub - warning is mandatory if
3982 it was a const and its value changed. */
3983 if (ckWARN(WARN_REDEFINE)
3985 && (!CvCONST((CV*)sref)
3986 || sv_cmp(cv_const_sv(cv),
3987 cv_const_sv((CV*)sref)))))
3989 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3991 ? "Constant subroutine %s::%s redefined"
3992 : "Subroutine %s::%s redefined",
3993 HvNAME_get(GvSTASH((GV*)dstr)),
3994 GvENAME((GV*)dstr));
3998 cv_ckproto(cv, (GV*)dstr,
4000 ? SvPVX_const(sref) : Nullch);
4002 GvCV(dstr) = (CV*)sref;
4003 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4004 GvASSUMECV_on(dstr);
4005 PL_sub_generation++;
4007 if (!GvIMPORTED_CV(dstr)
4008 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4010 GvIMPORTED_CV_on(dstr);
4015 SAVEGENERICSV(GvIOp(dstr));
4017 dref = (SV*)GvIOp(dstr);
4018 GvIOp(dstr) = (IO*)sref;
4022 SAVEGENERICSV(GvFORM(dstr));
4024 dref = (SV*)GvFORM(dstr);
4025 GvFORM(dstr) = (CV*)sref;
4029 SAVEGENERICSV(GvSV(dstr));
4031 dref = (SV*)GvSV(dstr);
4033 if (!GvIMPORTED_SV(dstr)
4034 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4036 GvIMPORTED_SV_on(dstr);
4042 if (SvTAINTED(sstr))
4046 if (SvPVX_const(dstr)) {
4052 (void)SvOK_off(dstr);
4053 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4055 if (sflags & SVp_NOK) {
4057 /* Only set the public OK flag if the source has public OK. */
4058 if (sflags & SVf_NOK)
4059 SvFLAGS(dstr) |= SVf_NOK;
4060 SvNV_set(dstr, SvNVX(sstr));
4062 if (sflags & SVp_IOK) {
4063 (void)SvIOKp_on(dstr);
4064 if (sflags & SVf_IOK)
4065 SvFLAGS(dstr) |= SVf_IOK;
4066 if (sflags & SVf_IVisUV)
4068 SvIV_set(dstr, SvIVX(sstr));
4070 if (SvAMAGIC(sstr)) {
4074 else if (sflags & SVp_POK) {
4078 * Check to see if we can just swipe the string. If so, it's a
4079 * possible small lose on short strings, but a big win on long ones.
4080 * It might even be a win on short strings if SvPVX_const(dstr)
4081 * has to be allocated and SvPVX_const(sstr) has to be freed.
4084 /* Whichever path we take through the next code, we want this true,
4085 and doing it now facilitates the COW check. */
4086 (void)SvPOK_only(dstr);
4089 /* We're not already COW */
4090 ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4091 #ifndef PERL_OLD_COPY_ON_WRITE
4092 /* or we are, but dstr isn't a suitable target. */
4093 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4098 (sflags & SVs_TEMP) && /* slated for free anyway? */
4099 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4100 (!(flags & SV_NOSTEAL)) &&
4101 /* and we're allowed to steal temps */
4102 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4103 SvLEN(sstr) && /* and really is a string */
4104 /* and won't be needed again, potentially */
4105 !(PL_op && PL_op->op_type == OP_AASSIGN))
4106 #ifdef PERL_OLD_COPY_ON_WRITE
4107 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4108 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4109 && SvTYPE(sstr) >= SVt_PVIV)
4112 /* Failed the swipe test, and it's not a shared hash key either.
4113 Have to copy the string. */
4114 STRLEN len = SvCUR(sstr);
4115 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4116 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4117 SvCUR_set(dstr, len);
4118 *SvEND(dstr) = '\0';
4120 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4122 /* Either it's a shared hash key, or it's suitable for
4123 copy-on-write or we can swipe the string. */
4125 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4129 #ifdef PERL_OLD_COPY_ON_WRITE
4131 /* I believe I should acquire a global SV mutex if
4132 it's a COW sv (not a shared hash key) to stop
4133 it going un copy-on-write.
4134 If the source SV has gone un copy on write between up there
4135 and down here, then (assert() that) it is of the correct
4136 form to make it copy on write again */
4137 if ((sflags & (SVf_FAKE | SVf_READONLY))
4138 != (SVf_FAKE | SVf_READONLY)) {
4139 SvREADONLY_on(sstr);
4141 /* Make the source SV into a loop of 1.
4142 (about to become 2) */
4143 SV_COW_NEXT_SV_SET(sstr, sstr);
4147 /* Initial code is common. */
4148 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4150 SvFLAGS(dstr) &= ~SVf_OOK;
4151 Safefree(SvPVX_const(dstr) - SvIVX(dstr));
4153 else if (SvLEN(dstr))
4154 Safefree(SvPVX_const(dstr));
4158 /* making another shared SV. */
4159 STRLEN cur = SvCUR(sstr);
4160 STRLEN len = SvLEN(sstr);
4161 #ifdef PERL_OLD_COPY_ON_WRITE
4163 assert (SvTYPE(dstr) >= SVt_PVIV);
4164 /* SvIsCOW_normal */
4165 /* splice us in between source and next-after-source. */
4166 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4167 SV_COW_NEXT_SV_SET(sstr, dstr);
4168 SvPV_set(dstr, SvPVX_mutable(sstr));
4172 /* SvIsCOW_shared_hash */
4173 DEBUG_C(PerlIO_printf(Perl_debug_log,
4174 "Copy on write: Sharing hash\n"));
4176 assert (SvTYPE(dstr) >= SVt_PV);
4178 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4180 SvLEN_set(dstr, len);
4181 SvCUR_set(dstr, cur);
4182 SvREADONLY_on(dstr);
4184 /* Relesase a global SV mutex. */
4187 { /* Passes the swipe test. */
4188 SvPV_set(dstr, SvPVX_mutable(sstr));
4189 SvLEN_set(dstr, SvLEN(sstr));
4190 SvCUR_set(dstr, SvCUR(sstr));
4193 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4194 SvPV_set(sstr, Nullch);
4200 if (sflags & SVf_UTF8)
4202 if (sflags & SVp_NOK) {
4204 if (sflags & SVf_NOK)
4205 SvFLAGS(dstr) |= SVf_NOK;
4206 SvNV_set(dstr, SvNVX(sstr));
4208 if (sflags & SVp_IOK) {
4209 (void)SvIOKp_on(dstr);
4210 if (sflags & SVf_IOK)
4211 SvFLAGS(dstr) |= SVf_IOK;
4212 if (sflags & SVf_IVisUV)
4214 SvIV_set(dstr, SvIVX(sstr));
4217 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4218 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4219 smg->mg_ptr, smg->mg_len);
4220 SvRMAGICAL_on(dstr);
4223 else if (sflags & SVp_IOK) {
4224 if (sflags & SVf_IOK)
4225 (void)SvIOK_only(dstr);
4227 (void)SvOK_off(dstr);
4228 (void)SvIOKp_on(dstr);
4230 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4231 if (sflags & SVf_IVisUV)
4233 SvIV_set(dstr, SvIVX(sstr));
4234 if (sflags & SVp_NOK) {
4235 if (sflags & SVf_NOK)
4236 (void)SvNOK_on(dstr);
4238 (void)SvNOKp_on(dstr);
4239 SvNV_set(dstr, SvNVX(sstr));
4242 else if (sflags & SVp_NOK) {
4243 if (sflags & SVf_NOK)
4244 (void)SvNOK_only(dstr);
4246 (void)SvOK_off(dstr);
4249 SvNV_set(dstr, SvNVX(sstr));
4252 if (dtype == SVt_PVGV) {
4253 if (ckWARN(WARN_MISC))
4254 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4257 (void)SvOK_off(dstr);
4259 if (SvTAINTED(sstr))
4264 =for apidoc sv_setsv_mg
4266 Like C<sv_setsv>, but also handles 'set' magic.
4272 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4274 sv_setsv(dstr,sstr);
4278 #ifdef PERL_OLD_COPY_ON_WRITE
4280 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4282 STRLEN cur = SvCUR(sstr);
4283 STRLEN len = SvLEN(sstr);
4284 register char *new_pv;
4287 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4295 if (SvTHINKFIRST(dstr))
4296 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4297 else if (SvPVX_const(dstr))
4298 Safefree(SvPVX_const(dstr));
4302 SvUPGRADE(dstr, SVt_PVIV);
4304 assert (SvPOK(sstr));
4305 assert (SvPOKp(sstr));
4306 assert (!SvIOK(sstr));
4307 assert (!SvIOKp(sstr));
4308 assert (!SvNOK(sstr));
4309 assert (!SvNOKp(sstr));
4311 if (SvIsCOW(sstr)) {
4313 if (SvLEN(sstr) == 0) {
4314 /* source is a COW shared hash key. */
4315 DEBUG_C(PerlIO_printf(Perl_debug_log,
4316 "Fast copy on write: Sharing hash\n"));
4317 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4320 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4322 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4323 SvUPGRADE(sstr, SVt_PVIV);
4324 SvREADONLY_on(sstr);
4326 DEBUG_C(PerlIO_printf(Perl_debug_log,
4327 "Fast copy on write: Converting sstr to COW\n"));
4328 SV_COW_NEXT_SV_SET(dstr, sstr);
4330 SV_COW_NEXT_SV_SET(sstr, dstr);
4331 new_pv = SvPVX_mutable(sstr);
4334 SvPV_set(dstr, new_pv);
4335 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4338 SvLEN_set(dstr, len);
4339 SvCUR_set(dstr, cur);
4348 =for apidoc sv_setpvn
4350 Copies a string into an SV. The C<len> parameter indicates the number of
4351 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4352 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4358 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4360 register char *dptr;
4362 SV_CHECK_THINKFIRST_COW_DROP(sv);
4368 /* len is STRLEN which is unsigned, need to copy to signed */
4371 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4373 SvUPGRADE(sv, SVt_PV);
4375 dptr = SvGROW(sv, len + 1);
4376 Move(ptr,dptr,len,char);
4379 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4384 =for apidoc sv_setpvn_mg
4386 Like C<sv_setpvn>, but also handles 'set' magic.
4392 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4394 sv_setpvn(sv,ptr,len);
4399 =for apidoc sv_setpv
4401 Copies a string into an SV. The string must be null-terminated. Does not
4402 handle 'set' magic. See C<sv_setpv_mg>.
4408 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4410 register STRLEN len;
4412 SV_CHECK_THINKFIRST_COW_DROP(sv);
4418 SvUPGRADE(sv, SVt_PV);
4420 SvGROW(sv, len + 1);
4421 Move(ptr,SvPVX(sv),len+1,char);
4423 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4428 =for apidoc sv_setpv_mg
4430 Like C<sv_setpv>, but also handles 'set' magic.
4436 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4443 =for apidoc sv_usepvn
4445 Tells an SV to use C<ptr> to find its string value. Normally the string is
4446 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4447 The C<ptr> should point to memory that was allocated by C<malloc>. The
4448 string length, C<len>, must be supplied. This function will realloc the
4449 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4450 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4451 See C<sv_usepvn_mg>.
4457 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4460 SV_CHECK_THINKFIRST_COW_DROP(sv);
4461 SvUPGRADE(sv, SVt_PV);
4466 if (SvPVX_const(sv))
4469 allocate = PERL_STRLEN_ROUNDUP(len + 1);
4470 ptr = saferealloc (ptr, allocate);
4473 SvLEN_set(sv, allocate);
4475 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4480 =for apidoc sv_usepvn_mg
4482 Like C<sv_usepvn>, but also handles 'set' magic.
4488 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4490 sv_usepvn(sv,ptr,len);
4494 #ifdef PERL_OLD_COPY_ON_WRITE
4495 /* Need to do this *after* making the SV normal, as we need the buffer
4496 pointer to remain valid until after we've copied it. If we let go too early,
4497 another thread could invalidate it by unsharing last of the same hash key
4498 (which it can do by means other than releasing copy-on-write Svs)
4499 or by changing the other copy-on-write SVs in the loop. */
4501 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
4503 if (len) { /* this SV was SvIsCOW_normal(sv) */
4504 /* we need to find the SV pointing to us. */
4505 SV *current = SV_COW_NEXT_SV(after);
4507 if (current == sv) {
4508 /* The SV we point to points back to us (there were only two of us
4510 Hence other SV is no longer copy on write either. */
4512 SvREADONLY_off(after);
4514 /* We need to follow the pointers around the loop. */
4516 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4519 /* don't loop forever if the structure is bust, and we have
4520 a pointer into a closed loop. */
4521 assert (current != after);
4522 assert (SvPVX_const(current) == pvx);
4524 /* Make the SV before us point to the SV after us. */
4525 SV_COW_NEXT_SV_SET(current, after);
4528 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4533 Perl_sv_release_IVX(pTHX_ register SV *sv)
4536 sv_force_normal_flags(sv, 0);
4542 =for apidoc sv_force_normal_flags
4544 Undo various types of fakery on an SV: if the PV is a shared string, make
4545 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4546 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4547 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4548 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4549 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4550 set to some other value.) In addition, the C<flags> parameter gets passed to
4551 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4552 with flags set to 0.
4558 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4560 #ifdef PERL_OLD_COPY_ON_WRITE
4561 if (SvREADONLY(sv)) {
4562 /* At this point I believe I should acquire a global SV mutex. */
4564 const char *pvx = SvPVX_const(sv);
4565 const STRLEN len = SvLEN(sv);
4566 const STRLEN cur = SvCUR(sv);
4567 SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
4569 PerlIO_printf(Perl_debug_log,
4570 "Copy on write: Force normal %ld\n",
4576 /* This SV doesn't own the buffer, so need to New() a new one: */
4577 SvPV_set(sv, (char*)0);
4579 if (flags & SV_COW_DROP_PV) {
4580 /* OK, so we don't need to copy our buffer. */
4583 SvGROW(sv, cur + 1);
4584 Move(pvx,SvPVX(sv),cur,char);
4588 sv_release_COW(sv, pvx, len, next);
4593 else if (IN_PERL_RUNTIME)
4594 Perl_croak(aTHX_ PL_no_modify);
4595 /* At this point I believe that I can drop the global SV mutex. */
4598 if (SvREADONLY(sv)) {
4600 const char *pvx = SvPVX_const(sv);
4601 const STRLEN len = SvCUR(sv);
4604 SvPV_set(sv, Nullch);
4606 SvGROW(sv, len + 1);
4607 Move(pvx,SvPVX_const(sv),len,char);
4609 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4611 else if (IN_PERL_RUNTIME)
4612 Perl_croak(aTHX_ PL_no_modify);
4616 sv_unref_flags(sv, flags);
4617 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4622 =for apidoc sv_force_normal
4624 Undo various types of fakery on an SV: if the PV is a shared string, make
4625 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4626 an xpvmg. See also C<sv_force_normal_flags>.
4632 Perl_sv_force_normal(pTHX_ register SV *sv)
4634 sv_force_normal_flags(sv, 0);
4640 Efficient removal of characters from the beginning of the string buffer.
4641 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4642 the string buffer. The C<ptr> becomes the first character of the adjusted
4643 string. Uses the "OOK hack".
4644 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4645 refer to the same chunk of data.
4651 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
4653 register STRLEN delta;
4654 if (!ptr || !SvPOKp(sv))
4656 delta = ptr - SvPVX_const(sv);
4657 SV_CHECK_THINKFIRST(sv);
4658 if (SvTYPE(sv) < SVt_PVIV)
4659 sv_upgrade(sv,SVt_PVIV);
4662 if (!SvLEN(sv)) { /* make copy of shared string */
4663 const char *pvx = SvPVX_const(sv);
4664 const STRLEN len = SvCUR(sv);
4665 SvGROW(sv, len + 1);
4666 Move(pvx,SvPVX_const(sv),len,char);
4670 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
4671 and we do that anyway inside the SvNIOK_off
4673 SvFLAGS(sv) |= SVf_OOK;
4676 SvLEN_set(sv, SvLEN(sv) - delta);
4677 SvCUR_set(sv, SvCUR(sv) - delta);
4678 SvPV_set(sv, SvPVX(sv) + delta);
4679 SvIV_set(sv, SvIVX(sv) + delta);
4682 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
4683 * this function provided for binary compatibility only
4687 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
4689 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
4693 =for apidoc sv_catpvn
4695 Concatenates the string onto the end of the string which is in the SV. The
4696 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4697 status set, then the bytes appended should be valid UTF-8.
4698 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4700 =for apidoc sv_catpvn_flags
4702 Concatenates the string onto the end of the string which is in the SV. The
4703 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4704 status set, then the bytes appended should be valid UTF-8.
4705 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4706 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4707 in terms of this function.
4713 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4716 const char *dstr = SvPV_force_flags(dsv, dlen, flags);
4718 SvGROW(dsv, dlen + slen + 1);
4720 sstr = SvPVX_const(dsv);
4721 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4722 SvCUR_set(dsv, SvCUR(dsv) + slen);
4724 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4729 =for apidoc sv_catpvn_mg
4731 Like C<sv_catpvn>, but also handles 'set' magic.
4737 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4739 sv_catpvn(sv,ptr,len);
4743 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
4744 * this function provided for binary compatibility only
4748 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
4750 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
4754 =for apidoc sv_catsv
4756 Concatenates the string from SV C<ssv> onto the end of the string in
4757 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4758 not 'set' magic. See C<sv_catsv_mg>.
4760 =for apidoc sv_catsv_flags
4762 Concatenates the string from SV C<ssv> onto the end of the string in
4763 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4764 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4765 and C<sv_catsv_nomg> are implemented in terms of this function.
4770 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4776 if ((spv = SvPV_const(ssv, slen))) {
4777 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4778 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4779 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4780 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4781 dsv->sv_flags doesn't have that bit set.
4782 Andy Dougherty 12 Oct 2001
4784 const I32 sutf8 = DO_UTF8(ssv);
4787 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4789 dutf8 = DO_UTF8(dsv);
4791 if (dutf8 != sutf8) {
4793 /* Not modifying source SV, so taking a temporary copy. */
4794 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4796 sv_utf8_upgrade(csv);
4797 spv = SvPV_const(csv, slen);
4800 sv_utf8_upgrade_nomg(dsv);
4802 sv_catpvn_nomg(dsv, spv, slen);
4807 =for apidoc sv_catsv_mg
4809 Like C<sv_catsv>, but also handles 'set' magic.
4815 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4822 =for apidoc sv_catpv
4824 Concatenates the string onto the end of the string which is in the SV.
4825 If the SV has the UTF-8 status set, then the bytes appended should be
4826 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4831 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4833 register STRLEN len;
4839 junk = SvPV_force(sv, tlen);
4841 SvGROW(sv, tlen + len + 1);
4843 ptr = SvPVX_const(sv);
4844 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4845 SvCUR_set(sv, SvCUR(sv) + len);
4846 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4851 =for apidoc sv_catpv_mg
4853 Like C<sv_catpv>, but also handles 'set' magic.
4859 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4868 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4869 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4876 Perl_newSV(pTHX_ STRLEN len)
4882 sv_upgrade(sv, SVt_PV);
4883 SvGROW(sv, len + 1);
4888 =for apidoc sv_magicext
4890 Adds magic to an SV, upgrading it if necessary. Applies the
4891 supplied vtable and returns a pointer to the magic added.
4893 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4894 In particular, you can add magic to SvREADONLY SVs, and add more than
4895 one instance of the same 'how'.
4897 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4898 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4899 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4900 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4902 (This is now used as a subroutine by C<sv_magic>.)
4907 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
4908 const char* name, I32 namlen)
4912 if (SvTYPE(sv) < SVt_PVMG) {
4913 SvUPGRADE(sv, SVt_PVMG);
4915 Newz(702,mg, 1, MAGIC);
4916 mg->mg_moremagic = SvMAGIC(sv);
4917 SvMAGIC_set(sv, mg);
4919 /* Sometimes a magic contains a reference loop, where the sv and
4920 object refer to each other. To prevent a reference loop that
4921 would prevent such objects being freed, we look for such loops
4922 and if we find one we avoid incrementing the object refcount.
4924 Note we cannot do this to avoid self-tie loops as intervening RV must
4925 have its REFCNT incremented to keep it in existence.
4928 if (!obj || obj == sv ||
4929 how == PERL_MAGIC_arylen ||
4930 how == PERL_MAGIC_qr ||
4931 how == PERL_MAGIC_symtab ||
4932 (SvTYPE(obj) == SVt_PVGV &&
4933 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4934 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4935 GvFORM(obj) == (CV*)sv)))
4940 mg->mg_obj = SvREFCNT_inc(obj);
4941 mg->mg_flags |= MGf_REFCOUNTED;
4944 /* Normal self-ties simply pass a null object, and instead of
4945 using mg_obj directly, use the SvTIED_obj macro to produce a
4946 new RV as needed. For glob "self-ties", we are tieing the PVIO
4947 with an RV obj pointing to the glob containing the PVIO. In
4948 this case, to avoid a reference loop, we need to weaken the
4952 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4953 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4959 mg->mg_len = namlen;
4962 mg->mg_ptr = savepvn(name, namlen);
4963 else if (namlen == HEf_SVKEY)
4964 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4966 mg->mg_ptr = (char *) name;
4968 mg->mg_virtual = vtable;
4972 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4977 =for apidoc sv_magic
4979 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4980 then adds a new magic item of type C<how> to the head of the magic list.
4982 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4983 handling of the C<name> and C<namlen> arguments.
4985 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4986 to add more than one instance of the same 'how'.
4992 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4994 const MGVTBL *vtable = 0;
4997 #ifdef PERL_OLD_COPY_ON_WRITE
4999 sv_force_normal_flags(sv, 0);
5001 if (SvREADONLY(sv)) {
5003 && how != PERL_MAGIC_regex_global
5004 && how != PERL_MAGIC_bm
5005 && how != PERL_MAGIC_fm
5006 && how != PERL_MAGIC_sv
5007 && how != PERL_MAGIC_backref
5010 Perl_croak(aTHX_ PL_no_modify);
5013 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5014 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5015 /* sv_magic() refuses to add a magic of the same 'how' as an
5018 if (how == PERL_MAGIC_taint)
5026 vtable = &PL_vtbl_sv;
5028 case PERL_MAGIC_overload:
5029 vtable = &PL_vtbl_amagic;
5031 case PERL_MAGIC_overload_elem:
5032 vtable = &PL_vtbl_amagicelem;
5034 case PERL_MAGIC_overload_table:
5035 vtable = &PL_vtbl_ovrld;
5038 vtable = &PL_vtbl_bm;
5040 case PERL_MAGIC_regdata:
5041 vtable = &PL_vtbl_regdata;
5043 case PERL_MAGIC_regdatum:
5044 vtable = &PL_vtbl_regdatum;
5046 case PERL_MAGIC_env:
5047 vtable = &PL_vtbl_env;
5050 vtable = &PL_vtbl_fm;
5052 case PERL_MAGIC_envelem:
5053 vtable = &PL_vtbl_envelem;
5055 case PERL_MAGIC_regex_global:
5056 vtable = &PL_vtbl_mglob;
5058 case PERL_MAGIC_isa:
5059 vtable = &PL_vtbl_isa;
5061 case PERL_MAGIC_isaelem:
5062 vtable = &PL_vtbl_isaelem;
5064 case PERL_MAGIC_nkeys:
5065 vtable = &PL_vtbl_nkeys;
5067 case PERL_MAGIC_dbfile:
5070 case PERL_MAGIC_dbline:
5071 vtable = &PL_vtbl_dbline;
5073 #ifdef USE_LOCALE_COLLATE
5074 case PERL_MAGIC_collxfrm:
5075 vtable = &PL_vtbl_collxfrm;
5077 #endif /* USE_LOCALE_COLLATE */
5078 case PERL_MAGIC_tied:
5079 vtable = &PL_vtbl_pack;
5081 case PERL_MAGIC_tiedelem:
5082 case PERL_MAGIC_tiedscalar:
5083 vtable = &PL_vtbl_packelem;
5086 vtable = &PL_vtbl_regexp;
5088 case PERL_MAGIC_sig:
5089 vtable = &PL_vtbl_sig;
5091 case PERL_MAGIC_sigelem:
5092 vtable = &PL_vtbl_sigelem;
5094 case PERL_MAGIC_taint:
5095 vtable = &PL_vtbl_taint;
5097 case PERL_MAGIC_uvar:
5098 vtable = &PL_vtbl_uvar;
5100 case PERL_MAGIC_vec:
5101 vtable = &PL_vtbl_vec;
5103 case PERL_MAGIC_arylen_p:
5104 case PERL_MAGIC_rhash:
5105 case PERL_MAGIC_symtab:
5106 case PERL_MAGIC_vstring:
5109 case PERL_MAGIC_utf8:
5110 vtable = &PL_vtbl_utf8;
5112 case PERL_MAGIC_substr:
5113 vtable = &PL_vtbl_substr;
5115 case PERL_MAGIC_defelem:
5116 vtable = &PL_vtbl_defelem;
5118 case PERL_MAGIC_glob:
5119 vtable = &PL_vtbl_glob;
5121 case PERL_MAGIC_arylen:
5122 vtable = &PL_vtbl_arylen;
5124 case PERL_MAGIC_pos:
5125 vtable = &PL_vtbl_pos;
5127 case PERL_MAGIC_backref:
5128 vtable = &PL_vtbl_backref;
5130 case PERL_MAGIC_ext:
5131 /* Reserved for use by extensions not perl internals. */
5132 /* Useful for attaching extension internal data to perl vars. */
5133 /* Note that multiple extensions may clash if magical scalars */
5134 /* etc holding private data from one are passed to another. */
5137 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5140 /* Rest of work is done else where */
5141 mg = sv_magicext(sv,obj,how,(MGVTBL*)vtable,name,namlen);
5144 case PERL_MAGIC_taint:
5147 case PERL_MAGIC_ext:
5148 case PERL_MAGIC_dbfile:
5155 =for apidoc sv_unmagic
5157 Removes all magic of type C<type> from an SV.
5163 Perl_sv_unmagic(pTHX_ SV *sv, int type)
5167 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5170 for (mg = *mgp; mg; mg = *mgp) {
5171 if (mg->mg_type == type) {
5172 const MGVTBL* const vtbl = mg->mg_virtual;
5173 *mgp = mg->mg_moremagic;
5174 if (vtbl && vtbl->svt_free)
5175 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5176 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5178 Safefree(mg->mg_ptr);
5179 else if (mg->mg_len == HEf_SVKEY)
5180 SvREFCNT_dec((SV*)mg->mg_ptr);
5181 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
5182 Safefree(mg->mg_ptr);
5184 if (mg->mg_flags & MGf_REFCOUNTED)
5185 SvREFCNT_dec(mg->mg_obj);
5189 mgp = &mg->mg_moremagic;
5193 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5200 =for apidoc sv_rvweaken
5202 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5203 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5204 push a back-reference to this RV onto the array of backreferences
5205 associated with that magic.
5211 Perl_sv_rvweaken(pTHX_ SV *sv)
5214 if (!SvOK(sv)) /* let undefs pass */
5217 Perl_croak(aTHX_ "Can't weaken a nonreference");
5218 else if (SvWEAKREF(sv)) {
5219 if (ckWARN(WARN_MISC))
5220 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5224 sv_add_backref(tsv, sv);
5230 /* Give tsv backref magic if it hasn't already got it, then push a
5231 * back-reference to sv onto the array associated with the backref magic.
5235 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
5239 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
5240 av = (AV*)mg->mg_obj;
5243 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5244 /* av now has a refcnt of 2, which avoids it getting freed
5245 * before us during global cleanup. The extra ref is removed
5246 * by magic_killbackrefs() when tsv is being freed */
5248 if (AvFILLp(av) >= AvMAX(av)) {
5250 SV **svp = AvARRAY(av);
5251 for (i = AvFILLp(av); i >= 0; i--)
5253 svp[i] = sv; /* reuse the slot */
5256 av_extend(av, AvFILLp(av)+1);
5258 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5261 /* delete a back-reference to ourselves from the backref magic associated
5262 * with the SV we point to.
5266 S_sv_del_backref(pTHX_ SV *sv)
5273 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
5274 Perl_croak(aTHX_ "panic: del_backref");
5275 av = (AV *)mg->mg_obj;
5277 for (i = AvFILLp(av); i >= 0; i--)
5278 if (svp[i] == sv) svp[i] = Nullsv;
5282 =for apidoc sv_insert
5284 Inserts a string at the specified offset/length within the SV. Similar to
5285 the Perl substr() function.
5291 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
5295 register char *midend;
5296 register char *bigend;
5302 Perl_croak(aTHX_ "Can't modify non-existent substring");
5303 SvPV_force(bigstr, curlen);
5304 (void)SvPOK_only_UTF8(bigstr);
5305 if (offset + len > curlen) {
5306 SvGROW(bigstr, offset+len+1);
5307 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5308 SvCUR_set(bigstr, offset+len);
5312 i = littlelen - len;
5313 if (i > 0) { /* string might grow */
5314 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5315 mid = big + offset + len;
5316 midend = bigend = big + SvCUR(bigstr);
5319 while (midend > mid) /* shove everything down */
5320 *--bigend = *--midend;
5321 Move(little,big+offset,littlelen,char);
5322 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5327 Move(little,SvPVX(bigstr)+offset,len,char);
5332 big = SvPVX(bigstr);
5335 bigend = big + SvCUR(bigstr);
5337 if (midend > bigend)
5338 Perl_croak(aTHX_ "panic: sv_insert");
5340 if (mid - big > bigend - midend) { /* faster to shorten from end */
5342 Move(little, mid, littlelen,char);
5345 i = bigend - midend;
5347 Move(midend, mid, i,char);
5351 SvCUR_set(bigstr, mid - big);
5353 else if ((i = mid - big)) { /* faster from front */
5354 midend -= littlelen;
5356 sv_chop(bigstr,midend-i);
5361 Move(little, mid, littlelen,char);
5363 else if (littlelen) {
5364 midend -= littlelen;
5365 sv_chop(bigstr,midend);
5366 Move(little,midend,littlelen,char);
5369 sv_chop(bigstr,midend);
5375 =for apidoc sv_replace
5377 Make the first argument a copy of the second, then delete the original.
5378 The target SV physically takes over ownership of the body of the source SV
5379 and inherits its flags; however, the target keeps any magic it owns,
5380 and any magic in the source is discarded.
5381 Note that this is a rather specialist SV copying operation; most of the
5382 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5388 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5390 const U32 refcnt = SvREFCNT(sv);
5391 SV_CHECK_THINKFIRST_COW_DROP(sv);
5392 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
5393 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
5394 if (SvMAGICAL(sv)) {
5398 sv_upgrade(nsv, SVt_PVMG);
5399 SvMAGIC_set(nsv, SvMAGIC(sv));
5400 SvFLAGS(nsv) |= SvMAGICAL(sv);
5402 SvMAGIC_set(sv, NULL);
5406 assert(!SvREFCNT(sv));
5407 #ifdef DEBUG_LEAKING_SCALARS
5408 sv->sv_flags = nsv->sv_flags;
5409 sv->sv_any = nsv->sv_any;
5410 sv->sv_refcnt = nsv->sv_refcnt;
5411 sv->sv_u = nsv->sv_u;
5413 StructCopy(nsv,sv,SV);
5415 /* Currently could join these into one piece of pointer arithmetic, but
5416 it would be unclear. */
5417 if(SvTYPE(sv) == SVt_IV)
5419 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5420 else if (SvTYPE(sv) == SVt_RV) {
5421 SvANY(sv) = &sv->sv_u.svu_rv;
5425 #ifdef PERL_OLD_COPY_ON_WRITE
5426 if (SvIsCOW_normal(nsv)) {
5427 /* We need to follow the pointers around the loop to make the
5428 previous SV point to sv, rather than nsv. */
5431 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5434 assert(SvPVX_const(current) == SvPVX_const(nsv));
5436 /* Make the SV before us point to the SV after us. */
5438 PerlIO_printf(Perl_debug_log, "previous is\n");
5440 PerlIO_printf(Perl_debug_log,
5441 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5442 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5444 SV_COW_NEXT_SV_SET(current, sv);
5447 SvREFCNT(sv) = refcnt;
5448 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5454 =for apidoc sv_clear
5456 Clear an SV: call any destructors, free up any memory used by the body,
5457 and free the body itself. The SV's head is I<not> freed, although
5458 its type is set to all 1's so that it won't inadvertently be assumed
5459 to be live during global destruction etc.
5460 This function should only be called when REFCNT is zero. Most of the time
5461 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5468 Perl_sv_clear(pTHX_ register SV *sv)
5473 assert(SvREFCNT(sv) == 0);
5476 if (PL_defstash) { /* Still have a symbol table? */
5480 stash = SvSTASH(sv);
5481 destructor = StashHANDLER(stash,DESTROY);
5483 SV* tmpref = newRV(sv);
5484 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5486 PUSHSTACKi(PERLSI_DESTROY);
5491 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5497 if(SvREFCNT(tmpref) < 2) {
5498 /* tmpref is not kept alive! */
5500 SvRV_set(tmpref, NULL);
5503 SvREFCNT_dec(tmpref);
5505 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5509 if (PL_in_clean_objs)
5510 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5512 /* DESTROY gave object new lease on life */
5518 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5519 SvOBJECT_off(sv); /* Curse the object. */
5520 if (SvTYPE(sv) != SVt_PVIO)
5521 --PL_sv_objcount; /* XXX Might want something more general */
5524 if (SvTYPE(sv) >= SVt_PVMG) {
5527 if (SvTYPE(sv) == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
5528 SvREFCNT_dec(SvSTASH(sv));
5531 switch (SvTYPE(sv)) {
5534 IoIFP(sv) != PerlIO_stdin() &&
5535 IoIFP(sv) != PerlIO_stdout() &&
5536 IoIFP(sv) != PerlIO_stderr())
5538 io_close((IO*)sv, FALSE);
5540 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5541 PerlDir_close(IoDIRP(sv));
5542 IoDIRP(sv) = (DIR*)NULL;
5543 Safefree(IoTOP_NAME(sv));
5544 Safefree(IoFMT_NAME(sv));
5545 Safefree(IoBOTTOM_NAME(sv));
5560 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5561 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5562 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5563 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5565 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5566 SvREFCNT_dec(LvTARG(sv));
5570 Safefree(GvNAME(sv));
5571 /* cannot decrease stash refcount yet, as we might recursively delete
5572 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
5573 of stash until current sv is completely gone.
5574 -- JohnPC, 27 Mar 1998 */
5575 stash = GvSTASH(sv);
5581 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5583 SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
5584 /* Don't even bother with turning off the OOK flag. */
5593 SvREFCNT_dec(SvRV(sv));
5595 #ifdef PERL_OLD_COPY_ON_WRITE
5596 else if (SvPVX_const(sv)) {
5598 /* I believe I need to grab the global SV mutex here and
5599 then recheck the COW status. */
5601 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5604 sv_release_COW(sv, SvPVX_const(sv), SvLEN(sv),
5605 SV_COW_NEXT_SV(sv));
5606 /* And drop it here. */
5608 } else if (SvLEN(sv)) {
5609 Safefree(SvPVX_const(sv));
5613 else if (SvPVX_const(sv) && SvLEN(sv))
5614 Safefree(SvPVX_const(sv));
5615 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5616 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5629 switch (SvTYPE(sv)) {
5643 del_XPVIV(SvANY(sv));
5646 del_XPVNV(SvANY(sv));
5649 del_XPVMG(SvANY(sv));
5652 del_XPVLV(SvANY(sv));
5655 del_XPVAV(SvANY(sv));
5658 del_XPVHV(SvANY(sv));
5661 del_XPVCV(SvANY(sv));
5664 del_XPVGV(SvANY(sv));
5665 /* code duplication for increased performance. */
5666 SvFLAGS(sv) &= SVf_BREAK;
5667 SvFLAGS(sv) |= SVTYPEMASK;
5668 /* decrease refcount of the stash that owns this GV, if any */
5670 SvREFCNT_dec(stash);
5671 return; /* not break, SvFLAGS reset already happened */
5673 del_XPVBM(SvANY(sv));
5676 del_XPVFM(SvANY(sv));
5679 del_XPVIO(SvANY(sv));
5682 SvFLAGS(sv) &= SVf_BREAK;
5683 SvFLAGS(sv) |= SVTYPEMASK;
5687 =for apidoc sv_newref
5689 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5696 Perl_sv_newref(pTHX_ SV *sv)
5706 Decrement an SV's reference count, and if it drops to zero, call
5707 C<sv_clear> to invoke destructors and free up any memory used by
5708 the body; finally, deallocate the SV's head itself.
5709 Normally called via a wrapper macro C<SvREFCNT_dec>.
5715 Perl_sv_free(pTHX_ SV *sv)
5720 if (SvREFCNT(sv) == 0) {
5721 if (SvFLAGS(sv) & SVf_BREAK)
5722 /* this SV's refcnt has been artificially decremented to
5723 * trigger cleanup */
5725 if (PL_in_clean_all) /* All is fair */
5727 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5728 /* make sure SvREFCNT(sv)==0 happens very seldom */
5729 SvREFCNT(sv) = (~(U32)0)/2;
5732 if (ckWARN_d(WARN_INTERNAL))
5733 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5734 "Attempt to free unreferenced scalar: SV 0x%"UVxf
5735 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5738 if (--(SvREFCNT(sv)) > 0)
5740 Perl_sv_free2(aTHX_ sv);
5744 Perl_sv_free2(pTHX_ SV *sv)
5749 if (ckWARN_d(WARN_DEBUGGING))
5750 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5751 "Attempt to free temp prematurely: SV 0x%"UVxf
5752 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5756 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5757 /* make sure SvREFCNT(sv)==0 happens very seldom */
5758 SvREFCNT(sv) = (~(U32)0)/2;
5769 Returns the length of the string in the SV. Handles magic and type
5770 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5776 Perl_sv_len(pTHX_ register SV *sv)
5784 len = mg_length(sv);
5786 (void)SvPV_const(sv, len);
5791 =for apidoc sv_len_utf8
5793 Returns the number of characters in the string in an SV, counting wide
5794 UTF-8 bytes as a single character. Handles magic and type coercion.
5800 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
5801 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
5802 * (Note that the mg_len is not the length of the mg_ptr field.)
5807 Perl_sv_len_utf8(pTHX_ register SV *sv)
5813 return mg_length(sv);
5817 const U8 *s = (U8*)SvPV_const(sv, len);
5818 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
5820 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
5822 #ifdef PERL_UTF8_CACHE_ASSERT
5823 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
5827 ulen = Perl_utf8_length(aTHX_ s, s + len);
5828 if (!mg && !SvREADONLY(sv)) {
5829 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5830 mg = mg_find(sv, PERL_MAGIC_utf8);
5840 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
5841 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5842 * between UTF-8 and byte offsets. There are two (substr offset and substr
5843 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
5844 * and byte offset) cache positions.
5846 * The mg_len field is used by sv_len_utf8(), see its comments.
5847 * Note that the mg_len is not the length of the mg_ptr field.
5851 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i,
5852 I32 offsetp, const U8 *s, const U8 *start)
5856 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5858 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
5862 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5864 Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5865 (*mgp)->mg_ptr = (char *) *cachep;
5869 (*cachep)[i] = offsetp;
5870 (*cachep)[i+1] = s - start;
5878 * S_utf8_mg_pos() is used to query and update mg_ptr field of
5879 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5880 * between UTF-8 and byte offsets. See also the comments of
5881 * S_utf8_mg_pos_init().
5885 S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, const U8 **sp, const U8 *start, const U8 *send)
5889 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5891 *mgp = mg_find(sv, PERL_MAGIC_utf8);
5892 if (*mgp && (*mgp)->mg_ptr) {
5893 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5894 ASSERT_UTF8_CACHE(*cachep);
5895 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
5897 else { /* We will skip to the right spot. */
5902 /* The assumption is that going backward is half
5903 * the speed of going forward (that's where the
5904 * 2 * backw in the below comes from). (The real
5905 * figure of course depends on the UTF-8 data.) */
5907 if ((*cachep)[i] > (STRLEN)uoff) {
5909 backw = (*cachep)[i] - (STRLEN)uoff;
5911 if (forw < 2 * backw)
5914 p = start + (*cachep)[i+1];
5916 /* Try this only for the substr offset (i == 0),
5917 * not for the substr length (i == 2). */
5918 else if (i == 0) { /* (*cachep)[i] < uoff */
5919 const STRLEN ulen = sv_len_utf8(sv);
5921 if ((STRLEN)uoff < ulen) {
5922 forw = (STRLEN)uoff - (*cachep)[i];
5923 backw = ulen - (STRLEN)uoff;
5925 if (forw < 2 * backw)
5926 p = start + (*cachep)[i+1];
5931 /* If the string is not long enough for uoff,
5932 * we could extend it, but not at this low a level. */
5936 if (forw < 2 * backw) {
5943 while (UTF8_IS_CONTINUATION(*p))
5948 /* Update the cache. */
5949 (*cachep)[i] = (STRLEN)uoff;
5950 (*cachep)[i+1] = p - start;
5952 /* Drop the stale "length" cache */
5961 if (found) { /* Setup the return values. */
5962 *offsetp = (*cachep)[i+1];
5963 *sp = start + *offsetp;
5966 *offsetp = send - start;
5968 else if (*sp < start) {
5974 #ifdef PERL_UTF8_CACHE_ASSERT
5979 while (n-- && s < send)
5983 assert(*offsetp == s - start);
5984 assert((*cachep)[0] == (STRLEN)uoff);
5985 assert((*cachep)[1] == *offsetp);
5987 ASSERT_UTF8_CACHE(*cachep);
5996 =for apidoc sv_pos_u2b
5998 Converts the value pointed to by offsetp from a count of UTF-8 chars from
5999 the start of the string, to a count of the equivalent number of bytes; if
6000 lenp is non-zero, it does the same to lenp, but this time starting from
6001 the offset, rather than from the start of the string. Handles magic and
6008 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6009 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6010 * byte offsets. See also the comments of S_utf8_mg_pos().
6015 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
6023 start = (U8*)SvPV_const(sv, len);
6027 const U8 *s = start;
6028 I32 uoffset = *offsetp;
6029 const U8 *send = s + len;
6033 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
6035 if (!found && uoffset > 0) {
6036 while (s < send && uoffset--)
6040 if (utf8_mg_pos_init(sv, &mg, &cache, 0, *offsetp, s, start))
6042 *offsetp = s - start;
6047 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) {
6051 if (!found && *lenp > 0) {
6054 while (s < send && ulen--)
6058 utf8_mg_pos_init(sv, &mg, &cache, 2, *lenp, s, start);
6062 ASSERT_UTF8_CACHE(cache);
6074 =for apidoc sv_pos_b2u
6076 Converts the value pointed to by offsetp from a count of bytes from the
6077 start of the string, to a count of the equivalent number of UTF-8 chars.
6078 Handles magic and type coercion.
6084 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6085 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6086 * byte offsets. See also the comments of S_utf8_mg_pos().
6091 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
6099 s = (const U8*)SvPV_const(sv, len);
6100 if ((I32)len < *offsetp)
6101 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6103 const U8* send = s + *offsetp;
6105 STRLEN *cache = NULL;
6109 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6110 mg = mg_find(sv, PERL_MAGIC_utf8);
6111 if (mg && mg->mg_ptr) {
6112 cache = (STRLEN *) mg->mg_ptr;
6113 if (cache[1] == (STRLEN)*offsetp) {
6114 /* An exact match. */
6115 *offsetp = cache[0];
6119 else if (cache[1] < (STRLEN)*offsetp) {
6120 /* We already know part of the way. */
6123 /* Let the below loop do the rest. */
6125 else { /* cache[1] > *offsetp */
6126 /* We already know all of the way, now we may
6127 * be able to walk back. The same assumption
6128 * is made as in S_utf8_mg_pos(), namely that
6129 * walking backward is twice slower than
6130 * walking forward. */
6131 STRLEN forw = *offsetp;
6132 STRLEN backw = cache[1] - *offsetp;
6134 if (!(forw < 2 * backw)) {
6135 const U8 *p = s + cache[1];
6142 while (UTF8_IS_CONTINUATION(*p)) {
6150 *offsetp = cache[0];
6152 /* Drop the stale "length" cache */
6160 ASSERT_UTF8_CACHE(cache);
6166 /* Call utf8n_to_uvchr() to validate the sequence
6167 * (unless a simple non-UTF character) */
6168 if (!UTF8_IS_INVARIANT(*s))
6169 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
6178 if (!SvREADONLY(sv)) {
6180 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6181 mg = mg_find(sv, PERL_MAGIC_utf8);
6186 Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6187 mg->mg_ptr = (char *) cache;
6192 cache[1] = *offsetp;
6193 /* Drop the stale "length" cache */
6206 Returns a boolean indicating whether the strings in the two SVs are
6207 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6208 coerce its args to strings if necessary.
6214 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6222 SV* svrecode = Nullsv;
6229 pv1 = SvPV_const(sv1, cur1);
6236 pv2 = SvPV_const(sv2, cur2);
6238 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6239 /* Differing utf8ness.
6240 * Do not UTF8size the comparands as a side-effect. */
6243 svrecode = newSVpvn(pv2, cur2);
6244 sv_recode_to_utf8(svrecode, PL_encoding);
6245 pv2 = SvPV_const(svrecode, cur2);
6248 svrecode = newSVpvn(pv1, cur1);
6249 sv_recode_to_utf8(svrecode, PL_encoding);
6250 pv1 = SvPV_const(svrecode, cur1);
6252 /* Now both are in UTF-8. */
6254 SvREFCNT_dec(svrecode);
6259 bool is_utf8 = TRUE;
6262 /* sv1 is the UTF-8 one,
6263 * if is equal it must be downgrade-able */
6264 char *pv = (char*)bytes_from_utf8((const U8*)pv1,
6270 /* sv2 is the UTF-8 one,
6271 * if is equal it must be downgrade-able */
6272 char *pv = (char *)bytes_from_utf8((const U8*)pv2,
6278 /* Downgrade not possible - cannot be eq */
6286 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6289 SvREFCNT_dec(svrecode);
6300 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6301 string in C<sv1> is less than, equal to, or greater than the string in
6302 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6303 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6309 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6312 const char *pv1, *pv2;
6315 SV *svrecode = Nullsv;
6322 pv1 = SvPV_const(sv1, cur1);
6329 pv2 = SvPV_const(sv2, cur2);
6331 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6332 /* Differing utf8ness.
6333 * Do not UTF8size the comparands as a side-effect. */
6336 svrecode = newSVpvn(pv2, cur2);
6337 sv_recode_to_utf8(svrecode, PL_encoding);
6338 pv2 = SvPV_const(svrecode, cur2);
6341 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6346 svrecode = newSVpvn(pv1, cur1);
6347 sv_recode_to_utf8(svrecode, PL_encoding);
6348 pv1 = SvPV_const(svrecode, cur1);
6351 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6357 cmp = cur2 ? -1 : 0;
6361 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6364 cmp = retval < 0 ? -1 : 1;
6365 } else if (cur1 == cur2) {
6368 cmp = cur1 < cur2 ? -1 : 1;
6373 SvREFCNT_dec(svrecode);
6382 =for apidoc sv_cmp_locale
6384 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6385 'use bytes' aware, handles get magic, and will coerce its args to strings
6386 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6392 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6394 #ifdef USE_LOCALE_COLLATE
6400 if (PL_collation_standard)
6404 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6406 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6408 if (!pv1 || !len1) {
6419 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6422 return retval < 0 ? -1 : 1;
6425 * When the result of collation is equality, that doesn't mean
6426 * that there are no differences -- some locales exclude some
6427 * characters from consideration. So to avoid false equalities,
6428 * we use the raw string as a tiebreaker.
6434 #endif /* USE_LOCALE_COLLATE */
6436 return sv_cmp(sv1, sv2);
6440 #ifdef USE_LOCALE_COLLATE
6443 =for apidoc sv_collxfrm
6445 Add Collate Transform magic to an SV if it doesn't already have it.
6447 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6448 scalar data of the variable, but transformed to such a format that a normal
6449 memory comparison can be used to compare the data according to the locale
6456 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6460 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6461 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6467 Safefree(mg->mg_ptr);
6468 s = SvPV_const(sv, len);
6469 if ((xf = mem_collxfrm(s, len, &xlen))) {
6470 if (SvREADONLY(sv)) {
6473 return xf + sizeof(PL_collation_ix);
6476 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6477 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6490 if (mg && mg->mg_ptr) {
6492 return mg->mg_ptr + sizeof(PL_collation_ix);
6500 #endif /* USE_LOCALE_COLLATE */
6505 Get a line from the filehandle and store it into the SV, optionally
6506 appending to the currently-stored string.
6512 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6516 register STDCHAR rslast;
6517 register STDCHAR *bp;
6523 if (SvTHINKFIRST(sv))
6524 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6525 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6527 However, perlbench says it's slower, because the existing swipe code
6528 is faster than copy on write.
6529 Swings and roundabouts. */
6530 SvUPGRADE(sv, SVt_PV);
6535 if (PerlIO_isutf8(fp)) {
6537 sv_utf8_upgrade_nomg(sv);
6538 sv_pos_u2b(sv,&append,0);
6540 } else if (SvUTF8(sv)) {
6541 SV *tsv = NEWSV(0,0);
6542 sv_gets(tsv, fp, 0);
6543 sv_utf8_upgrade_nomg(tsv);
6544 SvCUR_set(sv,append);
6547 goto return_string_or_null;
6552 if (PerlIO_isutf8(fp))
6555 if (IN_PERL_COMPILETIME) {
6556 /* we always read code in line mode */
6560 else if (RsSNARF(PL_rs)) {
6561 /* If it is a regular disk file use size from stat() as estimate
6562 of amount we are going to read - may result in malloc-ing
6563 more memory than we realy need if layers bellow reduce
6564 size we read (e.g. CRLF or a gzip layer)
6567 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6568 const Off_t offset = PerlIO_tell(fp);
6569 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6570 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6576 else if (RsRECORD(PL_rs)) {
6580 /* Grab the size of the record we're getting */
6581 recsize = SvIV(SvRV(PL_rs));
6582 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6585 /* VMS wants read instead of fread, because fread doesn't respect */
6586 /* RMS record boundaries. This is not necessarily a good thing to be */
6587 /* doing, but we've got no other real choice - except avoid stdio
6588 as implementation - perhaps write a :vms layer ?
6590 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6592 bytesread = PerlIO_read(fp, buffer, recsize);
6596 SvCUR_set(sv, bytesread += append);
6597 buffer[bytesread] = '\0';
6598 goto return_string_or_null;
6600 else if (RsPARA(PL_rs)) {
6606 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6607 if (PerlIO_isutf8(fp)) {
6608 rsptr = SvPVutf8(PL_rs, rslen);
6611 if (SvUTF8(PL_rs)) {
6612 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6613 Perl_croak(aTHX_ "Wide character in $/");
6616 rsptr = SvPV_const(PL_rs, rslen);
6620 rslast = rslen ? rsptr[rslen - 1] : '\0';
6622 if (rspara) { /* have to do this both before and after */
6623 do { /* to make sure file boundaries work right */
6626 i = PerlIO_getc(fp);
6630 PerlIO_ungetc(fp,i);
6636 /* See if we know enough about I/O mechanism to cheat it ! */
6638 /* This used to be #ifdef test - it is made run-time test for ease
6639 of abstracting out stdio interface. One call should be cheap
6640 enough here - and may even be a macro allowing compile
6644 if (PerlIO_fast_gets(fp)) {
6647 * We're going to steal some values from the stdio struct
6648 * and put EVERYTHING in the innermost loop into registers.
6650 register STDCHAR *ptr;
6654 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6655 /* An ungetc()d char is handled separately from the regular
6656 * buffer, so we getc() it back out and stuff it in the buffer.
6658 i = PerlIO_getc(fp);
6659 if (i == EOF) return 0;
6660 *(--((*fp)->_ptr)) = (unsigned char) i;
6664 /* Here is some breathtakingly efficient cheating */
6666 cnt = PerlIO_get_cnt(fp); /* get count into register */
6667 /* make sure we have the room */
6668 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
6669 /* Not room for all of it
6670 if we are looking for a separator and room for some
6672 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
6673 /* just process what we have room for */
6674 shortbuffered = cnt - SvLEN(sv) + append + 1;
6675 cnt -= shortbuffered;
6679 /* remember that cnt can be negative */
6680 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
6685 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
6686 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
6687 DEBUG_P(PerlIO_printf(Perl_debug_log,
6688 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6689 DEBUG_P(PerlIO_printf(Perl_debug_log,
6690 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6691 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6692 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6697 while (cnt > 0) { /* this | eat */
6699 if ((*bp++ = *ptr++) == rslast) /* really | dust */
6700 goto thats_all_folks; /* screams | sed :-) */
6704 Copy(ptr, bp, cnt, char); /* this | eat */
6705 bp += cnt; /* screams | dust */
6706 ptr += cnt; /* louder | sed :-) */
6711 if (shortbuffered) { /* oh well, must extend */
6712 cnt = shortbuffered;
6714 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6716 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6717 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6721 DEBUG_P(PerlIO_printf(Perl_debug_log,
6722 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6723 PTR2UV(ptr),(long)cnt));
6724 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6726 DEBUG_P(PerlIO_printf(Perl_debug_log,
6727 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6728 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6729 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6731 /* This used to call 'filbuf' in stdio form, but as that behaves like
6732 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6733 another abstraction. */
6734 i = PerlIO_getc(fp); /* get more characters */
6736 DEBUG_P(PerlIO_printf(Perl_debug_log,
6737 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6738 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6739 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6741 cnt = PerlIO_get_cnt(fp);
6742 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
6743 DEBUG_P(PerlIO_printf(Perl_debug_log,
6744 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6746 if (i == EOF) /* all done for ever? */
6747 goto thats_really_all_folks;
6749 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6751 SvGROW(sv, bpx + cnt + 2);
6752 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6754 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
6756 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
6757 goto thats_all_folks;
6761 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
6762 memNE((char*)bp - rslen, rsptr, rslen))
6763 goto screamer; /* go back to the fray */
6764 thats_really_all_folks:
6766 cnt += shortbuffered;
6767 DEBUG_P(PerlIO_printf(Perl_debug_log,
6768 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6769 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
6770 DEBUG_P(PerlIO_printf(Perl_debug_log,
6771 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6772 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6773 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6775 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
6776 DEBUG_P(PerlIO_printf(Perl_debug_log,
6777 "Screamer: done, len=%ld, string=|%.*s|\n",
6778 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
6782 /*The big, slow, and stupid way. */
6783 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
6785 New(0, buf, 8192, STDCHAR);
6793 const register STDCHAR *bpe = buf + sizeof(buf);
6795 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6796 ; /* keep reading */
6800 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6801 /* Accomodate broken VAXC compiler, which applies U8 cast to
6802 * both args of ?: operator, causing EOF to change into 255
6805 i = (U8)buf[cnt - 1];
6811 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
6813 sv_catpvn(sv, (char *) buf, cnt);
6815 sv_setpvn(sv, (char *) buf, cnt);
6817 if (i != EOF && /* joy */
6819 SvCUR(sv) < rslen ||
6820 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6824 * If we're reading from a TTY and we get a short read,
6825 * indicating that the user hit his EOF character, we need
6826 * to notice it now, because if we try to read from the TTY
6827 * again, the EOF condition will disappear.
6829 * The comparison of cnt to sizeof(buf) is an optimization
6830 * that prevents unnecessary calls to feof().
6834 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
6838 #ifdef USE_HEAP_INSTEAD_OF_STACK
6843 if (rspara) { /* have to do this both before and after */
6844 while (i != EOF) { /* to make sure file boundaries work right */
6845 i = PerlIO_getc(fp);
6847 PerlIO_ungetc(fp,i);
6853 return_string_or_null:
6854 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
6860 Auto-increment of the value in the SV, doing string to numeric conversion
6861 if necessary. Handles 'get' magic.
6867 Perl_sv_inc(pTHX_ register SV *sv)
6876 if (SvTHINKFIRST(sv)) {
6878 sv_force_normal_flags(sv, 0);
6879 if (SvREADONLY(sv)) {
6880 if (IN_PERL_RUNTIME)
6881 Perl_croak(aTHX_ PL_no_modify);
6885 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6887 i = PTR2IV(SvRV(sv));
6892 flags = SvFLAGS(sv);
6893 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6894 /* It's (privately or publicly) a float, but not tested as an
6895 integer, so test it to see. */
6897 flags = SvFLAGS(sv);
6899 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6900 /* It's publicly an integer, or privately an integer-not-float */
6901 #ifdef PERL_PRESERVE_IVUV
6905 if (SvUVX(sv) == UV_MAX)
6906 sv_setnv(sv, UV_MAX_P1);
6908 (void)SvIOK_only_UV(sv);
6909 SvUV_set(sv, SvUVX(sv) + 1);
6911 if (SvIVX(sv) == IV_MAX)
6912 sv_setuv(sv, (UV)IV_MAX + 1);
6914 (void)SvIOK_only(sv);
6915 SvIV_set(sv, SvIVX(sv) + 1);
6920 if (flags & SVp_NOK) {
6921 (void)SvNOK_only(sv);
6922 SvNV_set(sv, SvNVX(sv) + 1.0);
6926 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
6927 if ((flags & SVTYPEMASK) < SVt_PVIV)
6928 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
6929 (void)SvIOK_only(sv);
6934 while (isALPHA(*d)) d++;
6935 while (isDIGIT(*d)) d++;
6937 #ifdef PERL_PRESERVE_IVUV
6938 /* Got to punt this as an integer if needs be, but we don't issue
6939 warnings. Probably ought to make the sv_iv_please() that does
6940 the conversion if possible, and silently. */
6941 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6942 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6943 /* Need to try really hard to see if it's an integer.
6944 9.22337203685478e+18 is an integer.
6945 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6946 so $a="9.22337203685478e+18"; $a+0; $a++
6947 needs to be the same as $a="9.22337203685478e+18"; $a++
6954 /* sv_2iv *should* have made this an NV */
6955 if (flags & SVp_NOK) {
6956 (void)SvNOK_only(sv);
6957 SvNV_set(sv, SvNVX(sv) + 1.0);
6960 /* I don't think we can get here. Maybe I should assert this
6961 And if we do get here I suspect that sv_setnv will croak. NWC
6963 #if defined(USE_LONG_DOUBLE)
6964 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
6965 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6967 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6968 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6971 #endif /* PERL_PRESERVE_IVUV */
6972 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
6976 while (d >= SvPVX_const(sv)) {
6984 /* MKS: The original code here died if letters weren't consecutive.
6985 * at least it didn't have to worry about non-C locales. The
6986 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6987 * arranged in order (although not consecutively) and that only
6988 * [A-Za-z] are accepted by isALPHA in the C locale.
6990 if (*d != 'z' && *d != 'Z') {
6991 do { ++*d; } while (!isALPHA(*d));
6994 *(d--) -= 'z' - 'a';
6999 *(d--) -= 'z' - 'a' + 1;
7003 /* oh,oh, the number grew */
7004 SvGROW(sv, SvCUR(sv) + 2);
7005 SvCUR_set(sv, SvCUR(sv) + 1);
7006 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7017 Auto-decrement of the value in the SV, doing string to numeric conversion
7018 if necessary. Handles 'get' magic.
7024 Perl_sv_dec(pTHX_ register SV *sv)
7032 if (SvTHINKFIRST(sv)) {
7034 sv_force_normal_flags(sv, 0);
7035 if (SvREADONLY(sv)) {
7036 if (IN_PERL_RUNTIME)
7037 Perl_croak(aTHX_ PL_no_modify);
7041 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7043 i = PTR2IV(SvRV(sv));
7048 /* Unlike sv_inc we don't have to worry about string-never-numbers
7049 and keeping them magic. But we mustn't warn on punting */
7050 flags = SvFLAGS(sv);
7051 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7052 /* It's publicly an integer, or privately an integer-not-float */
7053 #ifdef PERL_PRESERVE_IVUV
7057 if (SvUVX(sv) == 0) {
7058 (void)SvIOK_only(sv);
7062 (void)SvIOK_only_UV(sv);
7063 SvUV_set(sv, SvUVX(sv) + 1);
7066 if (SvIVX(sv) == IV_MIN)
7067 sv_setnv(sv, (NV)IV_MIN - 1.0);
7069 (void)SvIOK_only(sv);
7070 SvIV_set(sv, SvIVX(sv) - 1);
7075 if (flags & SVp_NOK) {
7076 SvNV_set(sv, SvNVX(sv) - 1.0);
7077 (void)SvNOK_only(sv);
7080 if (!(flags & SVp_POK)) {
7081 if ((flags & SVTYPEMASK) < SVt_PVNV)
7082 sv_upgrade(sv, SVt_NV);
7084 (void)SvNOK_only(sv);
7087 #ifdef PERL_PRESERVE_IVUV
7089 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7090 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7091 /* Need to try really hard to see if it's an integer.
7092 9.22337203685478e+18 is an integer.
7093 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7094 so $a="9.22337203685478e+18"; $a+0; $a--
7095 needs to be the same as $a="9.22337203685478e+18"; $a--
7102 /* sv_2iv *should* have made this an NV */
7103 if (flags & SVp_NOK) {
7104 (void)SvNOK_only(sv);
7105 SvNV_set(sv, SvNVX(sv) - 1.0);
7108 /* I don't think we can get here. Maybe I should assert this
7109 And if we do get here I suspect that sv_setnv will croak. NWC
7111 #if defined(USE_LONG_DOUBLE)
7112 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",
7113 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7115 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7116 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7120 #endif /* PERL_PRESERVE_IVUV */
7121 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
7125 =for apidoc sv_mortalcopy
7127 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7128 The new SV is marked as mortal. It will be destroyed "soon", either by an
7129 explicit call to FREETMPS, or by an implicit call at places such as
7130 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7135 /* Make a string that will exist for the duration of the expression
7136 * evaluation. Actually, it may have to last longer than that, but
7137 * hopefully we won't free it until it has been assigned to a
7138 * permanent location. */
7141 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
7146 sv_setsv(sv,oldstr);
7148 PL_tmps_stack[++PL_tmps_ix] = sv;
7154 =for apidoc sv_newmortal
7156 Creates a new null SV which is mortal. The reference count of the SV is
7157 set to 1. It will be destroyed "soon", either by an explicit call to
7158 FREETMPS, or by an implicit call at places such as statement boundaries.
7159 See also C<sv_mortalcopy> and C<sv_2mortal>.
7165 Perl_sv_newmortal(pTHX)
7170 SvFLAGS(sv) = SVs_TEMP;
7172 PL_tmps_stack[++PL_tmps_ix] = sv;
7177 =for apidoc sv_2mortal
7179 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7180 by an explicit call to FREETMPS, or by an implicit call at places such as
7181 statement boundaries. SvTEMP() is turned on which means that the SV's
7182 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7183 and C<sv_mortalcopy>.
7189 Perl_sv_2mortal(pTHX_ register SV *sv)
7194 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7197 PL_tmps_stack[++PL_tmps_ix] = sv;
7205 Creates a new SV and copies a string into it. The reference count for the
7206 SV is set to 1. If C<len> is zero, Perl will compute the length using
7207 strlen(). For efficiency, consider using C<newSVpvn> instead.
7213 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
7218 sv_setpvn(sv,s,len ? len : strlen(s));
7223 =for apidoc newSVpvn
7225 Creates a new SV and copies a string into it. The reference count for the
7226 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7227 string. You are responsible for ensuring that the source string is at least
7228 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7234 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7239 sv_setpvn(sv,s,len);
7245 =for apidoc newSVhek
7247 Creates a new SV from the hash key structure. It will generate scalars that
7248 point to the shared string table where possible. Returns a new (undefined)
7249 SV if the hek is NULL.
7255 Perl_newSVhek(pTHX_ const HEK *hek)
7264 if (HEK_LEN(hek) == HEf_SVKEY) {
7265 return newSVsv(*(SV**)HEK_KEY(hek));
7267 const int flags = HEK_FLAGS(hek);
7268 if (flags & HVhek_WASUTF8) {
7270 Andreas would like keys he put in as utf8 to come back as utf8
7272 STRLEN utf8_len = HEK_LEN(hek);
7273 U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7274 SV *sv = newSVpvn ((char*)as_utf8, utf8_len);
7277 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7279 } else if (flags & HVhek_REHASH) {
7280 /* We don't have a pointer to the hv, so we have to replicate the
7281 flag into every HEK. This hv is using custom a hasing
7282 algorithm. Hence we can't return a shared string scalar, as
7283 that would contain the (wrong) hash value, and might get passed
7284 into an hv routine with a regular hash */
7286 SV *sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7291 /* This will be overwhelminly the most common case. */
7292 return newSVpvn_share(HEK_KEY(hek),
7293 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
7299 =for apidoc newSVpvn_share
7301 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7302 table. If the string does not already exist in the table, it is created
7303 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
7304 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
7305 otherwise the hash is computed. The idea here is that as the string table
7306 is used for shared hash keys these strings will have SvPVX_const == HeKEY and
7307 hash lookup will avoid string compare.
7313 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7316 bool is_utf8 = FALSE;
7318 STRLEN tmplen = -len;
7320 /* See the note in hv.c:hv_fetch() --jhi */
7321 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7325 PERL_HASH(hash, src, len);
7327 sv_upgrade(sv, SVt_PV);
7328 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7340 #if defined(PERL_IMPLICIT_CONTEXT)
7342 /* pTHX_ magic can't cope with varargs, so this is a no-context
7343 * version of the main function, (which may itself be aliased to us).
7344 * Don't access this version directly.
7348 Perl_newSVpvf_nocontext(const char* pat, ...)
7353 va_start(args, pat);
7354 sv = vnewSVpvf(pat, &args);
7361 =for apidoc newSVpvf
7363 Creates a new SV and initializes it with the string formatted like
7370 Perl_newSVpvf(pTHX_ const char* pat, ...)
7374 va_start(args, pat);
7375 sv = vnewSVpvf(pat, &args);
7380 /* backend for newSVpvf() and newSVpvf_nocontext() */
7383 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7387 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7394 Creates a new SV and copies a floating point value into it.
7395 The reference count for the SV is set to 1.
7401 Perl_newSVnv(pTHX_ NV n)
7413 Creates a new SV and copies an integer into it. The reference count for the
7420 Perl_newSViv(pTHX_ IV i)
7432 Creates a new SV and copies an unsigned integer into it.
7433 The reference count for the SV is set to 1.
7439 Perl_newSVuv(pTHX_ UV u)
7449 =for apidoc newRV_noinc
7451 Creates an RV wrapper for an SV. The reference count for the original
7452 SV is B<not> incremented.
7458 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7463 sv_upgrade(sv, SVt_RV);
7465 SvRV_set(sv, tmpRef);
7470 /* newRV_inc is the official function name to use now.
7471 * newRV_inc is in fact #defined to newRV in sv.h
7475 Perl_newRV(pTHX_ SV *tmpRef)
7477 return newRV_noinc(SvREFCNT_inc(tmpRef));
7483 Creates a new SV which is an exact duplicate of the original SV.
7490 Perl_newSVsv(pTHX_ register SV *old)
7496 if (SvTYPE(old) == SVTYPEMASK) {
7497 if (ckWARN_d(WARN_INTERNAL))
7498 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7502 /* SV_GMAGIC is the default for sv_setv()
7503 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7504 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7505 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7510 =for apidoc sv_reset
7512 Underlying implementation for the C<reset> Perl function.
7513 Note that the perl-level function is vaguely deprecated.
7519 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
7522 char todo[PERL_UCHAR_MAX+1];
7527 if (!*s) { /* reset ?? searches */
7528 MAGIC *mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
7530 PMOP *pm = (PMOP *) mg->mg_obj;
7532 pm->op_pmdynflags &= ~PMdf_USED;
7539 /* reset variables */
7541 if (!HvARRAY(stash))
7544 Zero(todo, 256, char);
7547 I32 i = (unsigned char)*s;
7551 max = (unsigned char)*s++;
7552 for ( ; i <= max; i++) {
7555 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7557 for (entry = HvARRAY(stash)[i];
7559 entry = HeNEXT(entry))
7564 if (!todo[(U8)*HeKEY(entry)])
7566 gv = (GV*)HeVAL(entry);
7568 if (SvTHINKFIRST(sv)) {
7569 if (!SvREADONLY(sv) && SvROK(sv))
7574 if (SvTYPE(sv) >= SVt_PV) {
7576 if (SvPVX_const(sv) != Nullch)
7583 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
7586 #ifdef USE_ENVIRON_ARRAY
7588 # ifdef USE_ITHREADS
7589 && PL_curinterp == aTHX
7593 environ[0] = Nullch;
7596 #endif /* !PERL_MICRO */
7606 Using various gambits, try to get an IO from an SV: the IO slot if its a
7607 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7608 named after the PV if we're a string.
7614 Perl_sv_2io(pTHX_ SV *sv)
7619 switch (SvTYPE(sv)) {
7627 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7631 Perl_croak(aTHX_ PL_no_usym, "filehandle");
7633 return sv_2io(SvRV(sv));
7634 gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
7640 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
7649 Using various gambits, try to get a CV from an SV; in addition, try if
7650 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7656 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7663 return *gvp = Nullgv, Nullcv;
7664 switch (SvTYPE(sv)) {
7683 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
7684 tryAMAGICunDEREF(to_cv);
7687 if (SvTYPE(sv) == SVt_PVCV) {
7696 Perl_croak(aTHX_ "Not a subroutine reference");
7701 gv = gv_fetchsv(sv, lref, SVt_PVCV);
7707 if (lref && !GvCVu(gv)) {
7710 tmpsv = NEWSV(704,0);
7711 gv_efullname3(tmpsv, gv, Nullch);
7712 /* XXX this is probably not what they think they're getting.
7713 * It has the same effect as "sub name;", i.e. just a forward
7715 newSUB(start_subparse(FALSE, 0),
7716 newSVOP(OP_CONST, 0, tmpsv),
7721 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
7731 Returns true if the SV has a true value by Perl's rules.
7732 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
7733 instead use an in-line version.
7739 Perl_sv_true(pTHX_ register SV *sv)
7744 const register XPV* tXpv;
7745 if ((tXpv = (XPV*)SvANY(sv)) &&
7746 (tXpv->xpv_cur > 1 ||
7747 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
7754 return SvIVX(sv) != 0;
7757 return SvNVX(sv) != 0.0;
7759 return sv_2bool(sv);
7767 A private implementation of the C<SvIVx> macro for compilers which can't
7768 cope with complex macro expressions. Always use the macro instead.
7774 Perl_sv_iv(pTHX_ register SV *sv)
7778 return (IV)SvUVX(sv);
7787 A private implementation of the C<SvUVx> macro for compilers which can't
7788 cope with complex macro expressions. Always use the macro instead.
7794 Perl_sv_uv(pTHX_ register SV *sv)
7799 return (UV)SvIVX(sv);
7807 A private implementation of the C<SvNVx> macro for compilers which can't
7808 cope with complex macro expressions. Always use the macro instead.
7814 Perl_sv_nv(pTHX_ register SV *sv)
7821 /* sv_pv() is now a macro using SvPV_nolen();
7822 * this function provided for binary compatibility only
7826 Perl_sv_pv(pTHX_ SV *sv)
7831 return sv_2pv(sv, 0);
7837 Use the C<SvPV_nolen> macro instead
7841 A private implementation of the C<SvPV> macro for compilers which can't
7842 cope with complex macro expressions. Always use the macro instead.
7848 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
7854 return sv_2pv(sv, lp);
7859 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
7865 return sv_2pv_flags(sv, lp, 0);
7868 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
7869 * this function provided for binary compatibility only
7873 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
7875 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
7879 =for apidoc sv_pvn_force
7881 Get a sensible string out of the SV somehow.
7882 A private implementation of the C<SvPV_force> macro for compilers which
7883 can't cope with complex macro expressions. Always use the macro instead.
7885 =for apidoc sv_pvn_force_flags
7887 Get a sensible string out of the SV somehow.
7888 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
7889 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
7890 implemented in terms of this function.
7891 You normally want to use the various wrapper macros instead: see
7892 C<SvPV_force> and C<SvPV_force_nomg>
7898 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
7901 if (SvTHINKFIRST(sv) && !SvROK(sv))
7902 sv_force_normal_flags(sv, 0);
7912 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
7914 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
7915 sv_reftype(sv,0), OP_NAME(PL_op));
7917 Perl_croak(aTHX_ "Can't coerce readonly %s to string",
7920 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
7921 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
7925 s = sv_2pv_flags(sv, &len, flags);
7929 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
7932 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
7933 SvGROW(sv, len + 1);
7934 Move(s,SvPVX_const(sv),len,char);
7939 SvPOK_on(sv); /* validate pointer */
7941 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
7942 PTR2UV(sv),SvPVX_const(sv)));
7945 return SvPVX_mutable(sv);
7948 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
7949 * this function provided for binary compatibility only
7953 Perl_sv_pvbyte(pTHX_ SV *sv)
7955 sv_utf8_downgrade(sv,0);
7960 =for apidoc sv_pvbyte
7962 Use C<SvPVbyte_nolen> instead.
7964 =for apidoc sv_pvbyten
7966 A private implementation of the C<SvPVbyte> macro for compilers
7967 which can't cope with complex macro expressions. Always use the macro
7974 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
7976 sv_utf8_downgrade(sv,0);
7977 return sv_pvn(sv,lp);
7981 =for apidoc sv_pvbyten_force
7983 A private implementation of the C<SvPVbytex_force> macro for compilers
7984 which can't cope with complex macro expressions. Always use the macro
7991 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
7993 sv_pvn_force(sv,lp);
7994 sv_utf8_downgrade(sv,0);
7999 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
8000 * this function provided for binary compatibility only
8004 Perl_sv_pvutf8(pTHX_ SV *sv)
8006 sv_utf8_upgrade(sv);
8011 =for apidoc sv_pvutf8
8013 Use the C<SvPVutf8_nolen> macro instead
8015 =for apidoc sv_pvutf8n
8017 A private implementation of the C<SvPVutf8> macro for compilers
8018 which can't cope with complex macro expressions. Always use the macro
8025 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
8027 sv_utf8_upgrade(sv);
8028 return sv_pvn(sv,lp);
8032 =for apidoc sv_pvutf8n_force
8034 A private implementation of the C<SvPVutf8_force> macro for compilers
8035 which can't cope with complex macro expressions. Always use the macro
8042 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
8044 sv_pvn_force(sv,lp);
8045 sv_utf8_upgrade(sv);
8051 =for apidoc sv_reftype
8053 Returns a string describing what the SV is a reference to.
8059 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
8061 /* The fact that I don't need to downcast to char * everywhere, only in ?:
8062 inside return suggests a const propagation bug in g++. */
8063 if (ob && SvOBJECT(sv)) {
8064 char *name = HvNAME_get(SvSTASH(sv));
8065 return name ? name : (char *) "__ANON__";
8068 switch (SvTYPE(sv)) {
8085 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
8086 /* tied lvalues should appear to be
8087 * scalars for backwards compatitbility */
8088 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8089 ? "SCALAR" : "LVALUE");
8090 case SVt_PVAV: return "ARRAY";
8091 case SVt_PVHV: return "HASH";
8092 case SVt_PVCV: return "CODE";
8093 case SVt_PVGV: return "GLOB";
8094 case SVt_PVFM: return "FORMAT";
8095 case SVt_PVIO: return "IO";
8096 default: return "UNKNOWN";
8102 =for apidoc sv_isobject
8104 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8105 object. If the SV is not an RV, or if the object is not blessed, then this
8112 Perl_sv_isobject(pTHX_ SV *sv)
8129 Returns a boolean indicating whether the SV is blessed into the specified
8130 class. This does not check for subtypes; use C<sv_derived_from> to verify
8131 an inheritance relationship.
8137 Perl_sv_isa(pTHX_ SV *sv, const char *name)
8149 hvname = HvNAME_get(SvSTASH(sv));
8153 return strEQ(hvname, name);
8159 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
8160 it will be upgraded to one. If C<classname> is non-null then the new SV will
8161 be blessed in the specified package. The new SV is returned and its
8162 reference count is 1.
8168 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
8174 SV_CHECK_THINKFIRST_COW_DROP(rv);
8177 if (SvTYPE(rv) >= SVt_PVMG) {
8178 const U32 refcnt = SvREFCNT(rv);
8182 SvREFCNT(rv) = refcnt;
8185 if (SvTYPE(rv) < SVt_RV)
8186 sv_upgrade(rv, SVt_RV);
8187 else if (SvTYPE(rv) > SVt_RV) {
8198 HV* stash = gv_stashpv(classname, TRUE);
8199 (void)sv_bless(rv, stash);
8205 =for apidoc sv_setref_pv
8207 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
8208 argument will be upgraded to an RV. That RV will be modified to point to
8209 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8210 into the SV. The C<classname> argument indicates the package for the
8211 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8212 will have a reference count of 1, and the RV will be returned.
8214 Do not use with other Perl types such as HV, AV, SV, CV, because those
8215 objects will become corrupted by the pointer copy process.
8217 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8223 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
8226 sv_setsv(rv, &PL_sv_undef);
8230 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8235 =for apidoc sv_setref_iv
8237 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
8238 argument will be upgraded to an RV. That RV will be modified to point to
8239 the new SV. The C<classname> argument indicates the package for the
8240 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8241 will have a reference count of 1, and the RV will be returned.
8247 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
8249 sv_setiv(newSVrv(rv,classname), iv);
8254 =for apidoc sv_setref_uv
8256 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
8257 argument will be upgraded to an RV. That RV will be modified to point to
8258 the new SV. The C<classname> argument indicates the package for the
8259 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8260 will have a reference count of 1, and the RV will be returned.
8266 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
8268 sv_setuv(newSVrv(rv,classname), uv);
8273 =for apidoc sv_setref_nv
8275 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8276 argument will be upgraded to an RV. That RV will be modified to point to
8277 the new SV. The C<classname> argument indicates the package for the
8278 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8279 will have a reference count of 1, and the RV will be returned.
8285 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
8287 sv_setnv(newSVrv(rv,classname), nv);
8292 =for apidoc sv_setref_pvn
8294 Copies a string into a new SV, optionally blessing the SV. The length of the
8295 string must be specified with C<n>. The C<rv> argument will be upgraded to
8296 an RV. That RV will be modified to point to the new SV. The C<classname>
8297 argument indicates the package for the blessing. Set C<classname> to
8298 C<Nullch> to avoid the blessing. The new SV will have a reference count
8299 of 1, and the RV will be returned.
8301 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8307 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
8309 sv_setpvn(newSVrv(rv,classname), pv, n);
8314 =for apidoc sv_bless
8316 Blesses an SV into a specified package. The SV must be an RV. The package
8317 must be designated by its stash (see C<gv_stashpv()>). The reference count
8318 of the SV is unaffected.
8324 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8328 Perl_croak(aTHX_ "Can't bless non-reference value");
8330 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8331 if (SvREADONLY(tmpRef))
8332 Perl_croak(aTHX_ PL_no_modify);
8333 if (SvOBJECT(tmpRef)) {
8334 if (SvTYPE(tmpRef) != SVt_PVIO)
8336 SvREFCNT_dec(SvSTASH(tmpRef));
8339 SvOBJECT_on(tmpRef);
8340 if (SvTYPE(tmpRef) != SVt_PVIO)
8342 SvUPGRADE(tmpRef, SVt_PVMG);
8343 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
8350 if(SvSMAGICAL(tmpRef))
8351 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8359 /* Downgrades a PVGV to a PVMG.
8363 S_sv_unglob(pTHX_ SV *sv)
8367 assert(SvTYPE(sv) == SVt_PVGV);
8372 SvREFCNT_dec(GvSTASH(sv));
8373 GvSTASH(sv) = Nullhv;
8375 sv_unmagic(sv, PERL_MAGIC_glob);
8376 Safefree(GvNAME(sv));
8379 /* need to keep SvANY(sv) in the right arena */
8380 xpvmg = new_XPVMG();
8381 StructCopy(SvANY(sv), xpvmg, XPVMG);
8382 del_XPVGV(SvANY(sv));
8385 SvFLAGS(sv) &= ~SVTYPEMASK;
8386 SvFLAGS(sv) |= SVt_PVMG;
8390 =for apidoc sv_unref_flags
8392 Unsets the RV status of the SV, and decrements the reference count of
8393 whatever was being referenced by the RV. This can almost be thought of
8394 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8395 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8396 (otherwise the decrementing is conditional on the reference count being
8397 different from one or the reference being a readonly SV).
8404 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
8408 if (SvWEAKREF(sv)) {
8416 /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
8417 assigned to as BEGIN {$a = \"Foo"} will fail. */
8418 if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
8420 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8421 sv_2mortal(rv); /* Schedule for freeing later */
8425 =for apidoc sv_unref
8427 Unsets the RV status of the SV, and decrements the reference count of
8428 whatever was being referenced by the RV. This can almost be thought of
8429 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
8430 being zero. See C<SvROK_off>.
8436 Perl_sv_unref(pTHX_ SV *sv)
8438 sv_unref_flags(sv, 0);
8442 =for apidoc sv_taint
8444 Taint an SV. Use C<SvTAINTED_on> instead.
8449 Perl_sv_taint(pTHX_ SV *sv)
8451 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
8455 =for apidoc sv_untaint
8457 Untaint an SV. Use C<SvTAINTED_off> instead.
8462 Perl_sv_untaint(pTHX_ SV *sv)
8464 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8465 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8472 =for apidoc sv_tainted
8474 Test an SV for taintedness. Use C<SvTAINTED> instead.
8479 Perl_sv_tainted(pTHX_ SV *sv)
8481 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8482 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8483 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
8490 =for apidoc sv_setpviv
8492 Copies an integer into the given SV, also updating its string value.
8493 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8499 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8501 char buf[TYPE_CHARS(UV)];
8503 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8505 sv_setpvn(sv, ptr, ebuf - ptr);
8509 =for apidoc sv_setpviv_mg
8511 Like C<sv_setpviv>, but also handles 'set' magic.
8517 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8519 char buf[TYPE_CHARS(UV)];
8521 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8523 sv_setpvn(sv, ptr, ebuf - ptr);
8527 #if defined(PERL_IMPLICIT_CONTEXT)
8529 /* pTHX_ magic can't cope with varargs, so this is a no-context
8530 * version of the main function, (which may itself be aliased to us).
8531 * Don't access this version directly.
8535 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8539 va_start(args, pat);
8540 sv_vsetpvf(sv, pat, &args);
8544 /* pTHX_ magic can't cope with varargs, so this is a no-context
8545 * version of the main function, (which may itself be aliased to us).
8546 * Don't access this version directly.
8550 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8554 va_start(args, pat);
8555 sv_vsetpvf_mg(sv, pat, &args);
8561 =for apidoc sv_setpvf
8563 Works like C<sv_catpvf> but copies the text into the SV instead of
8564 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8570 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8573 va_start(args, pat);
8574 sv_vsetpvf(sv, pat, &args);
8579 =for apidoc sv_vsetpvf
8581 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8582 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8584 Usually used via its frontend C<sv_setpvf>.
8590 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8592 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8596 =for apidoc sv_setpvf_mg
8598 Like C<sv_setpvf>, but also handles 'set' magic.
8604 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8607 va_start(args, pat);
8608 sv_vsetpvf_mg(sv, pat, &args);
8613 =for apidoc sv_vsetpvf_mg
8615 Like C<sv_vsetpvf>, but also handles 'set' magic.
8617 Usually used via its frontend C<sv_setpvf_mg>.
8623 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8625 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8629 #if defined(PERL_IMPLICIT_CONTEXT)
8631 /* pTHX_ magic can't cope with varargs, so this is a no-context
8632 * version of the main function, (which may itself be aliased to us).
8633 * Don't access this version directly.
8637 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8641 va_start(args, pat);
8642 sv_vcatpvf(sv, pat, &args);
8646 /* pTHX_ magic can't cope with varargs, so this is a no-context
8647 * version of the main function, (which may itself be aliased to us).
8648 * Don't access this version directly.
8652 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8656 va_start(args, pat);
8657 sv_vcatpvf_mg(sv, pat, &args);
8663 =for apidoc sv_catpvf
8665 Processes its arguments like C<sprintf> and appends the formatted
8666 output to an SV. If the appended data contains "wide" characters
8667 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8668 and characters >255 formatted with %c), the original SV might get
8669 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
8670 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
8671 valid UTF-8; if the original SV was bytes, the pattern should be too.
8676 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8679 va_start(args, pat);
8680 sv_vcatpvf(sv, pat, &args);
8685 =for apidoc sv_vcatpvf
8687 Processes its arguments like C<vsprintf> and appends the formatted output
8688 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
8690 Usually used via its frontend C<sv_catpvf>.
8696 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8698 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8702 =for apidoc sv_catpvf_mg
8704 Like C<sv_catpvf>, but also handles 'set' magic.
8710 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8713 va_start(args, pat);
8714 sv_vcatpvf_mg(sv, pat, &args);
8719 =for apidoc sv_vcatpvf_mg
8721 Like C<sv_vcatpvf>, but also handles 'set' magic.
8723 Usually used via its frontend C<sv_catpvf_mg>.
8729 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8731 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8736 =for apidoc sv_vsetpvfn
8738 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
8741 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
8747 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8749 sv_setpvn(sv, "", 0);
8750 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8753 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
8756 S_expect_number(pTHX_ char** pattern)
8759 switch (**pattern) {
8760 case '1': case '2': case '3':
8761 case '4': case '5': case '6':
8762 case '7': case '8': case '9':
8763 while (isDIGIT(**pattern))
8764 var = var * 10 + (*(*pattern)++ - '0');
8768 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
8771 F0convert(NV nv, char *endbuf, STRLEN *len)
8773 const int neg = nv < 0;
8782 if (uv & 1 && uv == nv)
8783 uv--; /* Round to even */
8785 const unsigned dig = uv % 10;
8798 =for apidoc sv_vcatpvfn
8800 Processes its arguments like C<vsprintf> and appends the formatted output
8801 to an SV. Uses an array of SVs if the C style variable argument list is
8802 missing (NULL). When running with taint checks enabled, indicates via
8803 C<maybe_tainted> if results are untrustworthy (often due to the use of
8806 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
8811 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
8814 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8821 static const char nullstr[] = "(null)";
8823 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
8824 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
8826 /* Times 4: a decimal digit takes more than 3 binary digits.
8827 * NV_DIG: mantissa takes than many decimal digits.
8828 * Plus 32: Playing safe. */
8829 char ebuf[IV_DIG * 4 + NV_DIG + 32];
8830 /* large enough for "%#.#f" --chip */
8831 /* what about long double NVs? --jhi */
8833 /* no matter what, this is a string now */
8834 (void)SvPV_force(sv, origlen);
8836 /* special-case "", "%s", and "%-p" (SVf) */
8839 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
8841 const char *s = va_arg(*args, char*);
8842 sv_catpv(sv, s ? s : nullstr);
8844 else if (svix < svmax) {
8845 sv_catsv(sv, *svargs);
8846 if (DO_UTF8(*svargs))
8851 if (patlen == 3 && pat[0] == '%' &&
8852 pat[1] == '-' && pat[2] == 'p') {
8854 argsv = va_arg(*args, SV*);
8855 sv_catsv(sv, argsv);
8862 #ifndef USE_LONG_DOUBLE
8863 /* special-case "%.<number>[gf]" */
8864 if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
8865 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
8866 unsigned digits = 0;
8870 while (*pp >= '0' && *pp <= '9')
8871 digits = 10 * digits + (*pp++ - '0');
8872 if (pp - pat == (int)patlen - 1) {
8876 nv = (NV)va_arg(*args, double);
8877 else if (svix < svmax)
8882 /* Add check for digits != 0 because it seems that some
8883 gconverts are buggy in this case, and we don't yet have
8884 a Configure test for this. */
8885 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
8886 /* 0, point, slack */
8887 Gconvert(nv, (int)digits, 0, ebuf);
8889 if (*ebuf) /* May return an empty string for digits==0 */
8892 } else if (!digits) {
8895 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
8896 sv_catpvn(sv, p, l);
8902 #endif /* !USE_LONG_DOUBLE */
8904 if (!args && svix < svmax && DO_UTF8(*svargs))
8907 patend = (char*)pat + patlen;
8908 for (p = (char*)pat; p < patend; p = q) {
8911 bool vectorize = FALSE;
8912 bool vectorarg = FALSE;
8913 bool vec_utf8 = FALSE;
8919 bool has_precis = FALSE;
8922 bool is_utf8 = FALSE; /* is this item utf8? */
8923 #ifdef HAS_LDBL_SPRINTF_BUG
8924 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8925 with sfio - Allen <allens@cpan.org> */
8926 bool fix_ldbl_sprintf_bug = FALSE;
8930 U8 utf8buf[UTF8_MAXBYTES+1];
8931 STRLEN esignlen = 0;
8933 const char *eptr = Nullch;
8936 const U8 *vecstr = Null(U8*);
8943 /* we need a long double target in case HAS_LONG_DOUBLE but
8946 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
8954 const char *dotstr = ".";
8955 STRLEN dotstrlen = 1;
8956 I32 efix = 0; /* explicit format parameter index */
8957 I32 ewix = 0; /* explicit width index */
8958 I32 epix = 0; /* explicit precision index */
8959 I32 evix = 0; /* explicit vector index */
8960 bool asterisk = FALSE;
8962 /* echo everything up to the next format specification */
8963 for (q = p; q < patend && *q != '%'; ++q) ;
8965 if (has_utf8 && !pat_utf8)
8966 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
8968 sv_catpvn(sv, p, q - p);
8975 We allow format specification elements in this order:
8976 \d+\$ explicit format parameter index
8978 v|\*(\d+\$)?v vector with optional (optionally specified) arg
8979 0 flag (as above): repeated to allow "v02"
8980 \d+|\*(\d+\$)? width using optional (optionally specified) arg
8981 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8983 [%bcdefginopsux_DFOUX] format (mandatory)
8985 if (EXPECT_NUMBER(q, width)) {
9026 if (EXPECT_NUMBER(q, ewix))
9035 if ((vectorarg = asterisk)) {
9047 EXPECT_NUMBER(q, width);
9052 vecsv = va_arg(*args, SV*);
9054 vecsv = (evix ? evix <= svmax : svix < svmax) ?
9055 svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
9056 dotstr = SvPV_const(vecsv, dotstrlen);
9061 vecsv = va_arg(*args, SV*);
9062 vecstr = (U8*)SvPV_const(vecsv,veclen);
9063 vec_utf8 = DO_UTF8(vecsv);
9065 else if (efix ? efix <= svmax : svix < svmax) {
9066 vecsv = svargs[efix ? efix-1 : svix++];
9067 vecstr = (U8*)SvPV_const(vecsv,veclen);
9068 vec_utf8 = DO_UTF8(vecsv);
9069 /* if this is a version object, we need to return the
9070 * stringified representation (which the SvPVX_const has
9071 * already done for us), but not vectorize the args
9073 if ( *q == 'd' && sv_derived_from(vecsv,"version") )
9075 q++; /* skip past the rest of the %vd format */
9076 eptr = (const char *) vecstr;
9077 elen = strlen(eptr);
9090 i = va_arg(*args, int);
9092 i = (ewix ? ewix <= svmax : svix < svmax) ?
9093 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9095 width = (i < 0) ? -i : i;
9105 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
9107 /* XXX: todo, support specified precision parameter */
9111 i = va_arg(*args, int);
9113 i = (ewix ? ewix <= svmax : svix < svmax)
9114 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9115 precis = (i < 0) ? 0 : i;
9120 precis = precis * 10 + (*q++ - '0');
9129 case 'I': /* Ix, I32x, and I64x */
9131 if (q[1] == '6' && q[2] == '4') {
9137 if (q[1] == '3' && q[2] == '2') {
9147 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9158 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9159 if (*(q + 1) == 'l') { /* lld, llf */
9184 argsv = (efix ? efix <= svmax : svix < svmax) ?
9185 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
9192 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
9194 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9196 eptr = (char*)utf8buf;
9197 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9208 if (args && !vectorize) {
9209 eptr = va_arg(*args, char*);
9211 #ifdef MACOS_TRADITIONAL
9212 /* On MacOS, %#s format is used for Pascal strings */
9217 elen = strlen(eptr);
9219 eptr = (char *)nullstr;
9220 elen = sizeof nullstr - 1;
9224 eptr = SvPVx_const(argsv, elen);
9225 if (DO_UTF8(argsv)) {
9226 if (has_precis && precis < elen) {
9228 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9231 if (width) { /* fudge width (can't fudge elen) */
9232 width += elen - sv_len_utf8(argsv);
9240 if (has_precis && elen > precis)
9247 if (left && args) { /* SVf */
9256 argsv = va_arg(*args, SV*);
9257 eptr = SvPVx_const(argsv, elen);
9262 if (alt || vectorize)
9264 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9282 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9291 esignbuf[esignlen++] = plus;
9295 case 'h': iv = (short)va_arg(*args, int); break;
9296 case 'l': iv = va_arg(*args, long); break;
9297 case 'V': iv = va_arg(*args, IV); break;
9298 default: iv = va_arg(*args, int); break;
9300 case 'q': iv = va_arg(*args, Quad_t); break;
9305 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
9307 case 'h': iv = (short)tiv; break;
9308 case 'l': iv = (long)tiv; break;
9310 default: iv = tiv; break;
9312 case 'q': iv = (Quad_t)tiv; break;
9316 if ( !vectorize ) /* we already set uv above */
9321 esignbuf[esignlen++] = plus;
9325 esignbuf[esignlen++] = '-';
9368 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9379 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9380 case 'l': uv = va_arg(*args, unsigned long); break;
9381 case 'V': uv = va_arg(*args, UV); break;
9382 default: uv = va_arg(*args, unsigned); break;
9384 case 'q': uv = va_arg(*args, Uquad_t); break;
9389 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9391 case 'h': uv = (unsigned short)tuv; break;
9392 case 'l': uv = (unsigned long)tuv; break;
9394 default: uv = tuv; break;
9396 case 'q': uv = (Uquad_t)tuv; break;
9403 char *ptr = ebuf + sizeof ebuf;
9409 p = (char*)((c == 'X')
9410 ? "0123456789ABCDEF" : "0123456789abcdef");
9416 esignbuf[esignlen++] = '0';
9417 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9425 if (alt && *ptr != '0')
9434 esignbuf[esignlen++] = '0';
9435 esignbuf[esignlen++] = 'b';
9438 default: /* it had better be ten or less */
9442 } while (uv /= base);
9445 elen = (ebuf + sizeof ebuf) - ptr;
9449 zeros = precis - elen;
9450 else if (precis == 0 && elen == 1 && *eptr == '0')
9456 /* FLOATING POINT */
9459 c = 'f'; /* maybe %F isn't supported here */
9465 /* This is evil, but floating point is even more evil */
9467 /* for SV-style calling, we can only get NV
9468 for C-style calling, we assume %f is double;
9469 for simplicity we allow any of %Lf, %llf, %qf for long double
9473 #if defined(USE_LONG_DOUBLE)
9477 /* [perl #20339] - we should accept and ignore %lf rather than die */
9481 #if defined(USE_LONG_DOUBLE)
9482 intsize = args ? 0 : 'q';
9486 #if defined(HAS_LONG_DOUBLE)
9495 /* now we need (long double) if intsize == 'q', else (double) */
9496 nv = (args && !vectorize) ?
9497 #if LONG_DOUBLESIZE > DOUBLESIZE
9499 va_arg(*args, long double) :
9500 va_arg(*args, double)
9502 va_arg(*args, double)
9508 if (c != 'e' && c != 'E') {
9510 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9511 will cast our (long double) to (double) */
9512 (void)Perl_frexp(nv, &i);
9513 if (i == PERL_INT_MIN)
9514 Perl_die(aTHX_ "panic: frexp");
9516 need = BIT_DIGITS(i);
9518 need += has_precis ? precis : 6; /* known default */
9523 #ifdef HAS_LDBL_SPRINTF_BUG
9524 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9525 with sfio - Allen <allens@cpan.org> */
9528 # define MY_DBL_MAX DBL_MAX
9529 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9530 # if DOUBLESIZE >= 8
9531 # define MY_DBL_MAX 1.7976931348623157E+308L
9533 # define MY_DBL_MAX 3.40282347E+38L
9537 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9538 # define MY_DBL_MAX_BUG 1L
9540 # define MY_DBL_MAX_BUG MY_DBL_MAX
9544 # define MY_DBL_MIN DBL_MIN
9545 # else /* XXX guessing! -Allen */
9546 # if DOUBLESIZE >= 8
9547 # define MY_DBL_MIN 2.2250738585072014E-308L
9549 # define MY_DBL_MIN 1.17549435E-38L
9553 if ((intsize == 'q') && (c == 'f') &&
9554 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9556 /* it's going to be short enough that
9557 * long double precision is not needed */
9559 if ((nv <= 0L) && (nv >= -0L))
9560 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9562 /* would use Perl_fp_class as a double-check but not
9563 * functional on IRIX - see perl.h comments */
9565 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9566 /* It's within the range that a double can represent */
9567 #if defined(DBL_MAX) && !defined(DBL_MIN)
9568 if ((nv >= ((long double)1/DBL_MAX)) ||
9569 (nv <= (-(long double)1/DBL_MAX)))
9571 fix_ldbl_sprintf_bug = TRUE;
9574 if (fix_ldbl_sprintf_bug == TRUE) {
9584 # undef MY_DBL_MAX_BUG
9587 #endif /* HAS_LDBL_SPRINTF_BUG */
9589 need += 20; /* fudge factor */
9590 if (PL_efloatsize < need) {
9591 Safefree(PL_efloatbuf);
9592 PL_efloatsize = need + 20; /* more fudge */
9593 New(906, PL_efloatbuf, PL_efloatsize, char);
9594 PL_efloatbuf[0] = '\0';
9597 if ( !(width || left || plus || alt) && fill != '0'
9598 && has_precis && intsize != 'q' ) { /* Shortcuts */
9599 /* See earlier comment about buggy Gconvert when digits,
9601 if ( c == 'g' && precis) {
9602 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9603 if (*PL_efloatbuf) /* May return an empty string for digits==0 */
9604 goto float_converted;
9605 } else if ( c == 'f' && !precis) {
9606 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9611 char *ptr = ebuf + sizeof ebuf;
9614 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9615 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9616 if (intsize == 'q') {
9617 /* Copy the one or more characters in a long double
9618 * format before the 'base' ([efgEFG]) character to
9619 * the format string. */
9620 static char const prifldbl[] = PERL_PRIfldbl;
9621 char const *p = prifldbl + sizeof(prifldbl) - 3;
9622 while (p >= prifldbl) { *--ptr = *p--; }
9627 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9632 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9644 /* No taint. Otherwise we are in the strange situation
9645 * where printf() taints but print($float) doesn't.
9647 #if defined(HAS_LONG_DOUBLE)
9649 (void)sprintf(PL_efloatbuf, ptr, nv);
9651 (void)sprintf(PL_efloatbuf, ptr, (double)nv);
9653 (void)sprintf(PL_efloatbuf, ptr, nv);
9657 eptr = PL_efloatbuf;
9658 elen = strlen(PL_efloatbuf);
9664 i = SvCUR(sv) - origlen;
9665 if (args && !vectorize) {
9667 case 'h': *(va_arg(*args, short*)) = i; break;
9668 default: *(va_arg(*args, int*)) = i; break;
9669 case 'l': *(va_arg(*args, long*)) = i; break;
9670 case 'V': *(va_arg(*args, IV*)) = i; break;
9672 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
9677 sv_setuv_mg(argsv, (UV)i);
9679 continue; /* not "break" */
9685 if (!args && ckWARN(WARN_PRINTF) &&
9686 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
9687 SV *msg = sv_newmortal();
9688 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9689 (PL_op->op_type == OP_PRTF) ? "" : "s");
9692 Perl_sv_catpvf(aTHX_ msg,
9693 "\"%%%c\"", c & 0xFF);
9695 Perl_sv_catpvf(aTHX_ msg,
9696 "\"%%\\%03"UVof"\"",
9699 sv_catpv(msg, "end of string");
9700 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
9703 /* output mangled stuff ... */
9709 /* ... right here, because formatting flags should not apply */
9710 SvGROW(sv, SvCUR(sv) + elen + 1);
9712 Copy(eptr, p, elen, char);
9715 SvCUR_set(sv, p - SvPVX_const(sv));
9717 continue; /* not "break" */
9720 /* calculate width before utf8_upgrade changes it */
9721 have = esignlen + zeros + elen;
9723 if (is_utf8 != has_utf8) {
9726 sv_utf8_upgrade(sv);
9729 SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
9730 sv_utf8_upgrade(nsv);
9731 eptr = SvPVX_const(nsv);
9734 SvGROW(sv, SvCUR(sv) + elen + 1);
9739 need = (have > width ? have : width);
9742 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
9744 if (esignlen && fill == '0') {
9745 for (i = 0; i < (int)esignlen; i++)
9749 memset(p, fill, gap);
9752 if (esignlen && fill != '0') {
9753 for (i = 0; i < (int)esignlen; i++)
9757 for (i = zeros; i; i--)
9761 Copy(eptr, p, elen, char);
9765 memset(p, ' ', gap);
9770 Copy(dotstr, p, dotstrlen, char);
9774 vectorize = FALSE; /* done iterating over vecstr */
9781 SvCUR_set(sv, p - SvPVX_const(sv));
9789 /* =========================================================================
9791 =head1 Cloning an interpreter
9793 All the macros and functions in this section are for the private use of
9794 the main function, perl_clone().
9796 The foo_dup() functions make an exact copy of an existing foo thinngy.
9797 During the course of a cloning, a hash table is used to map old addresses
9798 to new addresses. The table is created and manipulated with the
9799 ptr_table_* functions.
9803 ============================================================================*/
9806 #if defined(USE_ITHREADS)
9808 #ifndef GpREFCNT_inc
9809 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
9813 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
9814 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
9815 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9816 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
9817 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9818 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
9819 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9820 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
9821 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
9822 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
9823 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9824 #define SAVEPV(p) (p ? savepv(p) : Nullch)
9825 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
9828 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
9829 regcomp.c. AMS 20010712 */
9832 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
9837 struct reg_substr_datum *s;
9840 return (REGEXP *)NULL;
9842 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
9845 len = r->offsets[0];
9846 npar = r->nparens+1;
9848 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
9849 Copy(r->program, ret->program, len+1, regnode);
9851 New(0, ret->startp, npar, I32);
9852 Copy(r->startp, ret->startp, npar, I32);
9853 New(0, ret->endp, npar, I32);
9854 Copy(r->startp, ret->startp, npar, I32);
9856 New(0, ret->substrs, 1, struct reg_substr_data);
9857 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
9858 s->min_offset = r->substrs->data[i].min_offset;
9859 s->max_offset = r->substrs->data[i].max_offset;
9860 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
9861 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
9864 ret->regstclass = NULL;
9867 const int count = r->data->count;
9869 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
9870 char, struct reg_data);
9871 New(0, d->what, count, U8);
9874 for (i = 0; i < count; i++) {
9875 d->what[i] = r->data->what[i];
9876 switch (d->what[i]) {
9877 /* legal options are one of: sfpont
9878 see also regcomp.h and pregfree() */
9880 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
9883 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
9886 /* This is cheating. */
9887 New(0, d->data[i], 1, struct regnode_charclass_class);
9888 StructCopy(r->data->data[i], d->data[i],
9889 struct regnode_charclass_class);
9890 ret->regstclass = (regnode*)d->data[i];
9893 /* Compiled op trees are readonly, and can thus be
9894 shared without duplication. */
9896 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
9900 d->data[i] = r->data->data[i];
9903 d->data[i] = r->data->data[i];
9905 ((reg_trie_data*)d->data[i])->refcount++;
9909 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
9918 New(0, ret->offsets, 2*len+1, U32);
9919 Copy(r->offsets, ret->offsets, 2*len+1, U32);
9921 ret->precomp = SAVEPVN(r->precomp, r->prelen);
9922 ret->refcnt = r->refcnt;
9923 ret->minlen = r->minlen;
9924 ret->prelen = r->prelen;
9925 ret->nparens = r->nparens;
9926 ret->lastparen = r->lastparen;
9927 ret->lastcloseparen = r->lastcloseparen;
9928 ret->reganch = r->reganch;
9930 ret->sublen = r->sublen;
9932 if (RX_MATCH_COPIED(ret))
9933 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
9935 ret->subbeg = Nullch;
9936 #ifdef PERL_OLD_COPY_ON_WRITE
9937 ret->saved_copy = Nullsv;
9940 ptr_table_store(PL_ptr_table, r, ret);
9944 /* duplicate a file handle */
9947 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
9953 return (PerlIO*)NULL;
9955 /* look for it in the table first */
9956 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
9960 /* create anew and remember what it is */
9961 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
9962 ptr_table_store(PL_ptr_table, fp, ret);
9966 /* duplicate a directory handle */
9969 Perl_dirp_dup(pTHX_ DIR *dp)
9977 /* duplicate a typeglob */
9980 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
9985 /* look for it in the table first */
9986 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
9990 /* create anew and remember what it is */
9991 Newz(0, ret, 1, GP);
9992 ptr_table_store(PL_ptr_table, gp, ret);
9995 ret->gp_refcnt = 0; /* must be before any other dups! */
9996 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
9997 ret->gp_io = io_dup_inc(gp->gp_io, param);
9998 ret->gp_form = cv_dup_inc(gp->gp_form, param);
9999 ret->gp_av = av_dup_inc(gp->gp_av, param);
10000 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
10001 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10002 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
10003 ret->gp_cvgen = gp->gp_cvgen;
10004 ret->gp_flags = gp->gp_flags;
10005 ret->gp_line = gp->gp_line;
10006 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
10010 /* duplicate a chain of magic */
10013 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
10015 MAGIC *mgprev = (MAGIC*)NULL;
10018 return (MAGIC*)NULL;
10019 /* look for it in the table first */
10020 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
10024 for (; mg; mg = mg->mg_moremagic) {
10026 Newz(0, nmg, 1, MAGIC);
10028 mgprev->mg_moremagic = nmg;
10031 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
10032 nmg->mg_private = mg->mg_private;
10033 nmg->mg_type = mg->mg_type;
10034 nmg->mg_flags = mg->mg_flags;
10035 if (mg->mg_type == PERL_MAGIC_qr) {
10036 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
10038 else if(mg->mg_type == PERL_MAGIC_backref) {
10039 const AV * const av = (AV*) mg->mg_obj;
10042 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
10044 for (i = AvFILLp(av); i >= 0; i--) {
10045 if (!svp[i]) continue;
10046 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
10049 else if (mg->mg_type == PERL_MAGIC_symtab) {
10050 nmg->mg_obj = mg->mg_obj;
10053 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
10054 ? sv_dup_inc(mg->mg_obj, param)
10055 : sv_dup(mg->mg_obj, param);
10057 nmg->mg_len = mg->mg_len;
10058 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
10059 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
10060 if (mg->mg_len > 0) {
10061 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
10062 if (mg->mg_type == PERL_MAGIC_overload_table &&
10063 AMT_AMAGIC((AMT*)mg->mg_ptr))
10065 AMT *amtp = (AMT*)mg->mg_ptr;
10066 AMT *namtp = (AMT*)nmg->mg_ptr;
10068 for (i = 1; i < NofAMmeth; i++) {
10069 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
10073 else if (mg->mg_len == HEf_SVKEY)
10074 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
10076 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
10077 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10084 /* create a new pointer-mapping table */
10087 Perl_ptr_table_new(pTHX)
10090 Newz(0, tbl, 1, PTR_TBL_t);
10091 tbl->tbl_max = 511;
10092 tbl->tbl_items = 0;
10093 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10098 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
10100 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
10103 #define new_pte() new_body(struct ptr_tbl_ent, pte)
10104 #define del_pte(p) del_body(p, struct ptr_tbl_ent, pte)
10106 /* map an existing pointer using a table */
10109 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
10111 PTR_TBL_ENT_t *tblent;
10112 const UV hash = PTR_TABLE_HASH(sv);
10114 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10115 for (; tblent; tblent = tblent->next) {
10116 if (tblent->oldval == sv)
10117 return tblent->newval;
10119 return (void*)NULL;
10122 /* add a new entry to a pointer-mapping table */
10125 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
10127 PTR_TBL_ENT_t *tblent, **otblent;
10128 /* XXX this may be pessimal on platforms where pointers aren't good
10129 * hash values e.g. if they grow faster in the most significant
10131 const UV hash = PTR_TABLE_HASH(oldv);
10135 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
10136 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
10137 if (tblent->oldval == oldv) {
10138 tblent->newval = newv;
10142 tblent = new_pte();
10143 tblent->oldval = oldv;
10144 tblent->newval = newv;
10145 tblent->next = *otblent;
10148 if (!empty && tbl->tbl_items > tbl->tbl_max)
10149 ptr_table_split(tbl);
10152 /* double the hash bucket size of an existing ptr table */
10155 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
10157 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10158 const UV oldsize = tbl->tbl_max + 1;
10159 UV newsize = oldsize * 2;
10162 Renew(ary, newsize, PTR_TBL_ENT_t*);
10163 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10164 tbl->tbl_max = --newsize;
10165 tbl->tbl_ary = ary;
10166 for (i=0; i < oldsize; i++, ary++) {
10167 PTR_TBL_ENT_t **curentp, **entp, *ent;
10170 curentp = ary + oldsize;
10171 for (entp = ary, ent = *ary; ent; ent = *entp) {
10172 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10174 ent->next = *curentp;
10184 /* remove all the entries from a ptr table */
10187 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
10189 register PTR_TBL_ENT_t **array;
10190 register PTR_TBL_ENT_t *entry;
10194 if (!tbl || !tbl->tbl_items) {
10198 array = tbl->tbl_ary;
10200 max = tbl->tbl_max;
10204 PTR_TBL_ENT_t *oentry = entry;
10205 entry = entry->next;
10209 if (++riter > max) {
10212 entry = array[riter];
10216 tbl->tbl_items = 0;
10219 /* clear and free a ptr table */
10222 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
10227 ptr_table_clear(tbl);
10228 Safefree(tbl->tbl_ary);
10232 /* attempt to make everything in the typeglob readonly */
10235 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
10237 GV *gv = (GV*)sstr;
10238 SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */
10240 if (GvIO(gv) || GvFORM(gv)) {
10241 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
10243 else if (!GvCV(gv)) {
10244 GvCV(gv) = (CV*)sv;
10247 /* CvPADLISTs cannot be shared */
10248 if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
10253 if (!GvUNIQUE(gv)) {
10255 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
10256 HvNAME_get(GvSTASH(gv)), GvNAME(gv));
10262 * write attempts will die with
10263 * "Modification of a read-only value attempted"
10269 SvREADONLY_on(GvSV(gv));
10273 GvAV(gv) = (AV*)sv;
10276 SvREADONLY_on(GvAV(gv));
10280 GvHV(gv) = (HV*)sv;
10283 SvREADONLY_on(GvHV(gv));
10286 return sstr; /* he_dup() will SvREFCNT_inc() */
10289 /* duplicate an SV of any type (including AV, HV etc) */
10292 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
10295 SvRV_set(dstr, SvWEAKREF(sstr)
10296 ? sv_dup(SvRV(sstr), param)
10297 : sv_dup_inc(SvRV(sstr), param));
10300 else if (SvPVX_const(sstr)) {
10301 /* Has something there */
10303 /* Normal PV - clone whole allocated space */
10304 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
10305 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10306 /* Not that normal - actually sstr is copy on write.
10307 But we are a true, independant SV, so: */
10308 SvREADONLY_off(dstr);
10313 /* Special case - not normally malloced for some reason */
10314 if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
10315 /* A "shared" PV - clone it as "shared" PV */
10317 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
10321 /* Some other special case - random pointer */
10322 SvPV_set(dstr, SvPVX(sstr));
10327 /* Copy the Null */
10328 if (SvTYPE(dstr) == SVt_RV)
10329 SvRV_set(dstr, NULL);
10336 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
10341 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10343 /* look for it in the table first */
10344 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10348 if(param->flags & CLONEf_JOIN_IN) {
10349 /** We are joining here so we don't want do clone
10350 something that is bad **/
10351 const char *hvname;
10353 if(SvTYPE(sstr) == SVt_PVHV &&
10354 (hvname = HvNAME_get(sstr))) {
10355 /** don't clone stashes if they already exist **/
10356 HV* old_stash = gv_stashpv(hvname,0);
10357 return (SV*) old_stash;
10361 /* create anew and remember what it is */
10364 #ifdef DEBUG_LEAKING_SCALARS
10365 dstr->sv_debug_optype = sstr->sv_debug_optype;
10366 dstr->sv_debug_line = sstr->sv_debug_line;
10367 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10368 dstr->sv_debug_cloned = 1;
10370 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10372 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
10376 ptr_table_store(PL_ptr_table, sstr, dstr);
10379 SvFLAGS(dstr) = SvFLAGS(sstr);
10380 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10381 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10384 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
10385 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10386 PL_watch_pvx, SvPVX_const(sstr));
10389 /* don't clone objects whose class has asked us not to */
10390 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10391 SvFLAGS(dstr) &= ~SVTYPEMASK;
10392 SvOBJECT_off(dstr);
10396 switch (SvTYPE(sstr)) {
10398 SvANY(dstr) = NULL;
10401 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
10402 SvIV_set(dstr, SvIVX(sstr));
10405 SvANY(dstr) = new_XNV();
10406 SvNV_set(dstr, SvNVX(sstr));
10409 SvANY(dstr) = &(dstr->sv_u.svu_rv);
10410 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10413 SvANY(dstr) = new_XPV();
10414 SvCUR_set(dstr, SvCUR(sstr));
10415 SvLEN_set(dstr, SvLEN(sstr));
10416 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10419 SvANY(dstr) = new_XPVIV();
10420 SvCUR_set(dstr, SvCUR(sstr));
10421 SvLEN_set(dstr, SvLEN(sstr));
10422 SvIV_set(dstr, SvIVX(sstr));
10423 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10426 SvANY(dstr) = new_XPVNV();
10427 SvCUR_set(dstr, SvCUR(sstr));
10428 SvLEN_set(dstr, SvLEN(sstr));
10429 SvIV_set(dstr, SvIVX(sstr));
10430 SvNV_set(dstr, SvNVX(sstr));
10431 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10434 SvANY(dstr) = new_XPVMG();
10435 SvCUR_set(dstr, SvCUR(sstr));
10436 SvLEN_set(dstr, SvLEN(sstr));
10437 SvIV_set(dstr, SvIVX(sstr));
10438 SvNV_set(dstr, SvNVX(sstr));
10439 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10440 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10441 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10444 SvANY(dstr) = new_XPVBM();
10445 SvCUR_set(dstr, SvCUR(sstr));
10446 SvLEN_set(dstr, SvLEN(sstr));
10447 SvIV_set(dstr, SvIVX(sstr));
10448 SvNV_set(dstr, SvNVX(sstr));
10449 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10450 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10451 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10452 BmRARE(dstr) = BmRARE(sstr);
10453 BmUSEFUL(dstr) = BmUSEFUL(sstr);
10454 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
10457 SvANY(dstr) = new_XPVLV();
10458 SvCUR_set(dstr, SvCUR(sstr));
10459 SvLEN_set(dstr, SvLEN(sstr));
10460 SvIV_set(dstr, SvIVX(sstr));
10461 SvNV_set(dstr, SvNVX(sstr));
10462 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10463 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10464 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10465 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
10466 LvTARGLEN(dstr) = LvTARGLEN(sstr);
10467 if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */
10468 LvTARG(dstr) = dstr;
10469 else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */
10470 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param);
10472 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
10473 LvTYPE(dstr) = LvTYPE(sstr);
10476 if (GvUNIQUE((GV*)sstr)) {
10478 if ((share = gv_share(sstr, param))) {
10481 ptr_table_store(PL_ptr_table, sstr, dstr);
10483 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
10484 HvNAME_get(GvSTASH(share)), GvNAME(share));
10489 SvANY(dstr) = new_XPVGV();
10490 SvCUR_set(dstr, SvCUR(sstr));
10491 SvLEN_set(dstr, SvLEN(sstr));
10492 SvIV_set(dstr, SvIVX(sstr));
10493 SvNV_set(dstr, SvNVX(sstr));
10494 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10495 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10496 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10497 GvNAMELEN(dstr) = GvNAMELEN(sstr);
10498 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
10499 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
10500 GvFLAGS(dstr) = GvFLAGS(sstr);
10501 GvGP(dstr) = gp_dup(GvGP(sstr), param);
10502 (void)GpREFCNT_inc(GvGP(dstr));
10505 SvANY(dstr) = new_XPVIO();
10506 SvCUR_set(dstr, SvCUR(sstr));
10507 SvLEN_set(dstr, SvLEN(sstr));
10508 SvIV_set(dstr, SvIVX(sstr));
10509 SvNV_set(dstr, SvNVX(sstr));
10510 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10511 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10512 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10513 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
10514 if (IoOFP(sstr) == IoIFP(sstr))
10515 IoOFP(dstr) = IoIFP(dstr);
10517 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
10518 /* PL_rsfp_filters entries have fake IoDIRP() */
10519 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
10520 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
10522 IoDIRP(dstr) = IoDIRP(sstr);
10523 IoLINES(dstr) = IoLINES(sstr);
10524 IoPAGE(dstr) = IoPAGE(sstr);
10525 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
10526 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
10527 if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
10528 /* I have no idea why fake dirp (rsfps)
10529 should be treaded differently but otherwise
10530 we end up with leaks -- sky*/
10531 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(sstr), param);
10532 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(sstr), param);
10533 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(sstr), param);
10535 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
10536 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
10537 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
10539 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
10540 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
10541 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
10542 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
10543 IoTYPE(dstr) = IoTYPE(sstr);
10544 IoFLAGS(dstr) = IoFLAGS(sstr);
10547 SvANY(dstr) = new_XPVAV();
10548 SvCUR_set(dstr, SvCUR(sstr));
10549 SvLEN_set(dstr, SvLEN(sstr));
10550 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10551 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10552 if (AvARRAY((AV*)sstr)) {
10553 SV **dst_ary, **src_ary;
10554 SSize_t items = AvFILLp((AV*)sstr) + 1;
10556 src_ary = AvARRAY((AV*)sstr);
10557 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
10558 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10559 SvPV_set(dstr, (char*)dst_ary);
10560 AvALLOC((AV*)dstr) = dst_ary;
10561 if (AvREAL((AV*)sstr)) {
10562 while (items-- > 0)
10563 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10566 while (items-- > 0)
10567 *dst_ary++ = sv_dup(*src_ary++, param);
10569 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10570 while (items-- > 0) {
10571 *dst_ary++ = &PL_sv_undef;
10575 SvPV_set(dstr, Nullch);
10576 AvALLOC((AV*)dstr) = (SV**)NULL;
10580 SvANY(dstr) = new_XPVHV();
10581 SvCUR_set(dstr, SvCUR(sstr));
10582 SvLEN_set(dstr, SvLEN(sstr));
10583 HvTOTALKEYS(dstr) = HvTOTALKEYS(sstr);
10584 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10585 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10589 if (HvARRAY((HV*)sstr)) {
10591 const bool sharekeys = !!HvSHAREKEYS(sstr);
10592 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
10593 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
10596 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
10597 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0), char);
10598 HvARRAY(dstr) = (HE**)darray;
10599 while (i <= sxhv->xhv_max) {
10600 HE *source = HvARRAY(sstr)[i];
10602 = source ? he_dup(source, sharekeys, param) : 0;
10606 struct xpvhv_aux *saux = HvAUX(sstr);
10607 struct xpvhv_aux *daux = HvAUX(dstr);
10608 /* This flag isn't copied. */
10609 /* SvOOK_on(hv) attacks the IV flags. */
10610 SvFLAGS(dstr) |= SVf_OOK;
10612 hvname = saux->xhv_name;
10613 daux->xhv_name = hvname ? hek_dup(hvname, param) : hvname;
10615 daux->xhv_riter = saux->xhv_riter;
10616 daux->xhv_eiter = saux->xhv_eiter
10617 ? he_dup(saux->xhv_eiter, (bool)!!HvSHAREKEYS(sstr),
10622 SvPV_set(dstr, Nullch);
10624 /* Record stashes for possible cloning in Perl_clone(). */
10626 av_push(param->stashes, dstr);
10630 SvANY(dstr) = new_XPVFM();
10631 FmLINES(dstr) = FmLINES(sstr);
10635 SvANY(dstr) = new_XPVCV();
10637 SvCUR_set(dstr, SvCUR(sstr));
10638 SvLEN_set(dstr, SvLEN(sstr));
10639 SvIV_set(dstr, SvIVX(sstr));
10640 SvNV_set(dstr, SvNVX(sstr));
10641 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10642 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10643 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10644 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
10645 CvSTART(dstr) = CvSTART(sstr);
10647 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
10649 CvXSUB(dstr) = CvXSUB(sstr);
10650 CvXSUBANY(dstr) = CvXSUBANY(sstr);
10651 if (CvCONST(sstr)) {
10652 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
10653 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
10654 sv_dup_inc((SV *)CvXSUBANY(sstr).any_ptr, param);
10656 /* don't dup if copying back - CvGV isn't refcounted, so the
10657 * duped GV may never be freed. A bit of a hack! DAPM */
10658 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
10659 Nullgv : gv_dup(CvGV(sstr), param) ;
10660 if (param->flags & CLONEf_COPY_STACKS) {
10661 CvDEPTH(dstr) = CvDEPTH(sstr);
10665 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10666 CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
10668 CvWEAKOUTSIDE(sstr)
10669 ? cv_dup( CvOUTSIDE(sstr), param)
10670 : cv_dup_inc(CvOUTSIDE(sstr), param);
10671 CvFLAGS(dstr) = CvFLAGS(sstr);
10672 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
10675 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
10679 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10685 /* duplicate a context */
10688 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10690 PERL_CONTEXT *ncxs;
10693 return (PERL_CONTEXT*)NULL;
10695 /* look for it in the table first */
10696 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10700 /* create anew and remember what it is */
10701 Newz(56, ncxs, max + 1, PERL_CONTEXT);
10702 ptr_table_store(PL_ptr_table, cxs, ncxs);
10705 PERL_CONTEXT *cx = &cxs[ix];
10706 PERL_CONTEXT *ncx = &ncxs[ix];
10707 ncx->cx_type = cx->cx_type;
10708 if (CxTYPE(cx) == CXt_SUBST) {
10709 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10712 ncx->blk_oldsp = cx->blk_oldsp;
10713 ncx->blk_oldcop = cx->blk_oldcop;
10714 ncx->blk_oldmarksp = cx->blk_oldmarksp;
10715 ncx->blk_oldscopesp = cx->blk_oldscopesp;
10716 ncx->blk_oldpm = cx->blk_oldpm;
10717 ncx->blk_gimme = cx->blk_gimme;
10718 switch (CxTYPE(cx)) {
10720 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
10721 ? cv_dup_inc(cx->blk_sub.cv, param)
10722 : cv_dup(cx->blk_sub.cv,param));
10723 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
10724 ? av_dup_inc(cx->blk_sub.argarray, param)
10726 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
10727 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
10728 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10729 ncx->blk_sub.lval = cx->blk_sub.lval;
10730 ncx->blk_sub.retop = cx->blk_sub.retop;
10733 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
10734 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
10735 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
10736 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
10737 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
10738 ncx->blk_eval.retop = cx->blk_eval.retop;
10741 ncx->blk_loop.label = cx->blk_loop.label;
10742 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
10743 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
10744 ncx->blk_loop.next_op = cx->blk_loop.next_op;
10745 ncx->blk_loop.last_op = cx->blk_loop.last_op;
10746 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
10747 ? cx->blk_loop.iterdata
10748 : gv_dup((GV*)cx->blk_loop.iterdata, param));
10749 ncx->blk_loop.oldcomppad
10750 = (PAD*)ptr_table_fetch(PL_ptr_table,
10751 cx->blk_loop.oldcomppad);
10752 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
10753 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
10754 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
10755 ncx->blk_loop.iterix = cx->blk_loop.iterix;
10756 ncx->blk_loop.itermax = cx->blk_loop.itermax;
10759 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
10760 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
10761 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
10762 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10763 ncx->blk_sub.retop = cx->blk_sub.retop;
10775 /* duplicate a stack info structure */
10778 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10783 return (PERL_SI*)NULL;
10785 /* look for it in the table first */
10786 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10790 /* create anew and remember what it is */
10791 Newz(56, nsi, 1, PERL_SI);
10792 ptr_table_store(PL_ptr_table, si, nsi);
10794 nsi->si_stack = av_dup_inc(si->si_stack, param);
10795 nsi->si_cxix = si->si_cxix;
10796 nsi->si_cxmax = si->si_cxmax;
10797 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
10798 nsi->si_type = si->si_type;
10799 nsi->si_prev = si_dup(si->si_prev, param);
10800 nsi->si_next = si_dup(si->si_next, param);
10801 nsi->si_markoff = si->si_markoff;
10806 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
10807 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
10808 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
10809 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
10810 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
10811 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
10812 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
10813 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
10814 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
10815 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
10816 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
10817 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
10818 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
10819 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
10822 #define pv_dup_inc(p) SAVEPV(p)
10823 #define pv_dup(p) SAVEPV(p)
10824 #define svp_dup_inc(p,pp) any_dup(p,pp)
10826 /* map any object to the new equivent - either something in the
10827 * ptr table, or something in the interpreter structure
10831 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
10836 return (void*)NULL;
10838 /* look for it in the table first */
10839 ret = ptr_table_fetch(PL_ptr_table, v);
10843 /* see if it is part of the interpreter structure */
10844 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
10845 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
10853 /* duplicate the save stack */
10856 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
10858 ANY *ss = proto_perl->Tsavestack;
10859 I32 ix = proto_perl->Tsavestack_ix;
10860 I32 max = proto_perl->Tsavestack_max;
10872 void (*dptr) (void*);
10873 void (*dxptr) (pTHX_ void*);
10876 Newz(54, nss, max, ANY);
10879 I32 i = POPINT(ss,ix);
10880 TOPINT(nss,ix) = i;
10882 case SAVEt_ITEM: /* normal string */
10883 sv = (SV*)POPPTR(ss,ix);
10884 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10885 sv = (SV*)POPPTR(ss,ix);
10886 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10888 case SAVEt_SV: /* scalar reference */
10889 sv = (SV*)POPPTR(ss,ix);
10890 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10891 gv = (GV*)POPPTR(ss,ix);
10892 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10894 case SAVEt_GENERIC_PVREF: /* generic char* */
10895 c = (char*)POPPTR(ss,ix);
10896 TOPPTR(nss,ix) = pv_dup(c);
10897 ptr = POPPTR(ss,ix);
10898 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10900 case SAVEt_SHARED_PVREF: /* char* in shared space */
10901 c = (char*)POPPTR(ss,ix);
10902 TOPPTR(nss,ix) = savesharedpv(c);
10903 ptr = POPPTR(ss,ix);
10904 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10906 case SAVEt_GENERIC_SVREF: /* generic sv */
10907 case SAVEt_SVREF: /* scalar reference */
10908 sv = (SV*)POPPTR(ss,ix);
10909 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10910 ptr = POPPTR(ss,ix);
10911 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
10913 case SAVEt_AV: /* array reference */
10914 av = (AV*)POPPTR(ss,ix);
10915 TOPPTR(nss,ix) = av_dup_inc(av, param);
10916 gv = (GV*)POPPTR(ss,ix);
10917 TOPPTR(nss,ix) = gv_dup(gv, param);
10919 case SAVEt_HV: /* hash reference */
10920 hv = (HV*)POPPTR(ss,ix);
10921 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10922 gv = (GV*)POPPTR(ss,ix);
10923 TOPPTR(nss,ix) = gv_dup(gv, param);
10925 case SAVEt_INT: /* int reference */
10926 ptr = POPPTR(ss,ix);
10927 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10928 intval = (int)POPINT(ss,ix);
10929 TOPINT(nss,ix) = intval;
10931 case SAVEt_LONG: /* long reference */
10932 ptr = POPPTR(ss,ix);
10933 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10934 longval = (long)POPLONG(ss,ix);
10935 TOPLONG(nss,ix) = longval;
10937 case SAVEt_I32: /* I32 reference */
10938 case SAVEt_I16: /* I16 reference */
10939 case SAVEt_I8: /* I8 reference */
10940 ptr = POPPTR(ss,ix);
10941 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10943 TOPINT(nss,ix) = i;
10945 case SAVEt_IV: /* IV reference */
10946 ptr = POPPTR(ss,ix);
10947 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10949 TOPIV(nss,ix) = iv;
10951 case SAVEt_SPTR: /* SV* reference */
10952 ptr = POPPTR(ss,ix);
10953 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10954 sv = (SV*)POPPTR(ss,ix);
10955 TOPPTR(nss,ix) = sv_dup(sv, param);
10957 case SAVEt_VPTR: /* random* reference */
10958 ptr = POPPTR(ss,ix);
10959 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10960 ptr = POPPTR(ss,ix);
10961 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10963 case SAVEt_PPTR: /* char* reference */
10964 ptr = POPPTR(ss,ix);
10965 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10966 c = (char*)POPPTR(ss,ix);
10967 TOPPTR(nss,ix) = pv_dup(c);
10969 case SAVEt_HPTR: /* HV* reference */
10970 ptr = POPPTR(ss,ix);
10971 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10972 hv = (HV*)POPPTR(ss,ix);
10973 TOPPTR(nss,ix) = hv_dup(hv, param);
10975 case SAVEt_APTR: /* AV* reference */
10976 ptr = POPPTR(ss,ix);
10977 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10978 av = (AV*)POPPTR(ss,ix);
10979 TOPPTR(nss,ix) = av_dup(av, param);
10982 gv = (GV*)POPPTR(ss,ix);
10983 TOPPTR(nss,ix) = gv_dup(gv, param);
10985 case SAVEt_GP: /* scalar reference */
10986 gp = (GP*)POPPTR(ss,ix);
10987 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
10988 (void)GpREFCNT_inc(gp);
10989 gv = (GV*)POPPTR(ss,ix);
10990 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10991 c = (char*)POPPTR(ss,ix);
10992 TOPPTR(nss,ix) = pv_dup(c);
10994 TOPIV(nss,ix) = iv;
10996 TOPIV(nss,ix) = iv;
10999 case SAVEt_MORTALIZESV:
11000 sv = (SV*)POPPTR(ss,ix);
11001 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11004 ptr = POPPTR(ss,ix);
11005 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11006 /* these are assumed to be refcounted properly */
11007 switch (((OP*)ptr)->op_type) {
11009 case OP_LEAVESUBLV:
11013 case OP_LEAVEWRITE:
11014 TOPPTR(nss,ix) = ptr;
11019 TOPPTR(nss,ix) = Nullop;
11024 TOPPTR(nss,ix) = Nullop;
11027 c = (char*)POPPTR(ss,ix);
11028 TOPPTR(nss,ix) = pv_dup_inc(c);
11030 case SAVEt_CLEARSV:
11031 longval = POPLONG(ss,ix);
11032 TOPLONG(nss,ix) = longval;
11035 hv = (HV*)POPPTR(ss,ix);
11036 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11037 c = (char*)POPPTR(ss,ix);
11038 TOPPTR(nss,ix) = pv_dup_inc(c);
11040 TOPINT(nss,ix) = i;
11042 case SAVEt_DESTRUCTOR:
11043 ptr = POPPTR(ss,ix);
11044 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11045 dptr = POPDPTR(ss,ix);
11046 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
11047 any_dup(FPTR2DPTR(void *, dptr),
11050 case SAVEt_DESTRUCTOR_X:
11051 ptr = POPPTR(ss,ix);
11052 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11053 dxptr = POPDXPTR(ss,ix);
11054 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
11055 any_dup(FPTR2DPTR(void *, dxptr),
11058 case SAVEt_REGCONTEXT:
11061 TOPINT(nss,ix) = i;
11064 case SAVEt_STACK_POS: /* Position on Perl stack */
11066 TOPINT(nss,ix) = i;
11068 case SAVEt_AELEM: /* array element */
11069 sv = (SV*)POPPTR(ss,ix);
11070 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11072 TOPINT(nss,ix) = i;
11073 av = (AV*)POPPTR(ss,ix);
11074 TOPPTR(nss,ix) = av_dup_inc(av, param);
11076 case SAVEt_HELEM: /* hash element */
11077 sv = (SV*)POPPTR(ss,ix);
11078 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11079 sv = (SV*)POPPTR(ss,ix);
11080 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11081 hv = (HV*)POPPTR(ss,ix);
11082 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11085 ptr = POPPTR(ss,ix);
11086 TOPPTR(nss,ix) = ptr;
11090 TOPINT(nss,ix) = i;
11092 case SAVEt_COMPPAD:
11093 av = (AV*)POPPTR(ss,ix);
11094 TOPPTR(nss,ix) = av_dup(av, param);
11097 longval = (long)POPLONG(ss,ix);
11098 TOPLONG(nss,ix) = longval;
11099 ptr = POPPTR(ss,ix);
11100 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11101 sv = (SV*)POPPTR(ss,ix);
11102 TOPPTR(nss,ix) = sv_dup(sv, param);
11105 ptr = POPPTR(ss,ix);
11106 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11107 longval = (long)POPBOOL(ss,ix);
11108 TOPBOOL(nss,ix) = (bool)longval;
11110 case SAVEt_SET_SVFLAGS:
11112 TOPINT(nss,ix) = i;
11114 TOPINT(nss,ix) = i;
11115 sv = (SV*)POPPTR(ss,ix);
11116 TOPPTR(nss,ix) = sv_dup(sv, param);
11119 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
11127 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11128 * flag to the result. This is done for each stash before cloning starts,
11129 * so we know which stashes want their objects cloned */
11132 do_mark_cloneable_stash(pTHX_ SV *sv)
11134 const HEK *hvname = HvNAME_HEK((HV*)sv);
11136 GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
11137 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11138 if (cloner && GvCV(cloner)) {
11145 XPUSHs(sv_2mortal(newSVhek(hvname)));
11147 call_sv((SV*)GvCV(cloner), G_SCALAR);
11154 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11162 =for apidoc perl_clone
11164 Create and return a new interpreter by cloning the current one.
11166 perl_clone takes these flags as parameters:
11168 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11169 without it we only clone the data and zero the stacks,
11170 with it we copy the stacks and the new perl interpreter is
11171 ready to run at the exact same point as the previous one.
11172 The pseudo-fork code uses COPY_STACKS while the
11173 threads->new doesn't.
11175 CLONEf_KEEP_PTR_TABLE
11176 perl_clone keeps a ptr_table with the pointer of the old
11177 variable as a key and the new variable as a value,
11178 this allows it to check if something has been cloned and not
11179 clone it again but rather just use the value and increase the
11180 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11181 the ptr_table using the function
11182 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11183 reason to keep it around is if you want to dup some of your own
11184 variable who are outside the graph perl scans, example of this
11185 code is in threads.xs create
11188 This is a win32 thing, it is ignored on unix, it tells perls
11189 win32host code (which is c++) to clone itself, this is needed on
11190 win32 if you want to run two threads at the same time,
11191 if you just want to do some stuff in a separate perl interpreter
11192 and then throw it away and return to the original one,
11193 you don't need to do anything.
11198 /* XXX the above needs expanding by someone who actually understands it ! */
11199 EXTERN_C PerlInterpreter *
11200 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11203 perl_clone(PerlInterpreter *proto_perl, UV flags)
11206 #ifdef PERL_IMPLICIT_SYS
11208 /* perlhost.h so we need to call into it
11209 to clone the host, CPerlHost should have a c interface, sky */
11211 if (flags & CLONEf_CLONE_HOST) {
11212 return perl_clone_host(proto_perl,flags);
11214 return perl_clone_using(proto_perl, flags,
11216 proto_perl->IMemShared,
11217 proto_perl->IMemParse,
11219 proto_perl->IStdIO,
11223 proto_perl->IProc);
11227 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11228 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11229 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11230 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11231 struct IPerlDir* ipD, struct IPerlSock* ipS,
11232 struct IPerlProc* ipP)
11234 /* XXX many of the string copies here can be optimized if they're
11235 * constants; they need to be allocated as common memory and just
11236 * their pointers copied. */
11239 CLONE_PARAMS clone_params;
11240 CLONE_PARAMS* param = &clone_params;
11242 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11243 /* for each stash, determine whether its objects should be cloned */
11244 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11245 PERL_SET_THX(my_perl);
11248 Poison(my_perl, 1, PerlInterpreter);
11250 PL_curcop = (COP *)Nullop;
11254 PL_savestack_ix = 0;
11255 PL_savestack_max = -1;
11256 PL_sig_pending = 0;
11257 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11258 # else /* !DEBUGGING */
11259 Zero(my_perl, 1, PerlInterpreter);
11260 # endif /* DEBUGGING */
11262 /* host pointers */
11264 PL_MemShared = ipMS;
11265 PL_MemParse = ipMP;
11272 #else /* !PERL_IMPLICIT_SYS */
11274 CLONE_PARAMS clone_params;
11275 CLONE_PARAMS* param = &clone_params;
11276 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11277 /* for each stash, determine whether its objects should be cloned */
11278 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11279 PERL_SET_THX(my_perl);
11282 Poison(my_perl, 1, PerlInterpreter);
11284 PL_curcop = (COP *)Nullop;
11288 PL_savestack_ix = 0;
11289 PL_savestack_max = -1;
11290 PL_sig_pending = 0;
11291 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11292 # else /* !DEBUGGING */
11293 Zero(my_perl, 1, PerlInterpreter);
11294 # endif /* DEBUGGING */
11295 #endif /* PERL_IMPLICIT_SYS */
11296 param->flags = flags;
11297 param->proto_perl = proto_perl;
11300 PL_xnv_arenaroot = NULL;
11301 PL_xnv_root = NULL;
11302 PL_xpv_arenaroot = NULL;
11303 PL_xpv_root = NULL;
11304 PL_xpviv_arenaroot = NULL;
11305 PL_xpviv_root = NULL;
11306 PL_xpvnv_arenaroot = NULL;
11307 PL_xpvnv_root = NULL;
11308 PL_xpvcv_arenaroot = NULL;
11309 PL_xpvcv_root = NULL;
11310 PL_xpvav_arenaroot = NULL;
11311 PL_xpvav_root = NULL;
11312 PL_xpvhv_arenaroot = NULL;
11313 PL_xpvhv_root = NULL;
11314 PL_xpvmg_arenaroot = NULL;
11315 PL_xpvmg_root = NULL;
11316 PL_xpvgv_arenaroot = NULL;
11317 PL_xpvgv_root = NULL;
11318 PL_xpvlv_arenaroot = NULL;
11319 PL_xpvlv_root = NULL;
11320 PL_xpvbm_arenaroot = NULL;
11321 PL_xpvbm_root = NULL;
11322 PL_he_arenaroot = NULL;
11324 #if defined(USE_ITHREADS)
11325 PL_pte_arenaroot = NULL;
11326 PL_pte_root = NULL;
11328 PL_nice_chunk = NULL;
11329 PL_nice_chunk_size = 0;
11331 PL_sv_objcount = 0;
11332 PL_sv_root = Nullsv;
11333 PL_sv_arenaroot = Nullsv;
11335 PL_debug = proto_perl->Idebug;
11337 PL_hash_seed = proto_perl->Ihash_seed;
11338 PL_rehash_seed = proto_perl->Irehash_seed;
11340 #ifdef USE_REENTRANT_API
11341 /* XXX: things like -Dm will segfault here in perlio, but doing
11342 * PERL_SET_CONTEXT(proto_perl);
11343 * breaks too many other things
11345 Perl_reentrant_init(aTHX);
11348 /* create SV map for pointer relocation */
11349 PL_ptr_table = ptr_table_new();
11351 /* initialize these special pointers as early as possible */
11352 SvANY(&PL_sv_undef) = NULL;
11353 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11354 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11355 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11357 SvANY(&PL_sv_no) = new_XPVNV();
11358 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11359 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11360 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11361 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
11362 SvCUR_set(&PL_sv_no, 0);
11363 SvLEN_set(&PL_sv_no, 1);
11364 SvIV_set(&PL_sv_no, 0);
11365 SvNV_set(&PL_sv_no, 0);
11366 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11368 SvANY(&PL_sv_yes) = new_XPVNV();
11369 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11370 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11371 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11372 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
11373 SvCUR_set(&PL_sv_yes, 1);
11374 SvLEN_set(&PL_sv_yes, 2);
11375 SvIV_set(&PL_sv_yes, 1);
11376 SvNV_set(&PL_sv_yes, 1);
11377 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11379 /* create (a non-shared!) shared string table */
11380 PL_strtab = newHV();
11381 HvSHAREKEYS_off(PL_strtab);
11382 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
11383 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11385 PL_compiling = proto_perl->Icompiling;
11387 /* These two PVs will be free'd special way so must set them same way op.c does */
11388 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11389 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11391 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11392 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11394 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11395 if (!specialWARN(PL_compiling.cop_warnings))
11396 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
11397 if (!specialCopIO(PL_compiling.cop_io))
11398 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
11399 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
11401 /* pseudo environmental stuff */
11402 PL_origargc = proto_perl->Iorigargc;
11403 PL_origargv = proto_perl->Iorigargv;
11405 param->stashes = newAV(); /* Setup array of objects to call clone on */
11407 #ifdef PERLIO_LAYERS
11408 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11409 PerlIO_clone(aTHX_ proto_perl, param);
11412 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11413 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11414 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11415 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11416 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11417 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11420 PL_minus_c = proto_perl->Iminus_c;
11421 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11422 PL_localpatches = proto_perl->Ilocalpatches;
11423 PL_splitstr = proto_perl->Isplitstr;
11424 PL_preprocess = proto_perl->Ipreprocess;
11425 PL_minus_n = proto_perl->Iminus_n;
11426 PL_minus_p = proto_perl->Iminus_p;
11427 PL_minus_l = proto_perl->Iminus_l;
11428 PL_minus_a = proto_perl->Iminus_a;
11429 PL_minus_F = proto_perl->Iminus_F;
11430 PL_doswitches = proto_perl->Idoswitches;
11431 PL_dowarn = proto_perl->Idowarn;
11432 PL_doextract = proto_perl->Idoextract;
11433 PL_sawampersand = proto_perl->Isawampersand;
11434 PL_unsafe = proto_perl->Iunsafe;
11435 PL_inplace = SAVEPV(proto_perl->Iinplace);
11436 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11437 PL_perldb = proto_perl->Iperldb;
11438 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11439 PL_exit_flags = proto_perl->Iexit_flags;
11441 /* magical thingies */
11442 /* XXX time(&PL_basetime) when asked for? */
11443 PL_basetime = proto_perl->Ibasetime;
11444 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11446 PL_maxsysfd = proto_perl->Imaxsysfd;
11447 PL_multiline = proto_perl->Imultiline;
11448 PL_statusvalue = proto_perl->Istatusvalue;
11450 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11452 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11454 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11455 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11456 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11458 /* Clone the regex array */
11459 PL_regex_padav = newAV();
11461 const I32 len = av_len((AV*)proto_perl->Iregex_padav);
11462 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11464 av_push(PL_regex_padav,
11465 sv_dup_inc(regexen[0],param));
11466 for(i = 1; i <= len; i++) {
11467 if(SvREPADTMP(regexen[i])) {
11468 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11470 av_push(PL_regex_padav,
11472 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11473 SvIVX(regexen[i])), param)))
11478 PL_regex_pad = AvARRAY(PL_regex_padav);
11480 /* shortcuts to various I/O objects */
11481 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11482 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11483 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11484 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11485 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11486 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11488 /* shortcuts to regexp stuff */
11489 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11491 /* shortcuts to misc objects */
11492 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11494 /* shortcuts to debugging objects */
11495 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11496 PL_DBline = gv_dup(proto_perl->IDBline, param);
11497 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11498 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11499 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11500 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11501 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11502 PL_lineary = av_dup(proto_perl->Ilineary, param);
11503 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11505 /* symbol tables */
11506 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11507 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11508 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11509 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11510 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11512 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11513 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11514 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11515 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11516 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11517 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11519 PL_sub_generation = proto_perl->Isub_generation;
11521 /* funky return mechanisms */
11522 PL_forkprocess = proto_perl->Iforkprocess;
11524 /* subprocess state */
11525 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11527 /* internal state */
11528 PL_tainting = proto_perl->Itainting;
11529 PL_taint_warn = proto_perl->Itaint_warn;
11530 PL_maxo = proto_perl->Imaxo;
11531 if (proto_perl->Iop_mask)
11532 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11534 PL_op_mask = Nullch;
11535 /* PL_asserting = proto_perl->Iasserting; */
11537 /* current interpreter roots */
11538 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11539 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11540 PL_main_start = proto_perl->Imain_start;
11541 PL_eval_root = proto_perl->Ieval_root;
11542 PL_eval_start = proto_perl->Ieval_start;
11544 /* runtime control stuff */
11545 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11546 PL_copline = proto_perl->Icopline;
11548 PL_filemode = proto_perl->Ifilemode;
11549 PL_lastfd = proto_perl->Ilastfd;
11550 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11553 PL_gensym = proto_perl->Igensym;
11554 PL_preambled = proto_perl->Ipreambled;
11555 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11556 PL_laststatval = proto_perl->Ilaststatval;
11557 PL_laststype = proto_perl->Ilaststype;
11558 PL_mess_sv = Nullsv;
11560 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11561 PL_ofmt = SAVEPV(proto_perl->Iofmt);
11563 /* interpreter atexit processing */
11564 PL_exitlistlen = proto_perl->Iexitlistlen;
11565 if (PL_exitlistlen) {
11566 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11567 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11570 PL_exitlist = (PerlExitListEntry*)NULL;
11571 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11572 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11573 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11575 PL_profiledata = NULL;
11576 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
11577 /* PL_rsfp_filters entries have fake IoDIRP() */
11578 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
11580 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11582 PAD_CLONE_VARS(proto_perl, param);
11584 #ifdef HAVE_INTERP_INTERN
11585 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11588 /* more statics moved here */
11589 PL_generation = proto_perl->Igeneration;
11590 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11592 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11593 PL_in_clean_all = proto_perl->Iin_clean_all;
11595 PL_uid = proto_perl->Iuid;
11596 PL_euid = proto_perl->Ieuid;
11597 PL_gid = proto_perl->Igid;
11598 PL_egid = proto_perl->Iegid;
11599 PL_nomemok = proto_perl->Inomemok;
11600 PL_an = proto_perl->Ian;
11601 PL_evalseq = proto_perl->Ievalseq;
11602 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11603 PL_origalen = proto_perl->Iorigalen;
11604 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11605 PL_osname = SAVEPV(proto_perl->Iosname);
11606 PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */
11607 PL_sighandlerp = proto_perl->Isighandlerp;
11610 PL_runops = proto_perl->Irunops;
11612 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11615 PL_cshlen = proto_perl->Icshlen;
11616 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
11619 PL_lex_state = proto_perl->Ilex_state;
11620 PL_lex_defer = proto_perl->Ilex_defer;
11621 PL_lex_expect = proto_perl->Ilex_expect;
11622 PL_lex_formbrack = proto_perl->Ilex_formbrack;
11623 PL_lex_dojoin = proto_perl->Ilex_dojoin;
11624 PL_lex_starts = proto_perl->Ilex_starts;
11625 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
11626 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
11627 PL_lex_op = proto_perl->Ilex_op;
11628 PL_lex_inpat = proto_perl->Ilex_inpat;
11629 PL_lex_inwhat = proto_perl->Ilex_inwhat;
11630 PL_lex_brackets = proto_perl->Ilex_brackets;
11631 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11632 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
11633 PL_lex_casemods = proto_perl->Ilex_casemods;
11634 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11635 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
11637 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11638 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
11639 PL_nexttoke = proto_perl->Inexttoke;
11641 /* XXX This is probably masking the deeper issue of why
11642 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11643 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11644 * (A little debugging with a watchpoint on it may help.)
11646 if (SvANY(proto_perl->Ilinestr)) {
11647 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
11648 i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
11649 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11650 i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
11651 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11652 i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
11653 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11654 i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
11655 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11658 PL_linestr = NEWSV(65,79);
11659 sv_upgrade(PL_linestr,SVt_PVIV);
11660 sv_setpvn(PL_linestr,"",0);
11661 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
11663 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11664 PL_pending_ident = proto_perl->Ipending_ident;
11665 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
11667 PL_expect = proto_perl->Iexpect;
11669 PL_multi_start = proto_perl->Imulti_start;
11670 PL_multi_end = proto_perl->Imulti_end;
11671 PL_multi_open = proto_perl->Imulti_open;
11672 PL_multi_close = proto_perl->Imulti_close;
11674 PL_error_count = proto_perl->Ierror_count;
11675 PL_subline = proto_perl->Isubline;
11676 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
11678 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
11679 if (SvANY(proto_perl->Ilinestr)) {
11680 i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
11681 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11682 i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
11683 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11684 PL_last_lop_op = proto_perl->Ilast_lop_op;
11687 PL_last_uni = SvPVX(PL_linestr);
11688 PL_last_lop = SvPVX(PL_linestr);
11689 PL_last_lop_op = 0;
11691 PL_in_my = proto_perl->Iin_my;
11692 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
11694 PL_cryptseen = proto_perl->Icryptseen;
11697 PL_hints = proto_perl->Ihints;
11699 PL_amagic_generation = proto_perl->Iamagic_generation;
11701 #ifdef USE_LOCALE_COLLATE
11702 PL_collation_ix = proto_perl->Icollation_ix;
11703 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
11704 PL_collation_standard = proto_perl->Icollation_standard;
11705 PL_collxfrm_base = proto_perl->Icollxfrm_base;
11706 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
11707 #endif /* USE_LOCALE_COLLATE */
11709 #ifdef USE_LOCALE_NUMERIC
11710 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
11711 PL_numeric_standard = proto_perl->Inumeric_standard;
11712 PL_numeric_local = proto_perl->Inumeric_local;
11713 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11714 #endif /* !USE_LOCALE_NUMERIC */
11716 /* utf8 character classes */
11717 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11718 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11719 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11720 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11721 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
11722 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11723 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
11724 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
11725 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
11726 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
11727 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
11728 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
11729 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11730 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
11731 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11732 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11733 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11734 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11735 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11736 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11738 /* Did the locale setup indicate UTF-8? */
11739 PL_utf8locale = proto_perl->Iutf8locale;
11740 /* Unicode features (see perlrun/-C) */
11741 PL_unicode = proto_perl->Iunicode;
11743 /* Pre-5.8 signals control */
11744 PL_signals = proto_perl->Isignals;
11746 /* times() ticks per second */
11747 PL_clocktick = proto_perl->Iclocktick;
11749 /* Recursion stopper for PerlIO_find_layer */
11750 PL_in_load_module = proto_perl->Iin_load_module;
11752 /* sort() routine */
11753 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
11755 /* Not really needed/useful since the reenrant_retint is "volatile",
11756 * but do it for consistency's sake. */
11757 PL_reentrant_retint = proto_perl->Ireentrant_retint;
11759 /* Hooks to shared SVs and locks. */
11760 PL_sharehook = proto_perl->Isharehook;
11761 PL_lockhook = proto_perl->Ilockhook;
11762 PL_unlockhook = proto_perl->Iunlockhook;
11763 PL_threadhook = proto_perl->Ithreadhook;
11765 PL_runops_std = proto_perl->Irunops_std;
11766 PL_runops_dbg = proto_perl->Irunops_dbg;
11768 #ifdef THREADS_HAVE_PIDS
11769 PL_ppid = proto_perl->Ippid;
11773 PL_last_swash_hv = Nullhv; /* reinits on demand */
11774 PL_last_swash_klen = 0;
11775 PL_last_swash_key[0]= '\0';
11776 PL_last_swash_tmps = (U8*)NULL;
11777 PL_last_swash_slen = 0;
11779 PL_glob_index = proto_perl->Iglob_index;
11780 PL_srand_called = proto_perl->Isrand_called;
11781 PL_uudmap['M'] = 0; /* reinits on demand */
11782 PL_bitcount = Nullch; /* reinits on demand */
11784 if (proto_perl->Ipsig_pend) {
11785 Newz(0, PL_psig_pend, SIG_SIZE, int);
11788 PL_psig_pend = (int*)NULL;
11791 if (proto_perl->Ipsig_ptr) {
11792 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
11793 Newz(0, PL_psig_name, SIG_SIZE, SV*);
11794 for (i = 1; i < SIG_SIZE; i++) {
11795 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11796 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11800 PL_psig_ptr = (SV**)NULL;
11801 PL_psig_name = (SV**)NULL;
11804 /* thrdvar.h stuff */
11806 if (flags & CLONEf_COPY_STACKS) {
11807 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11808 PL_tmps_ix = proto_perl->Ttmps_ix;
11809 PL_tmps_max = proto_perl->Ttmps_max;
11810 PL_tmps_floor = proto_perl->Ttmps_floor;
11811 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
11813 while (i <= PL_tmps_ix) {
11814 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
11818 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11819 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
11820 Newz(54, PL_markstack, i, I32);
11821 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
11822 - proto_perl->Tmarkstack);
11823 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
11824 - proto_perl->Tmarkstack);
11825 Copy(proto_perl->Tmarkstack, PL_markstack,
11826 PL_markstack_ptr - PL_markstack + 1, I32);
11828 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
11829 * NOTE: unlike the others! */
11830 PL_scopestack_ix = proto_perl->Tscopestack_ix;
11831 PL_scopestack_max = proto_perl->Tscopestack_max;
11832 Newz(54, PL_scopestack, PL_scopestack_max, I32);
11833 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
11835 /* NOTE: si_dup() looks at PL_markstack */
11836 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
11838 /* PL_curstack = PL_curstackinfo->si_stack; */
11839 PL_curstack = av_dup(proto_perl->Tcurstack, param);
11840 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
11842 /* next PUSHs() etc. set *(PL_stack_sp+1) */
11843 PL_stack_base = AvARRAY(PL_curstack);
11844 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
11845 - proto_perl->Tstack_base);
11846 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
11848 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
11849 * NOTE: unlike the others! */
11850 PL_savestack_ix = proto_perl->Tsavestack_ix;
11851 PL_savestack_max = proto_perl->Tsavestack_max;
11852 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
11853 PL_savestack = ss_dup(proto_perl, param);
11857 ENTER; /* perl_destruct() wants to LEAVE; */
11860 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
11861 PL_top_env = &PL_start_env;
11863 PL_op = proto_perl->Top;
11866 PL_Xpv = (XPV*)NULL;
11867 PL_na = proto_perl->Tna;
11869 PL_statbuf = proto_perl->Tstatbuf;
11870 PL_statcache = proto_perl->Tstatcache;
11871 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
11872 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
11874 PL_timesbuf = proto_perl->Ttimesbuf;
11877 PL_tainted = proto_perl->Ttainted;
11878 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
11879 PL_rs = sv_dup_inc(proto_perl->Trs, param);
11880 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
11881 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
11882 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
11883 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
11884 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
11885 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
11886 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
11888 PL_restartop = proto_perl->Trestartop;
11889 PL_in_eval = proto_perl->Tin_eval;
11890 PL_delaymagic = proto_perl->Tdelaymagic;
11891 PL_dirty = proto_perl->Tdirty;
11892 PL_localizing = proto_perl->Tlocalizing;
11894 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
11895 PL_hv_fetch_ent_mh = Nullhe;
11896 PL_modcount = proto_perl->Tmodcount;
11897 PL_lastgotoprobe = Nullop;
11898 PL_dumpindent = proto_perl->Tdumpindent;
11900 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
11901 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
11902 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
11903 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
11904 PL_sortcxix = proto_perl->Tsortcxix;
11905 PL_efloatbuf = Nullch; /* reinits on demand */
11906 PL_efloatsize = 0; /* reinits on demand */
11910 PL_screamfirst = NULL;
11911 PL_screamnext = NULL;
11912 PL_maxscream = -1; /* reinits on demand */
11913 PL_lastscream = Nullsv;
11915 PL_watchaddr = NULL;
11916 PL_watchok = Nullch;
11918 PL_regdummy = proto_perl->Tregdummy;
11919 PL_regprecomp = Nullch;
11922 PL_colorset = 0; /* reinits PL_colors[] */
11923 /*PL_colors[6] = {0,0,0,0,0,0};*/
11924 PL_reginput = Nullch;
11925 PL_regbol = Nullch;
11926 PL_regeol = Nullch;
11927 PL_regstartp = (I32*)NULL;
11928 PL_regendp = (I32*)NULL;
11929 PL_reglastparen = (U32*)NULL;
11930 PL_reglastcloseparen = (U32*)NULL;
11931 PL_regtill = Nullch;
11932 PL_reg_start_tmp = (char**)NULL;
11933 PL_reg_start_tmpl = 0;
11934 PL_regdata = (struct reg_data*)NULL;
11937 PL_reg_eval_set = 0;
11939 PL_regprogram = (regnode*)NULL;
11941 PL_regcc = (CURCUR*)NULL;
11942 PL_reg_call_cc = (struct re_cc_state*)NULL;
11943 PL_reg_re = (regexp*)NULL;
11944 PL_reg_ganch = Nullch;
11945 PL_reg_sv = Nullsv;
11946 PL_reg_match_utf8 = FALSE;
11947 PL_reg_magic = (MAGIC*)NULL;
11949 PL_reg_oldcurpm = (PMOP*)NULL;
11950 PL_reg_curpm = (PMOP*)NULL;
11951 PL_reg_oldsaved = Nullch;
11952 PL_reg_oldsavedlen = 0;
11953 #ifdef PERL_OLD_COPY_ON_WRITE
11956 PL_reg_maxiter = 0;
11957 PL_reg_leftiter = 0;
11958 PL_reg_poscache = Nullch;
11959 PL_reg_poscache_size= 0;
11961 /* RE engine - function pointers */
11962 PL_regcompp = proto_perl->Tregcompp;
11963 PL_regexecp = proto_perl->Tregexecp;
11964 PL_regint_start = proto_perl->Tregint_start;
11965 PL_regint_string = proto_perl->Tregint_string;
11966 PL_regfree = proto_perl->Tregfree;
11968 PL_reginterp_cnt = 0;
11969 PL_reg_starttry = 0;
11971 /* Pluggable optimizer */
11972 PL_peepp = proto_perl->Tpeepp;
11974 PL_stashcache = newHV();
11976 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
11977 ptr_table_free(PL_ptr_table);
11978 PL_ptr_table = NULL;
11981 /* Call the ->CLONE method, if it exists, for each of the stashes
11982 identified by sv_dup() above.
11984 while(av_len(param->stashes) != -1) {
11985 HV* stash = (HV*) av_shift(param->stashes);
11986 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
11987 if (cloner && GvCV(cloner)) {
11992 XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
11994 call_sv((SV*)GvCV(cloner), G_DISCARD);
12000 SvREFCNT_dec(param->stashes);
12002 /* orphaned? eg threads->new inside BEGIN or use */
12003 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
12004 (void)SvREFCNT_inc(PL_compcv);
12005 SAVEFREESV(PL_compcv);
12011 #endif /* USE_ITHREADS */
12014 =head1 Unicode Support
12016 =for apidoc sv_recode_to_utf8
12018 The encoding is assumed to be an Encode object, on entry the PV
12019 of the sv is assumed to be octets in that encoding, and the sv
12020 will be converted into Unicode (and UTF-8).
12022 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12023 is not a reference, nothing is done to the sv. If the encoding is not
12024 an C<Encode::XS> Encoding object, bad things will happen.
12025 (See F<lib/encoding.pm> and L<Encode>).
12027 The PV of the sv is returned.
12032 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12035 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12049 Passing sv_yes is wrong - it needs to be or'ed set of constants
12050 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12051 remove converted chars from source.
12053 Both will default the value - let them.
12055 XPUSHs(&PL_sv_yes);
12058 call_method("decode", G_SCALAR);
12062 s = SvPV_const(uni, len);
12063 if (s != SvPVX_const(sv)) {
12064 SvGROW(sv, len + 1);
12065 Move(s, SvPVX(sv), len + 1, char);
12066 SvCUR_set(sv, len);
12073 return SvPOKp(sv) ? SvPVX(sv) : NULL;
12077 =for apidoc sv_cat_decode
12079 The encoding is assumed to be an Encode object, the PV of the ssv is
12080 assumed to be octets in that encoding and decoding the input starts
12081 from the position which (PV + *offset) pointed to. The dsv will be
12082 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
12083 when the string tstr appears in decoding output or the input ends on
12084 the PV of the ssv. The value which the offset points will be modified
12085 to the last input position on the ssv.
12087 Returns TRUE if the terminator was found, else returns FALSE.
12092 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12093 SV *ssv, int *offset, char *tstr, int tlen)
12097 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12108 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
12109 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
12111 call_method("cat_decode", G_SCALAR);
12113 ret = SvTRUE(TOPs);
12114 *offset = SvIV(offsv);
12120 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12126 * c-indentation-style: bsd
12127 * c-basic-offset: 4
12128 * indent-tabs-mode: t
12131 * ex: set ts=8 sts=4 sw=4 noet: