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 #define more_thingy(TYPE,lctype) \
1158 S_more_bodies(aTHX_ (void**)&PL_## lctype ## _arenaroot, \
1159 (void**)&PL_ ## lctype ## _root, \
1162 #define more_thingy_allocated(lctype) \
1163 S_more_bodies(aTHX_ (void**)&PL_## lctype ## _arenaroot, \
1164 (void**)&PL_ ## lctype ## _root, \
1165 sizeof(lctype ## _allocated))
1168 #define more_xnv() more_thingy(NV, xnv)
1169 #define more_xpv() more_thingy_allocated(xpv)
1170 #define more_xpviv() more_thingy_allocated(xpviv)
1171 #define more_xpvnv() more_thingy(XPVNV, xpvnv)
1172 #define more_xpvcv() more_thingy(XPVCV, xpvcv)
1173 #define more_xpvav() more_thingy_allocated(xpvav)
1174 #define more_xpvhv() more_thingy_allocated(xpvhv)
1175 #define more_xpvgv() more_thingy(XPVGV, xpvgv)
1176 #define more_xpvmg() more_thingy(XPVMG, xpvmg)
1177 #define more_xpvbm() more_thingy(XPVBM, xpvbm)
1178 #define more_xpvlv() more_thingy(XPVLV, xpvlv)
1181 /* grab a new NV body from the free list, allocating more if necessary */
1188 xnv = PL_xnv_root ? PL_xnv_root : more_xnv();
1189 PL_xnv_root = *(NV**)xnv;
1191 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
1194 /* return an NV body to the free list */
1197 S_del_xnv(pTHX_ XPVNV *p)
1199 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
1201 *(NV**)xnv = PL_xnv_root;
1206 /* grab a new struct xpv from the free list, allocating more if necessary */
1213 xpv = PL_xpv_root ? PL_xpv_root : more_xpv();
1214 PL_xpv_root = *(xpv_allocated**)xpv;
1216 /* If xpv_allocated is the same structure as XPV then the two OFFSETs
1217 sum to zero, and the pointer is unchanged. If the allocated structure
1218 is smaller (no initial IV actually allocated) then the net effect is
1219 to subtract the size of the IV from the pointer, to return a new pointer
1220 as if an initial IV were actually allocated. */
1221 return (XPV*)((char*)xpv - STRUCT_OFFSET(XPV, xpv_cur)
1222 + STRUCT_OFFSET(xpv_allocated, xpv_cur));
1225 /* return a struct xpv to the free list */
1228 S_del_xpv(pTHX_ XPV *p)
1231 = (xpv_allocated*)((char*)(p) + STRUCT_OFFSET(XPV, xpv_cur)
1232 - STRUCT_OFFSET(xpv_allocated, xpv_cur));
1234 *(xpv_allocated**)xpv = PL_xpv_root;
1239 /* grab a new struct xpviv from the free list, allocating more if necessary */
1244 xpviv_allocated* xpviv;
1246 xpviv = PL_xpviv_root ? PL_xpviv_root : more_xpviv();
1247 PL_xpviv_root = *(xpviv_allocated**)xpviv;
1249 /* If xpviv_allocated is the same structure as XPVIV then the two OFFSETs
1250 sum to zero, and the pointer is unchanged. If the allocated structure
1251 is smaller (no initial IV actually allocated) then the net effect is
1252 to subtract the size of the IV from the pointer, to return a new pointer
1253 as if an initial IV were actually allocated. */
1254 return (XPVIV*)((char*)xpviv - STRUCT_OFFSET(XPVIV, xpv_cur)
1255 + STRUCT_OFFSET(xpviv_allocated, xpv_cur));
1258 /* return a struct xpviv to the free list */
1261 S_del_xpviv(pTHX_ XPVIV *p)
1263 xpviv_allocated* xpviv
1264 = (xpviv_allocated*)((char*)(p) + STRUCT_OFFSET(XPVIV, xpv_cur)
1265 - STRUCT_OFFSET(xpviv_allocated, xpv_cur));
1267 *(xpviv_allocated**)xpviv = PL_xpviv_root;
1268 PL_xpviv_root = xpviv;
1272 /* grab a new struct xpvnv from the free list, allocating more if necessary */
1279 xpvnv = PL_xpvnv_root ? PL_xpvnv_root : more_xpvnv();
1280 PL_xpvnv_root = *(XPVNV**)xpvnv;
1285 /* return a struct xpvnv to the free list */
1288 S_del_xpvnv(pTHX_ XPVNV *p)
1291 *(XPVNV**)p = PL_xpvnv_root;
1296 /* grab a new struct xpvcv from the free list, allocating more if necessary */
1303 xpvcv = PL_xpvcv_root ? PL_xpvcv_root : more_xpvcv();
1304 PL_xpvcv_root = *(XPVCV**)xpvcv;
1309 /* return a struct xpvcv to the free list */
1312 S_del_xpvcv(pTHX_ XPVCV *p)
1315 *(XPVCV**)p = PL_xpvcv_root;
1320 /* grab a new struct xpvav from the free list, allocating more if necessary */
1325 xpvav_allocated* xpvav;
1327 xpvav = PL_xpvav_root ? PL_xpvav_root : more_xpvav();
1328 PL_xpvav_root = *(xpvav_allocated**)xpvav;
1330 return (XPVAV*)((char*)xpvav - STRUCT_OFFSET(XPVAV, xav_fill)
1331 + STRUCT_OFFSET(xpvav_allocated, xav_fill));
1334 /* return a struct xpvav to the free list */
1337 S_del_xpvav(pTHX_ XPVAV *p)
1339 xpvav_allocated* xpvav
1340 = (xpvav_allocated*)((char*)(p) + STRUCT_OFFSET(XPVAV, xav_fill)
1341 - STRUCT_OFFSET(xpvav_allocated, xav_fill));
1343 *(xpvav_allocated**)xpvav = PL_xpvav_root;
1344 PL_xpvav_root = xpvav;
1348 /* grab a new struct xpvhv from the free list, allocating more if necessary */
1353 xpvhv_allocated* xpvhv;
1355 xpvhv = PL_xpvhv_root ? PL_xpvhv_root : more_xpvhv();
1356 PL_xpvhv_root = *(xpvhv_allocated**)xpvhv;
1358 return (XPVHV*)((char*)xpvhv - STRUCT_OFFSET(XPVHV, xhv_fill)
1359 + STRUCT_OFFSET(xpvhv_allocated, xhv_fill));
1362 /* return a struct xpvhv to the free list */
1365 S_del_xpvhv(pTHX_ XPVHV *p)
1367 xpvhv_allocated* xpvhv
1368 = (xpvhv_allocated*)((char*)(p) + STRUCT_OFFSET(XPVHV, xhv_fill)
1369 - STRUCT_OFFSET(xpvhv_allocated, xhv_fill));
1371 *(xpvhv_allocated**)xpvhv = PL_xpvhv_root;
1372 PL_xpvhv_root = xpvhv;
1376 /* grab a new struct xpvmg from the free list, allocating more if necessary */
1383 xpvmg = PL_xpvmg_root ? PL_xpvmg_root : more_xpvmg();
1384 PL_xpvmg_root = *(XPVMG**)xpvmg;
1389 /* return a struct xpvmg to the free list */
1392 S_del_xpvmg(pTHX_ XPVMG *p)
1395 *(XPVMG**)p = PL_xpvmg_root;
1400 /* grab a new struct xpvgv from the free list, allocating more if necessary */
1407 xpvgv = PL_xpvgv_root ? PL_xpvgv_root : more_xpvgv();
1408 PL_xpvgv_root = *(XPVGV**)xpvgv;
1413 /* return a struct xpvgv to the free list */
1416 S_del_xpvgv(pTHX_ XPVGV *p)
1419 *(XPVGV**)p = PL_xpvgv_root;
1424 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1431 xpvlv = PL_xpvlv_root ? PL_xpvlv_root : more_xpvlv();
1432 PL_xpvlv_root = *(XPVLV**)xpvlv;
1437 /* return a struct xpvlv to the free list */
1440 S_del_xpvlv(pTHX_ XPVLV *p)
1443 *(XPVLV**)p = PL_xpvlv_root;
1448 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1455 xpvbm = PL_xpvbm_root ? PL_xpvbm_root : more_xpvbm();
1456 PL_xpvbm_root = *(XPVBM**)xpvbm;
1461 /* return a struct xpvbm to the free list */
1464 S_del_xpvbm(pTHX_ XPVBM *p)
1467 *(XPVBM**)p = PL_xpvbm_root;
1472 #define my_safemalloc(s) (void*)safemalloc(s)
1473 #define my_safefree(p) safefree((char*)p)
1477 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1478 #define del_XNV(p) my_safefree(p)
1480 #define new_XPV() my_safemalloc(sizeof(XPV))
1481 #define del_XPV(p) my_safefree(p)
1483 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1484 #define del_XPVIV(p) my_safefree(p)
1486 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1487 #define del_XPVNV(p) my_safefree(p)
1489 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1490 #define del_XPVCV(p) my_safefree(p)
1492 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1493 #define del_XPVAV(p) my_safefree(p)
1495 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1496 #define del_XPVHV(p) my_safefree(p)
1498 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1499 #define del_XPVMG(p) my_safefree(p)
1501 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1502 #define del_XPVGV(p) my_safefree(p)
1504 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1505 #define del_XPVLV(p) my_safefree(p)
1507 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1508 #define del_XPVBM(p) my_safefree(p)
1512 #define new_XNV() (void*)new_xnv()
1513 #define del_XNV(p) del_xnv((XPVNV*) p)
1515 #define new_XPV() (void*)new_xpv()
1516 #define del_XPV(p) del_xpv((XPV *)p)
1518 #define new_XPVIV() (void*)new_xpviv()
1519 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
1521 #define new_XPVNV() (void*)new_xpvnv()
1522 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
1524 #define new_XPVCV() (void*)new_xpvcv()
1525 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
1527 #define new_XPVAV() (void*)new_xpvav()
1528 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
1530 #define new_XPVHV() (void*)new_xpvhv()
1531 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
1533 #define new_XPVMG() (void*)new_xpvmg()
1534 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
1536 #define new_XPVGV() (void*)new_xpvgv()
1537 #define del_XPVGV(p) del_xpvgv((XPVGV *)p)
1539 #define new_XPVLV() (void*)new_xpvlv()
1540 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
1542 #define new_XPVBM() (void*)new_xpvbm()
1543 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
1547 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1548 #define del_XPVFM(p) my_safefree(p)
1550 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1551 #define del_XPVIO(p) my_safefree(p)
1554 =for apidoc sv_upgrade
1556 Upgrade an SV to a more complex form. Generally adds a new body type to the
1557 SV, then copies across as much information as possible from the old body.
1558 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1564 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1575 if (mt != SVt_PV && SvIsCOW(sv)) {
1576 sv_force_normal_flags(sv, 0);
1579 if (SvTYPE(sv) == mt)
1590 switch (SvTYPE(sv)) {
1597 else if (mt < SVt_PVIV)
1607 pv = (char*)SvRV(sv);
1610 pv = SvPVX_mutable(sv);
1616 else if (mt == SVt_NV)
1620 pv = SvPVX_mutable(sv);
1624 del_XPVIV(SvANY(sv));
1627 pv = SvPVX_mutable(sv);
1632 del_XPVNV(SvANY(sv));
1635 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1636 there's no way that it can be safely upgraded, because perl.c
1637 expects to Safefree(SvANY(PL_mess_sv)) */
1638 assert(sv != PL_mess_sv);
1639 /* This flag bit is used to mean other things in other scalar types.
1640 Given that it only has meaning inside the pad, it shouldn't be set
1641 on anything that can get upgraded. */
1642 assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
1643 pv = SvPVX_mutable(sv);
1648 magic = SvMAGIC(sv);
1649 stash = SvSTASH(sv);
1650 del_XPVMG(SvANY(sv));
1653 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1656 SvFLAGS(sv) &= ~SVTYPEMASK;
1661 Perl_croak(aTHX_ "Can't upgrade to undef");
1663 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1667 SvANY(sv) = new_XNV();
1671 SvANY(sv) = &sv->sv_u.svu_rv;
1672 SvRV_set(sv, (SV*)pv);
1675 SvANY(sv) = new_XPVHV();
1678 HvTOTALKEYS(sv) = 0;
1680 /* Fall through... */
1683 SvANY(sv) = new_XPVAV();
1690 /* XXX? Only SVt_NULL is ever upgraded to AV or HV? */
1692 /* FIXME. Should be able to remove all this if()... if the above
1693 assertion is genuinely always true. */
1696 SvFLAGS(sv) &= ~SVf_OOK;
1699 SvPV_set(sv, (char*)0);
1700 SvMAGIC_set(sv, magic);
1701 SvSTASH_set(sv, stash);
1705 SvANY(sv) = new_XPVIO();
1706 Zero(SvANY(sv), 1, XPVIO);
1707 IoPAGE_LEN(sv) = 60;
1708 goto set_magic_common;
1710 SvANY(sv) = new_XPVFM();
1711 Zero(SvANY(sv), 1, XPVFM);
1712 goto set_magic_common;
1714 SvANY(sv) = new_XPVBM();
1718 goto set_magic_common;
1720 SvANY(sv) = new_XPVGV();
1726 goto set_magic_common;
1728 SvANY(sv) = new_XPVCV();
1729 Zero(SvANY(sv), 1, XPVCV);
1730 goto set_magic_common;
1732 SvANY(sv) = new_XPVLV();
1745 SvANY(sv) = new_XPVMG();
1748 SvMAGIC_set(sv, magic);
1749 SvSTASH_set(sv, stash);
1753 SvANY(sv) = new_XPVNV();
1759 SvANY(sv) = new_XPVIV();
1768 SvANY(sv) = new_XPV();
1778 =for apidoc sv_backoff
1780 Remove any string offset. You should normally use the C<SvOOK_off> macro
1787 Perl_sv_backoff(pTHX_ register SV *sv)
1790 assert(SvTYPE(sv) != SVt_PVHV);
1791 assert(SvTYPE(sv) != SVt_PVAV);
1793 const char *s = SvPVX_const(sv);
1794 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1795 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1797 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1799 SvFLAGS(sv) &= ~SVf_OOK;
1806 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1807 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1808 Use the C<SvGROW> wrapper instead.
1814 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1818 #ifdef HAS_64K_LIMIT
1819 if (newlen >= 0x10000) {
1820 PerlIO_printf(Perl_debug_log,
1821 "Allocation too large: %"UVxf"\n", (UV)newlen);
1824 #endif /* HAS_64K_LIMIT */
1827 if (SvTYPE(sv) < SVt_PV) {
1828 sv_upgrade(sv, SVt_PV);
1829 s = SvPVX_mutable(sv);
1831 else if (SvOOK(sv)) { /* pv is offset? */
1833 s = SvPVX_mutable(sv);
1834 if (newlen > SvLEN(sv))
1835 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1836 #ifdef HAS_64K_LIMIT
1837 if (newlen >= 0x10000)
1842 s = SvPVX_mutable(sv);
1844 if (newlen > SvLEN(sv)) { /* need more room? */
1845 newlen = PERL_STRLEN_ROUNDUP(newlen);
1846 if (SvLEN(sv) && s) {
1848 const STRLEN l = malloced_size((void*)SvPVX_const(sv));
1854 s = saferealloc(s, newlen);
1857 s = safemalloc(newlen);
1858 if (SvPVX_const(sv) && SvCUR(sv)) {
1859 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1863 SvLEN_set(sv, newlen);
1869 =for apidoc sv_setiv
1871 Copies an integer into the given SV, upgrading first if necessary.
1872 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1878 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1880 SV_CHECK_THINKFIRST_COW_DROP(sv);
1881 switch (SvTYPE(sv)) {
1883 sv_upgrade(sv, SVt_IV);
1886 sv_upgrade(sv, SVt_PVNV);
1890 sv_upgrade(sv, SVt_PVIV);
1899 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1902 (void)SvIOK_only(sv); /* validate number */
1908 =for apidoc sv_setiv_mg
1910 Like C<sv_setiv>, but also handles 'set' magic.
1916 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1923 =for apidoc sv_setuv
1925 Copies an unsigned integer into the given SV, upgrading first if necessary.
1926 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1932 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1934 /* With these two if statements:
1935 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1938 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1940 If you wish to remove them, please benchmark to see what the effect is
1942 if (u <= (UV)IV_MAX) {
1943 sv_setiv(sv, (IV)u);
1952 =for apidoc sv_setuv_mg
1954 Like C<sv_setuv>, but also handles 'set' magic.
1960 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1962 /* With these two if statements:
1963 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1966 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1968 If you wish to remove them, please benchmark to see what the effect is
1970 if (u <= (UV)IV_MAX) {
1971 sv_setiv(sv, (IV)u);
1981 =for apidoc sv_setnv
1983 Copies a double into the given SV, upgrading first if necessary.
1984 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1990 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1992 SV_CHECK_THINKFIRST_COW_DROP(sv);
1993 switch (SvTYPE(sv)) {
1996 sv_upgrade(sv, SVt_NV);
2001 sv_upgrade(sv, SVt_PVNV);
2010 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
2014 (void)SvNOK_only(sv); /* validate number */
2019 =for apidoc sv_setnv_mg
2021 Like C<sv_setnv>, but also handles 'set' magic.
2027 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
2033 /* Print an "isn't numeric" warning, using a cleaned-up,
2034 * printable version of the offending string
2038 S_not_a_number(pTHX_ SV *sv)
2045 dsv = sv_2mortal(newSVpv("", 0));
2046 pv = sv_uni_display(dsv, sv, 10, 0);
2049 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
2050 /* each *s can expand to 4 chars + "...\0",
2051 i.e. need room for 8 chars */
2053 const char *s, *end;
2054 for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit;
2057 if (ch & 128 && !isPRINT_LC(ch)) {
2066 else if (ch == '\r') {
2070 else if (ch == '\f') {
2074 else if (ch == '\\') {
2078 else if (ch == '\0') {
2082 else if (isPRINT_LC(ch))
2099 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2100 "Argument \"%s\" isn't numeric in %s", pv,
2103 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2104 "Argument \"%s\" isn't numeric", pv);
2108 =for apidoc looks_like_number
2110 Test if the content of an SV looks like a number (or is a number).
2111 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
2112 non-numeric warning), even if your atof() doesn't grok them.
2118 Perl_looks_like_number(pTHX_ SV *sv)
2120 register const char *sbegin;
2124 sbegin = SvPVX_const(sv);
2127 else if (SvPOKp(sv))
2128 sbegin = SvPV_const(sv, len);
2130 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
2131 return grok_number(sbegin, len, NULL);
2134 /* Actually, ISO C leaves conversion of UV to IV undefined, but
2135 until proven guilty, assume that things are not that bad... */
2140 As 64 bit platforms often have an NV that doesn't preserve all bits of
2141 an IV (an assumption perl has been based on to date) it becomes necessary
2142 to remove the assumption that the NV always carries enough precision to
2143 recreate the IV whenever needed, and that the NV is the canonical form.
2144 Instead, IV/UV and NV need to be given equal rights. So as to not lose
2145 precision as a side effect of conversion (which would lead to insanity
2146 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
2147 1) to distinguish between IV/UV/NV slots that have cached a valid
2148 conversion where precision was lost and IV/UV/NV slots that have a
2149 valid conversion which has lost no precision
2150 2) to ensure that if a numeric conversion to one form is requested that
2151 would lose precision, the precise conversion (or differently
2152 imprecise conversion) is also performed and cached, to prevent
2153 requests for different numeric formats on the same SV causing
2154 lossy conversion chains. (lossless conversion chains are perfectly
2159 SvIOKp is true if the IV slot contains a valid value
2160 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
2161 SvNOKp is true if the NV slot contains a valid value
2162 SvNOK is true only if the NV value is accurate
2165 while converting from PV to NV, check to see if converting that NV to an
2166 IV(or UV) would lose accuracy over a direct conversion from PV to
2167 IV(or UV). If it would, cache both conversions, return NV, but mark
2168 SV as IOK NOKp (ie not NOK).
2170 While converting from PV to IV, check to see if converting that IV to an
2171 NV would lose accuracy over a direct conversion from PV to NV. If it
2172 would, cache both conversions, flag similarly.
2174 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2175 correctly because if IV & NV were set NV *always* overruled.
2176 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2177 changes - now IV and NV together means that the two are interchangeable:
2178 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
2180 The benefit of this is that operations such as pp_add know that if
2181 SvIOK is true for both left and right operands, then integer addition
2182 can be used instead of floating point (for cases where the result won't
2183 overflow). Before, floating point was always used, which could lead to
2184 loss of precision compared with integer addition.
2186 * making IV and NV equal status should make maths accurate on 64 bit
2188 * may speed up maths somewhat if pp_add and friends start to use
2189 integers when possible instead of fp. (Hopefully the overhead in
2190 looking for SvIOK and checking for overflow will not outweigh the
2191 fp to integer speedup)
2192 * will slow down integer operations (callers of SvIV) on "inaccurate"
2193 values, as the change from SvIOK to SvIOKp will cause a call into
2194 sv_2iv each time rather than a macro access direct to the IV slot
2195 * should speed up number->string conversion on integers as IV is
2196 favoured when IV and NV are equally accurate
2198 ####################################################################
2199 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2200 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2201 On the other hand, SvUOK is true iff UV.
2202 ####################################################################
2204 Your mileage will vary depending your CPU's relative fp to integer
2208 #ifndef NV_PRESERVES_UV
2209 # define IS_NUMBER_UNDERFLOW_IV 1
2210 # define IS_NUMBER_UNDERFLOW_UV 2
2211 # define IS_NUMBER_IV_AND_UV 2
2212 # define IS_NUMBER_OVERFLOW_IV 4
2213 # define IS_NUMBER_OVERFLOW_UV 5
2215 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2217 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2219 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2221 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));
2222 if (SvNVX(sv) < (NV)IV_MIN) {
2223 (void)SvIOKp_on(sv);
2225 SvIV_set(sv, IV_MIN);
2226 return IS_NUMBER_UNDERFLOW_IV;
2228 if (SvNVX(sv) > (NV)UV_MAX) {
2229 (void)SvIOKp_on(sv);
2232 SvUV_set(sv, UV_MAX);
2233 return IS_NUMBER_OVERFLOW_UV;
2235 (void)SvIOKp_on(sv);
2237 /* Can't use strtol etc to convert this string. (See truth table in
2239 if (SvNVX(sv) <= (UV)IV_MAX) {
2240 SvIV_set(sv, I_V(SvNVX(sv)));
2241 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2242 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2244 /* Integer is imprecise. NOK, IOKp */
2246 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2249 SvUV_set(sv, U_V(SvNVX(sv)));
2250 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2251 if (SvUVX(sv) == UV_MAX) {
2252 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2253 possibly be preserved by NV. Hence, it must be overflow.
2255 return IS_NUMBER_OVERFLOW_UV;
2257 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2259 /* Integer is imprecise. NOK, IOKp */
2261 return IS_NUMBER_OVERFLOW_IV;
2263 #endif /* !NV_PRESERVES_UV*/
2265 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
2266 * this function provided for binary compatibility only
2270 Perl_sv_2iv(pTHX_ register SV *sv)
2272 return sv_2iv_flags(sv, SV_GMAGIC);
2276 =for apidoc sv_2iv_flags
2278 Return the integer value of an SV, doing any necessary string
2279 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2280 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2286 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2290 if (SvGMAGICAL(sv)) {
2291 if (flags & SV_GMAGIC)
2296 return I_V(SvNVX(sv));
2298 if (SvPOKp(sv) && SvLEN(sv))
2301 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2302 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2308 if (SvTHINKFIRST(sv)) {
2311 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2312 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2313 return SvIV(tmpstr);
2314 return PTR2IV(SvRV(sv));
2317 sv_force_normal_flags(sv, 0);
2319 if (SvREADONLY(sv) && !SvOK(sv)) {
2320 if (ckWARN(WARN_UNINITIALIZED))
2327 return (IV)(SvUVX(sv));
2334 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2335 * without also getting a cached IV/UV from it at the same time
2336 * (ie PV->NV conversion should detect loss of accuracy and cache
2337 * IV or UV at same time to avoid this. NWC */
2339 if (SvTYPE(sv) == SVt_NV)
2340 sv_upgrade(sv, SVt_PVNV);
2342 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2343 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2344 certainly cast into the IV range at IV_MAX, whereas the correct
2345 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2347 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2348 SvIV_set(sv, I_V(SvNVX(sv)));
2349 if (SvNVX(sv) == (NV) SvIVX(sv)
2350 #ifndef NV_PRESERVES_UV
2351 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2352 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2353 /* Don't flag it as "accurately an integer" if the number
2354 came from a (by definition imprecise) NV operation, and
2355 we're outside the range of NV integer precision */
2358 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2359 DEBUG_c(PerlIO_printf(Perl_debug_log,
2360 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2366 /* IV not precise. No need to convert from PV, as NV
2367 conversion would already have cached IV if it detected
2368 that PV->IV would be better than PV->NV->IV
2369 flags already correct - don't set public IOK. */
2370 DEBUG_c(PerlIO_printf(Perl_debug_log,
2371 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2376 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2377 but the cast (NV)IV_MIN rounds to a the value less (more
2378 negative) than IV_MIN which happens to be equal to SvNVX ??
2379 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2380 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2381 (NV)UVX == NVX are both true, but the values differ. :-(
2382 Hopefully for 2s complement IV_MIN is something like
2383 0x8000000000000000 which will be exact. NWC */
2386 SvUV_set(sv, U_V(SvNVX(sv)));
2388 (SvNVX(sv) == (NV) SvUVX(sv))
2389 #ifndef NV_PRESERVES_UV
2390 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2391 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2392 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2393 /* Don't flag it as "accurately an integer" if the number
2394 came from a (by definition imprecise) NV operation, and
2395 we're outside the range of NV integer precision */
2401 DEBUG_c(PerlIO_printf(Perl_debug_log,
2402 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2406 return (IV)SvUVX(sv);
2409 else if (SvPOKp(sv) && SvLEN(sv)) {
2411 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2412 /* We want to avoid a possible problem when we cache an IV which
2413 may be later translated to an NV, and the resulting NV is not
2414 the same as the direct translation of the initial string
2415 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2416 be careful to ensure that the value with the .456 is around if the
2417 NV value is requested in the future).
2419 This means that if we cache such an IV, we need to cache the
2420 NV as well. Moreover, we trade speed for space, and do not
2421 cache the NV if we are sure it's not needed.
2424 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2425 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2426 == IS_NUMBER_IN_UV) {
2427 /* It's definitely an integer, only upgrade to PVIV */
2428 if (SvTYPE(sv) < SVt_PVIV)
2429 sv_upgrade(sv, SVt_PVIV);
2431 } else if (SvTYPE(sv) < SVt_PVNV)
2432 sv_upgrade(sv, SVt_PVNV);
2434 /* If NV preserves UV then we only use the UV value if we know that
2435 we aren't going to call atof() below. If NVs don't preserve UVs
2436 then the value returned may have more precision than atof() will
2437 return, even though value isn't perfectly accurate. */
2438 if ((numtype & (IS_NUMBER_IN_UV
2439 #ifdef NV_PRESERVES_UV
2442 )) == IS_NUMBER_IN_UV) {
2443 /* This won't turn off the public IOK flag if it was set above */
2444 (void)SvIOKp_on(sv);
2446 if (!(numtype & IS_NUMBER_NEG)) {
2448 if (value <= (UV)IV_MAX) {
2449 SvIV_set(sv, (IV)value);
2451 SvUV_set(sv, value);
2455 /* 2s complement assumption */
2456 if (value <= (UV)IV_MIN) {
2457 SvIV_set(sv, -(IV)value);
2459 /* Too negative for an IV. This is a double upgrade, but
2460 I'm assuming it will be rare. */
2461 if (SvTYPE(sv) < SVt_PVNV)
2462 sv_upgrade(sv, SVt_PVNV);
2466 SvNV_set(sv, -(NV)value);
2467 SvIV_set(sv, IV_MIN);
2471 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2472 will be in the previous block to set the IV slot, and the next
2473 block to set the NV slot. So no else here. */
2475 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2476 != IS_NUMBER_IN_UV) {
2477 /* It wasn't an (integer that doesn't overflow the UV). */
2478 SvNV_set(sv, Atof(SvPVX_const(sv)));
2480 if (! numtype && ckWARN(WARN_NUMERIC))
2483 #if defined(USE_LONG_DOUBLE)
2484 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2485 PTR2UV(sv), SvNVX(sv)));
2487 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2488 PTR2UV(sv), SvNVX(sv)));
2492 #ifdef NV_PRESERVES_UV
2493 (void)SvIOKp_on(sv);
2495 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2496 SvIV_set(sv, I_V(SvNVX(sv)));
2497 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2500 /* Integer is imprecise. NOK, IOKp */
2502 /* UV will not work better than IV */
2504 if (SvNVX(sv) > (NV)UV_MAX) {
2506 /* Integer is inaccurate. NOK, IOKp, is UV */
2507 SvUV_set(sv, UV_MAX);
2510 SvUV_set(sv, U_V(SvNVX(sv)));
2511 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2512 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2516 /* Integer is imprecise. NOK, IOKp, is UV */
2522 #else /* NV_PRESERVES_UV */
2523 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2524 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2525 /* The IV slot will have been set from value returned by
2526 grok_number above. The NV slot has just been set using
2529 assert (SvIOKp(sv));
2531 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2532 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2533 /* Small enough to preserve all bits. */
2534 (void)SvIOKp_on(sv);
2536 SvIV_set(sv, I_V(SvNVX(sv)));
2537 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2539 /* Assumption: first non-preserved integer is < IV_MAX,
2540 this NV is in the preserved range, therefore: */
2541 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2543 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);
2547 0 0 already failed to read UV.
2548 0 1 already failed to read UV.
2549 1 0 you won't get here in this case. IV/UV
2550 slot set, public IOK, Atof() unneeded.
2551 1 1 already read UV.
2552 so there's no point in sv_2iuv_non_preserve() attempting
2553 to use atol, strtol, strtoul etc. */
2554 if (sv_2iuv_non_preserve (sv, numtype)
2555 >= IS_NUMBER_OVERFLOW_IV)
2559 #endif /* NV_PRESERVES_UV */
2562 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2564 if (SvTYPE(sv) < SVt_IV)
2565 /* Typically the caller expects that sv_any is not NULL now. */
2566 sv_upgrade(sv, SVt_IV);
2569 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2570 PTR2UV(sv),SvIVX(sv)));
2571 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2574 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2575 * this function provided for binary compatibility only
2579 Perl_sv_2uv(pTHX_ register SV *sv)
2581 return sv_2uv_flags(sv, SV_GMAGIC);
2585 =for apidoc sv_2uv_flags
2587 Return the unsigned integer value of an SV, doing any necessary string
2588 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2589 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2595 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2599 if (SvGMAGICAL(sv)) {
2600 if (flags & SV_GMAGIC)
2605 return U_V(SvNVX(sv));
2606 if (SvPOKp(sv) && SvLEN(sv))
2609 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2610 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2616 if (SvTHINKFIRST(sv)) {
2619 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2620 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2621 return SvUV(tmpstr);
2622 return PTR2UV(SvRV(sv));
2625 sv_force_normal_flags(sv, 0);
2627 if (SvREADONLY(sv) && !SvOK(sv)) {
2628 if (ckWARN(WARN_UNINITIALIZED))
2638 return (UV)SvIVX(sv);
2642 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2643 * without also getting a cached IV/UV from it at the same time
2644 * (ie PV->NV conversion should detect loss of accuracy and cache
2645 * IV or UV at same time to avoid this. */
2646 /* IV-over-UV optimisation - choose to cache IV if possible */
2648 if (SvTYPE(sv) == SVt_NV)
2649 sv_upgrade(sv, SVt_PVNV);
2651 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2652 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2653 SvIV_set(sv, I_V(SvNVX(sv)));
2654 if (SvNVX(sv) == (NV) SvIVX(sv)
2655 #ifndef NV_PRESERVES_UV
2656 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2657 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2658 /* Don't flag it as "accurately an integer" if the number
2659 came from a (by definition imprecise) NV operation, and
2660 we're outside the range of NV integer precision */
2663 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2664 DEBUG_c(PerlIO_printf(Perl_debug_log,
2665 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2671 /* IV not precise. No need to convert from PV, as NV
2672 conversion would already have cached IV if it detected
2673 that PV->IV would be better than PV->NV->IV
2674 flags already correct - don't set public IOK. */
2675 DEBUG_c(PerlIO_printf(Perl_debug_log,
2676 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2681 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2682 but the cast (NV)IV_MIN rounds to a the value less (more
2683 negative) than IV_MIN which happens to be equal to SvNVX ??
2684 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2685 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2686 (NV)UVX == NVX are both true, but the values differ. :-(
2687 Hopefully for 2s complement IV_MIN is something like
2688 0x8000000000000000 which will be exact. NWC */
2691 SvUV_set(sv, U_V(SvNVX(sv)));
2693 (SvNVX(sv) == (NV) SvUVX(sv))
2694 #ifndef NV_PRESERVES_UV
2695 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2696 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2697 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2698 /* Don't flag it as "accurately an integer" if the number
2699 came from a (by definition imprecise) NV operation, and
2700 we're outside the range of NV integer precision */
2705 DEBUG_c(PerlIO_printf(Perl_debug_log,
2706 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2712 else if (SvPOKp(sv) && SvLEN(sv)) {
2714 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2716 /* We want to avoid a possible problem when we cache a UV which
2717 may be later translated to an NV, and the resulting NV is not
2718 the translation of the initial data.
2720 This means that if we cache such a UV, we need to cache the
2721 NV as well. Moreover, we trade speed for space, and do not
2722 cache the NV if not needed.
2725 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2726 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2727 == IS_NUMBER_IN_UV) {
2728 /* It's definitely an integer, only upgrade to PVIV */
2729 if (SvTYPE(sv) < SVt_PVIV)
2730 sv_upgrade(sv, SVt_PVIV);
2732 } else if (SvTYPE(sv) < SVt_PVNV)
2733 sv_upgrade(sv, SVt_PVNV);
2735 /* If NV preserves UV then we only use the UV value if we know that
2736 we aren't going to call atof() below. If NVs don't preserve UVs
2737 then the value returned may have more precision than atof() will
2738 return, even though it isn't accurate. */
2739 if ((numtype & (IS_NUMBER_IN_UV
2740 #ifdef NV_PRESERVES_UV
2743 )) == IS_NUMBER_IN_UV) {
2744 /* This won't turn off the public IOK flag if it was set above */
2745 (void)SvIOKp_on(sv);
2747 if (!(numtype & IS_NUMBER_NEG)) {
2749 if (value <= (UV)IV_MAX) {
2750 SvIV_set(sv, (IV)value);
2752 /* it didn't overflow, and it was positive. */
2753 SvUV_set(sv, value);
2757 /* 2s complement assumption */
2758 if (value <= (UV)IV_MIN) {
2759 SvIV_set(sv, -(IV)value);
2761 /* Too negative for an IV. This is a double upgrade, but
2762 I'm assuming it will be rare. */
2763 if (SvTYPE(sv) < SVt_PVNV)
2764 sv_upgrade(sv, SVt_PVNV);
2768 SvNV_set(sv, -(NV)value);
2769 SvIV_set(sv, IV_MIN);
2774 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2775 != IS_NUMBER_IN_UV) {
2776 /* It wasn't an integer, or it overflowed the UV. */
2777 SvNV_set(sv, Atof(SvPVX_const(sv)));
2779 if (! numtype && ckWARN(WARN_NUMERIC))
2782 #if defined(USE_LONG_DOUBLE)
2783 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2784 PTR2UV(sv), SvNVX(sv)));
2786 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2787 PTR2UV(sv), SvNVX(sv)));
2790 #ifdef NV_PRESERVES_UV
2791 (void)SvIOKp_on(sv);
2793 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2794 SvIV_set(sv, I_V(SvNVX(sv)));
2795 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2798 /* Integer is imprecise. NOK, IOKp */
2800 /* UV will not work better than IV */
2802 if (SvNVX(sv) > (NV)UV_MAX) {
2804 /* Integer is inaccurate. NOK, IOKp, is UV */
2805 SvUV_set(sv, UV_MAX);
2808 SvUV_set(sv, U_V(SvNVX(sv)));
2809 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2810 NV preservse UV so can do correct comparison. */
2811 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2815 /* Integer is imprecise. NOK, IOKp, is UV */
2820 #else /* NV_PRESERVES_UV */
2821 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2822 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2823 /* The UV slot will have been set from value returned by
2824 grok_number above. The NV slot has just been set using
2827 assert (SvIOKp(sv));
2829 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2830 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2831 /* Small enough to preserve all bits. */
2832 (void)SvIOKp_on(sv);
2834 SvIV_set(sv, I_V(SvNVX(sv)));
2835 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2837 /* Assumption: first non-preserved integer is < IV_MAX,
2838 this NV is in the preserved range, therefore: */
2839 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2841 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);
2844 sv_2iuv_non_preserve (sv, numtype);
2846 #endif /* NV_PRESERVES_UV */
2850 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2851 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2854 if (SvTYPE(sv) < SVt_IV)
2855 /* Typically the caller expects that sv_any is not NULL now. */
2856 sv_upgrade(sv, SVt_IV);
2860 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2861 PTR2UV(sv),SvUVX(sv)));
2862 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2868 Return the num value of an SV, doing any necessary string or integer
2869 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2876 Perl_sv_2nv(pTHX_ register SV *sv)
2880 if (SvGMAGICAL(sv)) {
2884 if (SvPOKp(sv) && SvLEN(sv)) {
2885 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2886 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2888 return Atof(SvPVX_const(sv));
2892 return (NV)SvUVX(sv);
2894 return (NV)SvIVX(sv);
2897 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2898 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2904 if (SvTHINKFIRST(sv)) {
2907 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2908 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2909 return SvNV(tmpstr);
2910 return PTR2NV(SvRV(sv));
2913 sv_force_normal_flags(sv, 0);
2915 if (SvREADONLY(sv) && !SvOK(sv)) {
2916 if (ckWARN(WARN_UNINITIALIZED))
2921 if (SvTYPE(sv) < SVt_NV) {
2922 if (SvTYPE(sv) == SVt_IV)
2923 sv_upgrade(sv, SVt_PVNV);
2925 sv_upgrade(sv, SVt_NV);
2926 #ifdef USE_LONG_DOUBLE
2928 STORE_NUMERIC_LOCAL_SET_STANDARD();
2929 PerlIO_printf(Perl_debug_log,
2930 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2931 PTR2UV(sv), SvNVX(sv));
2932 RESTORE_NUMERIC_LOCAL();
2936 STORE_NUMERIC_LOCAL_SET_STANDARD();
2937 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2938 PTR2UV(sv), SvNVX(sv));
2939 RESTORE_NUMERIC_LOCAL();
2943 else if (SvTYPE(sv) < SVt_PVNV)
2944 sv_upgrade(sv, SVt_PVNV);
2949 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2950 #ifdef NV_PRESERVES_UV
2953 /* Only set the public NV OK flag if this NV preserves the IV */
2954 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2955 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2956 : (SvIVX(sv) == I_V(SvNVX(sv))))
2962 else if (SvPOKp(sv) && SvLEN(sv)) {
2964 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2965 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2967 #ifdef NV_PRESERVES_UV
2968 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2969 == IS_NUMBER_IN_UV) {
2970 /* It's definitely an integer */
2971 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2973 SvNV_set(sv, Atof(SvPVX_const(sv)));
2976 SvNV_set(sv, Atof(SvPVX_const(sv)));
2977 /* Only set the public NV OK flag if this NV preserves the value in
2978 the PV at least as well as an IV/UV would.
2979 Not sure how to do this 100% reliably. */
2980 /* if that shift count is out of range then Configure's test is
2981 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2983 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2984 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2985 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2986 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2987 /* Can't use strtol etc to convert this string, so don't try.
2988 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2991 /* value has been set. It may not be precise. */
2992 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2993 /* 2s complement assumption for (UV)IV_MIN */
2994 SvNOK_on(sv); /* Integer is too negative. */
2999 if (numtype & IS_NUMBER_NEG) {
3000 SvIV_set(sv, -(IV)value);
3001 } else if (value <= (UV)IV_MAX) {
3002 SvIV_set(sv, (IV)value);
3004 SvUV_set(sv, value);
3008 if (numtype & IS_NUMBER_NOT_INT) {
3009 /* I believe that even if the original PV had decimals,
3010 they are lost beyond the limit of the FP precision.
3011 However, neither is canonical, so both only get p
3012 flags. NWC, 2000/11/25 */
3013 /* Both already have p flags, so do nothing */
3015 const NV nv = SvNVX(sv);
3016 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3017 if (SvIVX(sv) == I_V(nv)) {
3022 /* It had no "." so it must be integer. */
3025 /* between IV_MAX and NV(UV_MAX).
3026 Could be slightly > UV_MAX */
3028 if (numtype & IS_NUMBER_NOT_INT) {
3029 /* UV and NV both imprecise. */
3031 const UV nv_as_uv = U_V(nv);
3033 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
3044 #endif /* NV_PRESERVES_UV */
3047 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3049 if (SvTYPE(sv) < SVt_NV)
3050 /* Typically the caller expects that sv_any is not NULL now. */
3051 /* XXX Ilya implies that this is a bug in callers that assume this
3052 and ideally should be fixed. */
3053 sv_upgrade(sv, SVt_NV);
3056 #if defined(USE_LONG_DOUBLE)
3058 STORE_NUMERIC_LOCAL_SET_STANDARD();
3059 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
3060 PTR2UV(sv), SvNVX(sv));
3061 RESTORE_NUMERIC_LOCAL();
3065 STORE_NUMERIC_LOCAL_SET_STANDARD();
3066 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
3067 PTR2UV(sv), SvNVX(sv));
3068 RESTORE_NUMERIC_LOCAL();
3074 /* asIV(): extract an integer from the string value of an SV.
3075 * Caller must validate PVX */
3078 S_asIV(pTHX_ SV *sv)
3081 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
3083 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3084 == IS_NUMBER_IN_UV) {
3085 /* It's definitely an integer */
3086 if (numtype & IS_NUMBER_NEG) {
3087 if (value < (UV)IV_MIN)
3090 if (value < (UV)IV_MAX)
3095 if (ckWARN(WARN_NUMERIC))
3098 return I_V(Atof(SvPVX_const(sv)));
3101 /* asUV(): extract an unsigned integer from the string value of an SV
3102 * Caller must validate PVX */
3105 S_asUV(pTHX_ SV *sv)
3108 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
3110 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3111 == IS_NUMBER_IN_UV) {
3112 /* It's definitely an integer */
3113 if (!(numtype & IS_NUMBER_NEG))
3117 if (ckWARN(WARN_NUMERIC))
3120 return U_V(Atof(SvPVX_const(sv)));
3124 =for apidoc sv_2pv_nolen
3126 Like C<sv_2pv()>, but doesn't return the length too. You should usually
3127 use the macro wrapper C<SvPV_nolen(sv)> instead.
3132 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
3134 return sv_2pv(sv, 0);
3137 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
3138 * UV as a string towards the end of buf, and return pointers to start and
3141 * We assume that buf is at least TYPE_CHARS(UV) long.
3145 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
3147 char *ptr = buf + TYPE_CHARS(UV);
3161 *--ptr = '0' + (char)(uv % 10);
3169 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
3170 * this function provided for binary compatibility only
3174 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
3176 return sv_2pv_flags(sv, lp, SV_GMAGIC);
3180 =for apidoc sv_2pv_flags
3182 Returns a pointer to the string value of an SV, and sets *lp to its length.
3183 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
3185 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
3186 usually end up here too.
3192 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3197 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3198 char *tmpbuf = tbuf;
3205 if (SvGMAGICAL(sv)) {
3206 if (flags & SV_GMAGIC)
3211 if (flags & SV_MUTABLE_RETURN)
3212 return SvPVX_mutable(sv);
3213 if (flags & SV_CONST_RETURN)
3214 return (char *)SvPVX_const(sv);
3219 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
3221 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3226 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3231 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3232 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3240 if (SvTHINKFIRST(sv)) {
3243 register const char *typestr;
3244 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3245 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3247 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
3250 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
3251 if (flags & SV_CONST_RETURN) {
3252 pv = (char *) SvPVX_const(tmpstr);
3254 pv = (flags & SV_MUTABLE_RETURN)
3255 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
3258 *lp = SvCUR(tmpstr);
3260 pv = sv_2pv_flags(tmpstr, lp, flags);
3271 typestr = "NULLREF";
3275 switch (SvTYPE(sv)) {
3277 if ( ((SvFLAGS(sv) &
3278 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3279 == (SVs_OBJECT|SVs_SMG))
3280 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3281 const regexp *re = (regexp *)mg->mg_obj;
3284 const char *fptr = "msix";
3289 char need_newline = 0;
3290 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3292 while((ch = *fptr++)) {
3294 reflags[left++] = ch;
3297 reflags[right--] = ch;
3302 reflags[left] = '-';
3306 mg->mg_len = re->prelen + 4 + left;
3308 * If /x was used, we have to worry about a regex
3309 * ending with a comment later being embedded
3310 * within another regex. If so, we don't want this
3311 * regex's "commentization" to leak out to the
3312 * right part of the enclosing regex, we must cap
3313 * it with a newline.
3315 * So, if /x was used, we scan backwards from the
3316 * end of the regex. If we find a '#' before we
3317 * find a newline, we need to add a newline
3318 * ourself. If we find a '\n' first (or if we
3319 * don't find '#' or '\n'), we don't need to add
3320 * anything. -jfriedl
3322 if (PMf_EXTENDED & re->reganch)
3324 const char *endptr = re->precomp + re->prelen;
3325 while (endptr >= re->precomp)
3327 const char c = *(endptr--);
3329 break; /* don't need another */
3331 /* we end while in a comment, so we
3333 mg->mg_len++; /* save space for it */
3334 need_newline = 1; /* note to add it */
3340 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3341 Copy("(?", mg->mg_ptr, 2, char);
3342 Copy(reflags, mg->mg_ptr+2, left, char);
3343 Copy(":", mg->mg_ptr+left+2, 1, char);
3344 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3346 mg->mg_ptr[mg->mg_len - 2] = '\n';
3347 mg->mg_ptr[mg->mg_len - 1] = ')';
3348 mg->mg_ptr[mg->mg_len] = 0;
3350 PL_reginterp_cnt += re->program[0].next_off;
3352 if (re->reganch & ROPT_UTF8)
3368 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3369 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3370 /* tied lvalues should appear to be
3371 * scalars for backwards compatitbility */
3372 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3373 ? "SCALAR" : "LVALUE"; break;
3374 case SVt_PVAV: typestr = "ARRAY"; break;
3375 case SVt_PVHV: typestr = "HASH"; break;
3376 case SVt_PVCV: typestr = "CODE"; break;
3377 case SVt_PVGV: typestr = "GLOB"; break;
3378 case SVt_PVFM: typestr = "FORMAT"; break;
3379 case SVt_PVIO: typestr = "IO"; break;
3380 default: typestr = "UNKNOWN"; break;
3384 const char *name = HvNAME_get(SvSTASH(sv));
3385 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3386 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3389 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3393 *lp = strlen(typestr);
3394 return (char *)typestr;
3396 if (SvREADONLY(sv) && !SvOK(sv)) {
3397 if (ckWARN(WARN_UNINITIALIZED))
3404 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3405 /* I'm assuming that if both IV and NV are equally valid then
3406 converting the IV is going to be more efficient */
3407 const U32 isIOK = SvIOK(sv);
3408 const U32 isUIOK = SvIsUV(sv);
3409 char buf[TYPE_CHARS(UV)];
3412 if (SvTYPE(sv) < SVt_PVIV)
3413 sv_upgrade(sv, SVt_PVIV);
3415 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3417 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3418 /* inlined from sv_setpvn */
3419 SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
3420 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
3421 SvCUR_set(sv, ebuf - ptr);
3431 else if (SvNOKp(sv)) {
3432 if (SvTYPE(sv) < SVt_PVNV)
3433 sv_upgrade(sv, SVt_PVNV);
3434 /* The +20 is pure guesswork. Configure test needed. --jhi */
3435 s = SvGROW_mutable(sv, NV_DIG + 20);
3436 olderrno = errno; /* some Xenix systems wipe out errno here */
3438 if (SvNVX(sv) == 0.0)
3439 (void)strcpy(s,"0");
3443 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3446 #ifdef FIXNEGATIVEZERO
3447 if (*s == '-' && s[1] == '0' && !s[2])
3457 if (ckWARN(WARN_UNINITIALIZED)
3458 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3462 if (SvTYPE(sv) < SVt_PV)
3463 /* Typically the caller expects that sv_any is not NULL now. */
3464 sv_upgrade(sv, SVt_PV);
3468 STRLEN len = s - SvPVX_const(sv);
3474 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3475 PTR2UV(sv),SvPVX_const(sv)));
3476 if (flags & SV_CONST_RETURN)
3477 return (char *)SvPVX_const(sv);
3478 if (flags & SV_MUTABLE_RETURN)
3479 return SvPVX_mutable(sv);
3483 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3484 /* Sneaky stuff here */
3488 tsv = newSVpv(tmpbuf, 0);
3501 t = SvPVX_const(tsv);
3506 len = strlen(tmpbuf);
3508 #ifdef FIXNEGATIVEZERO
3509 if (len == 2 && t[0] == '-' && t[1] == '0') {
3514 SvUPGRADE(sv, SVt_PV);
3517 s = SvGROW_mutable(sv, len + 1);
3520 return strcpy(s, t);
3525 =for apidoc sv_copypv
3527 Copies a stringified representation of the source SV into the
3528 destination SV. Automatically performs any necessary mg_get and
3529 coercion of numeric values into strings. Guaranteed to preserve
3530 UTF-8 flag even from overloaded objects. Similar in nature to
3531 sv_2pv[_flags] but operates directly on an SV instead of just the
3532 string. Mostly uses sv_2pv_flags to do its work, except when that
3533 would lose the UTF-8'ness of the PV.
3539 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3543 s = SvPV_const(ssv,len);
3544 sv_setpvn(dsv,s,len);
3552 =for apidoc sv_2pvbyte_nolen
3554 Return a pointer to the byte-encoded representation of the SV.
3555 May cause the SV to be downgraded from UTF-8 as a side-effect.
3557 Usually accessed via the C<SvPVbyte_nolen> macro.
3563 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3565 return sv_2pvbyte(sv, 0);
3569 =for apidoc sv_2pvbyte
3571 Return a pointer to the byte-encoded representation of the SV, and set *lp
3572 to its length. May cause the SV to be downgraded from UTF-8 as a
3575 Usually accessed via the C<SvPVbyte> macro.
3581 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3583 sv_utf8_downgrade(sv,0);
3584 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3588 =for apidoc sv_2pvutf8_nolen
3590 Return a pointer to the UTF-8-encoded representation of the SV.
3591 May cause the SV to be upgraded to UTF-8 as a side-effect.
3593 Usually accessed via the C<SvPVutf8_nolen> macro.
3599 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3601 return sv_2pvutf8(sv, 0);
3605 =for apidoc sv_2pvutf8
3607 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3608 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3610 Usually accessed via the C<SvPVutf8> macro.
3616 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3618 sv_utf8_upgrade(sv);
3619 return SvPV(sv,*lp);
3623 =for apidoc sv_2bool
3625 This function is only called on magical items, and is only used by
3626 sv_true() or its macro equivalent.
3632 Perl_sv_2bool(pTHX_ register SV *sv)
3641 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3642 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3643 return (bool)SvTRUE(tmpsv);
3644 return SvRV(sv) != 0;
3647 register XPV* Xpvtmp;
3648 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3649 (*sv->sv_u.svu_pv > '0' ||
3650 Xpvtmp->xpv_cur > 1 ||
3651 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3658 return SvIVX(sv) != 0;
3661 return SvNVX(sv) != 0.0;
3668 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3669 * this function provided for binary compatibility only
3674 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3676 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3680 =for apidoc sv_utf8_upgrade
3682 Converts the PV of an SV to its UTF-8-encoded form.
3683 Forces the SV to string form if it is not already.
3684 Always sets the SvUTF8 flag to avoid future validity checks even
3685 if all the bytes have hibit clear.
3687 This is not as a general purpose byte encoding to Unicode interface:
3688 use the Encode extension for that.
3690 =for apidoc sv_utf8_upgrade_flags
3692 Converts the PV of an SV to its UTF-8-encoded form.
3693 Forces the SV to string form if it is not already.
3694 Always sets the SvUTF8 flag to avoid future validity checks even
3695 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3696 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3697 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3699 This is not as a general purpose byte encoding to Unicode interface:
3700 use the Encode extension for that.
3706 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3708 if (sv == &PL_sv_undef)
3712 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3713 (void) sv_2pv_flags(sv,&len, flags);
3717 (void) SvPV_force(sv,len);
3726 sv_force_normal_flags(sv, 0);
3729 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3730 sv_recode_to_utf8(sv, PL_encoding);
3731 else { /* Assume Latin-1/EBCDIC */
3732 /* This function could be much more efficient if we
3733 * had a FLAG in SVs to signal if there are any hibit
3734 * chars in the PV. Given that there isn't such a flag
3735 * make the loop as fast as possible. */
3736 const U8 *s = (U8 *) SvPVX_const(sv);
3737 const U8 *e = (U8 *) SvEND(sv);
3743 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3747 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3748 U8 *recoded = bytes_to_utf8((U8*)s, &len);
3750 SvPV_free(sv); /* No longer using what was there before. */
3752 SvPV_set(sv, (char*)recoded);
3753 SvCUR_set(sv, len - 1);
3754 SvLEN_set(sv, len); /* No longer know the real size. */
3756 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3763 =for apidoc sv_utf8_downgrade
3765 Attempts to convert the PV of an SV from characters to bytes.
3766 If the PV contains a character beyond byte, this conversion will fail;
3767 in this case, either returns false or, if C<fail_ok> is not
3770 This is not as a general purpose Unicode to byte encoding interface:
3771 use the Encode extension for that.
3777 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3779 if (SvPOKp(sv) && SvUTF8(sv)) {
3785 sv_force_normal_flags(sv, 0);
3787 s = (U8 *) SvPV(sv, len);
3788 if (!utf8_to_bytes(s, &len)) {
3793 Perl_croak(aTHX_ "Wide character in %s",
3796 Perl_croak(aTHX_ "Wide character");
3807 =for apidoc sv_utf8_encode
3809 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3810 flag off so that it looks like octets again.
3816 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3818 (void) sv_utf8_upgrade(sv);
3820 sv_force_normal_flags(sv, 0);
3822 if (SvREADONLY(sv)) {
3823 Perl_croak(aTHX_ PL_no_modify);
3829 =for apidoc sv_utf8_decode
3831 If the PV of the SV is an octet sequence in UTF-8
3832 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3833 so that it looks like a character. If the PV contains only single-byte
3834 characters, the C<SvUTF8> flag stays being off.
3835 Scans PV for validity and returns false if the PV is invalid UTF-8.
3841 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3847 /* The octets may have got themselves encoded - get them back as
3850 if (!sv_utf8_downgrade(sv, TRUE))
3853 /* it is actually just a matter of turning the utf8 flag on, but
3854 * we want to make sure everything inside is valid utf8 first.
3856 c = (const U8 *) SvPVX_const(sv);
3857 if (!is_utf8_string(c, SvCUR(sv)+1))
3859 e = (const U8 *) SvEND(sv);
3862 if (!UTF8_IS_INVARIANT(ch)) {
3871 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
3872 * this function provided for binary compatibility only
3876 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3878 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3882 =for apidoc sv_setsv
3884 Copies the contents of the source SV C<ssv> into the destination SV
3885 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3886 function if the source SV needs to be reused. Does not handle 'set' magic.
3887 Loosely speaking, it performs a copy-by-value, obliterating any previous
3888 content of the destination.
3890 You probably want to use one of the assortment of wrappers, such as
3891 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3892 C<SvSetMagicSV_nosteal>.
3894 =for apidoc sv_setsv_flags
3896 Copies the contents of the source SV C<ssv> into the destination SV
3897 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3898 function if the source SV needs to be reused. Does not handle 'set' magic.
3899 Loosely speaking, it performs a copy-by-value, obliterating any previous
3900 content of the destination.
3901 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3902 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3903 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3904 and C<sv_setsv_nomg> are implemented in terms of this function.
3906 You probably want to use one of the assortment of wrappers, such as
3907 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3908 C<SvSetMagicSV_nosteal>.
3910 This is the primary function for copying scalars, and most other
3911 copy-ish functions and macros use this underneath.
3917 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3919 register U32 sflags;
3925 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3927 sstr = &PL_sv_undef;
3928 stype = SvTYPE(sstr);
3929 dtype = SvTYPE(dstr);
3934 /* need to nuke the magic */
3936 SvRMAGICAL_off(dstr);
3939 /* There's a lot of redundancy below but we're going for speed here */
3944 if (dtype != SVt_PVGV) {
3945 (void)SvOK_off(dstr);
3953 sv_upgrade(dstr, SVt_IV);
3956 sv_upgrade(dstr, SVt_PVNV);
3960 sv_upgrade(dstr, SVt_PVIV);
3963 (void)SvIOK_only(dstr);
3964 SvIV_set(dstr, SvIVX(sstr));
3967 if (SvTAINTED(sstr))
3978 sv_upgrade(dstr, SVt_NV);
3983 sv_upgrade(dstr, SVt_PVNV);
3986 SvNV_set(dstr, SvNVX(sstr));
3987 (void)SvNOK_only(dstr);
3988 if (SvTAINTED(sstr))
3996 sv_upgrade(dstr, SVt_RV);
3997 else if (dtype == SVt_PVGV &&
3998 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
4001 if (GvIMPORTED(dstr) != GVf_IMPORTED
4002 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4004 GvIMPORTED_on(dstr);
4013 #ifdef PERL_OLD_COPY_ON_WRITE
4014 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
4015 if (dtype < SVt_PVIV)
4016 sv_upgrade(dstr, SVt_PVIV);
4023 sv_upgrade(dstr, SVt_PV);
4026 if (dtype < SVt_PVIV)
4027 sv_upgrade(dstr, SVt_PVIV);
4030 if (dtype < SVt_PVNV)
4031 sv_upgrade(dstr, SVt_PVNV);
4038 const char * const type = sv_reftype(sstr,0);
4040 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
4042 Perl_croak(aTHX_ "Bizarre copy of %s", type);
4047 if (dtype <= SVt_PVGV) {
4049 if (dtype != SVt_PVGV) {
4050 const char * const name = GvNAME(sstr);
4051 const STRLEN len = GvNAMELEN(sstr);
4052 /* don't upgrade SVt_PVLV: it can hold a glob */
4053 if (dtype != SVt_PVLV)
4054 sv_upgrade(dstr, SVt_PVGV);
4055 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
4056 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
4057 GvNAME(dstr) = savepvn(name, len);
4058 GvNAMELEN(dstr) = len;
4059 SvFAKE_on(dstr); /* can coerce to non-glob */
4061 /* ahem, death to those who redefine active sort subs */
4062 else if (PL_curstackinfo->si_type == PERLSI_SORT
4063 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
4064 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
4067 #ifdef GV_UNIQUE_CHECK
4068 if (GvUNIQUE((GV*)dstr)) {
4069 Perl_croak(aTHX_ PL_no_modify);
4073 (void)SvOK_off(dstr);
4074 GvINTRO_off(dstr); /* one-shot flag */
4076 GvGP(dstr) = gp_ref(GvGP(sstr));
4077 if (SvTAINTED(sstr))
4079 if (GvIMPORTED(dstr) != GVf_IMPORTED
4080 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4082 GvIMPORTED_on(dstr);
4090 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4092 if ((int)SvTYPE(sstr) != stype) {
4093 stype = SvTYPE(sstr);
4094 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
4098 if (stype == SVt_PVLV)
4099 SvUPGRADE(dstr, SVt_PVNV);
4101 SvUPGRADE(dstr, (U32)stype);
4104 sflags = SvFLAGS(sstr);
4106 if (sflags & SVf_ROK) {
4107 if (dtype >= SVt_PV) {
4108 if (dtype == SVt_PVGV) {
4109 SV *sref = SvREFCNT_inc(SvRV(sstr));
4111 const int intro = GvINTRO(dstr);
4113 #ifdef GV_UNIQUE_CHECK
4114 if (GvUNIQUE((GV*)dstr)) {
4115 Perl_croak(aTHX_ PL_no_modify);
4120 GvINTRO_off(dstr); /* one-shot flag */
4121 GvLINE(dstr) = CopLINE(PL_curcop);
4122 GvEGV(dstr) = (GV*)dstr;
4125 switch (SvTYPE(sref)) {
4128 SAVEGENERICSV(GvAV(dstr));
4130 dref = (SV*)GvAV(dstr);
4131 GvAV(dstr) = (AV*)sref;
4132 if (!GvIMPORTED_AV(dstr)
4133 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4135 GvIMPORTED_AV_on(dstr);
4140 SAVEGENERICSV(GvHV(dstr));
4142 dref = (SV*)GvHV(dstr);
4143 GvHV(dstr) = (HV*)sref;
4144 if (!GvIMPORTED_HV(dstr)
4145 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4147 GvIMPORTED_HV_on(dstr);
4152 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
4153 SvREFCNT_dec(GvCV(dstr));
4154 GvCV(dstr) = Nullcv;
4155 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4156 PL_sub_generation++;
4158 SAVEGENERICSV(GvCV(dstr));
4161 dref = (SV*)GvCV(dstr);
4162 if (GvCV(dstr) != (CV*)sref) {
4163 CV* cv = GvCV(dstr);
4165 if (!GvCVGEN((GV*)dstr) &&
4166 (CvROOT(cv) || CvXSUB(cv)))
4168 /* ahem, death to those who redefine
4169 * active sort subs */
4170 if (PL_curstackinfo->si_type == PERLSI_SORT &&
4171 PL_sortcop == CvSTART(cv))
4173 "Can't redefine active sort subroutine %s",
4174 GvENAME((GV*)dstr));
4175 /* Redefining a sub - warning is mandatory if
4176 it was a const and its value changed. */
4177 if (ckWARN(WARN_REDEFINE)
4179 && (!CvCONST((CV*)sref)
4180 || sv_cmp(cv_const_sv(cv),
4181 cv_const_sv((CV*)sref)))))
4183 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4185 ? "Constant subroutine %s::%s redefined"
4186 : "Subroutine %s::%s redefined",
4187 HvNAME_get(GvSTASH((GV*)dstr)),
4188 GvENAME((GV*)dstr));
4192 cv_ckproto(cv, (GV*)dstr,
4194 ? SvPVX_const(sref) : Nullch);
4196 GvCV(dstr) = (CV*)sref;
4197 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4198 GvASSUMECV_on(dstr);
4199 PL_sub_generation++;
4201 if (!GvIMPORTED_CV(dstr)
4202 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4204 GvIMPORTED_CV_on(dstr);
4209 SAVEGENERICSV(GvIOp(dstr));
4211 dref = (SV*)GvIOp(dstr);
4212 GvIOp(dstr) = (IO*)sref;
4216 SAVEGENERICSV(GvFORM(dstr));
4218 dref = (SV*)GvFORM(dstr);
4219 GvFORM(dstr) = (CV*)sref;
4223 SAVEGENERICSV(GvSV(dstr));
4225 dref = (SV*)GvSV(dstr);
4227 if (!GvIMPORTED_SV(dstr)
4228 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4230 GvIMPORTED_SV_on(dstr);
4236 if (SvTAINTED(sstr))
4240 if (SvPVX_const(dstr)) {
4246 (void)SvOK_off(dstr);
4247 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4249 if (sflags & SVp_NOK) {
4251 /* Only set the public OK flag if the source has public OK. */
4252 if (sflags & SVf_NOK)
4253 SvFLAGS(dstr) |= SVf_NOK;
4254 SvNV_set(dstr, SvNVX(sstr));
4256 if (sflags & SVp_IOK) {
4257 (void)SvIOKp_on(dstr);
4258 if (sflags & SVf_IOK)
4259 SvFLAGS(dstr) |= SVf_IOK;
4260 if (sflags & SVf_IVisUV)
4262 SvIV_set(dstr, SvIVX(sstr));
4264 if (SvAMAGIC(sstr)) {
4268 else if (sflags & SVp_POK) {
4272 * Check to see if we can just swipe the string. If so, it's a
4273 * possible small lose on short strings, but a big win on long ones.
4274 * It might even be a win on short strings if SvPVX_const(dstr)
4275 * has to be allocated and SvPVX_const(sstr) has to be freed.
4278 /* Whichever path we take through the next code, we want this true,
4279 and doing it now facilitates the COW check. */
4280 (void)SvPOK_only(dstr);
4283 /* We're not already COW */
4284 ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4285 #ifndef PERL_OLD_COPY_ON_WRITE
4286 /* or we are, but dstr isn't a suitable target. */
4287 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4292 (sflags & SVs_TEMP) && /* slated for free anyway? */
4293 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4294 (!(flags & SV_NOSTEAL)) &&
4295 /* and we're allowed to steal temps */
4296 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4297 SvLEN(sstr) && /* and really is a string */
4298 /* and won't be needed again, potentially */
4299 !(PL_op && PL_op->op_type == OP_AASSIGN))
4300 #ifdef PERL_OLD_COPY_ON_WRITE
4301 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4302 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4303 && SvTYPE(sstr) >= SVt_PVIV)
4306 /* Failed the swipe test, and it's not a shared hash key either.
4307 Have to copy the string. */
4308 STRLEN len = SvCUR(sstr);
4309 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4310 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4311 SvCUR_set(dstr, len);
4312 *SvEND(dstr) = '\0';
4314 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4316 /* Either it's a shared hash key, or it's suitable for
4317 copy-on-write or we can swipe the string. */
4319 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4323 #ifdef PERL_OLD_COPY_ON_WRITE
4325 /* I believe I should acquire a global SV mutex if
4326 it's a COW sv (not a shared hash key) to stop
4327 it going un copy-on-write.
4328 If the source SV has gone un copy on write between up there
4329 and down here, then (assert() that) it is of the correct
4330 form to make it copy on write again */
4331 if ((sflags & (SVf_FAKE | SVf_READONLY))
4332 != (SVf_FAKE | SVf_READONLY)) {
4333 SvREADONLY_on(sstr);
4335 /* Make the source SV into a loop of 1.
4336 (about to become 2) */
4337 SV_COW_NEXT_SV_SET(sstr, sstr);
4341 /* Initial code is common. */
4342 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4344 SvFLAGS(dstr) &= ~SVf_OOK;
4345 Safefree(SvPVX_const(dstr) - SvIVX(dstr));
4347 else if (SvLEN(dstr))
4348 Safefree(SvPVX_const(dstr));
4352 /* making another shared SV. */
4353 STRLEN cur = SvCUR(sstr);
4354 STRLEN len = SvLEN(sstr);
4355 #ifdef PERL_OLD_COPY_ON_WRITE
4357 assert (SvTYPE(dstr) >= SVt_PVIV);
4358 /* SvIsCOW_normal */
4359 /* splice us in between source and next-after-source. */
4360 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4361 SV_COW_NEXT_SV_SET(sstr, dstr);
4362 SvPV_set(dstr, SvPVX_mutable(sstr));
4366 /* SvIsCOW_shared_hash */
4367 DEBUG_C(PerlIO_printf(Perl_debug_log,
4368 "Copy on write: Sharing hash\n"));
4370 assert (SvTYPE(dstr) >= SVt_PV);
4372 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4374 SvLEN_set(dstr, len);
4375 SvCUR_set(dstr, cur);
4376 SvREADONLY_on(dstr);
4378 /* Relesase a global SV mutex. */
4381 { /* Passes the swipe test. */
4382 SvPV_set(dstr, SvPVX_mutable(sstr));
4383 SvLEN_set(dstr, SvLEN(sstr));
4384 SvCUR_set(dstr, SvCUR(sstr));
4387 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4388 SvPV_set(sstr, Nullch);
4394 if (sflags & SVf_UTF8)
4396 if (sflags & SVp_NOK) {
4398 if (sflags & SVf_NOK)
4399 SvFLAGS(dstr) |= SVf_NOK;
4400 SvNV_set(dstr, SvNVX(sstr));
4402 if (sflags & SVp_IOK) {
4403 (void)SvIOKp_on(dstr);
4404 if (sflags & SVf_IOK)
4405 SvFLAGS(dstr) |= SVf_IOK;
4406 if (sflags & SVf_IVisUV)
4408 SvIV_set(dstr, SvIVX(sstr));
4411 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4412 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4413 smg->mg_ptr, smg->mg_len);
4414 SvRMAGICAL_on(dstr);
4417 else if (sflags & SVp_IOK) {
4418 if (sflags & SVf_IOK)
4419 (void)SvIOK_only(dstr);
4421 (void)SvOK_off(dstr);
4422 (void)SvIOKp_on(dstr);
4424 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4425 if (sflags & SVf_IVisUV)
4427 SvIV_set(dstr, SvIVX(sstr));
4428 if (sflags & SVp_NOK) {
4429 if (sflags & SVf_NOK)
4430 (void)SvNOK_on(dstr);
4432 (void)SvNOKp_on(dstr);
4433 SvNV_set(dstr, SvNVX(sstr));
4436 else if (sflags & SVp_NOK) {
4437 if (sflags & SVf_NOK)
4438 (void)SvNOK_only(dstr);
4440 (void)SvOK_off(dstr);
4443 SvNV_set(dstr, SvNVX(sstr));
4446 if (dtype == SVt_PVGV) {
4447 if (ckWARN(WARN_MISC))
4448 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4451 (void)SvOK_off(dstr);
4453 if (SvTAINTED(sstr))
4458 =for apidoc sv_setsv_mg
4460 Like C<sv_setsv>, but also handles 'set' magic.
4466 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4468 sv_setsv(dstr,sstr);
4472 #ifdef PERL_OLD_COPY_ON_WRITE
4474 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4476 STRLEN cur = SvCUR(sstr);
4477 STRLEN len = SvLEN(sstr);
4478 register char *new_pv;
4481 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4489 if (SvTHINKFIRST(dstr))
4490 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4491 else if (SvPVX_const(dstr))
4492 Safefree(SvPVX_const(dstr));
4496 SvUPGRADE(dstr, SVt_PVIV);
4498 assert (SvPOK(sstr));
4499 assert (SvPOKp(sstr));
4500 assert (!SvIOK(sstr));
4501 assert (!SvIOKp(sstr));
4502 assert (!SvNOK(sstr));
4503 assert (!SvNOKp(sstr));
4505 if (SvIsCOW(sstr)) {
4507 if (SvLEN(sstr) == 0) {
4508 /* source is a COW shared hash key. */
4509 DEBUG_C(PerlIO_printf(Perl_debug_log,
4510 "Fast copy on write: Sharing hash\n"));
4511 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4514 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4516 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4517 SvUPGRADE(sstr, SVt_PVIV);
4518 SvREADONLY_on(sstr);
4520 DEBUG_C(PerlIO_printf(Perl_debug_log,
4521 "Fast copy on write: Converting sstr to COW\n"));
4522 SV_COW_NEXT_SV_SET(dstr, sstr);
4524 SV_COW_NEXT_SV_SET(sstr, dstr);
4525 new_pv = SvPVX_mutable(sstr);
4528 SvPV_set(dstr, new_pv);
4529 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4532 SvLEN_set(dstr, len);
4533 SvCUR_set(dstr, cur);
4542 =for apidoc sv_setpvn
4544 Copies a string into an SV. The C<len> parameter indicates the number of
4545 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4546 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4552 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4554 register char *dptr;
4556 SV_CHECK_THINKFIRST_COW_DROP(sv);
4562 /* len is STRLEN which is unsigned, need to copy to signed */
4565 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4567 SvUPGRADE(sv, SVt_PV);
4569 dptr = SvGROW(sv, len + 1);
4570 Move(ptr,dptr,len,char);
4573 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4578 =for apidoc sv_setpvn_mg
4580 Like C<sv_setpvn>, but also handles 'set' magic.
4586 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4588 sv_setpvn(sv,ptr,len);
4593 =for apidoc sv_setpv
4595 Copies a string into an SV. The string must be null-terminated. Does not
4596 handle 'set' magic. See C<sv_setpv_mg>.
4602 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4604 register STRLEN len;
4606 SV_CHECK_THINKFIRST_COW_DROP(sv);
4612 SvUPGRADE(sv, SVt_PV);
4614 SvGROW(sv, len + 1);
4615 Move(ptr,SvPVX(sv),len+1,char);
4617 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4622 =for apidoc sv_setpv_mg
4624 Like C<sv_setpv>, but also handles 'set' magic.
4630 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4637 =for apidoc sv_usepvn
4639 Tells an SV to use C<ptr> to find its string value. Normally the string is
4640 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4641 The C<ptr> should point to memory that was allocated by C<malloc>. The
4642 string length, C<len>, must be supplied. This function will realloc the
4643 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4644 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4645 See C<sv_usepvn_mg>.
4651 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4654 SV_CHECK_THINKFIRST_COW_DROP(sv);
4655 SvUPGRADE(sv, SVt_PV);
4660 if (SvPVX_const(sv))
4663 allocate = PERL_STRLEN_ROUNDUP(len + 1);
4664 ptr = saferealloc (ptr, allocate);
4667 SvLEN_set(sv, allocate);
4669 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4674 =for apidoc sv_usepvn_mg
4676 Like C<sv_usepvn>, but also handles 'set' magic.
4682 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4684 sv_usepvn(sv,ptr,len);
4688 #ifdef PERL_OLD_COPY_ON_WRITE
4689 /* Need to do this *after* making the SV normal, as we need the buffer
4690 pointer to remain valid until after we've copied it. If we let go too early,
4691 another thread could invalidate it by unsharing last of the same hash key
4692 (which it can do by means other than releasing copy-on-write Svs)
4693 or by changing the other copy-on-write SVs in the loop. */
4695 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
4697 if (len) { /* this SV was SvIsCOW_normal(sv) */
4698 /* we need to find the SV pointing to us. */
4699 SV *current = SV_COW_NEXT_SV(after);
4701 if (current == sv) {
4702 /* The SV we point to points back to us (there were only two of us
4704 Hence other SV is no longer copy on write either. */
4706 SvREADONLY_off(after);
4708 /* We need to follow the pointers around the loop. */
4710 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4713 /* don't loop forever if the structure is bust, and we have
4714 a pointer into a closed loop. */
4715 assert (current != after);
4716 assert (SvPVX_const(current) == pvx);
4718 /* Make the SV before us point to the SV after us. */
4719 SV_COW_NEXT_SV_SET(current, after);
4722 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4727 Perl_sv_release_IVX(pTHX_ register SV *sv)
4730 sv_force_normal_flags(sv, 0);
4736 =for apidoc sv_force_normal_flags
4738 Undo various types of fakery on an SV: if the PV is a shared string, make
4739 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4740 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4741 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4742 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4743 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4744 set to some other value.) In addition, the C<flags> parameter gets passed to
4745 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4746 with flags set to 0.
4752 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4754 #ifdef PERL_OLD_COPY_ON_WRITE
4755 if (SvREADONLY(sv)) {
4756 /* At this point I believe I should acquire a global SV mutex. */
4758 const char *pvx = SvPVX_const(sv);
4759 const STRLEN len = SvLEN(sv);
4760 const STRLEN cur = SvCUR(sv);
4761 SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
4763 PerlIO_printf(Perl_debug_log,
4764 "Copy on write: Force normal %ld\n",
4770 /* This SV doesn't own the buffer, so need to New() a new one: */
4771 SvPV_set(sv, (char*)0);
4773 if (flags & SV_COW_DROP_PV) {
4774 /* OK, so we don't need to copy our buffer. */
4777 SvGROW(sv, cur + 1);
4778 Move(pvx,SvPVX(sv),cur,char);
4782 sv_release_COW(sv, pvx, len, next);
4787 else if (IN_PERL_RUNTIME)
4788 Perl_croak(aTHX_ PL_no_modify);
4789 /* At this point I believe that I can drop the global SV mutex. */
4792 if (SvREADONLY(sv)) {
4794 const char *pvx = SvPVX_const(sv);
4795 const STRLEN len = SvCUR(sv);
4798 SvPV_set(sv, Nullch);
4800 SvGROW(sv, len + 1);
4801 Move(pvx,SvPVX_const(sv),len,char);
4803 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4805 else if (IN_PERL_RUNTIME)
4806 Perl_croak(aTHX_ PL_no_modify);
4810 sv_unref_flags(sv, flags);
4811 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4816 =for apidoc sv_force_normal
4818 Undo various types of fakery on an SV: if the PV is a shared string, make
4819 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4820 an xpvmg. See also C<sv_force_normal_flags>.
4826 Perl_sv_force_normal(pTHX_ register SV *sv)
4828 sv_force_normal_flags(sv, 0);
4834 Efficient removal of characters from the beginning of the string buffer.
4835 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4836 the string buffer. The C<ptr> becomes the first character of the adjusted
4837 string. Uses the "OOK hack".
4838 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4839 refer to the same chunk of data.
4845 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
4847 register STRLEN delta;
4848 if (!ptr || !SvPOKp(sv))
4850 delta = ptr - SvPVX_const(sv);
4851 SV_CHECK_THINKFIRST(sv);
4852 if (SvTYPE(sv) < SVt_PVIV)
4853 sv_upgrade(sv,SVt_PVIV);
4856 if (!SvLEN(sv)) { /* make copy of shared string */
4857 const char *pvx = SvPVX_const(sv);
4858 const STRLEN len = SvCUR(sv);
4859 SvGROW(sv, len + 1);
4860 Move(pvx,SvPVX_const(sv),len,char);
4864 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
4865 and we do that anyway inside the SvNIOK_off
4867 SvFLAGS(sv) |= SVf_OOK;
4870 SvLEN_set(sv, SvLEN(sv) - delta);
4871 SvCUR_set(sv, SvCUR(sv) - delta);
4872 SvPV_set(sv, SvPVX(sv) + delta);
4873 SvIV_set(sv, SvIVX(sv) + delta);
4876 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
4877 * this function provided for binary compatibility only
4881 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
4883 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
4887 =for apidoc sv_catpvn
4889 Concatenates the string onto the end of the string which is in the SV. The
4890 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4891 status set, then the bytes appended should be valid UTF-8.
4892 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4894 =for apidoc sv_catpvn_flags
4896 Concatenates the string onto the end of the string which is in the SV. The
4897 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4898 status set, then the bytes appended should be valid UTF-8.
4899 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4900 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4901 in terms of this function.
4907 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4910 const char *dstr = SvPV_force_flags(dsv, dlen, flags);
4912 SvGROW(dsv, dlen + slen + 1);
4914 sstr = SvPVX_const(dsv);
4915 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4916 SvCUR_set(dsv, SvCUR(dsv) + slen);
4918 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4923 =for apidoc sv_catpvn_mg
4925 Like C<sv_catpvn>, but also handles 'set' magic.
4931 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4933 sv_catpvn(sv,ptr,len);
4937 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
4938 * this function provided for binary compatibility only
4942 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
4944 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
4948 =for apidoc sv_catsv
4950 Concatenates the string from SV C<ssv> onto the end of the string in
4951 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4952 not 'set' magic. See C<sv_catsv_mg>.
4954 =for apidoc sv_catsv_flags
4956 Concatenates the string from SV C<ssv> onto the end of the string in
4957 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4958 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4959 and C<sv_catsv_nomg> are implemented in terms of this function.
4964 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4970 if ((spv = SvPV_const(ssv, slen))) {
4971 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4972 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4973 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4974 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4975 dsv->sv_flags doesn't have that bit set.
4976 Andy Dougherty 12 Oct 2001
4978 const I32 sutf8 = DO_UTF8(ssv);
4981 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4983 dutf8 = DO_UTF8(dsv);
4985 if (dutf8 != sutf8) {
4987 /* Not modifying source SV, so taking a temporary copy. */
4988 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4990 sv_utf8_upgrade(csv);
4991 spv = SvPV_const(csv, slen);
4994 sv_utf8_upgrade_nomg(dsv);
4996 sv_catpvn_nomg(dsv, spv, slen);
5001 =for apidoc sv_catsv_mg
5003 Like C<sv_catsv>, but also handles 'set' magic.
5009 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
5016 =for apidoc sv_catpv
5018 Concatenates the string onto the end of the string which is in the SV.
5019 If the SV has the UTF-8 status set, then the bytes appended should be
5020 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
5025 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
5027 register STRLEN len;
5033 junk = SvPV_force(sv, tlen);
5035 SvGROW(sv, tlen + len + 1);
5037 ptr = SvPVX_const(sv);
5038 Move(ptr,SvPVX(sv)+tlen,len+1,char);
5039 SvCUR_set(sv, SvCUR(sv) + len);
5040 (void)SvPOK_only_UTF8(sv); /* validate pointer */
5045 =for apidoc sv_catpv_mg
5047 Like C<sv_catpv>, but also handles 'set' magic.
5053 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
5062 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
5063 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
5070 Perl_newSV(pTHX_ STRLEN len)
5076 sv_upgrade(sv, SVt_PV);
5077 SvGROW(sv, len + 1);
5082 =for apidoc sv_magicext
5084 Adds magic to an SV, upgrading it if necessary. Applies the
5085 supplied vtable and returns a pointer to the magic added.
5087 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5088 In particular, you can add magic to SvREADONLY SVs, and add more than
5089 one instance of the same 'how'.
5091 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5092 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5093 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5094 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5096 (This is now used as a subroutine by C<sv_magic>.)
5101 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
5102 const char* name, I32 namlen)
5106 if (SvTYPE(sv) < SVt_PVMG) {
5107 SvUPGRADE(sv, SVt_PVMG);
5109 Newz(702,mg, 1, MAGIC);
5110 mg->mg_moremagic = SvMAGIC(sv);
5111 SvMAGIC_set(sv, mg);
5113 /* Sometimes a magic contains a reference loop, where the sv and
5114 object refer to each other. To prevent a reference loop that
5115 would prevent such objects being freed, we look for such loops
5116 and if we find one we avoid incrementing the object refcount.
5118 Note we cannot do this to avoid self-tie loops as intervening RV must
5119 have its REFCNT incremented to keep it in existence.
5122 if (!obj || obj == sv ||
5123 how == PERL_MAGIC_arylen ||
5124 how == PERL_MAGIC_qr ||
5125 how == PERL_MAGIC_symtab ||
5126 (SvTYPE(obj) == SVt_PVGV &&
5127 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
5128 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
5129 GvFORM(obj) == (CV*)sv)))
5134 mg->mg_obj = SvREFCNT_inc(obj);
5135 mg->mg_flags |= MGf_REFCOUNTED;
5138 /* Normal self-ties simply pass a null object, and instead of
5139 using mg_obj directly, use the SvTIED_obj macro to produce a
5140 new RV as needed. For glob "self-ties", we are tieing the PVIO
5141 with an RV obj pointing to the glob containing the PVIO. In
5142 this case, to avoid a reference loop, we need to weaken the
5146 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5147 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
5153 mg->mg_len = namlen;
5156 mg->mg_ptr = savepvn(name, namlen);
5157 else if (namlen == HEf_SVKEY)
5158 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
5160 mg->mg_ptr = (char *) name;
5162 mg->mg_virtual = vtable;
5166 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5171 =for apidoc sv_magic
5173 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
5174 then adds a new magic item of type C<how> to the head of the magic list.
5176 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5177 handling of the C<name> and C<namlen> arguments.
5179 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5180 to add more than one instance of the same 'how'.
5186 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
5188 const MGVTBL *vtable = 0;
5191 #ifdef PERL_OLD_COPY_ON_WRITE
5193 sv_force_normal_flags(sv, 0);
5195 if (SvREADONLY(sv)) {
5197 && how != PERL_MAGIC_regex_global
5198 && how != PERL_MAGIC_bm
5199 && how != PERL_MAGIC_fm
5200 && how != PERL_MAGIC_sv
5201 && how != PERL_MAGIC_backref
5204 Perl_croak(aTHX_ PL_no_modify);
5207 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5208 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5209 /* sv_magic() refuses to add a magic of the same 'how' as an
5212 if (how == PERL_MAGIC_taint)
5220 vtable = &PL_vtbl_sv;
5222 case PERL_MAGIC_overload:
5223 vtable = &PL_vtbl_amagic;
5225 case PERL_MAGIC_overload_elem:
5226 vtable = &PL_vtbl_amagicelem;
5228 case PERL_MAGIC_overload_table:
5229 vtable = &PL_vtbl_ovrld;
5232 vtable = &PL_vtbl_bm;
5234 case PERL_MAGIC_regdata:
5235 vtable = &PL_vtbl_regdata;
5237 case PERL_MAGIC_regdatum:
5238 vtable = &PL_vtbl_regdatum;
5240 case PERL_MAGIC_env:
5241 vtable = &PL_vtbl_env;
5244 vtable = &PL_vtbl_fm;
5246 case PERL_MAGIC_envelem:
5247 vtable = &PL_vtbl_envelem;
5249 case PERL_MAGIC_regex_global:
5250 vtable = &PL_vtbl_mglob;
5252 case PERL_MAGIC_isa:
5253 vtable = &PL_vtbl_isa;
5255 case PERL_MAGIC_isaelem:
5256 vtable = &PL_vtbl_isaelem;
5258 case PERL_MAGIC_nkeys:
5259 vtable = &PL_vtbl_nkeys;
5261 case PERL_MAGIC_dbfile:
5264 case PERL_MAGIC_dbline:
5265 vtable = &PL_vtbl_dbline;
5267 #ifdef USE_LOCALE_COLLATE
5268 case PERL_MAGIC_collxfrm:
5269 vtable = &PL_vtbl_collxfrm;
5271 #endif /* USE_LOCALE_COLLATE */
5272 case PERL_MAGIC_tied:
5273 vtable = &PL_vtbl_pack;
5275 case PERL_MAGIC_tiedelem:
5276 case PERL_MAGIC_tiedscalar:
5277 vtable = &PL_vtbl_packelem;
5280 vtable = &PL_vtbl_regexp;
5282 case PERL_MAGIC_sig:
5283 vtable = &PL_vtbl_sig;
5285 case PERL_MAGIC_sigelem:
5286 vtable = &PL_vtbl_sigelem;
5288 case PERL_MAGIC_taint:
5289 vtable = &PL_vtbl_taint;
5291 case PERL_MAGIC_uvar:
5292 vtable = &PL_vtbl_uvar;
5294 case PERL_MAGIC_vec:
5295 vtable = &PL_vtbl_vec;
5297 case PERL_MAGIC_arylen_p:
5298 case PERL_MAGIC_rhash:
5299 case PERL_MAGIC_symtab:
5300 case PERL_MAGIC_vstring:
5303 case PERL_MAGIC_utf8:
5304 vtable = &PL_vtbl_utf8;
5306 case PERL_MAGIC_substr:
5307 vtable = &PL_vtbl_substr;
5309 case PERL_MAGIC_defelem:
5310 vtable = &PL_vtbl_defelem;
5312 case PERL_MAGIC_glob:
5313 vtable = &PL_vtbl_glob;
5315 case PERL_MAGIC_arylen:
5316 vtable = &PL_vtbl_arylen;
5318 case PERL_MAGIC_pos:
5319 vtable = &PL_vtbl_pos;
5321 case PERL_MAGIC_backref:
5322 vtable = &PL_vtbl_backref;
5324 case PERL_MAGIC_ext:
5325 /* Reserved for use by extensions not perl internals. */
5326 /* Useful for attaching extension internal data to perl vars. */
5327 /* Note that multiple extensions may clash if magical scalars */
5328 /* etc holding private data from one are passed to another. */
5331 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5334 /* Rest of work is done else where */
5335 mg = sv_magicext(sv,obj,how,(MGVTBL*)vtable,name,namlen);
5338 case PERL_MAGIC_taint:
5341 case PERL_MAGIC_ext:
5342 case PERL_MAGIC_dbfile:
5349 =for apidoc sv_unmagic
5351 Removes all magic of type C<type> from an SV.
5357 Perl_sv_unmagic(pTHX_ SV *sv, int type)
5361 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5364 for (mg = *mgp; mg; mg = *mgp) {
5365 if (mg->mg_type == type) {
5366 const MGVTBL* const vtbl = mg->mg_virtual;
5367 *mgp = mg->mg_moremagic;
5368 if (vtbl && vtbl->svt_free)
5369 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5370 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5372 Safefree(mg->mg_ptr);
5373 else if (mg->mg_len == HEf_SVKEY)
5374 SvREFCNT_dec((SV*)mg->mg_ptr);
5375 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
5376 Safefree(mg->mg_ptr);
5378 if (mg->mg_flags & MGf_REFCOUNTED)
5379 SvREFCNT_dec(mg->mg_obj);
5383 mgp = &mg->mg_moremagic;
5387 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5394 =for apidoc sv_rvweaken
5396 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5397 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5398 push a back-reference to this RV onto the array of backreferences
5399 associated with that magic.
5405 Perl_sv_rvweaken(pTHX_ SV *sv)
5408 if (!SvOK(sv)) /* let undefs pass */
5411 Perl_croak(aTHX_ "Can't weaken a nonreference");
5412 else if (SvWEAKREF(sv)) {
5413 if (ckWARN(WARN_MISC))
5414 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5418 sv_add_backref(tsv, sv);
5424 /* Give tsv backref magic if it hasn't already got it, then push a
5425 * back-reference to sv onto the array associated with the backref magic.
5429 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
5433 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
5434 av = (AV*)mg->mg_obj;
5437 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5438 /* av now has a refcnt of 2, which avoids it getting freed
5439 * before us during global cleanup. The extra ref is removed
5440 * by magic_killbackrefs() when tsv is being freed */
5442 if (AvFILLp(av) >= AvMAX(av)) {
5444 SV **svp = AvARRAY(av);
5445 for (i = AvFILLp(av); i >= 0; i--)
5447 svp[i] = sv; /* reuse the slot */
5450 av_extend(av, AvFILLp(av)+1);
5452 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5455 /* delete a back-reference to ourselves from the backref magic associated
5456 * with the SV we point to.
5460 S_sv_del_backref(pTHX_ SV *sv)
5467 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
5468 Perl_croak(aTHX_ "panic: del_backref");
5469 av = (AV *)mg->mg_obj;
5471 for (i = AvFILLp(av); i >= 0; i--)
5472 if (svp[i] == sv) svp[i] = Nullsv;
5476 =for apidoc sv_insert
5478 Inserts a string at the specified offset/length within the SV. Similar to
5479 the Perl substr() function.
5485 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
5489 register char *midend;
5490 register char *bigend;
5496 Perl_croak(aTHX_ "Can't modify non-existent substring");
5497 SvPV_force(bigstr, curlen);
5498 (void)SvPOK_only_UTF8(bigstr);
5499 if (offset + len > curlen) {
5500 SvGROW(bigstr, offset+len+1);
5501 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5502 SvCUR_set(bigstr, offset+len);
5506 i = littlelen - len;
5507 if (i > 0) { /* string might grow */
5508 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5509 mid = big + offset + len;
5510 midend = bigend = big + SvCUR(bigstr);
5513 while (midend > mid) /* shove everything down */
5514 *--bigend = *--midend;
5515 Move(little,big+offset,littlelen,char);
5516 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5521 Move(little,SvPVX(bigstr)+offset,len,char);
5526 big = SvPVX(bigstr);
5529 bigend = big + SvCUR(bigstr);
5531 if (midend > bigend)
5532 Perl_croak(aTHX_ "panic: sv_insert");
5534 if (mid - big > bigend - midend) { /* faster to shorten from end */
5536 Move(little, mid, littlelen,char);
5539 i = bigend - midend;
5541 Move(midend, mid, i,char);
5545 SvCUR_set(bigstr, mid - big);
5547 else if ((i = mid - big)) { /* faster from front */
5548 midend -= littlelen;
5550 sv_chop(bigstr,midend-i);
5555 Move(little, mid, littlelen,char);
5557 else if (littlelen) {
5558 midend -= littlelen;
5559 sv_chop(bigstr,midend);
5560 Move(little,midend,littlelen,char);
5563 sv_chop(bigstr,midend);
5569 =for apidoc sv_replace
5571 Make the first argument a copy of the second, then delete the original.
5572 The target SV physically takes over ownership of the body of the source SV
5573 and inherits its flags; however, the target keeps any magic it owns,
5574 and any magic in the source is discarded.
5575 Note that this is a rather specialist SV copying operation; most of the
5576 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5582 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5584 const U32 refcnt = SvREFCNT(sv);
5585 SV_CHECK_THINKFIRST_COW_DROP(sv);
5586 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
5587 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
5588 if (SvMAGICAL(sv)) {
5592 sv_upgrade(nsv, SVt_PVMG);
5593 SvMAGIC_set(nsv, SvMAGIC(sv));
5594 SvFLAGS(nsv) |= SvMAGICAL(sv);
5596 SvMAGIC_set(sv, NULL);
5600 assert(!SvREFCNT(sv));
5601 #ifdef DEBUG_LEAKING_SCALARS
5602 sv->sv_flags = nsv->sv_flags;
5603 sv->sv_any = nsv->sv_any;
5604 sv->sv_refcnt = nsv->sv_refcnt;
5605 sv->sv_u = nsv->sv_u;
5607 StructCopy(nsv,sv,SV);
5609 /* Currently could join these into one piece of pointer arithmetic, but
5610 it would be unclear. */
5611 if(SvTYPE(sv) == SVt_IV)
5613 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5614 else if (SvTYPE(sv) == SVt_RV) {
5615 SvANY(sv) = &sv->sv_u.svu_rv;
5619 #ifdef PERL_OLD_COPY_ON_WRITE
5620 if (SvIsCOW_normal(nsv)) {
5621 /* We need to follow the pointers around the loop to make the
5622 previous SV point to sv, rather than nsv. */
5625 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5628 assert(SvPVX_const(current) == SvPVX_const(nsv));
5630 /* Make the SV before us point to the SV after us. */
5632 PerlIO_printf(Perl_debug_log, "previous is\n");
5634 PerlIO_printf(Perl_debug_log,
5635 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5636 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5638 SV_COW_NEXT_SV_SET(current, sv);
5641 SvREFCNT(sv) = refcnt;
5642 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5648 =for apidoc sv_clear
5650 Clear an SV: call any destructors, free up any memory used by the body,
5651 and free the body itself. The SV's head is I<not> freed, although
5652 its type is set to all 1's so that it won't inadvertently be assumed
5653 to be live during global destruction etc.
5654 This function should only be called when REFCNT is zero. Most of the time
5655 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5662 Perl_sv_clear(pTHX_ register SV *sv)
5667 assert(SvREFCNT(sv) == 0);
5670 if (PL_defstash) { /* Still have a symbol table? */
5674 stash = SvSTASH(sv);
5675 destructor = StashHANDLER(stash,DESTROY);
5677 SV* tmpref = newRV(sv);
5678 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5680 PUSHSTACKi(PERLSI_DESTROY);
5685 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5691 if(SvREFCNT(tmpref) < 2) {
5692 /* tmpref is not kept alive! */
5694 SvRV_set(tmpref, NULL);
5697 SvREFCNT_dec(tmpref);
5699 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5703 if (PL_in_clean_objs)
5704 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5706 /* DESTROY gave object new lease on life */
5712 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5713 SvOBJECT_off(sv); /* Curse the object. */
5714 if (SvTYPE(sv) != SVt_PVIO)
5715 --PL_sv_objcount; /* XXX Might want something more general */
5718 if (SvTYPE(sv) >= SVt_PVMG) {
5721 if (SvTYPE(sv) == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
5722 SvREFCNT_dec(SvSTASH(sv));
5725 switch (SvTYPE(sv)) {
5728 IoIFP(sv) != PerlIO_stdin() &&
5729 IoIFP(sv) != PerlIO_stdout() &&
5730 IoIFP(sv) != PerlIO_stderr())
5732 io_close((IO*)sv, FALSE);
5734 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5735 PerlDir_close(IoDIRP(sv));
5736 IoDIRP(sv) = (DIR*)NULL;
5737 Safefree(IoTOP_NAME(sv));
5738 Safefree(IoFMT_NAME(sv));
5739 Safefree(IoBOTTOM_NAME(sv));
5754 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5755 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5756 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5757 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5759 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5760 SvREFCNT_dec(LvTARG(sv));
5764 Safefree(GvNAME(sv));
5765 /* cannot decrease stash refcount yet, as we might recursively delete
5766 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
5767 of stash until current sv is completely gone.
5768 -- JohnPC, 27 Mar 1998 */
5769 stash = GvSTASH(sv);
5775 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5777 SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
5778 /* Don't even bother with turning off the OOK flag. */
5787 SvREFCNT_dec(SvRV(sv));
5789 #ifdef PERL_OLD_COPY_ON_WRITE
5790 else if (SvPVX_const(sv)) {
5792 /* I believe I need to grab the global SV mutex here and
5793 then recheck the COW status. */
5795 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5798 sv_release_COW(sv, SvPVX_const(sv), SvLEN(sv),
5799 SV_COW_NEXT_SV(sv));
5800 /* And drop it here. */
5802 } else if (SvLEN(sv)) {
5803 Safefree(SvPVX_const(sv));
5807 else if (SvPVX_const(sv) && SvLEN(sv))
5808 Safefree(SvPVX_const(sv));
5809 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5810 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5823 switch (SvTYPE(sv)) {
5837 del_XPVIV(SvANY(sv));
5840 del_XPVNV(SvANY(sv));
5843 del_XPVMG(SvANY(sv));
5846 del_XPVLV(SvANY(sv));
5849 del_XPVAV(SvANY(sv));
5852 del_XPVHV(SvANY(sv));
5855 del_XPVCV(SvANY(sv));
5858 del_XPVGV(SvANY(sv));
5859 /* code duplication for increased performance. */
5860 SvFLAGS(sv) &= SVf_BREAK;
5861 SvFLAGS(sv) |= SVTYPEMASK;
5862 /* decrease refcount of the stash that owns this GV, if any */
5864 SvREFCNT_dec(stash);
5865 return; /* not break, SvFLAGS reset already happened */
5867 del_XPVBM(SvANY(sv));
5870 del_XPVFM(SvANY(sv));
5873 del_XPVIO(SvANY(sv));
5876 SvFLAGS(sv) &= SVf_BREAK;
5877 SvFLAGS(sv) |= SVTYPEMASK;
5881 =for apidoc sv_newref
5883 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5890 Perl_sv_newref(pTHX_ SV *sv)
5900 Decrement an SV's reference count, and if it drops to zero, call
5901 C<sv_clear> to invoke destructors and free up any memory used by
5902 the body; finally, deallocate the SV's head itself.
5903 Normally called via a wrapper macro C<SvREFCNT_dec>.
5909 Perl_sv_free(pTHX_ SV *sv)
5914 if (SvREFCNT(sv) == 0) {
5915 if (SvFLAGS(sv) & SVf_BREAK)
5916 /* this SV's refcnt has been artificially decremented to
5917 * trigger cleanup */
5919 if (PL_in_clean_all) /* All is fair */
5921 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5922 /* make sure SvREFCNT(sv)==0 happens very seldom */
5923 SvREFCNT(sv) = (~(U32)0)/2;
5926 if (ckWARN_d(WARN_INTERNAL))
5927 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5928 "Attempt to free unreferenced scalar: SV 0x%"UVxf
5929 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5932 if (--(SvREFCNT(sv)) > 0)
5934 Perl_sv_free2(aTHX_ sv);
5938 Perl_sv_free2(pTHX_ SV *sv)
5943 if (ckWARN_d(WARN_DEBUGGING))
5944 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5945 "Attempt to free temp prematurely: SV 0x%"UVxf
5946 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5950 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5951 /* make sure SvREFCNT(sv)==0 happens very seldom */
5952 SvREFCNT(sv) = (~(U32)0)/2;
5963 Returns the length of the string in the SV. Handles magic and type
5964 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5970 Perl_sv_len(pTHX_ register SV *sv)
5978 len = mg_length(sv);
5980 (void)SvPV_const(sv, len);
5985 =for apidoc sv_len_utf8
5987 Returns the number of characters in the string in an SV, counting wide
5988 UTF-8 bytes as a single character. Handles magic and type coercion.
5994 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
5995 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
5996 * (Note that the mg_len is not the length of the mg_ptr field.)
6001 Perl_sv_len_utf8(pTHX_ register SV *sv)
6007 return mg_length(sv);
6011 const U8 *s = (U8*)SvPV_const(sv, len);
6012 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
6014 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
6016 #ifdef PERL_UTF8_CACHE_ASSERT
6017 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
6021 ulen = Perl_utf8_length(aTHX_ s, s + len);
6022 if (!mg && !SvREADONLY(sv)) {
6023 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6024 mg = mg_find(sv, PERL_MAGIC_utf8);
6034 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
6035 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
6036 * between UTF-8 and byte offsets. There are two (substr offset and substr
6037 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
6038 * and byte offset) cache positions.
6040 * The mg_len field is used by sv_len_utf8(), see its comments.
6041 * Note that the mg_len is not the length of the mg_ptr field.
6045 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i,
6046 I32 offsetp, const U8 *s, const U8 *start)
6050 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6052 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
6056 *cachep = (STRLEN *) (*mgp)->mg_ptr;
6058 Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6059 (*mgp)->mg_ptr = (char *) *cachep;
6063 (*cachep)[i] = offsetp;
6064 (*cachep)[i+1] = s - start;
6072 * S_utf8_mg_pos() is used to query and update mg_ptr field of
6073 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
6074 * between UTF-8 and byte offsets. See also the comments of
6075 * S_utf8_mg_pos_init().
6079 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)
6083 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6085 *mgp = mg_find(sv, PERL_MAGIC_utf8);
6086 if (*mgp && (*mgp)->mg_ptr) {
6087 *cachep = (STRLEN *) (*mgp)->mg_ptr;
6088 ASSERT_UTF8_CACHE(*cachep);
6089 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
6091 else { /* We will skip to the right spot. */
6096 /* The assumption is that going backward is half
6097 * the speed of going forward (that's where the
6098 * 2 * backw in the below comes from). (The real
6099 * figure of course depends on the UTF-8 data.) */
6101 if ((*cachep)[i] > (STRLEN)uoff) {
6103 backw = (*cachep)[i] - (STRLEN)uoff;
6105 if (forw < 2 * backw)
6108 p = start + (*cachep)[i+1];
6110 /* Try this only for the substr offset (i == 0),
6111 * not for the substr length (i == 2). */
6112 else if (i == 0) { /* (*cachep)[i] < uoff */
6113 const STRLEN ulen = sv_len_utf8(sv);
6115 if ((STRLEN)uoff < ulen) {
6116 forw = (STRLEN)uoff - (*cachep)[i];
6117 backw = ulen - (STRLEN)uoff;
6119 if (forw < 2 * backw)
6120 p = start + (*cachep)[i+1];
6125 /* If the string is not long enough for uoff,
6126 * we could extend it, but not at this low a level. */
6130 if (forw < 2 * backw) {
6137 while (UTF8_IS_CONTINUATION(*p))
6142 /* Update the cache. */
6143 (*cachep)[i] = (STRLEN)uoff;
6144 (*cachep)[i+1] = p - start;
6146 /* Drop the stale "length" cache */
6155 if (found) { /* Setup the return values. */
6156 *offsetp = (*cachep)[i+1];
6157 *sp = start + *offsetp;
6160 *offsetp = send - start;
6162 else if (*sp < start) {
6168 #ifdef PERL_UTF8_CACHE_ASSERT
6173 while (n-- && s < send)
6177 assert(*offsetp == s - start);
6178 assert((*cachep)[0] == (STRLEN)uoff);
6179 assert((*cachep)[1] == *offsetp);
6181 ASSERT_UTF8_CACHE(*cachep);
6190 =for apidoc sv_pos_u2b
6192 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6193 the start of the string, to a count of the equivalent number of bytes; if
6194 lenp is non-zero, it does the same to lenp, but this time starting from
6195 the offset, rather than from the start of the string. Handles magic and
6202 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6203 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6204 * byte offsets. See also the comments of S_utf8_mg_pos().
6209 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
6217 start = (U8*)SvPV_const(sv, len);
6221 const U8 *s = start;
6222 I32 uoffset = *offsetp;
6223 const U8 *send = s + len;
6227 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
6229 if (!found && uoffset > 0) {
6230 while (s < send && uoffset--)
6234 if (utf8_mg_pos_init(sv, &mg, &cache, 0, *offsetp, s, start))
6236 *offsetp = s - start;
6241 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) {
6245 if (!found && *lenp > 0) {
6248 while (s < send && ulen--)
6252 utf8_mg_pos_init(sv, &mg, &cache, 2, *lenp, s, start);
6256 ASSERT_UTF8_CACHE(cache);
6268 =for apidoc sv_pos_b2u
6270 Converts the value pointed to by offsetp from a count of bytes from the
6271 start of the string, to a count of the equivalent number of UTF-8 chars.
6272 Handles magic and type coercion.
6278 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6279 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6280 * byte offsets. See also the comments of S_utf8_mg_pos().
6285 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
6293 s = (const U8*)SvPV_const(sv, len);
6294 if ((I32)len < *offsetp)
6295 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6297 const U8* send = s + *offsetp;
6299 STRLEN *cache = NULL;
6303 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6304 mg = mg_find(sv, PERL_MAGIC_utf8);
6305 if (mg && mg->mg_ptr) {
6306 cache = (STRLEN *) mg->mg_ptr;
6307 if (cache[1] == (STRLEN)*offsetp) {
6308 /* An exact match. */
6309 *offsetp = cache[0];
6313 else if (cache[1] < (STRLEN)*offsetp) {
6314 /* We already know part of the way. */
6317 /* Let the below loop do the rest. */
6319 else { /* cache[1] > *offsetp */
6320 /* We already know all of the way, now we may
6321 * be able to walk back. The same assumption
6322 * is made as in S_utf8_mg_pos(), namely that
6323 * walking backward is twice slower than
6324 * walking forward. */
6325 STRLEN forw = *offsetp;
6326 STRLEN backw = cache[1] - *offsetp;
6328 if (!(forw < 2 * backw)) {
6329 const U8 *p = s + cache[1];
6336 while (UTF8_IS_CONTINUATION(*p)) {
6344 *offsetp = cache[0];
6346 /* Drop the stale "length" cache */
6354 ASSERT_UTF8_CACHE(cache);
6360 /* Call utf8n_to_uvchr() to validate the sequence
6361 * (unless a simple non-UTF character) */
6362 if (!UTF8_IS_INVARIANT(*s))
6363 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
6372 if (!SvREADONLY(sv)) {
6374 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6375 mg = mg_find(sv, PERL_MAGIC_utf8);
6380 Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6381 mg->mg_ptr = (char *) cache;
6386 cache[1] = *offsetp;
6387 /* Drop the stale "length" cache */
6400 Returns a boolean indicating whether the strings in the two SVs are
6401 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6402 coerce its args to strings if necessary.
6408 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6416 SV* svrecode = Nullsv;
6423 pv1 = SvPV_const(sv1, cur1);
6430 pv2 = SvPV_const(sv2, cur2);
6432 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6433 /* Differing utf8ness.
6434 * Do not UTF8size the comparands as a side-effect. */
6437 svrecode = newSVpvn(pv2, cur2);
6438 sv_recode_to_utf8(svrecode, PL_encoding);
6439 pv2 = SvPV_const(svrecode, cur2);
6442 svrecode = newSVpvn(pv1, cur1);
6443 sv_recode_to_utf8(svrecode, PL_encoding);
6444 pv1 = SvPV_const(svrecode, cur1);
6446 /* Now both are in UTF-8. */
6448 SvREFCNT_dec(svrecode);
6453 bool is_utf8 = TRUE;
6456 /* sv1 is the UTF-8 one,
6457 * if is equal it must be downgrade-able */
6458 char *pv = (char*)bytes_from_utf8((const U8*)pv1,
6464 /* sv2 is the UTF-8 one,
6465 * if is equal it must be downgrade-able */
6466 char *pv = (char *)bytes_from_utf8((const U8*)pv2,
6472 /* Downgrade not possible - cannot be eq */
6480 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6483 SvREFCNT_dec(svrecode);
6494 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6495 string in C<sv1> is less than, equal to, or greater than the string in
6496 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6497 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6503 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6506 const char *pv1, *pv2;
6509 SV *svrecode = Nullsv;
6516 pv1 = SvPV_const(sv1, cur1);
6523 pv2 = SvPV_const(sv2, cur2);
6525 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6526 /* Differing utf8ness.
6527 * Do not UTF8size the comparands as a side-effect. */
6530 svrecode = newSVpvn(pv2, cur2);
6531 sv_recode_to_utf8(svrecode, PL_encoding);
6532 pv2 = SvPV_const(svrecode, cur2);
6535 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6540 svrecode = newSVpvn(pv1, cur1);
6541 sv_recode_to_utf8(svrecode, PL_encoding);
6542 pv1 = SvPV_const(svrecode, cur1);
6545 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6551 cmp = cur2 ? -1 : 0;
6555 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6558 cmp = retval < 0 ? -1 : 1;
6559 } else if (cur1 == cur2) {
6562 cmp = cur1 < cur2 ? -1 : 1;
6567 SvREFCNT_dec(svrecode);
6576 =for apidoc sv_cmp_locale
6578 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6579 'use bytes' aware, handles get magic, and will coerce its args to strings
6580 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6586 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6588 #ifdef USE_LOCALE_COLLATE
6594 if (PL_collation_standard)
6598 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6600 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6602 if (!pv1 || !len1) {
6613 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6616 return retval < 0 ? -1 : 1;
6619 * When the result of collation is equality, that doesn't mean
6620 * that there are no differences -- some locales exclude some
6621 * characters from consideration. So to avoid false equalities,
6622 * we use the raw string as a tiebreaker.
6628 #endif /* USE_LOCALE_COLLATE */
6630 return sv_cmp(sv1, sv2);
6634 #ifdef USE_LOCALE_COLLATE
6637 =for apidoc sv_collxfrm
6639 Add Collate Transform magic to an SV if it doesn't already have it.
6641 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6642 scalar data of the variable, but transformed to such a format that a normal
6643 memory comparison can be used to compare the data according to the locale
6650 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6654 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6655 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6661 Safefree(mg->mg_ptr);
6662 s = SvPV_const(sv, len);
6663 if ((xf = mem_collxfrm(s, len, &xlen))) {
6664 if (SvREADONLY(sv)) {
6667 return xf + sizeof(PL_collation_ix);
6670 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6671 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6684 if (mg && mg->mg_ptr) {
6686 return mg->mg_ptr + sizeof(PL_collation_ix);
6694 #endif /* USE_LOCALE_COLLATE */
6699 Get a line from the filehandle and store it into the SV, optionally
6700 appending to the currently-stored string.
6706 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6710 register STDCHAR rslast;
6711 register STDCHAR *bp;
6717 if (SvTHINKFIRST(sv))
6718 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6719 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6721 However, perlbench says it's slower, because the existing swipe code
6722 is faster than copy on write.
6723 Swings and roundabouts. */
6724 SvUPGRADE(sv, SVt_PV);
6729 if (PerlIO_isutf8(fp)) {
6731 sv_utf8_upgrade_nomg(sv);
6732 sv_pos_u2b(sv,&append,0);
6734 } else if (SvUTF8(sv)) {
6735 SV *tsv = NEWSV(0,0);
6736 sv_gets(tsv, fp, 0);
6737 sv_utf8_upgrade_nomg(tsv);
6738 SvCUR_set(sv,append);
6741 goto return_string_or_null;
6746 if (PerlIO_isutf8(fp))
6749 if (IN_PERL_COMPILETIME) {
6750 /* we always read code in line mode */
6754 else if (RsSNARF(PL_rs)) {
6755 /* If it is a regular disk file use size from stat() as estimate
6756 of amount we are going to read - may result in malloc-ing
6757 more memory than we realy need if layers bellow reduce
6758 size we read (e.g. CRLF or a gzip layer)
6761 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6762 const Off_t offset = PerlIO_tell(fp);
6763 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6764 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6770 else if (RsRECORD(PL_rs)) {
6774 /* Grab the size of the record we're getting */
6775 recsize = SvIV(SvRV(PL_rs));
6776 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6779 /* VMS wants read instead of fread, because fread doesn't respect */
6780 /* RMS record boundaries. This is not necessarily a good thing to be */
6781 /* doing, but we've got no other real choice - except avoid stdio
6782 as implementation - perhaps write a :vms layer ?
6784 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6786 bytesread = PerlIO_read(fp, buffer, recsize);
6790 SvCUR_set(sv, bytesread += append);
6791 buffer[bytesread] = '\0';
6792 goto return_string_or_null;
6794 else if (RsPARA(PL_rs)) {
6800 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6801 if (PerlIO_isutf8(fp)) {
6802 rsptr = SvPVutf8(PL_rs, rslen);
6805 if (SvUTF8(PL_rs)) {
6806 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6807 Perl_croak(aTHX_ "Wide character in $/");
6810 rsptr = SvPV_const(PL_rs, rslen);
6814 rslast = rslen ? rsptr[rslen - 1] : '\0';
6816 if (rspara) { /* have to do this both before and after */
6817 do { /* to make sure file boundaries work right */
6820 i = PerlIO_getc(fp);
6824 PerlIO_ungetc(fp,i);
6830 /* See if we know enough about I/O mechanism to cheat it ! */
6832 /* This used to be #ifdef test - it is made run-time test for ease
6833 of abstracting out stdio interface. One call should be cheap
6834 enough here - and may even be a macro allowing compile
6838 if (PerlIO_fast_gets(fp)) {
6841 * We're going to steal some values from the stdio struct
6842 * and put EVERYTHING in the innermost loop into registers.
6844 register STDCHAR *ptr;
6848 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6849 /* An ungetc()d char is handled separately from the regular
6850 * buffer, so we getc() it back out and stuff it in the buffer.
6852 i = PerlIO_getc(fp);
6853 if (i == EOF) return 0;
6854 *(--((*fp)->_ptr)) = (unsigned char) i;
6858 /* Here is some breathtakingly efficient cheating */
6860 cnt = PerlIO_get_cnt(fp); /* get count into register */
6861 /* make sure we have the room */
6862 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
6863 /* Not room for all of it
6864 if we are looking for a separator and room for some
6866 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
6867 /* just process what we have room for */
6868 shortbuffered = cnt - SvLEN(sv) + append + 1;
6869 cnt -= shortbuffered;
6873 /* remember that cnt can be negative */
6874 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
6879 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
6880 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
6881 DEBUG_P(PerlIO_printf(Perl_debug_log,
6882 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6883 DEBUG_P(PerlIO_printf(Perl_debug_log,
6884 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6885 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6886 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6891 while (cnt > 0) { /* this | eat */
6893 if ((*bp++ = *ptr++) == rslast) /* really | dust */
6894 goto thats_all_folks; /* screams | sed :-) */
6898 Copy(ptr, bp, cnt, char); /* this | eat */
6899 bp += cnt; /* screams | dust */
6900 ptr += cnt; /* louder | sed :-) */
6905 if (shortbuffered) { /* oh well, must extend */
6906 cnt = shortbuffered;
6908 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6910 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6911 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6915 DEBUG_P(PerlIO_printf(Perl_debug_log,
6916 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6917 PTR2UV(ptr),(long)cnt));
6918 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6920 DEBUG_P(PerlIO_printf(Perl_debug_log,
6921 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6922 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6923 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6925 /* This used to call 'filbuf' in stdio form, but as that behaves like
6926 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6927 another abstraction. */
6928 i = PerlIO_getc(fp); /* get more characters */
6930 DEBUG_P(PerlIO_printf(Perl_debug_log,
6931 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6932 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6933 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6935 cnt = PerlIO_get_cnt(fp);
6936 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
6937 DEBUG_P(PerlIO_printf(Perl_debug_log,
6938 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6940 if (i == EOF) /* all done for ever? */
6941 goto thats_really_all_folks;
6943 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6945 SvGROW(sv, bpx + cnt + 2);
6946 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6948 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
6950 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
6951 goto thats_all_folks;
6955 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
6956 memNE((char*)bp - rslen, rsptr, rslen))
6957 goto screamer; /* go back to the fray */
6958 thats_really_all_folks:
6960 cnt += shortbuffered;
6961 DEBUG_P(PerlIO_printf(Perl_debug_log,
6962 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6963 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
6964 DEBUG_P(PerlIO_printf(Perl_debug_log,
6965 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6966 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6967 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6969 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
6970 DEBUG_P(PerlIO_printf(Perl_debug_log,
6971 "Screamer: done, len=%ld, string=|%.*s|\n",
6972 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
6976 /*The big, slow, and stupid way. */
6977 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
6979 New(0, buf, 8192, STDCHAR);
6987 const register STDCHAR *bpe = buf + sizeof(buf);
6989 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6990 ; /* keep reading */
6994 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6995 /* Accomodate broken VAXC compiler, which applies U8 cast to
6996 * both args of ?: operator, causing EOF to change into 255
6999 i = (U8)buf[cnt - 1];
7005 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
7007 sv_catpvn(sv, (char *) buf, cnt);
7009 sv_setpvn(sv, (char *) buf, cnt);
7011 if (i != EOF && /* joy */
7013 SvCUR(sv) < rslen ||
7014 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7018 * If we're reading from a TTY and we get a short read,
7019 * indicating that the user hit his EOF character, we need
7020 * to notice it now, because if we try to read from the TTY
7021 * again, the EOF condition will disappear.
7023 * The comparison of cnt to sizeof(buf) is an optimization
7024 * that prevents unnecessary calls to feof().
7028 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
7032 #ifdef USE_HEAP_INSTEAD_OF_STACK
7037 if (rspara) { /* have to do this both before and after */
7038 while (i != EOF) { /* to make sure file boundaries work right */
7039 i = PerlIO_getc(fp);
7041 PerlIO_ungetc(fp,i);
7047 return_string_or_null:
7048 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
7054 Auto-increment of the value in the SV, doing string to numeric conversion
7055 if necessary. Handles 'get' magic.
7061 Perl_sv_inc(pTHX_ register SV *sv)
7070 if (SvTHINKFIRST(sv)) {
7072 sv_force_normal_flags(sv, 0);
7073 if (SvREADONLY(sv)) {
7074 if (IN_PERL_RUNTIME)
7075 Perl_croak(aTHX_ PL_no_modify);
7079 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7081 i = PTR2IV(SvRV(sv));
7086 flags = SvFLAGS(sv);
7087 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7088 /* It's (privately or publicly) a float, but not tested as an
7089 integer, so test it to see. */
7091 flags = SvFLAGS(sv);
7093 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7094 /* It's publicly an integer, or privately an integer-not-float */
7095 #ifdef PERL_PRESERVE_IVUV
7099 if (SvUVX(sv) == UV_MAX)
7100 sv_setnv(sv, UV_MAX_P1);
7102 (void)SvIOK_only_UV(sv);
7103 SvUV_set(sv, SvUVX(sv) + 1);
7105 if (SvIVX(sv) == IV_MAX)
7106 sv_setuv(sv, (UV)IV_MAX + 1);
7108 (void)SvIOK_only(sv);
7109 SvIV_set(sv, SvIVX(sv) + 1);
7114 if (flags & SVp_NOK) {
7115 (void)SvNOK_only(sv);
7116 SvNV_set(sv, SvNVX(sv) + 1.0);
7120 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
7121 if ((flags & SVTYPEMASK) < SVt_PVIV)
7122 sv_upgrade(sv, SVt_IV);
7123 (void)SvIOK_only(sv);
7128 while (isALPHA(*d)) d++;
7129 while (isDIGIT(*d)) d++;
7131 #ifdef PERL_PRESERVE_IVUV
7132 /* Got to punt this as an integer if needs be, but we don't issue
7133 warnings. Probably ought to make the sv_iv_please() that does
7134 the conversion if possible, and silently. */
7135 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7136 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7137 /* Need to try really hard to see if it's an integer.
7138 9.22337203685478e+18 is an integer.
7139 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7140 so $a="9.22337203685478e+18"; $a+0; $a++
7141 needs to be the same as $a="9.22337203685478e+18"; $a++
7148 /* sv_2iv *should* have made this an NV */
7149 if (flags & SVp_NOK) {
7150 (void)SvNOK_only(sv);
7151 SvNV_set(sv, SvNVX(sv) + 1.0);
7154 /* I don't think we can get here. Maybe I should assert this
7155 And if we do get here I suspect that sv_setnv will croak. NWC
7157 #if defined(USE_LONG_DOUBLE)
7158 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",
7159 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7161 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7162 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7165 #endif /* PERL_PRESERVE_IVUV */
7166 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
7170 while (d >= SvPVX_const(sv)) {
7178 /* MKS: The original code here died if letters weren't consecutive.
7179 * at least it didn't have to worry about non-C locales. The
7180 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7181 * arranged in order (although not consecutively) and that only
7182 * [A-Za-z] are accepted by isALPHA in the C locale.
7184 if (*d != 'z' && *d != 'Z') {
7185 do { ++*d; } while (!isALPHA(*d));
7188 *(d--) -= 'z' - 'a';
7193 *(d--) -= 'z' - 'a' + 1;
7197 /* oh,oh, the number grew */
7198 SvGROW(sv, SvCUR(sv) + 2);
7199 SvCUR_set(sv, SvCUR(sv) + 1);
7200 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7211 Auto-decrement of the value in the SV, doing string to numeric conversion
7212 if necessary. Handles 'get' magic.
7218 Perl_sv_dec(pTHX_ register SV *sv)
7226 if (SvTHINKFIRST(sv)) {
7228 sv_force_normal_flags(sv, 0);
7229 if (SvREADONLY(sv)) {
7230 if (IN_PERL_RUNTIME)
7231 Perl_croak(aTHX_ PL_no_modify);
7235 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7237 i = PTR2IV(SvRV(sv));
7242 /* Unlike sv_inc we don't have to worry about string-never-numbers
7243 and keeping them magic. But we mustn't warn on punting */
7244 flags = SvFLAGS(sv);
7245 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7246 /* It's publicly an integer, or privately an integer-not-float */
7247 #ifdef PERL_PRESERVE_IVUV
7251 if (SvUVX(sv) == 0) {
7252 (void)SvIOK_only(sv);
7256 (void)SvIOK_only_UV(sv);
7257 SvUV_set(sv, SvUVX(sv) + 1);
7260 if (SvIVX(sv) == IV_MIN)
7261 sv_setnv(sv, (NV)IV_MIN - 1.0);
7263 (void)SvIOK_only(sv);
7264 SvIV_set(sv, SvIVX(sv) - 1);
7269 if (flags & SVp_NOK) {
7270 SvNV_set(sv, SvNVX(sv) - 1.0);
7271 (void)SvNOK_only(sv);
7274 if (!(flags & SVp_POK)) {
7275 if ((flags & SVTYPEMASK) < SVt_PVNV)
7276 sv_upgrade(sv, SVt_NV);
7278 (void)SvNOK_only(sv);
7281 #ifdef PERL_PRESERVE_IVUV
7283 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7284 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7285 /* Need to try really hard to see if it's an integer.
7286 9.22337203685478e+18 is an integer.
7287 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7288 so $a="9.22337203685478e+18"; $a+0; $a--
7289 needs to be the same as $a="9.22337203685478e+18"; $a--
7296 /* sv_2iv *should* have made this an NV */
7297 if (flags & SVp_NOK) {
7298 (void)SvNOK_only(sv);
7299 SvNV_set(sv, SvNVX(sv) - 1.0);
7302 /* I don't think we can get here. Maybe I should assert this
7303 And if we do get here I suspect that sv_setnv will croak. NWC
7305 #if defined(USE_LONG_DOUBLE)
7306 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",
7307 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7309 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7310 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7314 #endif /* PERL_PRESERVE_IVUV */
7315 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
7319 =for apidoc sv_mortalcopy
7321 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7322 The new SV is marked as mortal. It will be destroyed "soon", either by an
7323 explicit call to FREETMPS, or by an implicit call at places such as
7324 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7329 /* Make a string that will exist for the duration of the expression
7330 * evaluation. Actually, it may have to last longer than that, but
7331 * hopefully we won't free it until it has been assigned to a
7332 * permanent location. */
7335 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
7340 sv_setsv(sv,oldstr);
7342 PL_tmps_stack[++PL_tmps_ix] = sv;
7348 =for apidoc sv_newmortal
7350 Creates a new null SV which is mortal. The reference count of the SV is
7351 set to 1. It will be destroyed "soon", either by an explicit call to
7352 FREETMPS, or by an implicit call at places such as statement boundaries.
7353 See also C<sv_mortalcopy> and C<sv_2mortal>.
7359 Perl_sv_newmortal(pTHX)
7364 SvFLAGS(sv) = SVs_TEMP;
7366 PL_tmps_stack[++PL_tmps_ix] = sv;
7371 =for apidoc sv_2mortal
7373 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7374 by an explicit call to FREETMPS, or by an implicit call at places such as
7375 statement boundaries. SvTEMP() is turned on which means that the SV's
7376 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7377 and C<sv_mortalcopy>.
7383 Perl_sv_2mortal(pTHX_ register SV *sv)
7388 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7391 PL_tmps_stack[++PL_tmps_ix] = sv;
7399 Creates a new SV and copies a string into it. The reference count for the
7400 SV is set to 1. If C<len> is zero, Perl will compute the length using
7401 strlen(). For efficiency, consider using C<newSVpvn> instead.
7407 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
7412 sv_setpvn(sv,s,len ? len : strlen(s));
7417 =for apidoc newSVpvn
7419 Creates a new SV and copies a string into it. The reference count for the
7420 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7421 string. You are responsible for ensuring that the source string is at least
7422 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7428 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7433 sv_setpvn(sv,s,len);
7439 =for apidoc newSVhek
7441 Creates a new SV from the hash key structure. It will generate scalars that
7442 point to the shared string table where possible. Returns a new (undefined)
7443 SV if the hek is NULL.
7449 Perl_newSVhek(pTHX_ const HEK *hek)
7458 if (HEK_LEN(hek) == HEf_SVKEY) {
7459 return newSVsv(*(SV**)HEK_KEY(hek));
7461 const int flags = HEK_FLAGS(hek);
7462 if (flags & HVhek_WASUTF8) {
7464 Andreas would like keys he put in as utf8 to come back as utf8
7466 STRLEN utf8_len = HEK_LEN(hek);
7467 U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7468 SV *sv = newSVpvn ((char*)as_utf8, utf8_len);
7471 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7473 } else if (flags & HVhek_REHASH) {
7474 /* We don't have a pointer to the hv, so we have to replicate the
7475 flag into every HEK. This hv is using custom a hasing
7476 algorithm. Hence we can't return a shared string scalar, as
7477 that would contain the (wrong) hash value, and might get passed
7478 into an hv routine with a regular hash */
7480 SV *sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7485 /* This will be overwhelminly the most common case. */
7486 return newSVpvn_share(HEK_KEY(hek),
7487 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
7493 =for apidoc newSVpvn_share
7495 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7496 table. If the string does not already exist in the table, it is created
7497 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
7498 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
7499 otherwise the hash is computed. The idea here is that as the string table
7500 is used for shared hash keys these strings will have SvPVX_const == HeKEY and
7501 hash lookup will avoid string compare.
7507 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7510 bool is_utf8 = FALSE;
7512 STRLEN tmplen = -len;
7514 /* See the note in hv.c:hv_fetch() --jhi */
7515 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7519 PERL_HASH(hash, src, len);
7521 sv_upgrade(sv, SVt_PV);
7522 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7534 #if defined(PERL_IMPLICIT_CONTEXT)
7536 /* pTHX_ magic can't cope with varargs, so this is a no-context
7537 * version of the main function, (which may itself be aliased to us).
7538 * Don't access this version directly.
7542 Perl_newSVpvf_nocontext(const char* pat, ...)
7547 va_start(args, pat);
7548 sv = vnewSVpvf(pat, &args);
7555 =for apidoc newSVpvf
7557 Creates a new SV and initializes it with the string formatted like
7564 Perl_newSVpvf(pTHX_ const char* pat, ...)
7568 va_start(args, pat);
7569 sv = vnewSVpvf(pat, &args);
7574 /* backend for newSVpvf() and newSVpvf_nocontext() */
7577 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7581 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7588 Creates a new SV and copies a floating point value into it.
7589 The reference count for the SV is set to 1.
7595 Perl_newSVnv(pTHX_ NV n)
7607 Creates a new SV and copies an integer into it. The reference count for the
7614 Perl_newSViv(pTHX_ IV i)
7626 Creates a new SV and copies an unsigned integer into it.
7627 The reference count for the SV is set to 1.
7633 Perl_newSVuv(pTHX_ UV u)
7643 =for apidoc newRV_noinc
7645 Creates an RV wrapper for an SV. The reference count for the original
7646 SV is B<not> incremented.
7652 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7657 sv_upgrade(sv, SVt_RV);
7659 SvRV_set(sv, tmpRef);
7664 /* newRV_inc is the official function name to use now.
7665 * newRV_inc is in fact #defined to newRV in sv.h
7669 Perl_newRV(pTHX_ SV *tmpRef)
7671 return newRV_noinc(SvREFCNT_inc(tmpRef));
7677 Creates a new SV which is an exact duplicate of the original SV.
7684 Perl_newSVsv(pTHX_ register SV *old)
7690 if (SvTYPE(old) == SVTYPEMASK) {
7691 if (ckWARN_d(WARN_INTERNAL))
7692 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7696 /* SV_GMAGIC is the default for sv_setv()
7697 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7698 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7699 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7704 =for apidoc sv_reset
7706 Underlying implementation for the C<reset> Perl function.
7707 Note that the perl-level function is vaguely deprecated.
7713 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
7716 char todo[PERL_UCHAR_MAX+1];
7721 if (!*s) { /* reset ?? searches */
7722 MAGIC *mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
7724 PMOP *pm = (PMOP *) mg->mg_obj;
7726 pm->op_pmdynflags &= ~PMdf_USED;
7733 /* reset variables */
7735 if (!HvARRAY(stash))
7738 Zero(todo, 256, char);
7741 I32 i = (unsigned char)*s;
7745 max = (unsigned char)*s++;
7746 for ( ; i <= max; i++) {
7749 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7751 for (entry = HvARRAY(stash)[i];
7753 entry = HeNEXT(entry))
7758 if (!todo[(U8)*HeKEY(entry)])
7760 gv = (GV*)HeVAL(entry);
7762 if (SvTHINKFIRST(sv)) {
7763 if (!SvREADONLY(sv) && SvROK(sv))
7768 if (SvTYPE(sv) >= SVt_PV) {
7770 if (SvPVX_const(sv) != Nullch)
7777 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
7780 #ifdef USE_ENVIRON_ARRAY
7782 # ifdef USE_ITHREADS
7783 && PL_curinterp == aTHX
7787 environ[0] = Nullch;
7790 #endif /* !PERL_MICRO */
7800 Using various gambits, try to get an IO from an SV: the IO slot if its a
7801 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7802 named after the PV if we're a string.
7808 Perl_sv_2io(pTHX_ SV *sv)
7813 switch (SvTYPE(sv)) {
7821 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7825 Perl_croak(aTHX_ PL_no_usym, "filehandle");
7827 return sv_2io(SvRV(sv));
7828 gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
7834 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
7843 Using various gambits, try to get a CV from an SV; in addition, try if
7844 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7850 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7857 return *gvp = Nullgv, Nullcv;
7858 switch (SvTYPE(sv)) {
7877 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
7878 tryAMAGICunDEREF(to_cv);
7881 if (SvTYPE(sv) == SVt_PVCV) {
7890 Perl_croak(aTHX_ "Not a subroutine reference");
7895 gv = gv_fetchsv(sv, lref, SVt_PVCV);
7901 if (lref && !GvCVu(gv)) {
7904 tmpsv = NEWSV(704,0);
7905 gv_efullname3(tmpsv, gv, Nullch);
7906 /* XXX this is probably not what they think they're getting.
7907 * It has the same effect as "sub name;", i.e. just a forward
7909 newSUB(start_subparse(FALSE, 0),
7910 newSVOP(OP_CONST, 0, tmpsv),
7915 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
7925 Returns true if the SV has a true value by Perl's rules.
7926 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
7927 instead use an in-line version.
7933 Perl_sv_true(pTHX_ register SV *sv)
7938 const register XPV* tXpv;
7939 if ((tXpv = (XPV*)SvANY(sv)) &&
7940 (tXpv->xpv_cur > 1 ||
7941 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
7948 return SvIVX(sv) != 0;
7951 return SvNVX(sv) != 0.0;
7953 return sv_2bool(sv);
7961 A private implementation of the C<SvIVx> macro for compilers which can't
7962 cope with complex macro expressions. Always use the macro instead.
7968 Perl_sv_iv(pTHX_ register SV *sv)
7972 return (IV)SvUVX(sv);
7981 A private implementation of the C<SvUVx> macro for compilers which can't
7982 cope with complex macro expressions. Always use the macro instead.
7988 Perl_sv_uv(pTHX_ register SV *sv)
7993 return (UV)SvIVX(sv);
8001 A private implementation of the C<SvNVx> macro for compilers which can't
8002 cope with complex macro expressions. Always use the macro instead.
8008 Perl_sv_nv(pTHX_ register SV *sv)
8015 /* sv_pv() is now a macro using SvPV_nolen();
8016 * this function provided for binary compatibility only
8020 Perl_sv_pv(pTHX_ SV *sv)
8025 return sv_2pv(sv, 0);
8031 Use the C<SvPV_nolen> macro instead
8035 A private implementation of the C<SvPV> macro for compilers which can't
8036 cope with complex macro expressions. Always use the macro instead.
8042 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
8048 return sv_2pv(sv, lp);
8053 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
8059 return sv_2pv_flags(sv, lp, 0);
8062 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
8063 * this function provided for binary compatibility only
8067 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
8069 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
8073 =for apidoc sv_pvn_force
8075 Get a sensible string out of the SV somehow.
8076 A private implementation of the C<SvPV_force> macro for compilers which
8077 can't cope with complex macro expressions. Always use the macro instead.
8079 =for apidoc sv_pvn_force_flags
8081 Get a sensible string out of the SV somehow.
8082 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8083 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8084 implemented in terms of this function.
8085 You normally want to use the various wrapper macros instead: see
8086 C<SvPV_force> and C<SvPV_force_nomg>
8092 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
8095 if (SvTHINKFIRST(sv) && !SvROK(sv))
8096 sv_force_normal_flags(sv, 0);
8106 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
8108 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
8109 sv_reftype(sv,0), OP_NAME(PL_op));
8111 Perl_croak(aTHX_ "Can't coerce readonly %s to string",
8114 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
8115 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8119 s = sv_2pv_flags(sv, &len, flags);
8123 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
8126 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
8127 SvGROW(sv, len + 1);
8128 Move(s,SvPVX_const(sv),len,char);
8133 SvPOK_on(sv); /* validate pointer */
8135 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8136 PTR2UV(sv),SvPVX_const(sv)));
8139 return SvPVX_mutable(sv);
8142 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
8143 * this function provided for binary compatibility only
8147 Perl_sv_pvbyte(pTHX_ SV *sv)
8149 sv_utf8_downgrade(sv,0);
8154 =for apidoc sv_pvbyte
8156 Use C<SvPVbyte_nolen> instead.
8158 =for apidoc sv_pvbyten
8160 A private implementation of the C<SvPVbyte> macro for compilers
8161 which can't cope with complex macro expressions. Always use the macro
8168 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
8170 sv_utf8_downgrade(sv,0);
8171 return sv_pvn(sv,lp);
8175 =for apidoc sv_pvbyten_force
8177 A private implementation of the C<SvPVbytex_force> macro for compilers
8178 which can't cope with complex macro expressions. Always use the macro
8185 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
8187 sv_pvn_force(sv,lp);
8188 sv_utf8_downgrade(sv,0);
8193 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
8194 * this function provided for binary compatibility only
8198 Perl_sv_pvutf8(pTHX_ SV *sv)
8200 sv_utf8_upgrade(sv);
8205 =for apidoc sv_pvutf8
8207 Use the C<SvPVutf8_nolen> macro instead
8209 =for apidoc sv_pvutf8n
8211 A private implementation of the C<SvPVutf8> macro for compilers
8212 which can't cope with complex macro expressions. Always use the macro
8219 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
8221 sv_utf8_upgrade(sv);
8222 return sv_pvn(sv,lp);
8226 =for apidoc sv_pvutf8n_force
8228 A private implementation of the C<SvPVutf8_force> macro for compilers
8229 which can't cope with complex macro expressions. Always use the macro
8236 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
8238 sv_pvn_force(sv,lp);
8239 sv_utf8_upgrade(sv);
8245 =for apidoc sv_reftype
8247 Returns a string describing what the SV is a reference to.
8253 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
8255 /* The fact that I don't need to downcast to char * everywhere, only in ?:
8256 inside return suggests a const propagation bug in g++. */
8257 if (ob && SvOBJECT(sv)) {
8258 char *name = HvNAME_get(SvSTASH(sv));
8259 return name ? name : (char *) "__ANON__";
8262 switch (SvTYPE(sv)) {
8279 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
8280 /* tied lvalues should appear to be
8281 * scalars for backwards compatitbility */
8282 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8283 ? "SCALAR" : "LVALUE");
8284 case SVt_PVAV: return "ARRAY";
8285 case SVt_PVHV: return "HASH";
8286 case SVt_PVCV: return "CODE";
8287 case SVt_PVGV: return "GLOB";
8288 case SVt_PVFM: return "FORMAT";
8289 case SVt_PVIO: return "IO";
8290 default: return "UNKNOWN";
8296 =for apidoc sv_isobject
8298 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8299 object. If the SV is not an RV, or if the object is not blessed, then this
8306 Perl_sv_isobject(pTHX_ SV *sv)
8323 Returns a boolean indicating whether the SV is blessed into the specified
8324 class. This does not check for subtypes; use C<sv_derived_from> to verify
8325 an inheritance relationship.
8331 Perl_sv_isa(pTHX_ SV *sv, const char *name)
8343 hvname = HvNAME_get(SvSTASH(sv));
8347 return strEQ(hvname, name);
8353 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
8354 it will be upgraded to one. If C<classname> is non-null then the new SV will
8355 be blessed in the specified package. The new SV is returned and its
8356 reference count is 1.
8362 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
8368 SV_CHECK_THINKFIRST_COW_DROP(rv);
8371 if (SvTYPE(rv) >= SVt_PVMG) {
8372 const U32 refcnt = SvREFCNT(rv);
8376 SvREFCNT(rv) = refcnt;
8379 if (SvTYPE(rv) < SVt_RV)
8380 sv_upgrade(rv, SVt_RV);
8381 else if (SvTYPE(rv) > SVt_RV) {
8392 HV* stash = gv_stashpv(classname, TRUE);
8393 (void)sv_bless(rv, stash);
8399 =for apidoc sv_setref_pv
8401 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
8402 argument will be upgraded to an RV. That RV will be modified to point to
8403 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8404 into the SV. The C<classname> argument indicates the package for the
8405 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8406 will have a reference count of 1, and the RV will be returned.
8408 Do not use with other Perl types such as HV, AV, SV, CV, because those
8409 objects will become corrupted by the pointer copy process.
8411 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8417 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
8420 sv_setsv(rv, &PL_sv_undef);
8424 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8429 =for apidoc sv_setref_iv
8431 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
8432 argument will be upgraded to an RV. That RV will be modified to point to
8433 the new SV. The C<classname> argument indicates the package for the
8434 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8435 will have a reference count of 1, and the RV will be returned.
8441 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
8443 sv_setiv(newSVrv(rv,classname), iv);
8448 =for apidoc sv_setref_uv
8450 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
8451 argument will be upgraded to an RV. That RV will be modified to point to
8452 the new SV. The C<classname> argument indicates the package for the
8453 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8454 will have a reference count of 1, and the RV will be returned.
8460 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
8462 sv_setuv(newSVrv(rv,classname), uv);
8467 =for apidoc sv_setref_nv
8469 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8470 argument will be upgraded to an RV. That RV will be modified to point to
8471 the new SV. The C<classname> argument indicates the package for the
8472 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8473 will have a reference count of 1, and the RV will be returned.
8479 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
8481 sv_setnv(newSVrv(rv,classname), nv);
8486 =for apidoc sv_setref_pvn
8488 Copies a string into a new SV, optionally blessing the SV. The length of the
8489 string must be specified with C<n>. The C<rv> argument will be upgraded to
8490 an RV. That RV will be modified to point to the new SV. The C<classname>
8491 argument indicates the package for the blessing. Set C<classname> to
8492 C<Nullch> to avoid the blessing. The new SV will have a reference count
8493 of 1, and the RV will be returned.
8495 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8501 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
8503 sv_setpvn(newSVrv(rv,classname), pv, n);
8508 =for apidoc sv_bless
8510 Blesses an SV into a specified package. The SV must be an RV. The package
8511 must be designated by its stash (see C<gv_stashpv()>). The reference count
8512 of the SV is unaffected.
8518 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8522 Perl_croak(aTHX_ "Can't bless non-reference value");
8524 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8525 if (SvREADONLY(tmpRef))
8526 Perl_croak(aTHX_ PL_no_modify);
8527 if (SvOBJECT(tmpRef)) {
8528 if (SvTYPE(tmpRef) != SVt_PVIO)
8530 SvREFCNT_dec(SvSTASH(tmpRef));
8533 SvOBJECT_on(tmpRef);
8534 if (SvTYPE(tmpRef) != SVt_PVIO)
8536 SvUPGRADE(tmpRef, SVt_PVMG);
8537 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
8544 if(SvSMAGICAL(tmpRef))
8545 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8553 /* Downgrades a PVGV to a PVMG.
8557 S_sv_unglob(pTHX_ SV *sv)
8561 assert(SvTYPE(sv) == SVt_PVGV);
8566 SvREFCNT_dec(GvSTASH(sv));
8567 GvSTASH(sv) = Nullhv;
8569 sv_unmagic(sv, PERL_MAGIC_glob);
8570 Safefree(GvNAME(sv));
8573 /* need to keep SvANY(sv) in the right arena */
8574 xpvmg = new_XPVMG();
8575 StructCopy(SvANY(sv), xpvmg, XPVMG);
8576 del_XPVGV(SvANY(sv));
8579 SvFLAGS(sv) &= ~SVTYPEMASK;
8580 SvFLAGS(sv) |= SVt_PVMG;
8584 =for apidoc sv_unref_flags
8586 Unsets the RV status of the SV, and decrements the reference count of
8587 whatever was being referenced by the RV. This can almost be thought of
8588 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8589 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8590 (otherwise the decrementing is conditional on the reference count being
8591 different from one or the reference being a readonly SV).
8598 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
8602 if (SvWEAKREF(sv)) {
8610 /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
8611 assigned to as BEGIN {$a = \"Foo"} will fail. */
8612 if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
8614 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8615 sv_2mortal(rv); /* Schedule for freeing later */
8619 =for apidoc sv_unref
8621 Unsets the RV status of the SV, and decrements the reference count of
8622 whatever was being referenced by the RV. This can almost be thought of
8623 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
8624 being zero. See C<SvROK_off>.
8630 Perl_sv_unref(pTHX_ SV *sv)
8632 sv_unref_flags(sv, 0);
8636 =for apidoc sv_taint
8638 Taint an SV. Use C<SvTAINTED_on> instead.
8643 Perl_sv_taint(pTHX_ SV *sv)
8645 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
8649 =for apidoc sv_untaint
8651 Untaint an SV. Use C<SvTAINTED_off> instead.
8656 Perl_sv_untaint(pTHX_ SV *sv)
8658 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8659 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8666 =for apidoc sv_tainted
8668 Test an SV for taintedness. Use C<SvTAINTED> instead.
8673 Perl_sv_tainted(pTHX_ SV *sv)
8675 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8676 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8677 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
8684 =for apidoc sv_setpviv
8686 Copies an integer into the given SV, also updating its string value.
8687 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8693 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8695 char buf[TYPE_CHARS(UV)];
8697 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8699 sv_setpvn(sv, ptr, ebuf - ptr);
8703 =for apidoc sv_setpviv_mg
8705 Like C<sv_setpviv>, but also handles 'set' magic.
8711 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8713 char buf[TYPE_CHARS(UV)];
8715 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8717 sv_setpvn(sv, ptr, ebuf - ptr);
8721 #if defined(PERL_IMPLICIT_CONTEXT)
8723 /* pTHX_ magic can't cope with varargs, so this is a no-context
8724 * version of the main function, (which may itself be aliased to us).
8725 * Don't access this version directly.
8729 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8733 va_start(args, pat);
8734 sv_vsetpvf(sv, pat, &args);
8738 /* pTHX_ magic can't cope with varargs, so this is a no-context
8739 * version of the main function, (which may itself be aliased to us).
8740 * Don't access this version directly.
8744 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8748 va_start(args, pat);
8749 sv_vsetpvf_mg(sv, pat, &args);
8755 =for apidoc sv_setpvf
8757 Works like C<sv_catpvf> but copies the text into the SV instead of
8758 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8764 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8767 va_start(args, pat);
8768 sv_vsetpvf(sv, pat, &args);
8773 =for apidoc sv_vsetpvf
8775 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8776 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8778 Usually used via its frontend C<sv_setpvf>.
8784 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8786 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8790 =for apidoc sv_setpvf_mg
8792 Like C<sv_setpvf>, but also handles 'set' magic.
8798 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8801 va_start(args, pat);
8802 sv_vsetpvf_mg(sv, pat, &args);
8807 =for apidoc sv_vsetpvf_mg
8809 Like C<sv_vsetpvf>, but also handles 'set' magic.
8811 Usually used via its frontend C<sv_setpvf_mg>.
8817 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8819 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8823 #if defined(PERL_IMPLICIT_CONTEXT)
8825 /* pTHX_ magic can't cope with varargs, so this is a no-context
8826 * version of the main function, (which may itself be aliased to us).
8827 * Don't access this version directly.
8831 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8835 va_start(args, pat);
8836 sv_vcatpvf(sv, pat, &args);
8840 /* pTHX_ magic can't cope with varargs, so this is a no-context
8841 * version of the main function, (which may itself be aliased to us).
8842 * Don't access this version directly.
8846 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8850 va_start(args, pat);
8851 sv_vcatpvf_mg(sv, pat, &args);
8857 =for apidoc sv_catpvf
8859 Processes its arguments like C<sprintf> and appends the formatted
8860 output to an SV. If the appended data contains "wide" characters
8861 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8862 and characters >255 formatted with %c), the original SV might get
8863 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
8864 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
8865 valid UTF-8; if the original SV was bytes, the pattern should be too.
8870 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8873 va_start(args, pat);
8874 sv_vcatpvf(sv, pat, &args);
8879 =for apidoc sv_vcatpvf
8881 Processes its arguments like C<vsprintf> and appends the formatted output
8882 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
8884 Usually used via its frontend C<sv_catpvf>.
8890 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8892 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8896 =for apidoc sv_catpvf_mg
8898 Like C<sv_catpvf>, but also handles 'set' magic.
8904 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8907 va_start(args, pat);
8908 sv_vcatpvf_mg(sv, pat, &args);
8913 =for apidoc sv_vcatpvf_mg
8915 Like C<sv_vcatpvf>, but also handles 'set' magic.
8917 Usually used via its frontend C<sv_catpvf_mg>.
8923 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8925 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8930 =for apidoc sv_vsetpvfn
8932 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
8935 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
8941 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8943 sv_setpvn(sv, "", 0);
8944 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8947 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
8950 S_expect_number(pTHX_ char** pattern)
8953 switch (**pattern) {
8954 case '1': case '2': case '3':
8955 case '4': case '5': case '6':
8956 case '7': case '8': case '9':
8957 while (isDIGIT(**pattern))
8958 var = var * 10 + (*(*pattern)++ - '0');
8962 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
8965 F0convert(NV nv, char *endbuf, STRLEN *len)
8967 const int neg = nv < 0;
8976 if (uv & 1 && uv == nv)
8977 uv--; /* Round to even */
8979 const unsigned dig = uv % 10;
8992 =for apidoc sv_vcatpvfn
8994 Processes its arguments like C<vsprintf> and appends the formatted output
8995 to an SV. Uses an array of SVs if the C style variable argument list is
8996 missing (NULL). When running with taint checks enabled, indicates via
8997 C<maybe_tainted> if results are untrustworthy (often due to the use of
9000 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9005 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9008 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
9015 static const char nullstr[] = "(null)";
9017 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
9018 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
9020 /* Times 4: a decimal digit takes more than 3 binary digits.
9021 * NV_DIG: mantissa takes than many decimal digits.
9022 * Plus 32: Playing safe. */
9023 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9024 /* large enough for "%#.#f" --chip */
9025 /* what about long double NVs? --jhi */
9027 /* no matter what, this is a string now */
9028 (void)SvPV_force(sv, origlen);
9030 /* special-case "", "%s", and "%-p" (SVf) */
9033 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9035 const char *s = va_arg(*args, char*);
9036 sv_catpv(sv, s ? s : nullstr);
9038 else if (svix < svmax) {
9039 sv_catsv(sv, *svargs);
9040 if (DO_UTF8(*svargs))
9045 if (patlen == 3 && pat[0] == '%' &&
9046 pat[1] == '-' && pat[2] == 'p') {
9048 argsv = va_arg(*args, SV*);
9049 sv_catsv(sv, argsv);
9056 #ifndef USE_LONG_DOUBLE
9057 /* special-case "%.<number>[gf]" */
9058 if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9059 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9060 unsigned digits = 0;
9064 while (*pp >= '0' && *pp <= '9')
9065 digits = 10 * digits + (*pp++ - '0');
9066 if (pp - pat == (int)patlen - 1) {
9070 nv = (NV)va_arg(*args, double);
9071 else if (svix < svmax)
9076 /* Add check for digits != 0 because it seems that some
9077 gconverts are buggy in this case, and we don't yet have
9078 a Configure test for this. */
9079 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9080 /* 0, point, slack */
9081 Gconvert(nv, (int)digits, 0, ebuf);
9083 if (*ebuf) /* May return an empty string for digits==0 */
9086 } else if (!digits) {
9089 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9090 sv_catpvn(sv, p, l);
9096 #endif /* !USE_LONG_DOUBLE */
9098 if (!args && svix < svmax && DO_UTF8(*svargs))
9101 patend = (char*)pat + patlen;
9102 for (p = (char*)pat; p < patend; p = q) {
9105 bool vectorize = FALSE;
9106 bool vectorarg = FALSE;
9107 bool vec_utf8 = FALSE;
9113 bool has_precis = FALSE;
9116 bool is_utf8 = FALSE; /* is this item utf8? */
9117 #ifdef HAS_LDBL_SPRINTF_BUG
9118 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9119 with sfio - Allen <allens@cpan.org> */
9120 bool fix_ldbl_sprintf_bug = FALSE;
9124 U8 utf8buf[UTF8_MAXBYTES+1];
9125 STRLEN esignlen = 0;
9127 const char *eptr = Nullch;
9130 const U8 *vecstr = Null(U8*);
9137 /* we need a long double target in case HAS_LONG_DOUBLE but
9140 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9148 const char *dotstr = ".";
9149 STRLEN dotstrlen = 1;
9150 I32 efix = 0; /* explicit format parameter index */
9151 I32 ewix = 0; /* explicit width index */
9152 I32 epix = 0; /* explicit precision index */
9153 I32 evix = 0; /* explicit vector index */
9154 bool asterisk = FALSE;
9156 /* echo everything up to the next format specification */
9157 for (q = p; q < patend && *q != '%'; ++q) ;
9159 if (has_utf8 && !pat_utf8)
9160 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9162 sv_catpvn(sv, p, q - p);
9169 We allow format specification elements in this order:
9170 \d+\$ explicit format parameter index
9172 v|\*(\d+\$)?v vector with optional (optionally specified) arg
9173 0 flag (as above): repeated to allow "v02"
9174 \d+|\*(\d+\$)? width using optional (optionally specified) arg
9175 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9177 [%bcdefginopsux_DFOUX] format (mandatory)
9179 if (EXPECT_NUMBER(q, width)) {
9220 if (EXPECT_NUMBER(q, ewix))
9229 if ((vectorarg = asterisk)) {
9241 EXPECT_NUMBER(q, width);
9246 vecsv = va_arg(*args, SV*);
9248 vecsv = (evix ? evix <= svmax : svix < svmax) ?
9249 svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
9250 dotstr = SvPV_const(vecsv, dotstrlen);
9255 vecsv = va_arg(*args, SV*);
9256 vecstr = (U8*)SvPV_const(vecsv,veclen);
9257 vec_utf8 = DO_UTF8(vecsv);
9259 else if (efix ? efix <= svmax : svix < svmax) {
9260 vecsv = svargs[efix ? efix-1 : svix++];
9261 vecstr = (U8*)SvPV_const(vecsv,veclen);
9262 vec_utf8 = DO_UTF8(vecsv);
9263 /* if this is a version object, we need to return the
9264 * stringified representation (which the SvPVX_const has
9265 * already done for us), but not vectorize the args
9267 if ( *q == 'd' && sv_derived_from(vecsv,"version") )
9269 q++; /* skip past the rest of the %vd format */
9270 eptr = (const char *) vecstr;
9271 elen = strlen(eptr);
9284 i = va_arg(*args, int);
9286 i = (ewix ? ewix <= svmax : svix < svmax) ?
9287 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9289 width = (i < 0) ? -i : i;
9299 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
9301 /* XXX: todo, support specified precision parameter */
9305 i = va_arg(*args, int);
9307 i = (ewix ? ewix <= svmax : svix < svmax)
9308 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9309 precis = (i < 0) ? 0 : i;
9314 precis = precis * 10 + (*q++ - '0');
9323 case 'I': /* Ix, I32x, and I64x */
9325 if (q[1] == '6' && q[2] == '4') {
9331 if (q[1] == '3' && q[2] == '2') {
9341 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9352 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9353 if (*(q + 1) == 'l') { /* lld, llf */
9378 argsv = (efix ? efix <= svmax : svix < svmax) ?
9379 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
9386 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
9388 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9390 eptr = (char*)utf8buf;
9391 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9402 if (args && !vectorize) {
9403 eptr = va_arg(*args, char*);
9405 #ifdef MACOS_TRADITIONAL
9406 /* On MacOS, %#s format is used for Pascal strings */
9411 elen = strlen(eptr);
9413 eptr = (char *)nullstr;
9414 elen = sizeof nullstr - 1;
9418 eptr = SvPVx_const(argsv, elen);
9419 if (DO_UTF8(argsv)) {
9420 if (has_precis && precis < elen) {
9422 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9425 if (width) { /* fudge width (can't fudge elen) */
9426 width += elen - sv_len_utf8(argsv);
9434 if (has_precis && elen > precis)
9441 if (left && args) { /* SVf */
9450 argsv = va_arg(*args, SV*);
9451 eptr = SvPVx_const(argsv, elen);
9456 if (alt || vectorize)
9458 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9476 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9485 esignbuf[esignlen++] = plus;
9489 case 'h': iv = (short)va_arg(*args, int); break;
9490 case 'l': iv = va_arg(*args, long); break;
9491 case 'V': iv = va_arg(*args, IV); break;
9492 default: iv = va_arg(*args, int); break;
9494 case 'q': iv = va_arg(*args, Quad_t); break;
9499 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
9501 case 'h': iv = (short)tiv; break;
9502 case 'l': iv = (long)tiv; break;
9504 default: iv = tiv; break;
9506 case 'q': iv = (Quad_t)tiv; break;
9510 if ( !vectorize ) /* we already set uv above */
9515 esignbuf[esignlen++] = plus;
9519 esignbuf[esignlen++] = '-';
9562 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9573 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9574 case 'l': uv = va_arg(*args, unsigned long); break;
9575 case 'V': uv = va_arg(*args, UV); break;
9576 default: uv = va_arg(*args, unsigned); break;
9578 case 'q': uv = va_arg(*args, Uquad_t); break;
9583 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9585 case 'h': uv = (unsigned short)tuv; break;
9586 case 'l': uv = (unsigned long)tuv; break;
9588 default: uv = tuv; break;
9590 case 'q': uv = (Uquad_t)tuv; break;
9597 char *ptr = ebuf + sizeof ebuf;
9603 p = (char*)((c == 'X')
9604 ? "0123456789ABCDEF" : "0123456789abcdef");
9610 esignbuf[esignlen++] = '0';
9611 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9619 if (alt && *ptr != '0')
9628 esignbuf[esignlen++] = '0';
9629 esignbuf[esignlen++] = 'b';
9632 default: /* it had better be ten or less */
9636 } while (uv /= base);
9639 elen = (ebuf + sizeof ebuf) - ptr;
9643 zeros = precis - elen;
9644 else if (precis == 0 && elen == 1 && *eptr == '0')
9650 /* FLOATING POINT */
9653 c = 'f'; /* maybe %F isn't supported here */
9659 /* This is evil, but floating point is even more evil */
9661 /* for SV-style calling, we can only get NV
9662 for C-style calling, we assume %f is double;
9663 for simplicity we allow any of %Lf, %llf, %qf for long double
9667 #if defined(USE_LONG_DOUBLE)
9671 /* [perl #20339] - we should accept and ignore %lf rather than die */
9675 #if defined(USE_LONG_DOUBLE)
9676 intsize = args ? 0 : 'q';
9680 #if defined(HAS_LONG_DOUBLE)
9689 /* now we need (long double) if intsize == 'q', else (double) */
9690 nv = (args && !vectorize) ?
9691 #if LONG_DOUBLESIZE > DOUBLESIZE
9693 va_arg(*args, long double) :
9694 va_arg(*args, double)
9696 va_arg(*args, double)
9702 if (c != 'e' && c != 'E') {
9704 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9705 will cast our (long double) to (double) */
9706 (void)Perl_frexp(nv, &i);
9707 if (i == PERL_INT_MIN)
9708 Perl_die(aTHX_ "panic: frexp");
9710 need = BIT_DIGITS(i);
9712 need += has_precis ? precis : 6; /* known default */
9717 #ifdef HAS_LDBL_SPRINTF_BUG
9718 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9719 with sfio - Allen <allens@cpan.org> */
9722 # define MY_DBL_MAX DBL_MAX
9723 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9724 # if DOUBLESIZE >= 8
9725 # define MY_DBL_MAX 1.7976931348623157E+308L
9727 # define MY_DBL_MAX 3.40282347E+38L
9731 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9732 # define MY_DBL_MAX_BUG 1L
9734 # define MY_DBL_MAX_BUG MY_DBL_MAX
9738 # define MY_DBL_MIN DBL_MIN
9739 # else /* XXX guessing! -Allen */
9740 # if DOUBLESIZE >= 8
9741 # define MY_DBL_MIN 2.2250738585072014E-308L
9743 # define MY_DBL_MIN 1.17549435E-38L
9747 if ((intsize == 'q') && (c == 'f') &&
9748 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9750 /* it's going to be short enough that
9751 * long double precision is not needed */
9753 if ((nv <= 0L) && (nv >= -0L))
9754 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9756 /* would use Perl_fp_class as a double-check but not
9757 * functional on IRIX - see perl.h comments */
9759 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9760 /* It's within the range that a double can represent */
9761 #if defined(DBL_MAX) && !defined(DBL_MIN)
9762 if ((nv >= ((long double)1/DBL_MAX)) ||
9763 (nv <= (-(long double)1/DBL_MAX)))
9765 fix_ldbl_sprintf_bug = TRUE;
9768 if (fix_ldbl_sprintf_bug == TRUE) {
9778 # undef MY_DBL_MAX_BUG
9781 #endif /* HAS_LDBL_SPRINTF_BUG */
9783 need += 20; /* fudge factor */
9784 if (PL_efloatsize < need) {
9785 Safefree(PL_efloatbuf);
9786 PL_efloatsize = need + 20; /* more fudge */
9787 New(906, PL_efloatbuf, PL_efloatsize, char);
9788 PL_efloatbuf[0] = '\0';
9791 if ( !(width || left || plus || alt) && fill != '0'
9792 && has_precis && intsize != 'q' ) { /* Shortcuts */
9793 /* See earlier comment about buggy Gconvert when digits,
9795 if ( c == 'g' && precis) {
9796 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9797 if (*PL_efloatbuf) /* May return an empty string for digits==0 */
9798 goto float_converted;
9799 } else if ( c == 'f' && !precis) {
9800 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9805 char *ptr = ebuf + sizeof ebuf;
9808 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9809 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9810 if (intsize == 'q') {
9811 /* Copy the one or more characters in a long double
9812 * format before the 'base' ([efgEFG]) character to
9813 * the format string. */
9814 static char const prifldbl[] = PERL_PRIfldbl;
9815 char const *p = prifldbl + sizeof(prifldbl) - 3;
9816 while (p >= prifldbl) { *--ptr = *p--; }
9821 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9826 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9838 /* No taint. Otherwise we are in the strange situation
9839 * where printf() taints but print($float) doesn't.
9841 #if defined(HAS_LONG_DOUBLE)
9843 (void)sprintf(PL_efloatbuf, ptr, nv);
9845 (void)sprintf(PL_efloatbuf, ptr, (double)nv);
9847 (void)sprintf(PL_efloatbuf, ptr, nv);
9851 eptr = PL_efloatbuf;
9852 elen = strlen(PL_efloatbuf);
9858 i = SvCUR(sv) - origlen;
9859 if (args && !vectorize) {
9861 case 'h': *(va_arg(*args, short*)) = i; break;
9862 default: *(va_arg(*args, int*)) = i; break;
9863 case 'l': *(va_arg(*args, long*)) = i; break;
9864 case 'V': *(va_arg(*args, IV*)) = i; break;
9866 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
9871 sv_setuv_mg(argsv, (UV)i);
9873 continue; /* not "break" */
9879 if (!args && ckWARN(WARN_PRINTF) &&
9880 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
9881 SV *msg = sv_newmortal();
9882 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9883 (PL_op->op_type == OP_PRTF) ? "" : "s");
9886 Perl_sv_catpvf(aTHX_ msg,
9887 "\"%%%c\"", c & 0xFF);
9889 Perl_sv_catpvf(aTHX_ msg,
9890 "\"%%\\%03"UVof"\"",
9893 sv_catpv(msg, "end of string");
9894 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
9897 /* output mangled stuff ... */
9903 /* ... right here, because formatting flags should not apply */
9904 SvGROW(sv, SvCUR(sv) + elen + 1);
9906 Copy(eptr, p, elen, char);
9909 SvCUR_set(sv, p - SvPVX_const(sv));
9911 continue; /* not "break" */
9914 /* calculate width before utf8_upgrade changes it */
9915 have = esignlen + zeros + elen;
9917 if (is_utf8 != has_utf8) {
9920 sv_utf8_upgrade(sv);
9923 SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
9924 sv_utf8_upgrade(nsv);
9925 eptr = SvPVX_const(nsv);
9928 SvGROW(sv, SvCUR(sv) + elen + 1);
9933 need = (have > width ? have : width);
9936 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
9938 if (esignlen && fill == '0') {
9939 for (i = 0; i < (int)esignlen; i++)
9943 memset(p, fill, gap);
9946 if (esignlen && fill != '0') {
9947 for (i = 0; i < (int)esignlen; i++)
9951 for (i = zeros; i; i--)
9955 Copy(eptr, p, elen, char);
9959 memset(p, ' ', gap);
9964 Copy(dotstr, p, dotstrlen, char);
9968 vectorize = FALSE; /* done iterating over vecstr */
9975 SvCUR_set(sv, p - SvPVX_const(sv));
9983 /* =========================================================================
9985 =head1 Cloning an interpreter
9987 All the macros and functions in this section are for the private use of
9988 the main function, perl_clone().
9990 The foo_dup() functions make an exact copy of an existing foo thinngy.
9991 During the course of a cloning, a hash table is used to map old addresses
9992 to new addresses. The table is created and manipulated with the
9993 ptr_table_* functions.
9997 ============================================================================*/
10000 #if defined(USE_ITHREADS)
10002 #ifndef GpREFCNT_inc
10003 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10007 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10008 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
10009 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10010 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
10011 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10012 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
10013 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10014 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
10015 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
10016 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
10017 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10018 #define SAVEPV(p) (p ? savepv(p) : Nullch)
10019 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
10022 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
10023 regcomp.c. AMS 20010712 */
10026 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
10031 struct reg_substr_datum *s;
10034 return (REGEXP *)NULL;
10036 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
10039 len = r->offsets[0];
10040 npar = r->nparens+1;
10042 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
10043 Copy(r->program, ret->program, len+1, regnode);
10045 New(0, ret->startp, npar, I32);
10046 Copy(r->startp, ret->startp, npar, I32);
10047 New(0, ret->endp, npar, I32);
10048 Copy(r->startp, ret->startp, npar, I32);
10050 New(0, ret->substrs, 1, struct reg_substr_data);
10051 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
10052 s->min_offset = r->substrs->data[i].min_offset;
10053 s->max_offset = r->substrs->data[i].max_offset;
10054 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
10055 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
10058 ret->regstclass = NULL;
10060 struct reg_data *d;
10061 const int count = r->data->count;
10063 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
10064 char, struct reg_data);
10065 New(0, d->what, count, U8);
10068 for (i = 0; i < count; i++) {
10069 d->what[i] = r->data->what[i];
10070 switch (d->what[i]) {
10071 /* legal options are one of: sfpont
10072 see also regcomp.h and pregfree() */
10074 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
10077 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
10080 /* This is cheating. */
10081 New(0, d->data[i], 1, struct regnode_charclass_class);
10082 StructCopy(r->data->data[i], d->data[i],
10083 struct regnode_charclass_class);
10084 ret->regstclass = (regnode*)d->data[i];
10087 /* Compiled op trees are readonly, and can thus be
10088 shared without duplication. */
10090 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
10094 d->data[i] = r->data->data[i];
10097 d->data[i] = r->data->data[i];
10099 ((reg_trie_data*)d->data[i])->refcount++;
10103 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
10112 New(0, ret->offsets, 2*len+1, U32);
10113 Copy(r->offsets, ret->offsets, 2*len+1, U32);
10115 ret->precomp = SAVEPVN(r->precomp, r->prelen);
10116 ret->refcnt = r->refcnt;
10117 ret->minlen = r->minlen;
10118 ret->prelen = r->prelen;
10119 ret->nparens = r->nparens;
10120 ret->lastparen = r->lastparen;
10121 ret->lastcloseparen = r->lastcloseparen;
10122 ret->reganch = r->reganch;
10124 ret->sublen = r->sublen;
10126 if (RX_MATCH_COPIED(ret))
10127 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
10129 ret->subbeg = Nullch;
10130 #ifdef PERL_OLD_COPY_ON_WRITE
10131 ret->saved_copy = Nullsv;
10134 ptr_table_store(PL_ptr_table, r, ret);
10138 /* duplicate a file handle */
10141 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
10147 return (PerlIO*)NULL;
10149 /* look for it in the table first */
10150 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10154 /* create anew and remember what it is */
10155 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10156 ptr_table_store(PL_ptr_table, fp, ret);
10160 /* duplicate a directory handle */
10163 Perl_dirp_dup(pTHX_ DIR *dp)
10171 /* duplicate a typeglob */
10174 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
10179 /* look for it in the table first */
10180 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10184 /* create anew and remember what it is */
10185 Newz(0, ret, 1, GP);
10186 ptr_table_store(PL_ptr_table, gp, ret);
10189 ret->gp_refcnt = 0; /* must be before any other dups! */
10190 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
10191 ret->gp_io = io_dup_inc(gp->gp_io, param);
10192 ret->gp_form = cv_dup_inc(gp->gp_form, param);
10193 ret->gp_av = av_dup_inc(gp->gp_av, param);
10194 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
10195 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10196 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
10197 ret->gp_cvgen = gp->gp_cvgen;
10198 ret->gp_flags = gp->gp_flags;
10199 ret->gp_line = gp->gp_line;
10200 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
10204 /* duplicate a chain of magic */
10207 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
10209 MAGIC *mgprev = (MAGIC*)NULL;
10212 return (MAGIC*)NULL;
10213 /* look for it in the table first */
10214 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
10218 for (; mg; mg = mg->mg_moremagic) {
10220 Newz(0, nmg, 1, MAGIC);
10222 mgprev->mg_moremagic = nmg;
10225 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
10226 nmg->mg_private = mg->mg_private;
10227 nmg->mg_type = mg->mg_type;
10228 nmg->mg_flags = mg->mg_flags;
10229 if (mg->mg_type == PERL_MAGIC_qr) {
10230 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
10232 else if(mg->mg_type == PERL_MAGIC_backref) {
10233 const AV * const av = (AV*) mg->mg_obj;
10236 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
10238 for (i = AvFILLp(av); i >= 0; i--) {
10239 if (!svp[i]) continue;
10240 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
10243 else if (mg->mg_type == PERL_MAGIC_symtab) {
10244 nmg->mg_obj = mg->mg_obj;
10247 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
10248 ? sv_dup_inc(mg->mg_obj, param)
10249 : sv_dup(mg->mg_obj, param);
10251 nmg->mg_len = mg->mg_len;
10252 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
10253 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
10254 if (mg->mg_len > 0) {
10255 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
10256 if (mg->mg_type == PERL_MAGIC_overload_table &&
10257 AMT_AMAGIC((AMT*)mg->mg_ptr))
10259 AMT *amtp = (AMT*)mg->mg_ptr;
10260 AMT *namtp = (AMT*)nmg->mg_ptr;
10262 for (i = 1; i < NofAMmeth; i++) {
10263 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
10267 else if (mg->mg_len == HEf_SVKEY)
10268 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
10270 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
10271 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10278 /* create a new pointer-mapping table */
10281 Perl_ptr_table_new(pTHX)
10284 Newz(0, tbl, 1, PTR_TBL_t);
10285 tbl->tbl_max = 511;
10286 tbl->tbl_items = 0;
10287 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10292 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
10294 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
10302 struct ptr_tbl_ent* pte;
10303 struct ptr_tbl_ent* pteend;
10304 New(0, pte, PERL_ARENA_SIZE/sizeof(struct ptr_tbl_ent), struct ptr_tbl_ent);
10305 pte->next = PL_pte_arenaroot;
10306 PL_pte_arenaroot = pte;
10308 pteend = &pte[PERL_ARENA_SIZE / sizeof(struct ptr_tbl_ent) - 1];
10309 PL_pte_root = ++pte;
10310 while (pte < pteend) {
10311 pte->next = pte + 1;
10317 STATIC struct ptr_tbl_ent*
10320 struct ptr_tbl_ent* pte;
10324 PL_pte_root = pte->next;
10329 S_del_pte(pTHX_ struct ptr_tbl_ent*p)
10331 p->next = PL_pte_root;
10335 /* map an existing pointer using a table */
10338 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
10340 PTR_TBL_ENT_t *tblent;
10341 const UV hash = PTR_TABLE_HASH(sv);
10343 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10344 for (; tblent; tblent = tblent->next) {
10345 if (tblent->oldval == sv)
10346 return tblent->newval;
10348 return (void*)NULL;
10351 /* add a new entry to a pointer-mapping table */
10354 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
10356 PTR_TBL_ENT_t *tblent, **otblent;
10357 /* XXX this may be pessimal on platforms where pointers aren't good
10358 * hash values e.g. if they grow faster in the most significant
10360 const UV hash = PTR_TABLE_HASH(oldv);
10364 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
10365 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
10366 if (tblent->oldval == oldv) {
10367 tblent->newval = newv;
10371 tblent = S_new_pte(aTHX);
10372 tblent->oldval = oldv;
10373 tblent->newval = newv;
10374 tblent->next = *otblent;
10377 if (!empty && tbl->tbl_items > tbl->tbl_max)
10378 ptr_table_split(tbl);
10381 /* double the hash bucket size of an existing ptr table */
10384 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
10386 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10387 const UV oldsize = tbl->tbl_max + 1;
10388 UV newsize = oldsize * 2;
10391 Renew(ary, newsize, PTR_TBL_ENT_t*);
10392 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10393 tbl->tbl_max = --newsize;
10394 tbl->tbl_ary = ary;
10395 for (i=0; i < oldsize; i++, ary++) {
10396 PTR_TBL_ENT_t **curentp, **entp, *ent;
10399 curentp = ary + oldsize;
10400 for (entp = ary, ent = *ary; ent; ent = *entp) {
10401 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10403 ent->next = *curentp;
10413 /* remove all the entries from a ptr table */
10416 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
10418 register PTR_TBL_ENT_t **array;
10419 register PTR_TBL_ENT_t *entry;
10423 if (!tbl || !tbl->tbl_items) {
10427 array = tbl->tbl_ary;
10429 max = tbl->tbl_max;
10433 PTR_TBL_ENT_t *oentry = entry;
10434 entry = entry->next;
10435 S_del_pte(aTHX_ oentry);
10438 if (++riter > max) {
10441 entry = array[riter];
10445 tbl->tbl_items = 0;
10448 /* clear and free a ptr table */
10451 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
10456 ptr_table_clear(tbl);
10457 Safefree(tbl->tbl_ary);
10461 /* attempt to make everything in the typeglob readonly */
10464 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
10466 GV *gv = (GV*)sstr;
10467 SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */
10469 if (GvIO(gv) || GvFORM(gv)) {
10470 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
10472 else if (!GvCV(gv)) {
10473 GvCV(gv) = (CV*)sv;
10476 /* CvPADLISTs cannot be shared */
10477 if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
10482 if (!GvUNIQUE(gv)) {
10484 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
10485 HvNAME_get(GvSTASH(gv)), GvNAME(gv));
10491 * write attempts will die with
10492 * "Modification of a read-only value attempted"
10498 SvREADONLY_on(GvSV(gv));
10502 GvAV(gv) = (AV*)sv;
10505 SvREADONLY_on(GvAV(gv));
10509 GvHV(gv) = (HV*)sv;
10512 SvREADONLY_on(GvHV(gv));
10515 return sstr; /* he_dup() will SvREFCNT_inc() */
10518 /* duplicate an SV of any type (including AV, HV etc) */
10521 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
10524 SvRV_set(dstr, SvWEAKREF(sstr)
10525 ? sv_dup(SvRV(sstr), param)
10526 : sv_dup_inc(SvRV(sstr), param));
10529 else if (SvPVX_const(sstr)) {
10530 /* Has something there */
10532 /* Normal PV - clone whole allocated space */
10533 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
10534 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10535 /* Not that normal - actually sstr is copy on write.
10536 But we are a true, independant SV, so: */
10537 SvREADONLY_off(dstr);
10542 /* Special case - not normally malloced for some reason */
10543 if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
10544 /* A "shared" PV - clone it as "shared" PV */
10546 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
10550 /* Some other special case - random pointer */
10551 SvPV_set(dstr, SvPVX(sstr));
10556 /* Copy the Null */
10557 if (SvTYPE(dstr) == SVt_RV)
10558 SvRV_set(dstr, NULL);
10565 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
10570 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10572 /* look for it in the table first */
10573 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10577 if(param->flags & CLONEf_JOIN_IN) {
10578 /** We are joining here so we don't want do clone
10579 something that is bad **/
10580 const char *hvname;
10582 if(SvTYPE(sstr) == SVt_PVHV &&
10583 (hvname = HvNAME_get(sstr))) {
10584 /** don't clone stashes if they already exist **/
10585 HV* old_stash = gv_stashpv(hvname,0);
10586 return (SV*) old_stash;
10590 /* create anew and remember what it is */
10593 #ifdef DEBUG_LEAKING_SCALARS
10594 dstr->sv_debug_optype = sstr->sv_debug_optype;
10595 dstr->sv_debug_line = sstr->sv_debug_line;
10596 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10597 dstr->sv_debug_cloned = 1;
10599 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10601 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
10605 ptr_table_store(PL_ptr_table, sstr, dstr);
10608 SvFLAGS(dstr) = SvFLAGS(sstr);
10609 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10610 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10613 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
10614 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10615 PL_watch_pvx, SvPVX_const(sstr));
10618 /* don't clone objects whose class has asked us not to */
10619 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10620 SvFLAGS(dstr) &= ~SVTYPEMASK;
10621 SvOBJECT_off(dstr);
10625 switch (SvTYPE(sstr)) {
10627 SvANY(dstr) = NULL;
10630 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
10631 SvIV_set(dstr, SvIVX(sstr));
10634 SvANY(dstr) = new_XNV();
10635 SvNV_set(dstr, SvNVX(sstr));
10638 SvANY(dstr) = &(dstr->sv_u.svu_rv);
10639 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10642 SvANY(dstr) = new_XPV();
10643 SvCUR_set(dstr, SvCUR(sstr));
10644 SvLEN_set(dstr, SvLEN(sstr));
10645 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10648 SvANY(dstr) = new_XPVIV();
10649 SvCUR_set(dstr, SvCUR(sstr));
10650 SvLEN_set(dstr, SvLEN(sstr));
10651 SvIV_set(dstr, SvIVX(sstr));
10652 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10655 SvANY(dstr) = new_XPVNV();
10656 SvCUR_set(dstr, SvCUR(sstr));
10657 SvLEN_set(dstr, SvLEN(sstr));
10658 SvIV_set(dstr, SvIVX(sstr));
10659 SvNV_set(dstr, SvNVX(sstr));
10660 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10663 SvANY(dstr) = new_XPVMG();
10664 SvCUR_set(dstr, SvCUR(sstr));
10665 SvLEN_set(dstr, SvLEN(sstr));
10666 SvIV_set(dstr, SvIVX(sstr));
10667 SvNV_set(dstr, SvNVX(sstr));
10668 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10669 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10670 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10673 SvANY(dstr) = new_XPVBM();
10674 SvCUR_set(dstr, SvCUR(sstr));
10675 SvLEN_set(dstr, SvLEN(sstr));
10676 SvIV_set(dstr, SvIVX(sstr));
10677 SvNV_set(dstr, SvNVX(sstr));
10678 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10679 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10680 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10681 BmRARE(dstr) = BmRARE(sstr);
10682 BmUSEFUL(dstr) = BmUSEFUL(sstr);
10683 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
10686 SvANY(dstr) = new_XPVLV();
10687 SvCUR_set(dstr, SvCUR(sstr));
10688 SvLEN_set(dstr, SvLEN(sstr));
10689 SvIV_set(dstr, SvIVX(sstr));
10690 SvNV_set(dstr, SvNVX(sstr));
10691 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10692 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10693 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10694 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
10695 LvTARGLEN(dstr) = LvTARGLEN(sstr);
10696 if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */
10697 LvTARG(dstr) = dstr;
10698 else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */
10699 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param);
10701 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
10702 LvTYPE(dstr) = LvTYPE(sstr);
10705 if (GvUNIQUE((GV*)sstr)) {
10707 if ((share = gv_share(sstr, param))) {
10710 ptr_table_store(PL_ptr_table, sstr, dstr);
10712 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
10713 HvNAME_get(GvSTASH(share)), GvNAME(share));
10718 SvANY(dstr) = new_XPVGV();
10719 SvCUR_set(dstr, SvCUR(sstr));
10720 SvLEN_set(dstr, SvLEN(sstr));
10721 SvIV_set(dstr, SvIVX(sstr));
10722 SvNV_set(dstr, SvNVX(sstr));
10723 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10724 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10725 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10726 GvNAMELEN(dstr) = GvNAMELEN(sstr);
10727 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
10728 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
10729 GvFLAGS(dstr) = GvFLAGS(sstr);
10730 GvGP(dstr) = gp_dup(GvGP(sstr), param);
10731 (void)GpREFCNT_inc(GvGP(dstr));
10734 SvANY(dstr) = new_XPVIO();
10735 SvCUR_set(dstr, SvCUR(sstr));
10736 SvLEN_set(dstr, SvLEN(sstr));
10737 SvIV_set(dstr, SvIVX(sstr));
10738 SvNV_set(dstr, SvNVX(sstr));
10739 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10740 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10741 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10742 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
10743 if (IoOFP(sstr) == IoIFP(sstr))
10744 IoOFP(dstr) = IoIFP(dstr);
10746 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
10747 /* PL_rsfp_filters entries have fake IoDIRP() */
10748 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
10749 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
10751 IoDIRP(dstr) = IoDIRP(sstr);
10752 IoLINES(dstr) = IoLINES(sstr);
10753 IoPAGE(dstr) = IoPAGE(sstr);
10754 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
10755 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
10756 if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
10757 /* I have no idea why fake dirp (rsfps)
10758 should be treaded differently but otherwise
10759 we end up with leaks -- sky*/
10760 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(sstr), param);
10761 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(sstr), param);
10762 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(sstr), param);
10764 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
10765 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
10766 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
10768 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
10769 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
10770 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
10771 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
10772 IoTYPE(dstr) = IoTYPE(sstr);
10773 IoFLAGS(dstr) = IoFLAGS(sstr);
10776 SvANY(dstr) = new_XPVAV();
10777 SvCUR_set(dstr, SvCUR(sstr));
10778 SvLEN_set(dstr, SvLEN(sstr));
10779 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10780 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10781 if (AvARRAY((AV*)sstr)) {
10782 SV **dst_ary, **src_ary;
10783 SSize_t items = AvFILLp((AV*)sstr) + 1;
10785 src_ary = AvARRAY((AV*)sstr);
10786 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
10787 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10788 SvPV_set(dstr, (char*)dst_ary);
10789 AvALLOC((AV*)dstr) = dst_ary;
10790 if (AvREAL((AV*)sstr)) {
10791 while (items-- > 0)
10792 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10795 while (items-- > 0)
10796 *dst_ary++ = sv_dup(*src_ary++, param);
10798 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10799 while (items-- > 0) {
10800 *dst_ary++ = &PL_sv_undef;
10804 SvPV_set(dstr, Nullch);
10805 AvALLOC((AV*)dstr) = (SV**)NULL;
10809 SvANY(dstr) = new_XPVHV();
10810 SvCUR_set(dstr, SvCUR(sstr));
10811 SvLEN_set(dstr, SvLEN(sstr));
10812 HvTOTALKEYS(dstr) = HvTOTALKEYS(sstr);
10813 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10814 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10818 if (HvARRAY((HV*)sstr)) {
10820 const bool sharekeys = !!HvSHAREKEYS(sstr);
10821 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
10822 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
10825 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
10826 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0), char);
10827 HvARRAY(dstr) = (HE**)darray;
10828 while (i <= sxhv->xhv_max) {
10829 HE *source = HvARRAY(sstr)[i];
10831 = source ? he_dup(source, sharekeys, param) : 0;
10835 struct xpvhv_aux *saux = HvAUX(sstr);
10836 struct xpvhv_aux *daux = HvAUX(dstr);
10837 /* This flag isn't copied. */
10838 /* SvOOK_on(hv) attacks the IV flags. */
10839 SvFLAGS(dstr) |= SVf_OOK;
10841 hvname = saux->xhv_name;
10842 daux->xhv_name = hvname ? hek_dup(hvname, param) : hvname;
10844 daux->xhv_riter = saux->xhv_riter;
10845 daux->xhv_eiter = saux->xhv_eiter
10846 ? he_dup(saux->xhv_eiter, (bool)!!HvSHAREKEYS(sstr),
10851 SvPV_set(dstr, Nullch);
10853 /* Record stashes for possible cloning in Perl_clone(). */
10855 av_push(param->stashes, dstr);
10859 SvANY(dstr) = new_XPVFM();
10860 FmLINES(dstr) = FmLINES(sstr);
10864 SvANY(dstr) = new_XPVCV();
10866 SvCUR_set(dstr, SvCUR(sstr));
10867 SvLEN_set(dstr, SvLEN(sstr));
10868 SvIV_set(dstr, SvIVX(sstr));
10869 SvNV_set(dstr, SvNVX(sstr));
10870 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10871 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10872 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10873 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
10874 CvSTART(dstr) = CvSTART(sstr);
10876 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
10878 CvXSUB(dstr) = CvXSUB(sstr);
10879 CvXSUBANY(dstr) = CvXSUBANY(sstr);
10880 if (CvCONST(sstr)) {
10881 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
10882 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
10883 sv_dup_inc((SV *)CvXSUBANY(sstr).any_ptr, param);
10885 /* don't dup if copying back - CvGV isn't refcounted, so the
10886 * duped GV may never be freed. A bit of a hack! DAPM */
10887 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
10888 Nullgv : gv_dup(CvGV(sstr), param) ;
10889 if (param->flags & CLONEf_COPY_STACKS) {
10890 CvDEPTH(dstr) = CvDEPTH(sstr);
10894 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10895 CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
10897 CvWEAKOUTSIDE(sstr)
10898 ? cv_dup( CvOUTSIDE(sstr), param)
10899 : cv_dup_inc(CvOUTSIDE(sstr), param);
10900 CvFLAGS(dstr) = CvFLAGS(sstr);
10901 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
10904 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
10908 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10914 /* duplicate a context */
10917 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10919 PERL_CONTEXT *ncxs;
10922 return (PERL_CONTEXT*)NULL;
10924 /* look for it in the table first */
10925 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10929 /* create anew and remember what it is */
10930 Newz(56, ncxs, max + 1, PERL_CONTEXT);
10931 ptr_table_store(PL_ptr_table, cxs, ncxs);
10934 PERL_CONTEXT *cx = &cxs[ix];
10935 PERL_CONTEXT *ncx = &ncxs[ix];
10936 ncx->cx_type = cx->cx_type;
10937 if (CxTYPE(cx) == CXt_SUBST) {
10938 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10941 ncx->blk_oldsp = cx->blk_oldsp;
10942 ncx->blk_oldcop = cx->blk_oldcop;
10943 ncx->blk_oldmarksp = cx->blk_oldmarksp;
10944 ncx->blk_oldscopesp = cx->blk_oldscopesp;
10945 ncx->blk_oldpm = cx->blk_oldpm;
10946 ncx->blk_gimme = cx->blk_gimme;
10947 switch (CxTYPE(cx)) {
10949 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
10950 ? cv_dup_inc(cx->blk_sub.cv, param)
10951 : cv_dup(cx->blk_sub.cv,param));
10952 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
10953 ? av_dup_inc(cx->blk_sub.argarray, param)
10955 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
10956 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
10957 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10958 ncx->blk_sub.lval = cx->blk_sub.lval;
10959 ncx->blk_sub.retop = cx->blk_sub.retop;
10962 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
10963 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
10964 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
10965 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
10966 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
10967 ncx->blk_eval.retop = cx->blk_eval.retop;
10970 ncx->blk_loop.label = cx->blk_loop.label;
10971 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
10972 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
10973 ncx->blk_loop.next_op = cx->blk_loop.next_op;
10974 ncx->blk_loop.last_op = cx->blk_loop.last_op;
10975 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
10976 ? cx->blk_loop.iterdata
10977 : gv_dup((GV*)cx->blk_loop.iterdata, param));
10978 ncx->blk_loop.oldcomppad
10979 = (PAD*)ptr_table_fetch(PL_ptr_table,
10980 cx->blk_loop.oldcomppad);
10981 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
10982 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
10983 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
10984 ncx->blk_loop.iterix = cx->blk_loop.iterix;
10985 ncx->blk_loop.itermax = cx->blk_loop.itermax;
10988 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
10989 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
10990 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
10991 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10992 ncx->blk_sub.retop = cx->blk_sub.retop;
11004 /* duplicate a stack info structure */
11007 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11012 return (PERL_SI*)NULL;
11014 /* look for it in the table first */
11015 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11019 /* create anew and remember what it is */
11020 Newz(56, nsi, 1, PERL_SI);
11021 ptr_table_store(PL_ptr_table, si, nsi);
11023 nsi->si_stack = av_dup_inc(si->si_stack, param);
11024 nsi->si_cxix = si->si_cxix;
11025 nsi->si_cxmax = si->si_cxmax;
11026 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11027 nsi->si_type = si->si_type;
11028 nsi->si_prev = si_dup(si->si_prev, param);
11029 nsi->si_next = si_dup(si->si_next, param);
11030 nsi->si_markoff = si->si_markoff;
11035 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
11036 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
11037 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
11038 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
11039 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
11040 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
11041 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
11042 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
11043 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
11044 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
11045 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
11046 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
11047 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11048 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11051 #define pv_dup_inc(p) SAVEPV(p)
11052 #define pv_dup(p) SAVEPV(p)
11053 #define svp_dup_inc(p,pp) any_dup(p,pp)
11055 /* map any object to the new equivent - either something in the
11056 * ptr table, or something in the interpreter structure
11060 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
11065 return (void*)NULL;
11067 /* look for it in the table first */
11068 ret = ptr_table_fetch(PL_ptr_table, v);
11072 /* see if it is part of the interpreter structure */
11073 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11074 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11082 /* duplicate the save stack */
11085 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11087 ANY *ss = proto_perl->Tsavestack;
11088 I32 ix = proto_perl->Tsavestack_ix;
11089 I32 max = proto_perl->Tsavestack_max;
11101 void (*dptr) (void*);
11102 void (*dxptr) (pTHX_ void*);
11105 Newz(54, nss, max, ANY);
11108 I32 i = POPINT(ss,ix);
11109 TOPINT(nss,ix) = i;
11111 case SAVEt_ITEM: /* normal string */
11112 sv = (SV*)POPPTR(ss,ix);
11113 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11114 sv = (SV*)POPPTR(ss,ix);
11115 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11117 case SAVEt_SV: /* scalar reference */
11118 sv = (SV*)POPPTR(ss,ix);
11119 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11120 gv = (GV*)POPPTR(ss,ix);
11121 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11123 case SAVEt_GENERIC_PVREF: /* generic char* */
11124 c = (char*)POPPTR(ss,ix);
11125 TOPPTR(nss,ix) = pv_dup(c);
11126 ptr = POPPTR(ss,ix);
11127 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11129 case SAVEt_SHARED_PVREF: /* char* in shared space */
11130 c = (char*)POPPTR(ss,ix);
11131 TOPPTR(nss,ix) = savesharedpv(c);
11132 ptr = POPPTR(ss,ix);
11133 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11135 case SAVEt_GENERIC_SVREF: /* generic sv */
11136 case SAVEt_SVREF: /* scalar reference */
11137 sv = (SV*)POPPTR(ss,ix);
11138 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11139 ptr = POPPTR(ss,ix);
11140 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11142 case SAVEt_AV: /* array reference */
11143 av = (AV*)POPPTR(ss,ix);
11144 TOPPTR(nss,ix) = av_dup_inc(av, param);
11145 gv = (GV*)POPPTR(ss,ix);
11146 TOPPTR(nss,ix) = gv_dup(gv, param);
11148 case SAVEt_HV: /* hash reference */
11149 hv = (HV*)POPPTR(ss,ix);
11150 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11151 gv = (GV*)POPPTR(ss,ix);
11152 TOPPTR(nss,ix) = gv_dup(gv, param);
11154 case SAVEt_INT: /* int reference */
11155 ptr = POPPTR(ss,ix);
11156 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11157 intval = (int)POPINT(ss,ix);
11158 TOPINT(nss,ix) = intval;
11160 case SAVEt_LONG: /* long reference */
11161 ptr = POPPTR(ss,ix);
11162 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11163 longval = (long)POPLONG(ss,ix);
11164 TOPLONG(nss,ix) = longval;
11166 case SAVEt_I32: /* I32 reference */
11167 case SAVEt_I16: /* I16 reference */
11168 case SAVEt_I8: /* I8 reference */
11169 ptr = POPPTR(ss,ix);
11170 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11172 TOPINT(nss,ix) = i;
11174 case SAVEt_IV: /* IV reference */
11175 ptr = POPPTR(ss,ix);
11176 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11178 TOPIV(nss,ix) = iv;
11180 case SAVEt_SPTR: /* SV* reference */
11181 ptr = POPPTR(ss,ix);
11182 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11183 sv = (SV*)POPPTR(ss,ix);
11184 TOPPTR(nss,ix) = sv_dup(sv, param);
11186 case SAVEt_VPTR: /* random* reference */
11187 ptr = POPPTR(ss,ix);
11188 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11189 ptr = POPPTR(ss,ix);
11190 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11192 case SAVEt_PPTR: /* char* reference */
11193 ptr = POPPTR(ss,ix);
11194 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11195 c = (char*)POPPTR(ss,ix);
11196 TOPPTR(nss,ix) = pv_dup(c);
11198 case SAVEt_HPTR: /* HV* reference */
11199 ptr = POPPTR(ss,ix);
11200 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11201 hv = (HV*)POPPTR(ss,ix);
11202 TOPPTR(nss,ix) = hv_dup(hv, param);
11204 case SAVEt_APTR: /* AV* reference */
11205 ptr = POPPTR(ss,ix);
11206 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11207 av = (AV*)POPPTR(ss,ix);
11208 TOPPTR(nss,ix) = av_dup(av, param);
11211 gv = (GV*)POPPTR(ss,ix);
11212 TOPPTR(nss,ix) = gv_dup(gv, param);
11214 case SAVEt_GP: /* scalar reference */
11215 gp = (GP*)POPPTR(ss,ix);
11216 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11217 (void)GpREFCNT_inc(gp);
11218 gv = (GV*)POPPTR(ss,ix);
11219 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11220 c = (char*)POPPTR(ss,ix);
11221 TOPPTR(nss,ix) = pv_dup(c);
11223 TOPIV(nss,ix) = iv;
11225 TOPIV(nss,ix) = iv;
11228 case SAVEt_MORTALIZESV:
11229 sv = (SV*)POPPTR(ss,ix);
11230 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11233 ptr = POPPTR(ss,ix);
11234 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11235 /* these are assumed to be refcounted properly */
11236 switch (((OP*)ptr)->op_type) {
11238 case OP_LEAVESUBLV:
11242 case OP_LEAVEWRITE:
11243 TOPPTR(nss,ix) = ptr;
11248 TOPPTR(nss,ix) = Nullop;
11253 TOPPTR(nss,ix) = Nullop;
11256 c = (char*)POPPTR(ss,ix);
11257 TOPPTR(nss,ix) = pv_dup_inc(c);
11259 case SAVEt_CLEARSV:
11260 longval = POPLONG(ss,ix);
11261 TOPLONG(nss,ix) = longval;
11264 hv = (HV*)POPPTR(ss,ix);
11265 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11266 c = (char*)POPPTR(ss,ix);
11267 TOPPTR(nss,ix) = pv_dup_inc(c);
11269 TOPINT(nss,ix) = i;
11271 case SAVEt_DESTRUCTOR:
11272 ptr = POPPTR(ss,ix);
11273 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11274 dptr = POPDPTR(ss,ix);
11275 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
11276 any_dup(FPTR2DPTR(void *, dptr),
11279 case SAVEt_DESTRUCTOR_X:
11280 ptr = POPPTR(ss,ix);
11281 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11282 dxptr = POPDXPTR(ss,ix);
11283 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
11284 any_dup(FPTR2DPTR(void *, dxptr),
11287 case SAVEt_REGCONTEXT:
11290 TOPINT(nss,ix) = i;
11293 case SAVEt_STACK_POS: /* Position on Perl stack */
11295 TOPINT(nss,ix) = i;
11297 case SAVEt_AELEM: /* array element */
11298 sv = (SV*)POPPTR(ss,ix);
11299 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11301 TOPINT(nss,ix) = i;
11302 av = (AV*)POPPTR(ss,ix);
11303 TOPPTR(nss,ix) = av_dup_inc(av, param);
11305 case SAVEt_HELEM: /* hash element */
11306 sv = (SV*)POPPTR(ss,ix);
11307 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11308 sv = (SV*)POPPTR(ss,ix);
11309 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11310 hv = (HV*)POPPTR(ss,ix);
11311 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11314 ptr = POPPTR(ss,ix);
11315 TOPPTR(nss,ix) = ptr;
11319 TOPINT(nss,ix) = i;
11321 case SAVEt_COMPPAD:
11322 av = (AV*)POPPTR(ss,ix);
11323 TOPPTR(nss,ix) = av_dup(av, param);
11326 longval = (long)POPLONG(ss,ix);
11327 TOPLONG(nss,ix) = longval;
11328 ptr = POPPTR(ss,ix);
11329 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11330 sv = (SV*)POPPTR(ss,ix);
11331 TOPPTR(nss,ix) = sv_dup(sv, param);
11334 ptr = POPPTR(ss,ix);
11335 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11336 longval = (long)POPBOOL(ss,ix);
11337 TOPBOOL(nss,ix) = (bool)longval;
11339 case SAVEt_SET_SVFLAGS:
11341 TOPINT(nss,ix) = i;
11343 TOPINT(nss,ix) = i;
11344 sv = (SV*)POPPTR(ss,ix);
11345 TOPPTR(nss,ix) = sv_dup(sv, param);
11348 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
11356 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11357 * flag to the result. This is done for each stash before cloning starts,
11358 * so we know which stashes want their objects cloned */
11361 do_mark_cloneable_stash(pTHX_ SV *sv)
11363 const HEK *hvname = HvNAME_HEK((HV*)sv);
11365 GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
11366 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11367 if (cloner && GvCV(cloner)) {
11374 XPUSHs(sv_2mortal(newSVhek(hvname)));
11376 call_sv((SV*)GvCV(cloner), G_SCALAR);
11383 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11391 =for apidoc perl_clone
11393 Create and return a new interpreter by cloning the current one.
11395 perl_clone takes these flags as parameters:
11397 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11398 without it we only clone the data and zero the stacks,
11399 with it we copy the stacks and the new perl interpreter is
11400 ready to run at the exact same point as the previous one.
11401 The pseudo-fork code uses COPY_STACKS while the
11402 threads->new doesn't.
11404 CLONEf_KEEP_PTR_TABLE
11405 perl_clone keeps a ptr_table with the pointer of the old
11406 variable as a key and the new variable as a value,
11407 this allows it to check if something has been cloned and not
11408 clone it again but rather just use the value and increase the
11409 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11410 the ptr_table using the function
11411 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11412 reason to keep it around is if you want to dup some of your own
11413 variable who are outside the graph perl scans, example of this
11414 code is in threads.xs create
11417 This is a win32 thing, it is ignored on unix, it tells perls
11418 win32host code (which is c++) to clone itself, this is needed on
11419 win32 if you want to run two threads at the same time,
11420 if you just want to do some stuff in a separate perl interpreter
11421 and then throw it away and return to the original one,
11422 you don't need to do anything.
11427 /* XXX the above needs expanding by someone who actually understands it ! */
11428 EXTERN_C PerlInterpreter *
11429 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11432 perl_clone(PerlInterpreter *proto_perl, UV flags)
11435 #ifdef PERL_IMPLICIT_SYS
11437 /* perlhost.h so we need to call into it
11438 to clone the host, CPerlHost should have a c interface, sky */
11440 if (flags & CLONEf_CLONE_HOST) {
11441 return perl_clone_host(proto_perl,flags);
11443 return perl_clone_using(proto_perl, flags,
11445 proto_perl->IMemShared,
11446 proto_perl->IMemParse,
11448 proto_perl->IStdIO,
11452 proto_perl->IProc);
11456 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11457 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11458 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11459 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11460 struct IPerlDir* ipD, struct IPerlSock* ipS,
11461 struct IPerlProc* ipP)
11463 /* XXX many of the string copies here can be optimized if they're
11464 * constants; they need to be allocated as common memory and just
11465 * their pointers copied. */
11468 CLONE_PARAMS clone_params;
11469 CLONE_PARAMS* param = &clone_params;
11471 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11472 /* for each stash, determine whether its objects should be cloned */
11473 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11474 PERL_SET_THX(my_perl);
11477 Poison(my_perl, 1, PerlInterpreter);
11479 PL_curcop = (COP *)Nullop;
11483 PL_savestack_ix = 0;
11484 PL_savestack_max = -1;
11485 PL_sig_pending = 0;
11486 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11487 # else /* !DEBUGGING */
11488 Zero(my_perl, 1, PerlInterpreter);
11489 # endif /* DEBUGGING */
11491 /* host pointers */
11493 PL_MemShared = ipMS;
11494 PL_MemParse = ipMP;
11501 #else /* !PERL_IMPLICIT_SYS */
11503 CLONE_PARAMS clone_params;
11504 CLONE_PARAMS* param = &clone_params;
11505 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11506 /* for each stash, determine whether its objects should be cloned */
11507 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11508 PERL_SET_THX(my_perl);
11511 Poison(my_perl, 1, PerlInterpreter);
11513 PL_curcop = (COP *)Nullop;
11517 PL_savestack_ix = 0;
11518 PL_savestack_max = -1;
11519 PL_sig_pending = 0;
11520 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11521 # else /* !DEBUGGING */
11522 Zero(my_perl, 1, PerlInterpreter);
11523 # endif /* DEBUGGING */
11524 #endif /* PERL_IMPLICIT_SYS */
11525 param->flags = flags;
11526 param->proto_perl = proto_perl;
11529 PL_xnv_arenaroot = NULL;
11530 PL_xnv_root = NULL;
11531 PL_xpv_arenaroot = NULL;
11532 PL_xpv_root = NULL;
11533 PL_xpviv_arenaroot = NULL;
11534 PL_xpviv_root = NULL;
11535 PL_xpvnv_arenaroot = NULL;
11536 PL_xpvnv_root = NULL;
11537 PL_xpvcv_arenaroot = NULL;
11538 PL_xpvcv_root = NULL;
11539 PL_xpvav_arenaroot = NULL;
11540 PL_xpvav_root = NULL;
11541 PL_xpvhv_arenaroot = NULL;
11542 PL_xpvhv_root = NULL;
11543 PL_xpvmg_arenaroot = NULL;
11544 PL_xpvmg_root = NULL;
11545 PL_xpvgv_arenaroot = NULL;
11546 PL_xpvgv_root = NULL;
11547 PL_xpvlv_arenaroot = NULL;
11548 PL_xpvlv_root = NULL;
11549 PL_xpvbm_arenaroot = NULL;
11550 PL_xpvbm_root = NULL;
11551 PL_he_arenaroot = NULL;
11553 #if defined(USE_ITHREADS)
11554 PL_pte_arenaroot = NULL;
11555 PL_pte_root = NULL;
11557 PL_nice_chunk = NULL;
11558 PL_nice_chunk_size = 0;
11560 PL_sv_objcount = 0;
11561 PL_sv_root = Nullsv;
11562 PL_sv_arenaroot = Nullsv;
11564 PL_debug = proto_perl->Idebug;
11566 PL_hash_seed = proto_perl->Ihash_seed;
11567 PL_rehash_seed = proto_perl->Irehash_seed;
11569 #ifdef USE_REENTRANT_API
11570 /* XXX: things like -Dm will segfault here in perlio, but doing
11571 * PERL_SET_CONTEXT(proto_perl);
11572 * breaks too many other things
11574 Perl_reentrant_init(aTHX);
11577 /* create SV map for pointer relocation */
11578 PL_ptr_table = ptr_table_new();
11580 /* initialize these special pointers as early as possible */
11581 SvANY(&PL_sv_undef) = NULL;
11582 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11583 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11584 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11586 SvANY(&PL_sv_no) = new_XPVNV();
11587 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11588 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11589 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11590 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
11591 SvCUR_set(&PL_sv_no, 0);
11592 SvLEN_set(&PL_sv_no, 1);
11593 SvIV_set(&PL_sv_no, 0);
11594 SvNV_set(&PL_sv_no, 0);
11595 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11597 SvANY(&PL_sv_yes) = new_XPVNV();
11598 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11599 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11600 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11601 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
11602 SvCUR_set(&PL_sv_yes, 1);
11603 SvLEN_set(&PL_sv_yes, 2);
11604 SvIV_set(&PL_sv_yes, 1);
11605 SvNV_set(&PL_sv_yes, 1);
11606 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11608 /* create (a non-shared!) shared string table */
11609 PL_strtab = newHV();
11610 HvSHAREKEYS_off(PL_strtab);
11611 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
11612 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11614 PL_compiling = proto_perl->Icompiling;
11616 /* These two PVs will be free'd special way so must set them same way op.c does */
11617 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11618 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11620 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11621 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11623 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11624 if (!specialWARN(PL_compiling.cop_warnings))
11625 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
11626 if (!specialCopIO(PL_compiling.cop_io))
11627 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
11628 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
11630 /* pseudo environmental stuff */
11631 PL_origargc = proto_perl->Iorigargc;
11632 PL_origargv = proto_perl->Iorigargv;
11634 param->stashes = newAV(); /* Setup array of objects to call clone on */
11636 #ifdef PERLIO_LAYERS
11637 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11638 PerlIO_clone(aTHX_ proto_perl, param);
11641 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11642 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11643 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11644 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11645 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11646 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11649 PL_minus_c = proto_perl->Iminus_c;
11650 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11651 PL_localpatches = proto_perl->Ilocalpatches;
11652 PL_splitstr = proto_perl->Isplitstr;
11653 PL_preprocess = proto_perl->Ipreprocess;
11654 PL_minus_n = proto_perl->Iminus_n;
11655 PL_minus_p = proto_perl->Iminus_p;
11656 PL_minus_l = proto_perl->Iminus_l;
11657 PL_minus_a = proto_perl->Iminus_a;
11658 PL_minus_F = proto_perl->Iminus_F;
11659 PL_doswitches = proto_perl->Idoswitches;
11660 PL_dowarn = proto_perl->Idowarn;
11661 PL_doextract = proto_perl->Idoextract;
11662 PL_sawampersand = proto_perl->Isawampersand;
11663 PL_unsafe = proto_perl->Iunsafe;
11664 PL_inplace = SAVEPV(proto_perl->Iinplace);
11665 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11666 PL_perldb = proto_perl->Iperldb;
11667 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11668 PL_exit_flags = proto_perl->Iexit_flags;
11670 /* magical thingies */
11671 /* XXX time(&PL_basetime) when asked for? */
11672 PL_basetime = proto_perl->Ibasetime;
11673 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11675 PL_maxsysfd = proto_perl->Imaxsysfd;
11676 PL_multiline = proto_perl->Imultiline;
11677 PL_statusvalue = proto_perl->Istatusvalue;
11679 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11681 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11683 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11684 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11685 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11687 /* Clone the regex array */
11688 PL_regex_padav = newAV();
11690 const I32 len = av_len((AV*)proto_perl->Iregex_padav);
11691 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11693 av_push(PL_regex_padav,
11694 sv_dup_inc(regexen[0],param));
11695 for(i = 1; i <= len; i++) {
11696 if(SvREPADTMP(regexen[i])) {
11697 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11699 av_push(PL_regex_padav,
11701 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11702 SvIVX(regexen[i])), param)))
11707 PL_regex_pad = AvARRAY(PL_regex_padav);
11709 /* shortcuts to various I/O objects */
11710 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11711 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11712 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11713 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11714 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11715 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11717 /* shortcuts to regexp stuff */
11718 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11720 /* shortcuts to misc objects */
11721 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11723 /* shortcuts to debugging objects */
11724 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11725 PL_DBline = gv_dup(proto_perl->IDBline, param);
11726 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11727 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11728 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11729 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11730 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11731 PL_lineary = av_dup(proto_perl->Ilineary, param);
11732 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11734 /* symbol tables */
11735 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11736 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11737 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11738 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11739 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11741 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11742 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11743 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11744 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11745 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11746 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11748 PL_sub_generation = proto_perl->Isub_generation;
11750 /* funky return mechanisms */
11751 PL_forkprocess = proto_perl->Iforkprocess;
11753 /* subprocess state */
11754 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11756 /* internal state */
11757 PL_tainting = proto_perl->Itainting;
11758 PL_taint_warn = proto_perl->Itaint_warn;
11759 PL_maxo = proto_perl->Imaxo;
11760 if (proto_perl->Iop_mask)
11761 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11763 PL_op_mask = Nullch;
11764 /* PL_asserting = proto_perl->Iasserting; */
11766 /* current interpreter roots */
11767 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11768 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11769 PL_main_start = proto_perl->Imain_start;
11770 PL_eval_root = proto_perl->Ieval_root;
11771 PL_eval_start = proto_perl->Ieval_start;
11773 /* runtime control stuff */
11774 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11775 PL_copline = proto_perl->Icopline;
11777 PL_filemode = proto_perl->Ifilemode;
11778 PL_lastfd = proto_perl->Ilastfd;
11779 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11782 PL_gensym = proto_perl->Igensym;
11783 PL_preambled = proto_perl->Ipreambled;
11784 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11785 PL_laststatval = proto_perl->Ilaststatval;
11786 PL_laststype = proto_perl->Ilaststype;
11787 PL_mess_sv = Nullsv;
11789 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11790 PL_ofmt = SAVEPV(proto_perl->Iofmt);
11792 /* interpreter atexit processing */
11793 PL_exitlistlen = proto_perl->Iexitlistlen;
11794 if (PL_exitlistlen) {
11795 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11796 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11799 PL_exitlist = (PerlExitListEntry*)NULL;
11800 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11801 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11802 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11804 PL_profiledata = NULL;
11805 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
11806 /* PL_rsfp_filters entries have fake IoDIRP() */
11807 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
11809 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11811 PAD_CLONE_VARS(proto_perl, param);
11813 #ifdef HAVE_INTERP_INTERN
11814 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11817 /* more statics moved here */
11818 PL_generation = proto_perl->Igeneration;
11819 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11821 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11822 PL_in_clean_all = proto_perl->Iin_clean_all;
11824 PL_uid = proto_perl->Iuid;
11825 PL_euid = proto_perl->Ieuid;
11826 PL_gid = proto_perl->Igid;
11827 PL_egid = proto_perl->Iegid;
11828 PL_nomemok = proto_perl->Inomemok;
11829 PL_an = proto_perl->Ian;
11830 PL_evalseq = proto_perl->Ievalseq;
11831 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11832 PL_origalen = proto_perl->Iorigalen;
11833 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11834 PL_osname = SAVEPV(proto_perl->Iosname);
11835 PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */
11836 PL_sighandlerp = proto_perl->Isighandlerp;
11839 PL_runops = proto_perl->Irunops;
11841 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11844 PL_cshlen = proto_perl->Icshlen;
11845 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
11848 PL_lex_state = proto_perl->Ilex_state;
11849 PL_lex_defer = proto_perl->Ilex_defer;
11850 PL_lex_expect = proto_perl->Ilex_expect;
11851 PL_lex_formbrack = proto_perl->Ilex_formbrack;
11852 PL_lex_dojoin = proto_perl->Ilex_dojoin;
11853 PL_lex_starts = proto_perl->Ilex_starts;
11854 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
11855 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
11856 PL_lex_op = proto_perl->Ilex_op;
11857 PL_lex_inpat = proto_perl->Ilex_inpat;
11858 PL_lex_inwhat = proto_perl->Ilex_inwhat;
11859 PL_lex_brackets = proto_perl->Ilex_brackets;
11860 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11861 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
11862 PL_lex_casemods = proto_perl->Ilex_casemods;
11863 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11864 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
11866 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11867 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
11868 PL_nexttoke = proto_perl->Inexttoke;
11870 /* XXX This is probably masking the deeper issue of why
11871 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11872 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11873 * (A little debugging with a watchpoint on it may help.)
11875 if (SvANY(proto_perl->Ilinestr)) {
11876 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
11877 i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
11878 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11879 i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
11880 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11881 i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
11882 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11883 i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
11884 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11887 PL_linestr = NEWSV(65,79);
11888 sv_upgrade(PL_linestr,SVt_PVIV);
11889 sv_setpvn(PL_linestr,"",0);
11890 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
11892 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11893 PL_pending_ident = proto_perl->Ipending_ident;
11894 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
11896 PL_expect = proto_perl->Iexpect;
11898 PL_multi_start = proto_perl->Imulti_start;
11899 PL_multi_end = proto_perl->Imulti_end;
11900 PL_multi_open = proto_perl->Imulti_open;
11901 PL_multi_close = proto_perl->Imulti_close;
11903 PL_error_count = proto_perl->Ierror_count;
11904 PL_subline = proto_perl->Isubline;
11905 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
11907 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
11908 if (SvANY(proto_perl->Ilinestr)) {
11909 i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
11910 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11911 i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
11912 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11913 PL_last_lop_op = proto_perl->Ilast_lop_op;
11916 PL_last_uni = SvPVX(PL_linestr);
11917 PL_last_lop = SvPVX(PL_linestr);
11918 PL_last_lop_op = 0;
11920 PL_in_my = proto_perl->Iin_my;
11921 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
11923 PL_cryptseen = proto_perl->Icryptseen;
11926 PL_hints = proto_perl->Ihints;
11928 PL_amagic_generation = proto_perl->Iamagic_generation;
11930 #ifdef USE_LOCALE_COLLATE
11931 PL_collation_ix = proto_perl->Icollation_ix;
11932 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
11933 PL_collation_standard = proto_perl->Icollation_standard;
11934 PL_collxfrm_base = proto_perl->Icollxfrm_base;
11935 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
11936 #endif /* USE_LOCALE_COLLATE */
11938 #ifdef USE_LOCALE_NUMERIC
11939 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
11940 PL_numeric_standard = proto_perl->Inumeric_standard;
11941 PL_numeric_local = proto_perl->Inumeric_local;
11942 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11943 #endif /* !USE_LOCALE_NUMERIC */
11945 /* utf8 character classes */
11946 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11947 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11948 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11949 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11950 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
11951 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11952 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
11953 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
11954 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
11955 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
11956 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
11957 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
11958 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11959 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
11960 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11961 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11962 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11963 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11964 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11965 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11967 /* Did the locale setup indicate UTF-8? */
11968 PL_utf8locale = proto_perl->Iutf8locale;
11969 /* Unicode features (see perlrun/-C) */
11970 PL_unicode = proto_perl->Iunicode;
11972 /* Pre-5.8 signals control */
11973 PL_signals = proto_perl->Isignals;
11975 /* times() ticks per second */
11976 PL_clocktick = proto_perl->Iclocktick;
11978 /* Recursion stopper for PerlIO_find_layer */
11979 PL_in_load_module = proto_perl->Iin_load_module;
11981 /* sort() routine */
11982 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
11984 /* Not really needed/useful since the reenrant_retint is "volatile",
11985 * but do it for consistency's sake. */
11986 PL_reentrant_retint = proto_perl->Ireentrant_retint;
11988 /* Hooks to shared SVs and locks. */
11989 PL_sharehook = proto_perl->Isharehook;
11990 PL_lockhook = proto_perl->Ilockhook;
11991 PL_unlockhook = proto_perl->Iunlockhook;
11992 PL_threadhook = proto_perl->Ithreadhook;
11994 PL_runops_std = proto_perl->Irunops_std;
11995 PL_runops_dbg = proto_perl->Irunops_dbg;
11997 #ifdef THREADS_HAVE_PIDS
11998 PL_ppid = proto_perl->Ippid;
12002 PL_last_swash_hv = Nullhv; /* reinits on demand */
12003 PL_last_swash_klen = 0;
12004 PL_last_swash_key[0]= '\0';
12005 PL_last_swash_tmps = (U8*)NULL;
12006 PL_last_swash_slen = 0;
12008 PL_glob_index = proto_perl->Iglob_index;
12009 PL_srand_called = proto_perl->Isrand_called;
12010 PL_uudmap['M'] = 0; /* reinits on demand */
12011 PL_bitcount = Nullch; /* reinits on demand */
12013 if (proto_perl->Ipsig_pend) {
12014 Newz(0, PL_psig_pend, SIG_SIZE, int);
12017 PL_psig_pend = (int*)NULL;
12020 if (proto_perl->Ipsig_ptr) {
12021 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
12022 Newz(0, PL_psig_name, SIG_SIZE, SV*);
12023 for (i = 1; i < SIG_SIZE; i++) {
12024 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
12025 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
12029 PL_psig_ptr = (SV**)NULL;
12030 PL_psig_name = (SV**)NULL;
12033 /* thrdvar.h stuff */
12035 if (flags & CLONEf_COPY_STACKS) {
12036 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12037 PL_tmps_ix = proto_perl->Ttmps_ix;
12038 PL_tmps_max = proto_perl->Ttmps_max;
12039 PL_tmps_floor = proto_perl->Ttmps_floor;
12040 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
12042 while (i <= PL_tmps_ix) {
12043 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
12047 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12048 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
12049 Newz(54, PL_markstack, i, I32);
12050 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
12051 - proto_perl->Tmarkstack);
12052 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
12053 - proto_perl->Tmarkstack);
12054 Copy(proto_perl->Tmarkstack, PL_markstack,
12055 PL_markstack_ptr - PL_markstack + 1, I32);
12057 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12058 * NOTE: unlike the others! */
12059 PL_scopestack_ix = proto_perl->Tscopestack_ix;
12060 PL_scopestack_max = proto_perl->Tscopestack_max;
12061 Newz(54, PL_scopestack, PL_scopestack_max, I32);
12062 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
12064 /* NOTE: si_dup() looks at PL_markstack */
12065 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
12067 /* PL_curstack = PL_curstackinfo->si_stack; */
12068 PL_curstack = av_dup(proto_perl->Tcurstack, param);
12069 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
12071 /* next PUSHs() etc. set *(PL_stack_sp+1) */
12072 PL_stack_base = AvARRAY(PL_curstack);
12073 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
12074 - proto_perl->Tstack_base);
12075 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
12077 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12078 * NOTE: unlike the others! */
12079 PL_savestack_ix = proto_perl->Tsavestack_ix;
12080 PL_savestack_max = proto_perl->Tsavestack_max;
12081 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
12082 PL_savestack = ss_dup(proto_perl, param);
12086 ENTER; /* perl_destruct() wants to LEAVE; */
12089 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
12090 PL_top_env = &PL_start_env;
12092 PL_op = proto_perl->Top;
12095 PL_Xpv = (XPV*)NULL;
12096 PL_na = proto_perl->Tna;
12098 PL_statbuf = proto_perl->Tstatbuf;
12099 PL_statcache = proto_perl->Tstatcache;
12100 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
12101 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
12103 PL_timesbuf = proto_perl->Ttimesbuf;
12106 PL_tainted = proto_perl->Ttainted;
12107 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
12108 PL_rs = sv_dup_inc(proto_perl->Trs, param);
12109 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
12110 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
12111 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
12112 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
12113 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
12114 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
12115 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
12117 PL_restartop = proto_perl->Trestartop;
12118 PL_in_eval = proto_perl->Tin_eval;
12119 PL_delaymagic = proto_perl->Tdelaymagic;
12120 PL_dirty = proto_perl->Tdirty;
12121 PL_localizing = proto_perl->Tlocalizing;
12123 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
12124 PL_hv_fetch_ent_mh = Nullhe;
12125 PL_modcount = proto_perl->Tmodcount;
12126 PL_lastgotoprobe = Nullop;
12127 PL_dumpindent = proto_perl->Tdumpindent;
12129 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
12130 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
12131 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
12132 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
12133 PL_sortcxix = proto_perl->Tsortcxix;
12134 PL_efloatbuf = Nullch; /* reinits on demand */
12135 PL_efloatsize = 0; /* reinits on demand */
12139 PL_screamfirst = NULL;
12140 PL_screamnext = NULL;
12141 PL_maxscream = -1; /* reinits on demand */
12142 PL_lastscream = Nullsv;
12144 PL_watchaddr = NULL;
12145 PL_watchok = Nullch;
12147 PL_regdummy = proto_perl->Tregdummy;
12148 PL_regprecomp = Nullch;
12151 PL_colorset = 0; /* reinits PL_colors[] */
12152 /*PL_colors[6] = {0,0,0,0,0,0};*/
12153 PL_reginput = Nullch;
12154 PL_regbol = Nullch;
12155 PL_regeol = Nullch;
12156 PL_regstartp = (I32*)NULL;
12157 PL_regendp = (I32*)NULL;
12158 PL_reglastparen = (U32*)NULL;
12159 PL_reglastcloseparen = (U32*)NULL;
12160 PL_regtill = Nullch;
12161 PL_reg_start_tmp = (char**)NULL;
12162 PL_reg_start_tmpl = 0;
12163 PL_regdata = (struct reg_data*)NULL;
12166 PL_reg_eval_set = 0;
12168 PL_regprogram = (regnode*)NULL;
12170 PL_regcc = (CURCUR*)NULL;
12171 PL_reg_call_cc = (struct re_cc_state*)NULL;
12172 PL_reg_re = (regexp*)NULL;
12173 PL_reg_ganch = Nullch;
12174 PL_reg_sv = Nullsv;
12175 PL_reg_match_utf8 = FALSE;
12176 PL_reg_magic = (MAGIC*)NULL;
12178 PL_reg_oldcurpm = (PMOP*)NULL;
12179 PL_reg_curpm = (PMOP*)NULL;
12180 PL_reg_oldsaved = Nullch;
12181 PL_reg_oldsavedlen = 0;
12182 #ifdef PERL_OLD_COPY_ON_WRITE
12185 PL_reg_maxiter = 0;
12186 PL_reg_leftiter = 0;
12187 PL_reg_poscache = Nullch;
12188 PL_reg_poscache_size= 0;
12190 /* RE engine - function pointers */
12191 PL_regcompp = proto_perl->Tregcompp;
12192 PL_regexecp = proto_perl->Tregexecp;
12193 PL_regint_start = proto_perl->Tregint_start;
12194 PL_regint_string = proto_perl->Tregint_string;
12195 PL_regfree = proto_perl->Tregfree;
12197 PL_reginterp_cnt = 0;
12198 PL_reg_starttry = 0;
12200 /* Pluggable optimizer */
12201 PL_peepp = proto_perl->Tpeepp;
12203 PL_stashcache = newHV();
12205 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12206 ptr_table_free(PL_ptr_table);
12207 PL_ptr_table = NULL;
12210 /* Call the ->CLONE method, if it exists, for each of the stashes
12211 identified by sv_dup() above.
12213 while(av_len(param->stashes) != -1) {
12214 HV* stash = (HV*) av_shift(param->stashes);
12215 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12216 if (cloner && GvCV(cloner)) {
12221 XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
12223 call_sv((SV*)GvCV(cloner), G_DISCARD);
12229 SvREFCNT_dec(param->stashes);
12231 /* orphaned? eg threads->new inside BEGIN or use */
12232 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
12233 (void)SvREFCNT_inc(PL_compcv);
12234 SAVEFREESV(PL_compcv);
12240 #endif /* USE_ITHREADS */
12243 =head1 Unicode Support
12245 =for apidoc sv_recode_to_utf8
12247 The encoding is assumed to be an Encode object, on entry the PV
12248 of the sv is assumed to be octets in that encoding, and the sv
12249 will be converted into Unicode (and UTF-8).
12251 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12252 is not a reference, nothing is done to the sv. If the encoding is not
12253 an C<Encode::XS> Encoding object, bad things will happen.
12254 (See F<lib/encoding.pm> and L<Encode>).
12256 The PV of the sv is returned.
12261 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12264 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12278 Passing sv_yes is wrong - it needs to be or'ed set of constants
12279 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12280 remove converted chars from source.
12282 Both will default the value - let them.
12284 XPUSHs(&PL_sv_yes);
12287 call_method("decode", G_SCALAR);
12291 s = SvPV_const(uni, len);
12292 if (s != SvPVX_const(sv)) {
12293 SvGROW(sv, len + 1);
12294 Move(s, SvPVX(sv), len + 1, char);
12295 SvCUR_set(sv, len);
12302 return SvPOKp(sv) ? SvPVX(sv) : NULL;
12306 =for apidoc sv_cat_decode
12308 The encoding is assumed to be an Encode object, the PV of the ssv is
12309 assumed to be octets in that encoding and decoding the input starts
12310 from the position which (PV + *offset) pointed to. The dsv will be
12311 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
12312 when the string tstr appears in decoding output or the input ends on
12313 the PV of the ssv. The value which the offset points will be modified
12314 to the last input position on the ssv.
12316 Returns TRUE if the terminator was found, else returns FALSE.
12321 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12322 SV *ssv, int *offset, char *tstr, int tlen)
12326 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12337 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
12338 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
12340 call_method("cat_decode", G_SCALAR);
12342 ret = SvTRUE(TOPs);
12343 *offset = SvIV(offsv);
12349 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12355 * c-indentation-style: bsd
12356 * c-basic-offset: 4
12357 * indent-tabs-mode: t
12360 * ex: set ts=8 sts=4 sw=4 noet: