3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
9 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
12 * This file contains the code that creates, manipulates and destroys
13 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
14 * structure of an SV, so their creation and destruction is handled
15 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
16 * level functions (eg. substr, split, join) for each of the types are
28 /* Missing proto on LynxOS */
29 char *gconvert(double, int, int, char *);
32 #ifdef PERL_UTF8_CACHE_ASSERT
33 /* The cache element 0 is the Unicode offset;
34 * the cache element 1 is the byte offset of the element 0;
35 * the cache element 2 is the Unicode length of the substring;
36 * the cache element 3 is the byte length of the substring;
37 * The checking of the substring side would be good
38 * but substr() has enough code paths to make my head spin;
39 * if adding more checks watch out for the following tests:
40 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
41 * lib/utf8.t lib/Unicode/Collate/t/index.t
44 #define ASSERT_UTF8_CACHE(cache) \
45 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
47 #define ASSERT_UTF8_CACHE(cache) NOOP
50 #ifdef PERL_COPY_ON_WRITE
51 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
52 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
53 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
57 /* ============================================================================
59 =head1 Allocation and deallocation of SVs.
61 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
62 av, hv...) contains type and reference count information, as well as a
63 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
64 specific to each type.
66 Normally, this allocation is done using arenas, which 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);
763 if (!cv || !CvPADLIST(cv))
765 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
766 sv = *av_fetch(av, targ, FALSE);
767 /* SvLEN in a pad name is not to be trusted */
769 sv_setpvn(name, str, len);
772 if (subscript_type == FUV_SUBSCRIPT_HASH) {
775 Perl_sv_catpvf(aTHX_ name, "{%s}",
776 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
779 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
781 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
783 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
784 sv_insert(name, 0, 0, "within ", 7);
791 =for apidoc find_uninit_var
793 Find the name of the undefined variable (if any) that caused the operator o
794 to issue a "Use of uninitialized value" warning.
795 If match is true, only return a name if it's value matches uninit_sv.
796 So roughly speaking, if a unary operator (such as OP_COS) generates a
797 warning, then following the direct child of the op may yield an
798 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
799 other hand, with OP_ADD there are two branches to follow, so we only print
800 the variable name if we get an exact match.
802 The name is returned as a mortal SV.
804 Assumes that PL_op is the op that originally triggered the error, and that
805 PL_comppad/PL_curpad points to the currently executing pad.
811 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
820 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
821 uninit_sv == &PL_sv_placeholder)))
824 switch (obase->op_type) {
831 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
832 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
835 int subscript_type = FUV_SUBSCRIPT_WITHIN;
837 if (pad) { /* @lex, %lex */
838 sv = PAD_SVl(obase->op_targ);
842 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
843 /* @global, %global */
844 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
847 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
849 else /* @{expr}, %{expr} */
850 return find_uninit_var(cUNOPx(obase)->op_first,
854 /* attempt to find a match within the aggregate */
856 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
858 subscript_type = FUV_SUBSCRIPT_HASH;
861 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
863 subscript_type = FUV_SUBSCRIPT_ARRAY;
866 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
869 return S_varname(aTHX_ gv, hash ? "%" : "@", obase->op_targ,
870 keysv, index, subscript_type);
874 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
876 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
877 Nullsv, 0, FUV_SUBSCRIPT_NONE);
880 gv = cGVOPx_gv(obase);
881 if (!gv || (match && GvSV(gv) != uninit_sv))
883 return S_varname(aTHX_ gv, "$", 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
886 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
888 av = (AV*)PAD_SV(obase->op_targ);
889 if (!av || SvRMAGICAL(av))
891 svp = av_fetch(av, (I32)obase->op_private, FALSE);
892 if (!svp || *svp != uninit_sv)
895 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
896 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
899 gv = cGVOPx_gv(obase);
904 if (!av || SvRMAGICAL(av))
906 svp = av_fetch(av, (I32)obase->op_private, FALSE);
907 if (!svp || *svp != uninit_sv)
910 return S_varname(aTHX_ gv, "$", 0,
911 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
916 o = cUNOPx(obase)->op_first;
917 if (!o || o->op_type != OP_NULL ||
918 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
920 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
925 /* $a[uninit_expr] or $h{uninit_expr} */
926 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
929 o = cBINOPx(obase)->op_first;
930 kid = cBINOPx(obase)->op_last;
932 /* get the av or hv, and optionally the gv */
934 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
935 sv = PAD_SV(o->op_targ);
937 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
938 && cUNOPo->op_first->op_type == OP_GV)
940 gv = cGVOPx_gv(cUNOPo->op_first);
943 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
948 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
949 /* index is constant */
953 if (obase->op_type == OP_HELEM) {
954 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
955 if (!he || HeVAL(he) != uninit_sv)
959 svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
960 if (!svp || *svp != uninit_sv)
964 if (obase->op_type == OP_HELEM)
965 return S_varname(aTHX_ gv, "%", o->op_targ,
966 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
968 return S_varname(aTHX_ gv, "@", o->op_targ, Nullsv,
969 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
973 /* index is an expression;
974 * attempt to find a match within the aggregate */
975 if (obase->op_type == OP_HELEM) {
976 SV *keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
978 return S_varname(aTHX_ gv, "%", o->op_targ,
979 keysv, 0, FUV_SUBSCRIPT_HASH);
982 const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
984 return S_varname(aTHX_ gv, "@", o->op_targ,
985 Nullsv, index, FUV_SUBSCRIPT_ARRAY);
989 return S_varname(aTHX_ gv,
990 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
992 o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
998 /* only examine RHS */
999 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
1002 o = cUNOPx(obase)->op_first;
1003 if (o->op_type == OP_PUSHMARK)
1006 if (!o->op_sibling) {
1007 /* one-arg version of open is highly magical */
1009 if (o->op_type == OP_GV) { /* open FOO; */
1011 if (match && GvSV(gv) != uninit_sv)
1013 return S_varname(aTHX_ gv, "$", 0,
1014 Nullsv, 0, FUV_SUBSCRIPT_NONE);
1016 /* other possibilities not handled are:
1017 * open $x; or open my $x; should return '${*$x}'
1018 * open expr; should return '$'.expr ideally
1024 /* ops where $_ may be an implicit arg */
1028 if ( !(obase->op_flags & OPf_STACKED)) {
1029 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
1030 ? PAD_SVl(obase->op_targ)
1033 sv = sv_newmortal();
1034 sv_setpvn(sv, "$_", 2);
1042 /* skip filehandle as it can't produce 'undef' warning */
1043 o = cUNOPx(obase)->op_first;
1044 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
1045 o = o->op_sibling->op_sibling;
1052 match = 1; /* XS or custom code could trigger random warnings */
1057 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
1058 return sv_2mortal(newSVpv("${$/}", 0));
1063 if (!(obase->op_flags & OPf_KIDS))
1065 o = cUNOPx(obase)->op_first;
1071 /* if all except one arg are constant, or have no side-effects,
1072 * or are optimized away, then it's unambiguous */
1074 for (kid=o; kid; kid = kid->op_sibling) {
1076 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
1077 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
1078 || (kid->op_type == OP_PUSHMARK)
1082 if (o2) { /* more than one found */
1089 return find_uninit_var(o2, uninit_sv, match);
1093 sv = find_uninit_var(o, uninit_sv, 1);
1105 =for apidoc report_uninit
1107 Print appropriate "Use of uninitialized variable" warning
1113 Perl_report_uninit(pTHX_ SV* uninit_sv)
1116 SV* varname = Nullsv;
1118 varname = find_uninit_var(PL_op, uninit_sv,0);
1120 sv_insert(varname, 0, 0, " ", 1);
1122 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1123 varname ? SvPV_nolen(varname) : "",
1124 " in ", OP_DESC(PL_op));
1127 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1131 /* allocate another arena's worth of NV bodies */
1139 New(711, ptr, PERL_ARENA_SIZE/sizeof(NV), NV);
1140 *((void **) ptr) = (void *)PL_xnv_arenaroot;
1141 PL_xnv_arenaroot = ptr;
1144 xnvend = &xnv[PERL_ARENA_SIZE / sizeof(NV) - 1];
1145 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
1147 while (xnv < xnvend) {
1148 *(NV**)xnv = (NV*)(xnv + 1);
1154 /* allocate another arena's worth of struct xpv */
1160 xpv_allocated* xpvend;
1161 New(713, xpv, PERL_ARENA_SIZE/sizeof(xpv_allocated), xpv_allocated);
1162 *((xpv_allocated**)xpv) = PL_xpv_arenaroot;
1163 PL_xpv_arenaroot = xpv;
1165 xpvend = &xpv[PERL_ARENA_SIZE / sizeof(xpv_allocated) - 1];
1166 PL_xpv_root = ++xpv;
1167 while (xpv < xpvend) {
1168 *((xpv_allocated**)xpv) = xpv + 1;
1171 *((xpv_allocated**)xpv) = 0;
1174 /* allocate another arena's worth of struct xpviv */
1179 xpviv_allocated* xpviv;
1180 xpviv_allocated* xpvivend;
1181 New(713, xpviv, PERL_ARENA_SIZE/sizeof(xpviv_allocated), xpviv_allocated);
1182 *((xpviv_allocated**)xpviv) = PL_xpviv_arenaroot;
1183 PL_xpviv_arenaroot = xpviv;
1185 xpvivend = &xpviv[PERL_ARENA_SIZE / sizeof(xpviv_allocated) - 1];
1186 PL_xpviv_root = ++xpviv;
1187 while (xpviv < xpvivend) {
1188 *((xpviv_allocated**)xpviv) = xpviv + 1;
1191 *((xpviv_allocated**)xpviv) = 0;
1194 /* allocate another arena's worth of struct xpvnv */
1201 New(715, xpvnv, PERL_ARENA_SIZE/sizeof(XPVNV), XPVNV);
1202 *((XPVNV**)xpvnv) = PL_xpvnv_arenaroot;
1203 PL_xpvnv_arenaroot = xpvnv;
1205 xpvnvend = &xpvnv[PERL_ARENA_SIZE / sizeof(XPVNV) - 1];
1206 PL_xpvnv_root = ++xpvnv;
1207 while (xpvnv < xpvnvend) {
1208 *((XPVNV**)xpvnv) = xpvnv + 1;
1211 *((XPVNV**)xpvnv) = 0;
1214 /* allocate another arena's worth of struct xpvcv */
1221 New(716, xpvcv, PERL_ARENA_SIZE/sizeof(XPVCV), XPVCV);
1222 *((XPVCV**)xpvcv) = PL_xpvcv_arenaroot;
1223 PL_xpvcv_arenaroot = xpvcv;
1225 xpvcvend = &xpvcv[PERL_ARENA_SIZE / sizeof(XPVCV) - 1];
1226 PL_xpvcv_root = ++xpvcv;
1227 while (xpvcv < xpvcvend) {
1228 *((XPVCV**)xpvcv) = xpvcv + 1;
1231 *((XPVCV**)xpvcv) = 0;
1234 /* allocate another arena's worth of struct xpvav */
1239 xpvav_allocated* xpvav;
1240 xpvav_allocated* xpvavend;
1241 New(717, xpvav, PERL_ARENA_SIZE/sizeof(xpvav_allocated),
1243 *((xpvav_allocated**)xpvav) = PL_xpvav_arenaroot;
1244 PL_xpvav_arenaroot = xpvav;
1246 xpvavend = &xpvav[PERL_ARENA_SIZE / sizeof(xpvav_allocated) - 1];
1247 PL_xpvav_root = ++xpvav;
1248 while (xpvav < xpvavend) {
1249 *((xpvav_allocated**)xpvav) = xpvav + 1;
1252 *((xpvav_allocated**)xpvav) = 0;
1255 /* allocate another arena's worth of struct xpvhv */
1260 xpvhv_allocated* xpvhv;
1261 xpvhv_allocated* xpvhvend;
1262 New(718, xpvhv, PERL_ARENA_SIZE/sizeof(xpvhv_allocated),
1264 *((xpvhv_allocated**)xpvhv) = PL_xpvhv_arenaroot;
1265 PL_xpvhv_arenaroot = xpvhv;
1267 xpvhvend = &xpvhv[PERL_ARENA_SIZE / sizeof(xpvhv_allocated) - 1];
1268 PL_xpvhv_root = ++xpvhv;
1269 while (xpvhv < xpvhvend) {
1270 *((xpvhv_allocated**)xpvhv) = xpvhv + 1;
1273 *((xpvhv_allocated**)xpvhv) = 0;
1276 /* allocate another arena's worth of struct xpvmg */
1283 New(719, xpvmg, PERL_ARENA_SIZE/sizeof(XPVMG), XPVMG);
1284 *((XPVMG**)xpvmg) = PL_xpvmg_arenaroot;
1285 PL_xpvmg_arenaroot = xpvmg;
1287 xpvmgend = &xpvmg[PERL_ARENA_SIZE / sizeof(XPVMG) - 1];
1288 PL_xpvmg_root = ++xpvmg;
1289 while (xpvmg < xpvmgend) {
1290 *((XPVMG**)xpvmg) = xpvmg + 1;
1293 *((XPVMG**)xpvmg) = 0;
1296 /* allocate another arena's worth of struct xpvgv */
1303 New(720, xpvgv, PERL_ARENA_SIZE/sizeof(XPVGV), XPVGV);
1304 *((XPVGV**)xpvgv) = PL_xpvgv_arenaroot;
1305 PL_xpvgv_arenaroot = xpvgv;
1307 xpvgvend = &xpvgv[PERL_ARENA_SIZE / sizeof(XPVGV) - 1];
1308 PL_xpvgv_root = ++xpvgv;
1309 while (xpvgv < xpvgvend) {
1310 *((XPVGV**)xpvgv) = xpvgv + 1;
1313 *((XPVGV**)xpvgv) = 0;
1316 /* allocate another arena's worth of struct xpvlv */
1323 New(720, xpvlv, PERL_ARENA_SIZE/sizeof(XPVLV), XPVLV);
1324 *((XPVLV**)xpvlv) = PL_xpvlv_arenaroot;
1325 PL_xpvlv_arenaroot = xpvlv;
1327 xpvlvend = &xpvlv[PERL_ARENA_SIZE / sizeof(XPVLV) - 1];
1328 PL_xpvlv_root = ++xpvlv;
1329 while (xpvlv < xpvlvend) {
1330 *((XPVLV**)xpvlv) = xpvlv + 1;
1333 *((XPVLV**)xpvlv) = 0;
1336 /* allocate another arena's worth of struct xpvbm */
1343 New(721, xpvbm, PERL_ARENA_SIZE/sizeof(XPVBM), XPVBM);
1344 *((XPVBM**)xpvbm) = PL_xpvbm_arenaroot;
1345 PL_xpvbm_arenaroot = xpvbm;
1347 xpvbmend = &xpvbm[PERL_ARENA_SIZE / sizeof(XPVBM) - 1];
1348 PL_xpvbm_root = ++xpvbm;
1349 while (xpvbm < xpvbmend) {
1350 *((XPVBM**)xpvbm) = xpvbm + 1;
1353 *((XPVBM**)xpvbm) = 0;
1356 /* grab a new NV body from the free list, allocating more if necessary */
1366 PL_xnv_root = *(NV**)xnv;
1368 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
1371 /* return an NV body to the free list */
1374 S_del_xnv(pTHX_ XPVNV *p)
1376 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
1378 *(NV**)xnv = PL_xnv_root;
1383 /* grab a new struct xpv from the free list, allocating more if necessary */
1393 PL_xpv_root = *(xpv_allocated**)xpv;
1395 /* If xpv_allocated is the same structure as XPV then the two OFFSETs
1396 sum to zero, and the pointer is unchanged. If the allocated structure
1397 is smaller (no initial IV actually allocated) then the net effect is
1398 to subtract the size of the IV from the pointer, to return a new pointer
1399 as if an initial IV were actually allocated. */
1400 return (XPV*)((char*)xpv - STRUCT_OFFSET(XPV, xpv_cur)
1401 + STRUCT_OFFSET(xpv_allocated, xpv_cur));
1404 /* return a struct xpv to the free list */
1407 S_del_xpv(pTHX_ XPV *p)
1410 = (xpv_allocated*)((char*)(p) + STRUCT_OFFSET(XPV, xpv_cur)
1411 - STRUCT_OFFSET(xpv_allocated, xpv_cur));
1413 *(xpv_allocated**)xpv = PL_xpv_root;
1418 /* grab a new struct xpviv from the free list, allocating more if necessary */
1423 xpviv_allocated* xpviv;
1427 xpviv = PL_xpviv_root;
1428 PL_xpviv_root = *(xpviv_allocated**)xpviv;
1430 /* If xpviv_allocated is the same structure as XPVIV then the two OFFSETs
1431 sum to zero, and the pointer is unchanged. If the allocated structure
1432 is smaller (no initial IV actually allocated) then the net effect is
1433 to subtract the size of the IV from the pointer, to return a new pointer
1434 as if an initial IV were actually allocated. */
1435 return (XPVIV*)((char*)xpviv - STRUCT_OFFSET(XPVIV, xpv_cur)
1436 + STRUCT_OFFSET(xpviv_allocated, xpv_cur));
1439 /* return a struct xpviv to the free list */
1442 S_del_xpviv(pTHX_ XPVIV *p)
1444 xpviv_allocated* xpviv
1445 = (xpviv_allocated*)((char*)(p) + STRUCT_OFFSET(XPVIV, xpv_cur)
1446 - STRUCT_OFFSET(xpviv_allocated, xpv_cur));
1448 *(xpviv_allocated**)xpviv = PL_xpviv_root;
1449 PL_xpviv_root = xpviv;
1453 /* grab a new struct xpvnv from the free list, allocating more if necessary */
1462 xpvnv = PL_xpvnv_root;
1463 PL_xpvnv_root = *(XPVNV**)xpvnv;
1468 /* return a struct xpvnv to the free list */
1471 S_del_xpvnv(pTHX_ XPVNV *p)
1474 *(XPVNV**)p = PL_xpvnv_root;
1479 /* grab a new struct xpvcv from the free list, allocating more if necessary */
1488 xpvcv = PL_xpvcv_root;
1489 PL_xpvcv_root = *(XPVCV**)xpvcv;
1494 /* return a struct xpvcv to the free list */
1497 S_del_xpvcv(pTHX_ XPVCV *p)
1500 *(XPVCV**)p = PL_xpvcv_root;
1505 /* grab a new struct xpvav from the free list, allocating more if necessary */
1510 xpvav_allocated* xpvav;
1514 xpvav = PL_xpvav_root;
1515 PL_xpvav_root = *(xpvav_allocated**)xpvav;
1517 return (XPVAV*)((char*)xpvav - STRUCT_OFFSET(XPVAV, xav_fill)
1518 + STRUCT_OFFSET(xpvav_allocated, xav_fill));
1521 /* return a struct xpvav to the free list */
1524 S_del_xpvav(pTHX_ XPVAV *p)
1526 xpvav_allocated* xpvav
1527 = (xpvav_allocated*)((char*)(p) + STRUCT_OFFSET(XPVAV, xav_fill)
1528 - STRUCT_OFFSET(xpvav_allocated, xav_fill));
1530 *(xpvav_allocated**)xpvav = PL_xpvav_root;
1531 PL_xpvav_root = xpvav;
1535 /* grab a new struct xpvhv from the free list, allocating more if necessary */
1540 xpvhv_allocated* xpvhv;
1544 xpvhv = PL_xpvhv_root;
1545 PL_xpvhv_root = *(xpvhv_allocated**)xpvhv;
1547 return (XPVHV*)((char*)xpvhv - STRUCT_OFFSET(XPVHV, xhv_fill)
1548 + STRUCT_OFFSET(xpvhv_allocated, xhv_fill));
1551 /* return a struct xpvhv to the free list */
1554 S_del_xpvhv(pTHX_ XPVHV *p)
1556 xpvhv_allocated* xpvhv
1557 = (xpvhv_allocated*)((char*)(p) + STRUCT_OFFSET(XPVHV, xhv_fill)
1558 - STRUCT_OFFSET(xpvhv_allocated, xhv_fill));
1560 *(xpvhv_allocated**)xpvhv = PL_xpvhv_root;
1561 PL_xpvhv_root = xpvhv;
1565 /* grab a new struct xpvmg from the free list, allocating more if necessary */
1574 xpvmg = PL_xpvmg_root;
1575 PL_xpvmg_root = *(XPVMG**)xpvmg;
1580 /* return a struct xpvmg to the free list */
1583 S_del_xpvmg(pTHX_ XPVMG *p)
1586 *(XPVMG**)p = PL_xpvmg_root;
1591 /* grab a new struct xpvgv from the free list, allocating more if necessary */
1600 xpvgv = PL_xpvgv_root;
1601 PL_xpvgv_root = *(XPVGV**)xpvgv;
1606 /* return a struct xpvgv to the free list */
1609 S_del_xpvgv(pTHX_ XPVGV *p)
1612 *(XPVGV**)p = PL_xpvgv_root;
1617 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1626 xpvlv = PL_xpvlv_root;
1627 PL_xpvlv_root = *(XPVLV**)xpvlv;
1632 /* return a struct xpvlv to the free list */
1635 S_del_xpvlv(pTHX_ XPVLV *p)
1638 *(XPVLV**)p = PL_xpvlv_root;
1643 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1652 xpvbm = PL_xpvbm_root;
1653 PL_xpvbm_root = *(XPVBM**)xpvbm;
1658 /* return a struct xpvbm to the free list */
1661 S_del_xpvbm(pTHX_ XPVBM *p)
1664 *(XPVBM**)p = PL_xpvbm_root;
1669 #define my_safemalloc(s) (void*)safemalloc(s)
1670 #define my_safefree(p) safefree((char*)p)
1674 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1675 #define del_XNV(p) my_safefree(p)
1677 #define new_XPV() my_safemalloc(sizeof(XPV))
1678 #define del_XPV(p) my_safefree(p)
1680 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1681 #define del_XPVIV(p) my_safefree(p)
1683 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1684 #define del_XPVNV(p) my_safefree(p)
1686 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1687 #define del_XPVCV(p) my_safefree(p)
1689 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1690 #define del_XPVAV(p) my_safefree(p)
1692 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1693 #define del_XPVHV(p) my_safefree(p)
1695 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1696 #define del_XPVMG(p) my_safefree(p)
1698 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1699 #define del_XPVGV(p) my_safefree(p)
1701 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1702 #define del_XPVLV(p) my_safefree(p)
1704 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1705 #define del_XPVBM(p) my_safefree(p)
1709 #define new_XNV() (void*)new_xnv()
1710 #define del_XNV(p) del_xnv((XPVNV*) p)
1712 #define new_XPV() (void*)new_xpv()
1713 #define del_XPV(p) del_xpv((XPV *)p)
1715 #define new_XPVIV() (void*)new_xpviv()
1716 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
1718 #define new_XPVNV() (void*)new_xpvnv()
1719 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
1721 #define new_XPVCV() (void*)new_xpvcv()
1722 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
1724 #define new_XPVAV() (void*)new_xpvav()
1725 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
1727 #define new_XPVHV() (void*)new_xpvhv()
1728 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
1730 #define new_XPVMG() (void*)new_xpvmg()
1731 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
1733 #define new_XPVGV() (void*)new_xpvgv()
1734 #define del_XPVGV(p) del_xpvgv((XPVGV *)p)
1736 #define new_XPVLV() (void*)new_xpvlv()
1737 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
1739 #define new_XPVBM() (void*)new_xpvbm()
1740 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
1744 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1745 #define del_XPVFM(p) my_safefree(p)
1747 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1748 #define del_XPVIO(p) my_safefree(p)
1751 =for apidoc sv_upgrade
1753 Upgrade an SV to a more complex form. Generally adds a new body type to the
1754 SV, then copies across as much information as possible from the old body.
1755 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1761 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1772 if (mt != SVt_PV && SvIsCOW(sv)) {
1773 sv_force_normal_flags(sv, 0);
1776 if (SvTYPE(sv) == mt)
1787 switch (SvTYPE(sv)) {
1794 else if (mt < SVt_PVIV)
1804 pv = (char*)SvRV(sv);
1807 pv = SvPVX_mutable(sv);
1813 else if (mt == SVt_NV)
1817 pv = SvPVX_mutable(sv);
1821 del_XPVIV(SvANY(sv));
1824 pv = SvPVX_mutable(sv);
1829 del_XPVNV(SvANY(sv));
1832 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1833 there's no way that it can be safely upgraded, because perl.c
1834 expects to Safefree(SvANY(PL_mess_sv)) */
1835 assert(sv != PL_mess_sv);
1836 /* This flag bit is used to mean other things in other scalar types.
1837 Given that it only has meaning inside the pad, it shouldn't be set
1838 on anything that can get upgraded. */
1839 assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
1840 pv = SvPVX_mutable(sv);
1845 magic = SvMAGIC(sv);
1846 stash = SvSTASH(sv);
1847 del_XPVMG(SvANY(sv));
1850 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1853 SvFLAGS(sv) &= ~SVTYPEMASK;
1858 Perl_croak(aTHX_ "Can't upgrade to undef");
1860 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1864 SvANY(sv) = new_XNV();
1868 SvANY(sv) = &sv->sv_u.svu_rv;
1869 SvRV_set(sv, (SV*)pv);
1872 SvANY(sv) = new_XPVHV();
1875 HvTOTALKEYS(sv) = 0;
1877 /* Fall through... */
1880 SvANY(sv) = new_XPVAV();
1887 /* XXX? Only SVt_NULL is ever upgraded to AV or HV? */
1889 /* FIXME. Should be able to remove all this if()... if the above
1890 assertion is genuinely always true. */
1893 SvFLAGS(sv) &= ~SVf_OOK;
1896 SvPV_set(sv, (char*)0);
1897 SvMAGIC_set(sv, magic);
1898 SvSTASH_set(sv, stash);
1902 SvANY(sv) = new_XPVIO();
1903 Zero(SvANY(sv), 1, XPVIO);
1904 IoPAGE_LEN(sv) = 60;
1905 goto set_magic_common;
1907 SvANY(sv) = new_XPVFM();
1908 Zero(SvANY(sv), 1, XPVFM);
1909 goto set_magic_common;
1911 SvANY(sv) = new_XPVBM();
1915 goto set_magic_common;
1917 SvANY(sv) = new_XPVGV();
1923 goto set_magic_common;
1925 SvANY(sv) = new_XPVCV();
1926 Zero(SvANY(sv), 1, XPVCV);
1927 goto set_magic_common;
1929 SvANY(sv) = new_XPVLV();
1942 SvANY(sv) = new_XPVMG();
1945 SvMAGIC_set(sv, magic);
1946 SvSTASH_set(sv, stash);
1950 SvANY(sv) = new_XPVNV();
1956 SvANY(sv) = new_XPVIV();
1965 SvANY(sv) = new_XPV();
1976 =for apidoc sv_backoff
1978 Remove any string offset. You should normally use the C<SvOOK_off> macro
1985 Perl_sv_backoff(pTHX_ register SV *sv)
1988 assert(SvTYPE(sv) != SVt_PVHV);
1989 assert(SvTYPE(sv) != SVt_PVAV);
1991 const char *s = SvPVX_const(sv);
1992 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1993 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1995 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1997 SvFLAGS(sv) &= ~SVf_OOK;
2004 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
2005 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
2006 Use the C<SvGROW> wrapper instead.
2012 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
2016 #ifdef HAS_64K_LIMIT
2017 if (newlen >= 0x10000) {
2018 PerlIO_printf(Perl_debug_log,
2019 "Allocation too large: %"UVxf"\n", (UV)newlen);
2022 #endif /* HAS_64K_LIMIT */
2025 if (SvTYPE(sv) < SVt_PV) {
2026 sv_upgrade(sv, SVt_PV);
2029 else if (SvOOK(sv)) { /* pv is offset? */
2032 if (newlen > SvLEN(sv))
2033 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
2034 #ifdef HAS_64K_LIMIT
2035 if (newlen >= 0x10000)
2040 s = SvPVX_mutable(sv);
2042 if (newlen > SvLEN(sv)) { /* need more room? */
2043 newlen = PERL_STRLEN_ROUNDUP(newlen);
2044 if (SvLEN(sv) && s) {
2046 const STRLEN l = malloced_size((void*)SvPVX(sv));
2052 s = saferealloc(s, newlen);
2055 s = safemalloc(newlen);
2056 if (SvPVX_const(sv) && SvCUR(sv)) {
2057 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
2061 SvLEN_set(sv, newlen);
2067 =for apidoc sv_setiv
2069 Copies an integer into the given SV, upgrading first if necessary.
2070 Does not handle 'set' magic. See also C<sv_setiv_mg>.
2076 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
2078 SV_CHECK_THINKFIRST_COW_DROP(sv);
2079 switch (SvTYPE(sv)) {
2081 sv_upgrade(sv, SVt_IV);
2084 sv_upgrade(sv, SVt_PVNV);
2088 sv_upgrade(sv, SVt_PVIV);
2097 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
2100 (void)SvIOK_only(sv); /* validate number */
2106 =for apidoc sv_setiv_mg
2108 Like C<sv_setiv>, but also handles 'set' magic.
2114 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
2121 =for apidoc sv_setuv
2123 Copies an unsigned integer into the given SV, upgrading first if necessary.
2124 Does not handle 'set' magic. See also C<sv_setuv_mg>.
2130 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
2132 /* With these two if statements:
2133 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2136 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2138 If you wish to remove them, please benchmark to see what the effect is
2140 if (u <= (UV)IV_MAX) {
2141 sv_setiv(sv, (IV)u);
2150 =for apidoc sv_setuv_mg
2152 Like C<sv_setuv>, but also handles 'set' magic.
2158 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
2160 /* With these two if statements:
2161 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2164 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2166 If you wish to remove them, please benchmark to see what the effect is
2168 if (u <= (UV)IV_MAX) {
2169 sv_setiv(sv, (IV)u);
2179 =for apidoc sv_setnv
2181 Copies a double into the given SV, upgrading first if necessary.
2182 Does not handle 'set' magic. See also C<sv_setnv_mg>.
2188 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
2190 SV_CHECK_THINKFIRST_COW_DROP(sv);
2191 switch (SvTYPE(sv)) {
2194 sv_upgrade(sv, SVt_NV);
2199 sv_upgrade(sv, SVt_PVNV);
2208 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
2212 (void)SvNOK_only(sv); /* validate number */
2217 =for apidoc sv_setnv_mg
2219 Like C<sv_setnv>, but also handles 'set' magic.
2225 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
2231 /* Print an "isn't numeric" warning, using a cleaned-up,
2232 * printable version of the offending string
2236 S_not_a_number(pTHX_ SV *sv)
2243 dsv = sv_2mortal(newSVpv("", 0));
2244 pv = sv_uni_display(dsv, sv, 10, 0);
2247 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
2248 /* each *s can expand to 4 chars + "...\0",
2249 i.e. need room for 8 chars */
2251 const char *s, *end;
2252 for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit;
2255 if (ch & 128 && !isPRINT_LC(ch)) {
2264 else if (ch == '\r') {
2268 else if (ch == '\f') {
2272 else if (ch == '\\') {
2276 else if (ch == '\0') {
2280 else if (isPRINT_LC(ch))
2297 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2298 "Argument \"%s\" isn't numeric in %s", pv,
2301 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2302 "Argument \"%s\" isn't numeric", pv);
2306 =for apidoc looks_like_number
2308 Test if the content of an SV looks like a number (or is a number).
2309 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
2310 non-numeric warning), even if your atof() doesn't grok them.
2316 Perl_looks_like_number(pTHX_ SV *sv)
2318 register const char *sbegin;
2322 sbegin = SvPVX_const(sv);
2325 else if (SvPOKp(sv))
2326 sbegin = SvPV(sv, len);
2328 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
2329 return grok_number(sbegin, len, NULL);
2332 /* Actually, ISO C leaves conversion of UV to IV undefined, but
2333 until proven guilty, assume that things are not that bad... */
2338 As 64 bit platforms often have an NV that doesn't preserve all bits of
2339 an IV (an assumption perl has been based on to date) it becomes necessary
2340 to remove the assumption that the NV always carries enough precision to
2341 recreate the IV whenever needed, and that the NV is the canonical form.
2342 Instead, IV/UV and NV need to be given equal rights. So as to not lose
2343 precision as a side effect of conversion (which would lead to insanity
2344 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
2345 1) to distinguish between IV/UV/NV slots that have cached a valid
2346 conversion where precision was lost and IV/UV/NV slots that have a
2347 valid conversion which has lost no precision
2348 2) to ensure that if a numeric conversion to one form is requested that
2349 would lose precision, the precise conversion (or differently
2350 imprecise conversion) is also performed and cached, to prevent
2351 requests for different numeric formats on the same SV causing
2352 lossy conversion chains. (lossless conversion chains are perfectly
2357 SvIOKp is true if the IV slot contains a valid value
2358 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
2359 SvNOKp is true if the NV slot contains a valid value
2360 SvNOK is true only if the NV value is accurate
2363 while converting from PV to NV, check to see if converting that NV to an
2364 IV(or UV) would lose accuracy over a direct conversion from PV to
2365 IV(or UV). If it would, cache both conversions, return NV, but mark
2366 SV as IOK NOKp (ie not NOK).
2368 While converting from PV to IV, check to see if converting that IV to an
2369 NV would lose accuracy over a direct conversion from PV to NV. If it
2370 would, cache both conversions, flag similarly.
2372 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2373 correctly because if IV & NV were set NV *always* overruled.
2374 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2375 changes - now IV and NV together means that the two are interchangeable:
2376 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
2378 The benefit of this is that operations such as pp_add know that if
2379 SvIOK is true for both left and right operands, then integer addition
2380 can be used instead of floating point (for cases where the result won't
2381 overflow). Before, floating point was always used, which could lead to
2382 loss of precision compared with integer addition.
2384 * making IV and NV equal status should make maths accurate on 64 bit
2386 * may speed up maths somewhat if pp_add and friends start to use
2387 integers when possible instead of fp. (Hopefully the overhead in
2388 looking for SvIOK and checking for overflow will not outweigh the
2389 fp to integer speedup)
2390 * will slow down integer operations (callers of SvIV) on "inaccurate"
2391 values, as the change from SvIOK to SvIOKp will cause a call into
2392 sv_2iv each time rather than a macro access direct to the IV slot
2393 * should speed up number->string conversion on integers as IV is
2394 favoured when IV and NV are equally accurate
2396 ####################################################################
2397 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2398 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2399 On the other hand, SvUOK is true iff UV.
2400 ####################################################################
2402 Your mileage will vary depending your CPU's relative fp to integer
2406 #ifndef NV_PRESERVES_UV
2407 # define IS_NUMBER_UNDERFLOW_IV 1
2408 # define IS_NUMBER_UNDERFLOW_UV 2
2409 # define IS_NUMBER_IV_AND_UV 2
2410 # define IS_NUMBER_OVERFLOW_IV 4
2411 # define IS_NUMBER_OVERFLOW_UV 5
2413 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2415 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2417 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2419 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));
2420 if (SvNVX(sv) < (NV)IV_MIN) {
2421 (void)SvIOKp_on(sv);
2423 SvIV_set(sv, IV_MIN);
2424 return IS_NUMBER_UNDERFLOW_IV;
2426 if (SvNVX(sv) > (NV)UV_MAX) {
2427 (void)SvIOKp_on(sv);
2430 SvUV_set(sv, UV_MAX);
2431 return IS_NUMBER_OVERFLOW_UV;
2433 (void)SvIOKp_on(sv);
2435 /* Can't use strtol etc to convert this string. (See truth table in
2437 if (SvNVX(sv) <= (UV)IV_MAX) {
2438 SvIV_set(sv, I_V(SvNVX(sv)));
2439 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2440 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2442 /* Integer is imprecise. NOK, IOKp */
2444 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2447 SvUV_set(sv, U_V(SvNVX(sv)));
2448 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2449 if (SvUVX(sv) == UV_MAX) {
2450 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2451 possibly be preserved by NV. Hence, it must be overflow.
2453 return IS_NUMBER_OVERFLOW_UV;
2455 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2457 /* Integer is imprecise. NOK, IOKp */
2459 return IS_NUMBER_OVERFLOW_IV;
2461 #endif /* !NV_PRESERVES_UV*/
2463 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
2464 * this function provided for binary compatibility only
2468 Perl_sv_2iv(pTHX_ register SV *sv)
2470 return sv_2iv_flags(sv, SV_GMAGIC);
2474 =for apidoc sv_2iv_flags
2476 Return the integer value of an SV, doing any necessary string
2477 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2478 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2484 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2488 if (SvGMAGICAL(sv)) {
2489 if (flags & SV_GMAGIC)
2494 return I_V(SvNVX(sv));
2496 if (SvPOKp(sv) && SvLEN(sv))
2499 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2500 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2506 if (SvTHINKFIRST(sv)) {
2509 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2510 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2511 return SvIV(tmpstr);
2512 return PTR2IV(SvRV(sv));
2515 sv_force_normal_flags(sv, 0);
2517 if (SvREADONLY(sv) && !SvOK(sv)) {
2518 if (ckWARN(WARN_UNINITIALIZED))
2525 return (IV)(SvUVX(sv));
2532 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2533 * without also getting a cached IV/UV from it at the same time
2534 * (ie PV->NV conversion should detect loss of accuracy and cache
2535 * IV or UV at same time to avoid this. NWC */
2537 if (SvTYPE(sv) == SVt_NV)
2538 sv_upgrade(sv, SVt_PVNV);
2540 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2541 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2542 certainly cast into the IV range at IV_MAX, whereas the correct
2543 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2545 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2546 SvIV_set(sv, I_V(SvNVX(sv)));
2547 if (SvNVX(sv) == (NV) SvIVX(sv)
2548 #ifndef NV_PRESERVES_UV
2549 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2550 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2551 /* Don't flag it as "accurately an integer" if the number
2552 came from a (by definition imprecise) NV operation, and
2553 we're outside the range of NV integer precision */
2556 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2557 DEBUG_c(PerlIO_printf(Perl_debug_log,
2558 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2564 /* IV not precise. No need to convert from PV, as NV
2565 conversion would already have cached IV if it detected
2566 that PV->IV would be better than PV->NV->IV
2567 flags already correct - don't set public IOK. */
2568 DEBUG_c(PerlIO_printf(Perl_debug_log,
2569 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2574 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2575 but the cast (NV)IV_MIN rounds to a the value less (more
2576 negative) than IV_MIN which happens to be equal to SvNVX ??
2577 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2578 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2579 (NV)UVX == NVX are both true, but the values differ. :-(
2580 Hopefully for 2s complement IV_MIN is something like
2581 0x8000000000000000 which will be exact. NWC */
2584 SvUV_set(sv, U_V(SvNVX(sv)));
2586 (SvNVX(sv) == (NV) SvUVX(sv))
2587 #ifndef NV_PRESERVES_UV
2588 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2589 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2590 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2591 /* Don't flag it as "accurately an integer" if the number
2592 came from a (by definition imprecise) NV operation, and
2593 we're outside the range of NV integer precision */
2599 DEBUG_c(PerlIO_printf(Perl_debug_log,
2600 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2604 return (IV)SvUVX(sv);
2607 else if (SvPOKp(sv) && SvLEN(sv)) {
2609 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2610 /* We want to avoid a possible problem when we cache an IV which
2611 may be later translated to an NV, and the resulting NV is not
2612 the same as the direct translation of the initial string
2613 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2614 be careful to ensure that the value with the .456 is around if the
2615 NV value is requested in the future).
2617 This means that if we cache such an IV, we need to cache the
2618 NV as well. Moreover, we trade speed for space, and do not
2619 cache the NV if we are sure it's not needed.
2622 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2623 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2624 == IS_NUMBER_IN_UV) {
2625 /* It's definitely an integer, only upgrade to PVIV */
2626 if (SvTYPE(sv) < SVt_PVIV)
2627 sv_upgrade(sv, SVt_PVIV);
2629 } else if (SvTYPE(sv) < SVt_PVNV)
2630 sv_upgrade(sv, SVt_PVNV);
2632 /* If NV preserves UV then we only use the UV value if we know that
2633 we aren't going to call atof() below. If NVs don't preserve UVs
2634 then the value returned may have more precision than atof() will
2635 return, even though value isn't perfectly accurate. */
2636 if ((numtype & (IS_NUMBER_IN_UV
2637 #ifdef NV_PRESERVES_UV
2640 )) == IS_NUMBER_IN_UV) {
2641 /* This won't turn off the public IOK flag if it was set above */
2642 (void)SvIOKp_on(sv);
2644 if (!(numtype & IS_NUMBER_NEG)) {
2646 if (value <= (UV)IV_MAX) {
2647 SvIV_set(sv, (IV)value);
2649 SvUV_set(sv, value);
2653 /* 2s complement assumption */
2654 if (value <= (UV)IV_MIN) {
2655 SvIV_set(sv, -(IV)value);
2657 /* Too negative for an IV. This is a double upgrade, but
2658 I'm assuming it will be rare. */
2659 if (SvTYPE(sv) < SVt_PVNV)
2660 sv_upgrade(sv, SVt_PVNV);
2664 SvNV_set(sv, -(NV)value);
2665 SvIV_set(sv, IV_MIN);
2669 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2670 will be in the previous block to set the IV slot, and the next
2671 block to set the NV slot. So no else here. */
2673 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2674 != IS_NUMBER_IN_UV) {
2675 /* It wasn't an (integer that doesn't overflow the UV). */
2676 SvNV_set(sv, Atof(SvPVX_const(sv)));
2678 if (! numtype && ckWARN(WARN_NUMERIC))
2681 #if defined(USE_LONG_DOUBLE)
2682 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2683 PTR2UV(sv), SvNVX(sv)));
2685 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2686 PTR2UV(sv), SvNVX(sv)));
2690 #ifdef NV_PRESERVES_UV
2691 (void)SvIOKp_on(sv);
2693 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2694 SvIV_set(sv, I_V(SvNVX(sv)));
2695 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2698 /* Integer is imprecise. NOK, IOKp */
2700 /* UV will not work better than IV */
2702 if (SvNVX(sv) > (NV)UV_MAX) {
2704 /* Integer is inaccurate. NOK, IOKp, is UV */
2705 SvUV_set(sv, UV_MAX);
2708 SvUV_set(sv, U_V(SvNVX(sv)));
2709 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2710 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2714 /* Integer is imprecise. NOK, IOKp, is UV */
2720 #else /* NV_PRESERVES_UV */
2721 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2722 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2723 /* The IV slot will have been set from value returned by
2724 grok_number above. The NV slot has just been set using
2727 assert (SvIOKp(sv));
2729 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2730 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2731 /* Small enough to preserve all bits. */
2732 (void)SvIOKp_on(sv);
2734 SvIV_set(sv, I_V(SvNVX(sv)));
2735 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2737 /* Assumption: first non-preserved integer is < IV_MAX,
2738 this NV is in the preserved range, therefore: */
2739 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2741 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);
2745 0 0 already failed to read UV.
2746 0 1 already failed to read UV.
2747 1 0 you won't get here in this case. IV/UV
2748 slot set, public IOK, Atof() unneeded.
2749 1 1 already read UV.
2750 so there's no point in sv_2iuv_non_preserve() attempting
2751 to use atol, strtol, strtoul etc. */
2752 if (sv_2iuv_non_preserve (sv, numtype)
2753 >= IS_NUMBER_OVERFLOW_IV)
2757 #endif /* NV_PRESERVES_UV */
2760 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2762 if (SvTYPE(sv) < SVt_IV)
2763 /* Typically the caller expects that sv_any is not NULL now. */
2764 sv_upgrade(sv, SVt_IV);
2767 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2768 PTR2UV(sv),SvIVX(sv)));
2769 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2772 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2773 * this function provided for binary compatibility only
2777 Perl_sv_2uv(pTHX_ register SV *sv)
2779 return sv_2uv_flags(sv, SV_GMAGIC);
2783 =for apidoc sv_2uv_flags
2785 Return the unsigned integer value of an SV, doing any necessary string
2786 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2787 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2793 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2797 if (SvGMAGICAL(sv)) {
2798 if (flags & SV_GMAGIC)
2803 return U_V(SvNVX(sv));
2804 if (SvPOKp(sv) && SvLEN(sv))
2807 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2808 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2814 if (SvTHINKFIRST(sv)) {
2817 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2818 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2819 return SvUV(tmpstr);
2820 return PTR2UV(SvRV(sv));
2823 sv_force_normal_flags(sv, 0);
2825 if (SvREADONLY(sv) && !SvOK(sv)) {
2826 if (ckWARN(WARN_UNINITIALIZED))
2836 return (UV)SvIVX(sv);
2840 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2841 * without also getting a cached IV/UV from it at the same time
2842 * (ie PV->NV conversion should detect loss of accuracy and cache
2843 * IV or UV at same time to avoid this. */
2844 /* IV-over-UV optimisation - choose to cache IV if possible */
2846 if (SvTYPE(sv) == SVt_NV)
2847 sv_upgrade(sv, SVt_PVNV);
2849 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2850 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2851 SvIV_set(sv, I_V(SvNVX(sv)));
2852 if (SvNVX(sv) == (NV) SvIVX(sv)
2853 #ifndef NV_PRESERVES_UV
2854 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2855 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2856 /* Don't flag it as "accurately an integer" if the number
2857 came from a (by definition imprecise) NV operation, and
2858 we're outside the range of NV integer precision */
2861 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2862 DEBUG_c(PerlIO_printf(Perl_debug_log,
2863 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2869 /* IV not precise. No need to convert from PV, as NV
2870 conversion would already have cached IV if it detected
2871 that PV->IV would be better than PV->NV->IV
2872 flags already correct - don't set public IOK. */
2873 DEBUG_c(PerlIO_printf(Perl_debug_log,
2874 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2879 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2880 but the cast (NV)IV_MIN rounds to a the value less (more
2881 negative) than IV_MIN which happens to be equal to SvNVX ??
2882 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2883 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2884 (NV)UVX == NVX are both true, but the values differ. :-(
2885 Hopefully for 2s complement IV_MIN is something like
2886 0x8000000000000000 which will be exact. NWC */
2889 SvUV_set(sv, U_V(SvNVX(sv)));
2891 (SvNVX(sv) == (NV) SvUVX(sv))
2892 #ifndef NV_PRESERVES_UV
2893 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2894 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2895 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2896 /* Don't flag it as "accurately an integer" if the number
2897 came from a (by definition imprecise) NV operation, and
2898 we're outside the range of NV integer precision */
2903 DEBUG_c(PerlIO_printf(Perl_debug_log,
2904 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2910 else if (SvPOKp(sv) && SvLEN(sv)) {
2912 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2914 /* We want to avoid a possible problem when we cache a UV which
2915 may be later translated to an NV, and the resulting NV is not
2916 the translation of the initial data.
2918 This means that if we cache such a UV, we need to cache the
2919 NV as well. Moreover, we trade speed for space, and do not
2920 cache the NV if not needed.
2923 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2924 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2925 == IS_NUMBER_IN_UV) {
2926 /* It's definitely an integer, only upgrade to PVIV */
2927 if (SvTYPE(sv) < SVt_PVIV)
2928 sv_upgrade(sv, SVt_PVIV);
2930 } else if (SvTYPE(sv) < SVt_PVNV)
2931 sv_upgrade(sv, SVt_PVNV);
2933 /* If NV preserves UV then we only use the UV value if we know that
2934 we aren't going to call atof() below. If NVs don't preserve UVs
2935 then the value returned may have more precision than atof() will
2936 return, even though it isn't accurate. */
2937 if ((numtype & (IS_NUMBER_IN_UV
2938 #ifdef NV_PRESERVES_UV
2941 )) == IS_NUMBER_IN_UV) {
2942 /* This won't turn off the public IOK flag if it was set above */
2943 (void)SvIOKp_on(sv);
2945 if (!(numtype & IS_NUMBER_NEG)) {
2947 if (value <= (UV)IV_MAX) {
2948 SvIV_set(sv, (IV)value);
2950 /* it didn't overflow, and it was positive. */
2951 SvUV_set(sv, value);
2955 /* 2s complement assumption */
2956 if (value <= (UV)IV_MIN) {
2957 SvIV_set(sv, -(IV)value);
2959 /* Too negative for an IV. This is a double upgrade, but
2960 I'm assuming it will be rare. */
2961 if (SvTYPE(sv) < SVt_PVNV)
2962 sv_upgrade(sv, SVt_PVNV);
2966 SvNV_set(sv, -(NV)value);
2967 SvIV_set(sv, IV_MIN);
2972 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2973 != IS_NUMBER_IN_UV) {
2974 /* It wasn't an integer, or it overflowed the UV. */
2975 SvNV_set(sv, Atof(SvPVX_const(sv)));
2977 if (! numtype && ckWARN(WARN_NUMERIC))
2980 #if defined(USE_LONG_DOUBLE)
2981 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2982 PTR2UV(sv), SvNVX(sv)));
2984 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2985 PTR2UV(sv), SvNVX(sv)));
2988 #ifdef NV_PRESERVES_UV
2989 (void)SvIOKp_on(sv);
2991 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2992 SvIV_set(sv, I_V(SvNVX(sv)));
2993 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2996 /* Integer is imprecise. NOK, IOKp */
2998 /* UV will not work better than IV */
3000 if (SvNVX(sv) > (NV)UV_MAX) {
3002 /* Integer is inaccurate. NOK, IOKp, is UV */
3003 SvUV_set(sv, UV_MAX);
3006 SvUV_set(sv, U_V(SvNVX(sv)));
3007 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
3008 NV preservse UV so can do correct comparison. */
3009 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
3013 /* Integer is imprecise. NOK, IOKp, is UV */
3018 #else /* NV_PRESERVES_UV */
3019 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3020 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
3021 /* The UV slot will have been set from value returned by
3022 grok_number above. The NV slot has just been set using
3025 assert (SvIOKp(sv));
3027 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3028 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3029 /* Small enough to preserve all bits. */
3030 (void)SvIOKp_on(sv);
3032 SvIV_set(sv, I_V(SvNVX(sv)));
3033 if ((NV)(SvIVX(sv)) == SvNVX(sv))
3035 /* Assumption: first non-preserved integer is < IV_MAX,
3036 this NV is in the preserved range, therefore: */
3037 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
3039 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);
3042 sv_2iuv_non_preserve (sv, numtype);
3044 #endif /* NV_PRESERVES_UV */
3048 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3049 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3052 if (SvTYPE(sv) < SVt_IV)
3053 /* Typically the caller expects that sv_any is not NULL now. */
3054 sv_upgrade(sv, SVt_IV);
3058 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
3059 PTR2UV(sv),SvUVX(sv)));
3060 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
3066 Return the num value of an SV, doing any necessary string or integer
3067 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
3074 Perl_sv_2nv(pTHX_ register SV *sv)
3078 if (SvGMAGICAL(sv)) {
3082 if (SvPOKp(sv) && SvLEN(sv)) {
3083 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
3084 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
3086 return Atof(SvPVX_const(sv));
3090 return (NV)SvUVX(sv);
3092 return (NV)SvIVX(sv);
3095 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3096 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3102 if (SvTHINKFIRST(sv)) {
3105 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
3106 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
3107 return SvNV(tmpstr);
3108 return PTR2NV(SvRV(sv));
3111 sv_force_normal_flags(sv, 0);
3113 if (SvREADONLY(sv) && !SvOK(sv)) {
3114 if (ckWARN(WARN_UNINITIALIZED))
3119 if (SvTYPE(sv) < SVt_NV) {
3120 if (SvTYPE(sv) == SVt_IV)
3121 sv_upgrade(sv, SVt_PVNV);
3123 sv_upgrade(sv, SVt_NV);
3124 #ifdef USE_LONG_DOUBLE
3126 STORE_NUMERIC_LOCAL_SET_STANDARD();
3127 PerlIO_printf(Perl_debug_log,
3128 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
3129 PTR2UV(sv), SvNVX(sv));
3130 RESTORE_NUMERIC_LOCAL();
3134 STORE_NUMERIC_LOCAL_SET_STANDARD();
3135 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
3136 PTR2UV(sv), SvNVX(sv));
3137 RESTORE_NUMERIC_LOCAL();
3141 else if (SvTYPE(sv) < SVt_PVNV)
3142 sv_upgrade(sv, SVt_PVNV);
3147 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
3148 #ifdef NV_PRESERVES_UV
3151 /* Only set the public NV OK flag if this NV preserves the IV */
3152 /* Check it's not 0xFFFFFFFFFFFFFFFF */
3153 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
3154 : (SvIVX(sv) == I_V(SvNVX(sv))))
3160 else if (SvPOKp(sv) && SvLEN(sv)) {
3162 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
3163 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
3165 #ifdef NV_PRESERVES_UV
3166 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3167 == IS_NUMBER_IN_UV) {
3168 /* It's definitely an integer */
3169 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
3171 SvNV_set(sv, Atof(SvPVX_const(sv)));
3174 SvNV_set(sv, Atof(SvPVX_const(sv)));
3175 /* Only set the public NV OK flag if this NV preserves the value in
3176 the PV at least as well as an IV/UV would.
3177 Not sure how to do this 100% reliably. */
3178 /* if that shift count is out of range then Configure's test is
3179 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
3181 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3182 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3183 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
3184 } else if (!(numtype & IS_NUMBER_IN_UV)) {
3185 /* Can't use strtol etc to convert this string, so don't try.
3186 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
3189 /* value has been set. It may not be precise. */
3190 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
3191 /* 2s complement assumption for (UV)IV_MIN */
3192 SvNOK_on(sv); /* Integer is too negative. */
3197 if (numtype & IS_NUMBER_NEG) {
3198 SvIV_set(sv, -(IV)value);
3199 } else if (value <= (UV)IV_MAX) {
3200 SvIV_set(sv, (IV)value);
3202 SvUV_set(sv, value);
3206 if (numtype & IS_NUMBER_NOT_INT) {
3207 /* I believe that even if the original PV had decimals,
3208 they are lost beyond the limit of the FP precision.
3209 However, neither is canonical, so both only get p
3210 flags. NWC, 2000/11/25 */
3211 /* Both already have p flags, so do nothing */
3213 const NV nv = SvNVX(sv);
3214 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3215 if (SvIVX(sv) == I_V(nv)) {
3220 /* It had no "." so it must be integer. */
3223 /* between IV_MAX and NV(UV_MAX).
3224 Could be slightly > UV_MAX */
3226 if (numtype & IS_NUMBER_NOT_INT) {
3227 /* UV and NV both imprecise. */
3229 const UV nv_as_uv = U_V(nv);
3231 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
3242 #endif /* NV_PRESERVES_UV */
3245 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3247 if (SvTYPE(sv) < SVt_NV)
3248 /* Typically the caller expects that sv_any is not NULL now. */
3249 /* XXX Ilya implies that this is a bug in callers that assume this
3250 and ideally should be fixed. */
3251 sv_upgrade(sv, SVt_NV);
3254 #if defined(USE_LONG_DOUBLE)
3256 STORE_NUMERIC_LOCAL_SET_STANDARD();
3257 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
3258 PTR2UV(sv), SvNVX(sv));
3259 RESTORE_NUMERIC_LOCAL();
3263 STORE_NUMERIC_LOCAL_SET_STANDARD();
3264 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
3265 PTR2UV(sv), SvNVX(sv));
3266 RESTORE_NUMERIC_LOCAL();
3272 /* asIV(): extract an integer from the string value of an SV.
3273 * Caller must validate PVX */
3276 S_asIV(pTHX_ SV *sv)
3279 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
3281 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3282 == IS_NUMBER_IN_UV) {
3283 /* It's definitely an integer */
3284 if (numtype & IS_NUMBER_NEG) {
3285 if (value < (UV)IV_MIN)
3288 if (value < (UV)IV_MAX)
3293 if (ckWARN(WARN_NUMERIC))
3296 return I_V(Atof(SvPVX_const(sv)));
3299 /* asUV(): extract an unsigned integer from the string value of an SV
3300 * Caller must validate PVX */
3303 S_asUV(pTHX_ SV *sv)
3306 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
3308 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3309 == IS_NUMBER_IN_UV) {
3310 /* It's definitely an integer */
3311 if (!(numtype & IS_NUMBER_NEG))
3315 if (ckWARN(WARN_NUMERIC))
3318 return U_V(Atof(SvPVX_const(sv)));
3322 =for apidoc sv_2pv_nolen
3324 Like C<sv_2pv()>, but doesn't return the length too. You should usually
3325 use the macro wrapper C<SvPV_nolen(sv)> instead.
3330 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
3332 return sv_2pv(sv, 0);
3335 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
3336 * UV as a string towards the end of buf, and return pointers to start and
3339 * We assume that buf is at least TYPE_CHARS(UV) long.
3343 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
3345 char *ptr = buf + TYPE_CHARS(UV);
3359 *--ptr = '0' + (char)(uv % 10);
3367 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
3368 * this function provided for binary compatibility only
3372 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
3374 return sv_2pv_flags(sv, lp, SV_GMAGIC);
3378 =for apidoc sv_2pv_flags
3380 Returns a pointer to the string value of an SV, and sets *lp to its length.
3381 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
3383 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
3384 usually end up here too.
3390 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3395 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3396 char *tmpbuf = tbuf;
3400 /* Saves needing to do lots of if (!lp) checks below */
3408 if (SvGMAGICAL(sv)) {
3409 if (flags & SV_GMAGIC)
3413 if (flags & SV_MUTABLE_RETURN)
3414 return SvPVX_mutable(sv);
3415 if (flags & SV_CONST_RETURN)
3416 return (char *)SvPVX_const(sv);
3421 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
3423 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3428 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3433 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3434 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3441 if (SvTHINKFIRST(sv)) {
3444 register const char *typestr;
3445 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3446 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3447 char *pv = SvPV(tmpstr, *lp);
3457 typestr = "NULLREF";
3461 switch (SvTYPE(sv)) {
3463 if ( ((SvFLAGS(sv) &
3464 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3465 == (SVs_OBJECT|SVs_SMG))
3466 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3467 const regexp *re = (regexp *)mg->mg_obj;
3470 const char *fptr = "msix";
3475 char need_newline = 0;
3476 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3478 while((ch = *fptr++)) {
3480 reflags[left++] = ch;
3483 reflags[right--] = ch;
3488 reflags[left] = '-';
3492 mg->mg_len = re->prelen + 4 + left;
3494 * If /x was used, we have to worry about a regex
3495 * ending with a comment later being embedded
3496 * within another regex. If so, we don't want this
3497 * regex's "commentization" to leak out to the
3498 * right part of the enclosing regex, we must cap
3499 * it with a newline.
3501 * So, if /x was used, we scan backwards from the
3502 * end of the regex. If we find a '#' before we
3503 * find a newline, we need to add a newline
3504 * ourself. If we find a '\n' first (or if we
3505 * don't find '#' or '\n'), we don't need to add
3506 * anything. -jfriedl
3508 if (PMf_EXTENDED & re->reganch)
3510 const char *endptr = re->precomp + re->prelen;
3511 while (endptr >= re->precomp)
3513 const char c = *(endptr--);
3515 break; /* don't need another */
3517 /* we end while in a comment, so we
3519 mg->mg_len++; /* save space for it */
3520 need_newline = 1; /* note to add it */
3526 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3527 Copy("(?", mg->mg_ptr, 2, char);
3528 Copy(reflags, mg->mg_ptr+2, left, char);
3529 Copy(":", mg->mg_ptr+left+2, 1, char);
3530 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3532 mg->mg_ptr[mg->mg_len - 2] = '\n';
3533 mg->mg_ptr[mg->mg_len - 1] = ')';
3534 mg->mg_ptr[mg->mg_len] = 0;
3536 PL_reginterp_cnt += re->program[0].next_off;
3538 if (re->reganch & ROPT_UTF8)
3553 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3554 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3555 /* tied lvalues should appear to be
3556 * scalars for backwards compatitbility */
3557 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3558 ? "SCALAR" : "LVALUE"; break;
3559 case SVt_PVAV: typestr = "ARRAY"; break;
3560 case SVt_PVHV: typestr = "HASH"; break;
3561 case SVt_PVCV: typestr = "CODE"; break;
3562 case SVt_PVGV: typestr = "GLOB"; break;
3563 case SVt_PVFM: typestr = "FORMAT"; break;
3564 case SVt_PVIO: typestr = "IO"; break;
3565 default: typestr = "UNKNOWN"; break;
3569 const char *name = HvNAME_get(SvSTASH(sv));
3570 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3571 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3574 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3577 *lp = strlen(typestr);
3578 return (char *)typestr;
3580 if (SvREADONLY(sv) && !SvOK(sv)) {
3581 if (ckWARN(WARN_UNINITIALIZED))
3587 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3588 /* I'm assuming that if both IV and NV are equally valid then
3589 converting the IV is going to be more efficient */
3590 const U32 isIOK = SvIOK(sv);
3591 const U32 isUIOK = SvIsUV(sv);
3592 char buf[TYPE_CHARS(UV)];
3595 if (SvTYPE(sv) < SVt_PVIV)
3596 sv_upgrade(sv, SVt_PVIV);
3598 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3600 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3601 SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */
3602 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
3603 SvCUR_set(sv, ebuf - ptr);
3613 else if (SvNOKp(sv)) {
3614 if (SvTYPE(sv) < SVt_PVNV)
3615 sv_upgrade(sv, SVt_PVNV);
3616 /* The +20 is pure guesswork. Configure test needed. --jhi */
3617 SvGROW(sv, NV_DIG + 20);
3618 s = SvPVX_mutable(sv);
3619 olderrno = errno; /* some Xenix systems wipe out errno here */
3621 if (SvNVX(sv) == 0.0)
3622 (void)strcpy(s,"0");
3626 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3629 #ifdef FIXNEGATIVEZERO
3630 if (*s == '-' && s[1] == '0' && !s[2])
3640 if (ckWARN(WARN_UNINITIALIZED)
3641 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3644 if (SvTYPE(sv) < SVt_PV)
3645 /* Typically the caller expects that sv_any is not NULL now. */
3646 sv_upgrade(sv, SVt_PV);
3649 *lp = s - SvPVX_const(sv);
3652 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3653 PTR2UV(sv),SvPVX_const(sv)));
3654 if (flags & SV_CONST_RETURN)
3655 return (char *)SvPVX_const(sv);
3656 if (flags & SV_MUTABLE_RETURN)
3657 return SvPVX_mutable(sv);
3661 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3662 /* Sneaky stuff here */
3666 tsv = newSVpv(tmpbuf, 0);
3678 t = SvPVX_const(tsv);
3683 len = strlen(tmpbuf);
3685 #ifdef FIXNEGATIVEZERO
3686 if (len == 2 && t[0] == '-' && t[1] == '0') {
3691 SvUPGRADE(sv, SVt_PV);
3693 s = SvGROW(sv, len + 1);
3696 return strcpy(s, t);
3701 =for apidoc sv_copypv
3703 Copies a stringified representation of the source SV into the
3704 destination SV. Automatically performs any necessary mg_get and
3705 coercion of numeric values into strings. Guaranteed to preserve
3706 UTF-8 flag even from overloaded objects. Similar in nature to
3707 sv_2pv[_flags] but operates directly on an SV instead of just the
3708 string. Mostly uses sv_2pv_flags to do its work, except when that
3709 would lose the UTF-8'ness of the PV.
3715 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3719 s = SvPV_const(ssv,len);
3720 sv_setpvn(dsv,s,len);
3728 =for apidoc sv_2pvbyte_nolen
3730 Return a pointer to the byte-encoded representation of the SV.
3731 May cause the SV to be downgraded from UTF-8 as a side-effect.
3733 Usually accessed via the C<SvPVbyte_nolen> macro.
3739 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3741 return sv_2pvbyte(sv, 0);
3745 =for apidoc sv_2pvbyte
3747 Return a pointer to the byte-encoded representation of the SV, and set *lp
3748 to its length. May cause the SV to be downgraded from UTF-8 as a
3751 Usually accessed via the C<SvPVbyte> macro.
3757 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3759 sv_utf8_downgrade(sv,0);
3760 return SvPV(sv,*lp);
3764 =for apidoc sv_2pvutf8_nolen
3766 Return a pointer to the UTF-8-encoded representation of the SV.
3767 May cause the SV to be upgraded to UTF-8 as a side-effect.
3769 Usually accessed via the C<SvPVutf8_nolen> macro.
3775 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3777 return sv_2pvutf8(sv, 0);
3781 =for apidoc sv_2pvutf8
3783 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3784 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3786 Usually accessed via the C<SvPVutf8> macro.
3792 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3794 sv_utf8_upgrade(sv);
3795 return SvPV(sv,*lp);
3799 =for apidoc sv_2bool
3801 This function is only called on magical items, and is only used by
3802 sv_true() or its macro equivalent.
3808 Perl_sv_2bool(pTHX_ register SV *sv)
3817 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3818 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3819 return (bool)SvTRUE(tmpsv);
3820 return SvRV(sv) != 0;
3823 register XPV* Xpvtmp;
3824 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3825 (*sv->sv_u.svu_pv > '0' ||
3826 Xpvtmp->xpv_cur > 1 ||
3827 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3834 return SvIVX(sv) != 0;
3837 return SvNVX(sv) != 0.0;
3844 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3845 * this function provided for binary compatibility only
3850 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3852 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3856 =for apidoc sv_utf8_upgrade
3858 Converts the PV of an SV to its UTF-8-encoded form.
3859 Forces the SV to string form if it is not already.
3860 Always sets the SvUTF8 flag to avoid future validity checks even
3861 if all the bytes have hibit clear.
3863 This is not as a general purpose byte encoding to Unicode interface:
3864 use the Encode extension for that.
3866 =for apidoc sv_utf8_upgrade_flags
3868 Converts the PV of an SV to its UTF-8-encoded form.
3869 Forces the SV to string form if it is not already.
3870 Always sets the SvUTF8 flag to avoid future validity checks even
3871 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3872 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3873 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3875 This is not as a general purpose byte encoding to Unicode interface:
3876 use the Encode extension for that.
3882 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3884 if (sv == &PL_sv_undef)
3888 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3889 (void) sv_2pv_flags(sv,&len, flags);
3893 (void) SvPV_force(sv,len);
3902 sv_force_normal_flags(sv, 0);
3905 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3906 sv_recode_to_utf8(sv, PL_encoding);
3907 else { /* Assume Latin-1/EBCDIC */
3908 /* This function could be much more efficient if we
3909 * had a FLAG in SVs to signal if there are any hibit
3910 * chars in the PV. Given that there isn't such a flag
3911 * make the loop as fast as possible. */
3912 U8 *s = (U8 *) SvPVX(sv);
3913 U8 *e = (U8 *) SvEND(sv);
3919 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3923 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3924 s = bytes_to_utf8((U8*)s, &len);
3926 SvPV_free(sv); /* No longer using what was there before. */
3928 SvPV_set(sv, (char*)s);
3929 SvCUR_set(sv, len - 1);
3930 SvLEN_set(sv, len); /* No longer know the real size. */
3932 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3939 =for apidoc sv_utf8_downgrade
3941 Attempts to convert the PV of an SV from characters to bytes.
3942 If the PV contains a character beyond byte, this conversion will fail;
3943 in this case, either returns false or, if C<fail_ok> is not
3946 This is not as a general purpose Unicode to byte encoding interface:
3947 use the Encode extension for that.
3953 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3955 if (SvPOKp(sv) && SvUTF8(sv)) {
3961 sv_force_normal_flags(sv, 0);
3963 s = (U8 *) SvPV(sv, len);
3964 if (!utf8_to_bytes(s, &len)) {
3969 Perl_croak(aTHX_ "Wide character in %s",
3972 Perl_croak(aTHX_ "Wide character");
3983 =for apidoc sv_utf8_encode
3985 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3986 flag off so that it looks like octets again.
3992 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3994 (void) sv_utf8_upgrade(sv);
3996 sv_force_normal_flags(sv, 0);
3998 if (SvREADONLY(sv)) {
3999 Perl_croak(aTHX_ PL_no_modify);
4005 =for apidoc sv_utf8_decode
4007 If the PV of the SV is an octet sequence in UTF-8
4008 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
4009 so that it looks like a character. If the PV contains only single-byte
4010 characters, the C<SvUTF8> flag stays being off.
4011 Scans PV for validity and returns false if the PV is invalid UTF-8.
4017 Perl_sv_utf8_decode(pTHX_ register SV *sv)
4023 /* The octets may have got themselves encoded - get them back as
4026 if (!sv_utf8_downgrade(sv, TRUE))
4029 /* it is actually just a matter of turning the utf8 flag on, but
4030 * we want to make sure everything inside is valid utf8 first.
4032 c = (U8 *) SvPVX(sv);
4033 if (!is_utf8_string(c, SvCUR(sv)+1))
4035 e = (U8 *) SvEND(sv);
4038 if (!UTF8_IS_INVARIANT(ch)) {
4047 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
4048 * this function provided for binary compatibility only
4052 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
4054 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
4058 =for apidoc sv_setsv
4060 Copies the contents of the source SV C<ssv> into the destination SV
4061 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4062 function if the source SV needs to be reused. Does not handle 'set' magic.
4063 Loosely speaking, it performs a copy-by-value, obliterating any previous
4064 content of the destination.
4066 You probably want to use one of the assortment of wrappers, such as
4067 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4068 C<SvSetMagicSV_nosteal>.
4070 =for apidoc sv_setsv_flags
4072 Copies the contents of the source SV C<ssv> into the destination SV
4073 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4074 function if the source SV needs to be reused. Does not handle 'set' magic.
4075 Loosely speaking, it performs a copy-by-value, obliterating any previous
4076 content of the destination.
4077 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
4078 C<ssv> if appropriate, else not. If the C<flags> parameter has the
4079 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
4080 and C<sv_setsv_nomg> are implemented in terms of this function.
4082 You probably want to use one of the assortment of wrappers, such as
4083 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4084 C<SvSetMagicSV_nosteal>.
4086 This is the primary function for copying scalars, and most other
4087 copy-ish functions and macros use this underneath.
4093 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
4095 register U32 sflags;
4101 SV_CHECK_THINKFIRST_COW_DROP(dstr);
4103 sstr = &PL_sv_undef;
4104 stype = SvTYPE(sstr);
4105 dtype = SvTYPE(dstr);
4110 /* need to nuke the magic */
4112 SvRMAGICAL_off(dstr);
4115 /* There's a lot of redundancy below but we're going for speed here */
4120 if (dtype != SVt_PVGV) {
4121 (void)SvOK_off(dstr);
4129 sv_upgrade(dstr, SVt_IV);
4132 sv_upgrade(dstr, SVt_PVNV);
4136 sv_upgrade(dstr, SVt_PVIV);
4139 (void)SvIOK_only(dstr);
4140 SvIV_set(dstr, SvIVX(sstr));
4143 if (SvTAINTED(sstr))
4154 sv_upgrade(dstr, SVt_NV);
4159 sv_upgrade(dstr, SVt_PVNV);
4162 SvNV_set(dstr, SvNVX(sstr));
4163 (void)SvNOK_only(dstr);
4164 if (SvTAINTED(sstr))
4172 sv_upgrade(dstr, SVt_RV);
4173 else if (dtype == SVt_PVGV &&
4174 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
4177 if (GvIMPORTED(dstr) != GVf_IMPORTED
4178 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4180 GvIMPORTED_on(dstr);
4189 #ifdef PERL_COPY_ON_WRITE
4190 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
4191 if (dtype < SVt_PVIV)
4192 sv_upgrade(dstr, SVt_PVIV);
4199 sv_upgrade(dstr, SVt_PV);
4202 if (dtype < SVt_PVIV)
4203 sv_upgrade(dstr, SVt_PVIV);
4206 if (dtype < SVt_PVNV)
4207 sv_upgrade(dstr, SVt_PVNV);
4214 const char * const type = sv_reftype(sstr,0);
4216 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
4218 Perl_croak(aTHX_ "Bizarre copy of %s", type);
4223 if (dtype <= SVt_PVGV) {
4225 if (dtype != SVt_PVGV) {
4226 const char * const name = GvNAME(sstr);
4227 const STRLEN len = GvNAMELEN(sstr);
4228 /* don't upgrade SVt_PVLV: it can hold a glob */
4229 if (dtype != SVt_PVLV)
4230 sv_upgrade(dstr, SVt_PVGV);
4231 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
4232 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
4233 GvNAME(dstr) = savepvn(name, len);
4234 GvNAMELEN(dstr) = len;
4235 SvFAKE_on(dstr); /* can coerce to non-glob */
4237 /* ahem, death to those who redefine active sort subs */
4238 else if (PL_curstackinfo->si_type == PERLSI_SORT
4239 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
4240 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
4243 #ifdef GV_UNIQUE_CHECK
4244 if (GvUNIQUE((GV*)dstr)) {
4245 Perl_croak(aTHX_ PL_no_modify);
4249 (void)SvOK_off(dstr);
4250 GvINTRO_off(dstr); /* one-shot flag */
4252 GvGP(dstr) = gp_ref(GvGP(sstr));
4253 if (SvTAINTED(sstr))
4255 if (GvIMPORTED(dstr) != GVf_IMPORTED
4256 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4258 GvIMPORTED_on(dstr);
4266 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4268 if ((int)SvTYPE(sstr) != stype) {
4269 stype = SvTYPE(sstr);
4270 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
4274 if (stype == SVt_PVLV)
4275 SvUPGRADE(dstr, SVt_PVNV);
4277 SvUPGRADE(dstr, (U32)stype);
4280 sflags = SvFLAGS(sstr);
4282 if (sflags & SVf_ROK) {
4283 if (dtype >= SVt_PV) {
4284 if (dtype == SVt_PVGV) {
4285 SV *sref = SvREFCNT_inc(SvRV(sstr));
4287 const int intro = GvINTRO(dstr);
4289 #ifdef GV_UNIQUE_CHECK
4290 if (GvUNIQUE((GV*)dstr)) {
4291 Perl_croak(aTHX_ PL_no_modify);
4296 GvINTRO_off(dstr); /* one-shot flag */
4297 GvLINE(dstr) = CopLINE(PL_curcop);
4298 GvEGV(dstr) = (GV*)dstr;
4301 switch (SvTYPE(sref)) {
4304 SAVEGENERICSV(GvAV(dstr));
4306 dref = (SV*)GvAV(dstr);
4307 GvAV(dstr) = (AV*)sref;
4308 if (!GvIMPORTED_AV(dstr)
4309 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4311 GvIMPORTED_AV_on(dstr);
4316 SAVEGENERICSV(GvHV(dstr));
4318 dref = (SV*)GvHV(dstr);
4319 GvHV(dstr) = (HV*)sref;
4320 if (!GvIMPORTED_HV(dstr)
4321 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4323 GvIMPORTED_HV_on(dstr);
4328 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
4329 SvREFCNT_dec(GvCV(dstr));
4330 GvCV(dstr) = Nullcv;
4331 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4332 PL_sub_generation++;
4334 SAVEGENERICSV(GvCV(dstr));
4337 dref = (SV*)GvCV(dstr);
4338 if (GvCV(dstr) != (CV*)sref) {
4339 CV* cv = GvCV(dstr);
4341 if (!GvCVGEN((GV*)dstr) &&
4342 (CvROOT(cv) || CvXSUB(cv)))
4344 /* ahem, death to those who redefine
4345 * active sort subs */
4346 if (PL_curstackinfo->si_type == PERLSI_SORT &&
4347 PL_sortcop == CvSTART(cv))
4349 "Can't redefine active sort subroutine %s",
4350 GvENAME((GV*)dstr));
4351 /* Redefining a sub - warning is mandatory if
4352 it was a const and its value changed. */
4353 if (ckWARN(WARN_REDEFINE)
4355 && (!CvCONST((CV*)sref)
4356 || sv_cmp(cv_const_sv(cv),
4357 cv_const_sv((CV*)sref)))))
4359 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4361 ? "Constant subroutine %s::%s redefined"
4362 : "Subroutine %s::%s redefined",
4363 HvNAME_get(GvSTASH((GV*)dstr)),
4364 GvENAME((GV*)dstr));
4368 cv_ckproto(cv, (GV*)dstr,
4369 SvPOK(sref) ? SvPVX(sref) : Nullch);
4371 GvCV(dstr) = (CV*)sref;
4372 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4373 GvASSUMECV_on(dstr);
4374 PL_sub_generation++;
4376 if (!GvIMPORTED_CV(dstr)
4377 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4379 GvIMPORTED_CV_on(dstr);
4384 SAVEGENERICSV(GvIOp(dstr));
4386 dref = (SV*)GvIOp(dstr);
4387 GvIOp(dstr) = (IO*)sref;
4391 SAVEGENERICSV(GvFORM(dstr));
4393 dref = (SV*)GvFORM(dstr);
4394 GvFORM(dstr) = (CV*)sref;
4398 SAVEGENERICSV(GvSV(dstr));
4400 dref = (SV*)GvSV(dstr);
4402 if (!GvIMPORTED_SV(dstr)
4403 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4405 GvIMPORTED_SV_on(dstr);
4411 if (SvTAINTED(sstr))
4415 if (SvPVX_const(dstr)) {
4421 (void)SvOK_off(dstr);
4422 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4424 if (sflags & SVp_NOK) {
4426 /* Only set the public OK flag if the source has public OK. */
4427 if (sflags & SVf_NOK)
4428 SvFLAGS(dstr) |= SVf_NOK;
4429 SvNV_set(dstr, SvNVX(sstr));
4431 if (sflags & SVp_IOK) {
4432 (void)SvIOKp_on(dstr);
4433 if (sflags & SVf_IOK)
4434 SvFLAGS(dstr) |= SVf_IOK;
4435 if (sflags & SVf_IVisUV)
4437 SvIV_set(dstr, SvIVX(sstr));
4439 if (SvAMAGIC(sstr)) {
4443 else if (sflags & SVp_POK) {
4447 * Check to see if we can just swipe the string. If so, it's a
4448 * possible small lose on short strings, but a big win on long ones.
4449 * It might even be a win on short strings if SvPVX_const(dstr)
4450 * has to be allocated and SvPVX_const(sstr) has to be freed.
4453 /* Whichever path we take through the next code, we want this true,
4454 and doing it now facilitates the COW check. */
4455 (void)SvPOK_only(dstr);
4458 /* We're not already COW */
4459 ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4460 #ifndef PERL_COPY_ON_WRITE
4461 /* or we are, but dstr isn't a suitable target. */
4462 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
4467 (sflags & SVs_TEMP) && /* slated for free anyway? */
4468 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4469 (!(flags & SV_NOSTEAL)) &&
4470 /* and we're allowed to steal temps */
4471 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4472 SvLEN(sstr) && /* and really is a string */
4473 /* and won't be needed again, potentially */
4474 !(PL_op && PL_op->op_type == OP_AASSIGN))
4475 #ifdef PERL_COPY_ON_WRITE
4476 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4477 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4478 && SvTYPE(sstr) >= SVt_PVIV)
4481 /* Failed the swipe test, and it's not a shared hash key either.
4482 Have to copy the string. */
4483 STRLEN len = SvCUR(sstr);
4484 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4485 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4486 SvCUR_set(dstr, len);
4487 *SvEND(dstr) = '\0';
4489 /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
4491 /* Either it's a shared hash key, or it's suitable for
4492 copy-on-write or we can swipe the string. */
4494 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4498 #ifdef PERL_COPY_ON_WRITE
4500 /* I believe I should acquire a global SV mutex if
4501 it's a COW sv (not a shared hash key) to stop
4502 it going un copy-on-write.
4503 If the source SV has gone un copy on write between up there
4504 and down here, then (assert() that) it is of the correct
4505 form to make it copy on write again */
4506 if ((sflags & (SVf_FAKE | SVf_READONLY))
4507 != (SVf_FAKE | SVf_READONLY)) {
4508 SvREADONLY_on(sstr);
4510 /* Make the source SV into a loop of 1.
4511 (about to become 2) */
4512 SV_COW_NEXT_SV_SET(sstr, sstr);
4516 /* Initial code is common. */
4517 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4519 SvFLAGS(dstr) &= ~SVf_OOK;
4520 Safefree(SvPVX_const(dstr) - SvIVX(dstr));
4522 else if (SvLEN(dstr))
4523 Safefree(SvPVX_const(dstr));
4527 /* making another shared SV. */
4528 STRLEN cur = SvCUR(sstr);
4529 STRLEN len = SvLEN(sstr);
4530 #ifdef PERL_COPY_ON_WRITE
4532 assert (SvTYPE(dstr) >= SVt_PVIV);
4533 /* SvIsCOW_normal */
4534 /* splice us in between source and next-after-source. */
4535 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4536 SV_COW_NEXT_SV_SET(sstr, dstr);
4537 SvPV_set(dstr, SvPVX(sstr));
4541 /* SvIsCOW_shared_hash */
4542 UV hash = SvSHARED_HASH(sstr);
4543 DEBUG_C(PerlIO_printf(Perl_debug_log,
4544 "Copy on write: Sharing hash\n"));
4546 assert (SvTYPE(dstr) >= SVt_PVIV);
4548 sharepvn(SvPVX_const(sstr),
4549 (sflags & SVf_UTF8?-cur:cur), hash));
4550 SvUV_set(dstr, hash);
4552 SvLEN_set(dstr, len);
4553 SvCUR_set(dstr, cur);
4554 SvREADONLY_on(dstr);
4556 /* Relesase a global SV mutex. */
4559 { /* Passes the swipe test. */
4560 SvPV_set(dstr, SvPVX(sstr));
4561 SvLEN_set(dstr, SvLEN(sstr));
4562 SvCUR_set(dstr, SvCUR(sstr));
4565 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4566 SvPV_set(sstr, Nullch);
4572 if (sflags & SVf_UTF8)
4575 if (sflags & SVp_NOK) {
4577 if (sflags & SVf_NOK)
4578 SvFLAGS(dstr) |= SVf_NOK;
4579 SvNV_set(dstr, SvNVX(sstr));
4581 if (sflags & SVp_IOK) {
4582 (void)SvIOKp_on(dstr);
4583 if (sflags & SVf_IOK)
4584 SvFLAGS(dstr) |= SVf_IOK;
4585 if (sflags & SVf_IVisUV)
4587 SvIV_set(dstr, SvIVX(sstr));
4590 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4591 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4592 smg->mg_ptr, smg->mg_len);
4593 SvRMAGICAL_on(dstr);
4596 else if (sflags & SVp_IOK) {
4597 if (sflags & SVf_IOK)
4598 (void)SvIOK_only(dstr);
4600 (void)SvOK_off(dstr);
4601 (void)SvIOKp_on(dstr);
4603 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4604 if (sflags & SVf_IVisUV)
4606 SvIV_set(dstr, SvIVX(sstr));
4607 if (sflags & SVp_NOK) {
4608 if (sflags & SVf_NOK)
4609 (void)SvNOK_on(dstr);
4611 (void)SvNOKp_on(dstr);
4612 SvNV_set(dstr, SvNVX(sstr));
4615 else if (sflags & SVp_NOK) {
4616 if (sflags & SVf_NOK)
4617 (void)SvNOK_only(dstr);
4619 (void)SvOK_off(dstr);
4622 SvNV_set(dstr, SvNVX(sstr));
4625 if (dtype == SVt_PVGV) {
4626 if (ckWARN(WARN_MISC))
4627 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4630 (void)SvOK_off(dstr);
4632 if (SvTAINTED(sstr))
4637 =for apidoc sv_setsv_mg
4639 Like C<sv_setsv>, but also handles 'set' magic.
4645 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4647 sv_setsv(dstr,sstr);
4651 #ifdef PERL_COPY_ON_WRITE
4653 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4655 STRLEN cur = SvCUR(sstr);
4656 STRLEN len = SvLEN(sstr);
4657 register char *new_pv;
4660 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4668 if (SvTHINKFIRST(dstr))
4669 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4670 else if (SvPVX_const(dstr))
4671 Safefree(SvPVX_const(dstr));
4675 SvUPGRADE(dstr, SVt_PVIV);
4677 assert (SvPOK(sstr));
4678 assert (SvPOKp(sstr));
4679 assert (!SvIOK(sstr));
4680 assert (!SvIOKp(sstr));
4681 assert (!SvNOK(sstr));
4682 assert (!SvNOKp(sstr));
4684 if (SvIsCOW(sstr)) {
4686 if (SvLEN(sstr) == 0) {
4687 /* source is a COW shared hash key. */
4688 UV hash = SvSHARED_HASH(sstr);
4689 DEBUG_C(PerlIO_printf(Perl_debug_log,
4690 "Fast copy on write: Sharing hash\n"));
4691 SvUV_set(dstr, hash);
4692 new_pv = sharepvn(SvPVX_const(sstr), (SvUTF8(sstr)?-cur:cur), hash);
4695 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4697 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4698 SvUPGRADE(sstr, SVt_PVIV);
4699 SvREADONLY_on(sstr);
4701 DEBUG_C(PerlIO_printf(Perl_debug_log,
4702 "Fast copy on write: Converting sstr to COW\n"));
4703 SV_COW_NEXT_SV_SET(dstr, sstr);
4705 SV_COW_NEXT_SV_SET(sstr, dstr);
4706 new_pv = SvPVX(sstr);
4709 SvPV_set(dstr, new_pv);
4710 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4713 SvLEN_set(dstr, len);
4714 SvCUR_set(dstr, cur);
4723 =for apidoc sv_setpvn
4725 Copies a string into an SV. The C<len> parameter indicates the number of
4726 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4727 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4733 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4735 register char *dptr;
4737 SV_CHECK_THINKFIRST_COW_DROP(sv);
4743 /* len is STRLEN which is unsigned, need to copy to signed */
4746 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4748 SvUPGRADE(sv, SVt_PV);
4750 SvGROW(sv, len + 1);
4752 Move(ptr,dptr,len,char);
4755 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4760 =for apidoc sv_setpvn_mg
4762 Like C<sv_setpvn>, but also handles 'set' magic.
4768 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4770 sv_setpvn(sv,ptr,len);
4775 =for apidoc sv_setpv
4777 Copies a string into an SV. The string must be null-terminated. Does not
4778 handle 'set' magic. See C<sv_setpv_mg>.
4784 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4786 register STRLEN len;
4788 SV_CHECK_THINKFIRST_COW_DROP(sv);
4794 SvUPGRADE(sv, SVt_PV);
4796 SvGROW(sv, len + 1);
4797 Move(ptr,SvPVX(sv),len+1,char);
4799 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4804 =for apidoc sv_setpv_mg
4806 Like C<sv_setpv>, but also handles 'set' magic.
4812 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4819 =for apidoc sv_usepvn
4821 Tells an SV to use C<ptr> to find its string value. Normally the string is
4822 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4823 The C<ptr> should point to memory that was allocated by C<malloc>. The
4824 string length, C<len>, must be supplied. This function will realloc the
4825 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4826 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4827 See C<sv_usepvn_mg>.
4833 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4836 SV_CHECK_THINKFIRST_COW_DROP(sv);
4837 SvUPGRADE(sv, SVt_PV);
4842 if (SvPVX_const(sv))
4845 allocate = PERL_STRLEN_ROUNDUP(len + 1);
4846 ptr = saferealloc (ptr, allocate);
4849 SvLEN_set(sv, allocate);
4851 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4856 =for apidoc sv_usepvn_mg
4858 Like C<sv_usepvn>, but also handles 'set' magic.
4864 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4866 sv_usepvn(sv,ptr,len);
4870 #ifdef PERL_COPY_ON_WRITE
4871 /* Need to do this *after* making the SV normal, as we need the buffer
4872 pointer to remain valid until after we've copied it. If we let go too early,
4873 another thread could invalidate it by unsharing last of the same hash key
4874 (which it can do by means other than releasing copy-on-write Svs)
4875 or by changing the other copy-on-write SVs in the loop. */
4877 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN cur, STRLEN len,
4878 U32 hash, SV *after)
4880 if (len) { /* this SV was SvIsCOW_normal(sv) */
4881 /* we need to find the SV pointing to us. */
4882 SV *current = SV_COW_NEXT_SV(after);
4884 if (current == sv) {
4885 /* The SV we point to points back to us (there were only two of us
4887 Hence other SV is no longer copy on write either. */
4889 SvREADONLY_off(after);
4891 /* We need to follow the pointers around the loop. */
4893 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4896 /* don't loop forever if the structure is bust, and we have
4897 a pointer into a closed loop. */
4898 assert (current != after);
4899 assert (SvPVX_const(current) == pvx);
4901 /* Make the SV before us point to the SV after us. */
4902 SV_COW_NEXT_SV_SET(current, after);
4905 unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash);
4910 Perl_sv_release_IVX(pTHX_ register SV *sv)
4913 sv_force_normal_flags(sv, 0);
4919 =for apidoc sv_force_normal_flags
4921 Undo various types of fakery on an SV: if the PV is a shared string, make
4922 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4923 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4924 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4925 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4926 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4927 set to some other value.) In addition, the C<flags> parameter gets passed to
4928 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4929 with flags set to 0.
4935 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4937 #ifdef PERL_COPY_ON_WRITE
4938 if (SvREADONLY(sv)) {
4939 /* At this point I believe I should acquire a global SV mutex. */
4941 const char *pvx = SvPVX_const(sv);
4942 const STRLEN len = SvLEN(sv);
4943 const STRLEN cur = SvCUR(sv);
4944 const U32 hash = SvSHARED_HASH(sv);
4945 SV *const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
4947 PerlIO_printf(Perl_debug_log,
4948 "Copy on write: Force normal %ld\n",
4954 /* This SV doesn't own the buffer, so need to New() a new one: */
4955 SvPV_set(sv, (char*)0);
4957 if (flags & SV_COW_DROP_PV) {
4958 /* OK, so we don't need to copy our buffer. */
4961 SvGROW(sv, cur + 1);
4962 Move(pvx,SvPVX(sv),cur,char);
4966 sv_release_COW(sv, pvx, cur, len, hash, next);
4971 else if (IN_PERL_RUNTIME)
4972 Perl_croak(aTHX_ PL_no_modify);
4973 /* At this point I believe that I can drop the global SV mutex. */
4976 if (SvREADONLY(sv)) {
4978 const char *pvx = SvPVX_const(sv);
4979 const int is_utf8 = SvUTF8(sv);
4980 const STRLEN len = SvCUR(sv);
4981 const U32 hash = SvSHARED_HASH(sv);
4984 SvPV_set(sv, Nullch);
4986 SvGROW(sv, len + 1);
4987 Move(pvx,SvPVX_const(sv),len,char);
4989 unsharepvn(pvx, is_utf8 ? -(I32)len : len, hash);
4991 else if (IN_PERL_RUNTIME)
4992 Perl_croak(aTHX_ PL_no_modify);
4996 sv_unref_flags(sv, flags);
4997 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
5002 =for apidoc sv_force_normal
5004 Undo various types of fakery on an SV: if the PV is a shared string, make
5005 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5006 an xpvmg. See also C<sv_force_normal_flags>.
5012 Perl_sv_force_normal(pTHX_ register SV *sv)
5014 sv_force_normal_flags(sv, 0);
5020 Efficient removal of characters from the beginning of the string buffer.
5021 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
5022 the string buffer. The C<ptr> becomes the first character of the adjusted
5023 string. Uses the "OOK hack".
5024 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
5025 refer to the same chunk of data.
5031 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
5033 register STRLEN delta;
5034 if (!ptr || !SvPOKp(sv))
5036 delta = ptr - SvPVX_const(sv);
5037 SV_CHECK_THINKFIRST(sv);
5038 if (SvTYPE(sv) < SVt_PVIV)
5039 sv_upgrade(sv,SVt_PVIV);
5042 if (!SvLEN(sv)) { /* make copy of shared string */
5043 const char *pvx = SvPVX_const(sv);
5044 STRLEN len = SvCUR(sv);
5045 SvGROW(sv, len + 1);
5046 Move(pvx,SvPVX_const(sv),len,char);
5050 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
5051 and we do that anyway inside the SvNIOK_off
5053 SvFLAGS(sv) |= SVf_OOK;
5056 SvLEN_set(sv, SvLEN(sv) - delta);
5057 SvCUR_set(sv, SvCUR(sv) - delta);
5058 SvPV_set(sv, SvPVX(sv) + delta);
5059 SvIV_set(sv, SvIVX(sv) + delta);
5062 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
5063 * this function provided for binary compatibility only
5067 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
5069 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
5073 =for apidoc sv_catpvn
5075 Concatenates the string onto the end of the string which is in the SV. The
5076 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5077 status set, then the bytes appended should be valid UTF-8.
5078 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
5080 =for apidoc sv_catpvn_flags
5082 Concatenates the string onto the end of the string which is in the SV. The
5083 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5084 status set, then the bytes appended should be valid UTF-8.
5085 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
5086 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5087 in terms of this function.
5093 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
5096 const char *dstr = SvPV_force_flags(dsv, dlen, flags);
5098 SvGROW(dsv, dlen + slen + 1);
5100 sstr = SvPVX_const(dsv);
5101 Move(sstr, SvPVX(dsv) + dlen, slen, char);
5102 SvCUR_set(dsv, SvCUR(dsv) + slen);
5104 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
5109 =for apidoc sv_catpvn_mg
5111 Like C<sv_catpvn>, but also handles 'set' magic.
5117 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
5119 sv_catpvn(sv,ptr,len);
5123 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
5124 * this function provided for binary compatibility only
5128 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
5130 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
5134 =for apidoc sv_catsv
5136 Concatenates the string from SV C<ssv> onto the end of the string in
5137 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
5138 not 'set' magic. See C<sv_catsv_mg>.
5140 =for apidoc sv_catsv_flags
5142 Concatenates the string from SV C<ssv> onto the end of the string in
5143 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
5144 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
5145 and C<sv_catsv_nomg> are implemented in terms of this function.
5150 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
5156 if ((spv = SvPV_const(ssv, slen))) {
5157 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
5158 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
5159 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
5160 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
5161 dsv->sv_flags doesn't have that bit set.
5162 Andy Dougherty 12 Oct 2001
5164 const I32 sutf8 = DO_UTF8(ssv);
5167 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
5169 dutf8 = DO_UTF8(dsv);
5171 if (dutf8 != sutf8) {
5173 /* Not modifying source SV, so taking a temporary copy. */
5174 SV* csv = sv_2mortal(newSVpvn(spv, slen));
5176 sv_utf8_upgrade(csv);
5177 spv = SvPV(csv, slen);
5180 sv_utf8_upgrade_nomg(dsv);
5182 sv_catpvn_nomg(dsv, spv, slen);
5187 =for apidoc sv_catsv_mg
5189 Like C<sv_catsv>, but also handles 'set' magic.
5195 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
5202 =for apidoc sv_catpv
5204 Concatenates the string onto the end of the string which is in the SV.
5205 If the SV has the UTF-8 status set, then the bytes appended should be
5206 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
5211 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
5213 register STRLEN len;
5219 junk = SvPV_force(sv, tlen);
5221 SvGROW(sv, tlen + len + 1);
5223 ptr = SvPVX_const(sv);
5224 Move(ptr,SvPVX(sv)+tlen,len+1,char);
5225 SvCUR_set(sv, SvCUR(sv) + len);
5226 (void)SvPOK_only_UTF8(sv); /* validate pointer */
5231 =for apidoc sv_catpv_mg
5233 Like C<sv_catpv>, but also handles 'set' magic.
5239 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
5248 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
5249 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
5256 Perl_newSV(pTHX_ STRLEN len)
5262 sv_upgrade(sv, SVt_PV);
5263 SvGROW(sv, len + 1);
5268 =for apidoc sv_magicext
5270 Adds magic to an SV, upgrading it if necessary. Applies the
5271 supplied vtable and returns a pointer to the magic added.
5273 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5274 In particular, you can add magic to SvREADONLY SVs, and add more than
5275 one instance of the same 'how'.
5277 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5278 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5279 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5280 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5282 (This is now used as a subroutine by C<sv_magic>.)
5287 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
5288 const char* name, I32 namlen)
5292 if (SvTYPE(sv) < SVt_PVMG) {
5293 SvUPGRADE(sv, SVt_PVMG);
5295 Newz(702,mg, 1, MAGIC);
5296 mg->mg_moremagic = SvMAGIC(sv);
5297 SvMAGIC_set(sv, mg);
5299 /* Sometimes a magic contains a reference loop, where the sv and
5300 object refer to each other. To prevent a reference loop that
5301 would prevent such objects being freed, we look for such loops
5302 and if we find one we avoid incrementing the object refcount.
5304 Note we cannot do this to avoid self-tie loops as intervening RV must
5305 have its REFCNT incremented to keep it in existence.
5308 if (!obj || obj == sv ||
5309 how == PERL_MAGIC_arylen ||
5310 how == PERL_MAGIC_qr ||
5311 how == PERL_MAGIC_symtab ||
5312 (SvTYPE(obj) == SVt_PVGV &&
5313 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
5314 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
5315 GvFORM(obj) == (CV*)sv)))
5320 mg->mg_obj = SvREFCNT_inc(obj);
5321 mg->mg_flags |= MGf_REFCOUNTED;
5324 /* Normal self-ties simply pass a null object, and instead of
5325 using mg_obj directly, use the SvTIED_obj macro to produce a
5326 new RV as needed. For glob "self-ties", we are tieing the PVIO
5327 with an RV obj pointing to the glob containing the PVIO. In
5328 this case, to avoid a reference loop, we need to weaken the
5332 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5333 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
5339 mg->mg_len = namlen;
5342 mg->mg_ptr = savepvn(name, namlen);
5343 else if (namlen == HEf_SVKEY)
5344 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
5346 mg->mg_ptr = (char *) name;
5348 mg->mg_virtual = vtable;
5352 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5357 =for apidoc sv_magic
5359 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
5360 then adds a new magic item of type C<how> to the head of the magic list.
5362 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5363 handling of the C<name> and C<namlen> arguments.
5365 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5366 to add more than one instance of the same 'how'.
5372 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
5374 const MGVTBL *vtable = 0;
5377 #ifdef PERL_COPY_ON_WRITE
5379 sv_force_normal_flags(sv, 0);
5381 if (SvREADONLY(sv)) {
5383 && how != PERL_MAGIC_regex_global
5384 && how != PERL_MAGIC_bm
5385 && how != PERL_MAGIC_fm
5386 && how != PERL_MAGIC_sv
5387 && how != PERL_MAGIC_backref
5390 Perl_croak(aTHX_ PL_no_modify);
5393 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5394 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5395 /* sv_magic() refuses to add a magic of the same 'how' as an
5398 if (how == PERL_MAGIC_taint)
5406 vtable = &PL_vtbl_sv;
5408 case PERL_MAGIC_overload:
5409 vtable = &PL_vtbl_amagic;
5411 case PERL_MAGIC_overload_elem:
5412 vtable = &PL_vtbl_amagicelem;
5414 case PERL_MAGIC_overload_table:
5415 vtable = &PL_vtbl_ovrld;
5418 vtable = &PL_vtbl_bm;
5420 case PERL_MAGIC_regdata:
5421 vtable = &PL_vtbl_regdata;
5423 case PERL_MAGIC_regdatum:
5424 vtable = &PL_vtbl_regdatum;
5426 case PERL_MAGIC_env:
5427 vtable = &PL_vtbl_env;
5430 vtable = &PL_vtbl_fm;
5432 case PERL_MAGIC_envelem:
5433 vtable = &PL_vtbl_envelem;
5435 case PERL_MAGIC_regex_global:
5436 vtable = &PL_vtbl_mglob;
5438 case PERL_MAGIC_isa:
5439 vtable = &PL_vtbl_isa;
5441 case PERL_MAGIC_isaelem:
5442 vtable = &PL_vtbl_isaelem;
5444 case PERL_MAGIC_nkeys:
5445 vtable = &PL_vtbl_nkeys;
5447 case PERL_MAGIC_dbfile:
5450 case PERL_MAGIC_dbline:
5451 vtable = &PL_vtbl_dbline;
5453 #ifdef USE_LOCALE_COLLATE
5454 case PERL_MAGIC_collxfrm:
5455 vtable = &PL_vtbl_collxfrm;
5457 #endif /* USE_LOCALE_COLLATE */
5458 case PERL_MAGIC_tied:
5459 vtable = &PL_vtbl_pack;
5461 case PERL_MAGIC_tiedelem:
5462 case PERL_MAGIC_tiedscalar:
5463 vtable = &PL_vtbl_packelem;
5466 vtable = &PL_vtbl_regexp;
5468 case PERL_MAGIC_sig:
5469 vtable = &PL_vtbl_sig;
5471 case PERL_MAGIC_sigelem:
5472 vtable = &PL_vtbl_sigelem;
5474 case PERL_MAGIC_taint:
5475 vtable = &PL_vtbl_taint;
5477 case PERL_MAGIC_uvar:
5478 vtable = &PL_vtbl_uvar;
5480 case PERL_MAGIC_vec:
5481 vtable = &PL_vtbl_vec;
5483 case PERL_MAGIC_arylen_p:
5484 case PERL_MAGIC_rhash:
5485 case PERL_MAGIC_symtab:
5486 case PERL_MAGIC_vstring:
5489 case PERL_MAGIC_utf8:
5490 vtable = &PL_vtbl_utf8;
5492 case PERL_MAGIC_substr:
5493 vtable = &PL_vtbl_substr;
5495 case PERL_MAGIC_defelem:
5496 vtable = &PL_vtbl_defelem;
5498 case PERL_MAGIC_glob:
5499 vtable = &PL_vtbl_glob;
5501 case PERL_MAGIC_arylen:
5502 vtable = &PL_vtbl_arylen;
5504 case PERL_MAGIC_pos:
5505 vtable = &PL_vtbl_pos;
5507 case PERL_MAGIC_backref:
5508 vtable = &PL_vtbl_backref;
5510 case PERL_MAGIC_ext:
5511 /* Reserved for use by extensions not perl internals. */
5512 /* Useful for attaching extension internal data to perl vars. */
5513 /* Note that multiple extensions may clash if magical scalars */
5514 /* etc holding private data from one are passed to another. */
5517 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5520 /* Rest of work is done else where */
5521 mg = sv_magicext(sv,obj,how,(MGVTBL*)vtable,name,namlen);
5524 case PERL_MAGIC_taint:
5527 case PERL_MAGIC_ext:
5528 case PERL_MAGIC_dbfile:
5535 =for apidoc sv_unmagic
5537 Removes all magic of type C<type> from an SV.
5543 Perl_sv_unmagic(pTHX_ SV *sv, int type)
5547 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5550 for (mg = *mgp; mg; mg = *mgp) {
5551 if (mg->mg_type == type) {
5552 const MGVTBL* const vtbl = mg->mg_virtual;
5553 *mgp = mg->mg_moremagic;
5554 if (vtbl && vtbl->svt_free)
5555 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5556 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5558 Safefree(mg->mg_ptr);
5559 else if (mg->mg_len == HEf_SVKEY)
5560 SvREFCNT_dec((SV*)mg->mg_ptr);
5561 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
5562 Safefree(mg->mg_ptr);
5564 if (mg->mg_flags & MGf_REFCOUNTED)
5565 SvREFCNT_dec(mg->mg_obj);
5569 mgp = &mg->mg_moremagic;
5573 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5580 =for apidoc sv_rvweaken
5582 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5583 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5584 push a back-reference to this RV onto the array of backreferences
5585 associated with that magic.
5591 Perl_sv_rvweaken(pTHX_ SV *sv)
5594 if (!SvOK(sv)) /* let undefs pass */
5597 Perl_croak(aTHX_ "Can't weaken a nonreference");
5598 else if (SvWEAKREF(sv)) {
5599 if (ckWARN(WARN_MISC))
5600 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5604 sv_add_backref(tsv, sv);
5610 /* Give tsv backref magic if it hasn't already got it, then push a
5611 * back-reference to sv onto the array associated with the backref magic.
5615 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
5619 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
5620 av = (AV*)mg->mg_obj;
5623 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5624 /* av now has a refcnt of 2, which avoids it getting freed
5625 * before us during global cleanup. The extra ref is removed
5626 * by magic_killbackrefs() when tsv is being freed */
5628 if (AvFILLp(av) >= AvMAX(av)) {
5630 SV **svp = AvARRAY(av);
5631 for (i = AvFILLp(av); i >= 0; i--)
5633 svp[i] = sv; /* reuse the slot */
5636 av_extend(av, AvFILLp(av)+1);
5638 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5641 /* delete a back-reference to ourselves from the backref magic associated
5642 * with the SV we point to.
5646 S_sv_del_backref(pTHX_ SV *sv)
5653 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
5654 Perl_croak(aTHX_ "panic: del_backref");
5655 av = (AV *)mg->mg_obj;
5657 for (i = AvFILLp(av); i >= 0; i--)
5658 if (svp[i] == sv) svp[i] = Nullsv;
5662 =for apidoc sv_insert
5664 Inserts a string at the specified offset/length within the SV. Similar to
5665 the Perl substr() function.
5671 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
5675 register char *midend;
5676 register char *bigend;
5682 Perl_croak(aTHX_ "Can't modify non-existent substring");
5683 SvPV_force(bigstr, curlen);
5684 (void)SvPOK_only_UTF8(bigstr);
5685 if (offset + len > curlen) {
5686 SvGROW(bigstr, offset+len+1);
5687 Zero(SvPVX_const(bigstr)+curlen, offset+len-curlen, char);
5688 SvCUR_set(bigstr, offset+len);
5692 i = littlelen - len;
5693 if (i > 0) { /* string might grow */
5694 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5695 mid = big + offset + len;
5696 midend = bigend = big + SvCUR(bigstr);
5699 while (midend > mid) /* shove everything down */
5700 *--bigend = *--midend;
5701 Move(little,big+offset,littlelen,char);
5702 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5707 Move(little,SvPVX(bigstr)+offset,len,char);
5712 big = SvPVX(bigstr);
5715 bigend = big + SvCUR(bigstr);
5717 if (midend > bigend)
5718 Perl_croak(aTHX_ "panic: sv_insert");
5720 if (mid - big > bigend - midend) { /* faster to shorten from end */
5722 Move(little, mid, littlelen,char);
5725 i = bigend - midend;
5727 Move(midend, mid, i,char);
5731 SvCUR_set(bigstr, mid - big);
5734 else if ((i = mid - big)) { /* faster from front */
5735 midend -= littlelen;
5737 sv_chop(bigstr,midend-i);
5742 Move(little, mid, littlelen,char);
5744 else if (littlelen) {
5745 midend -= littlelen;
5746 sv_chop(bigstr,midend);
5747 Move(little,midend,littlelen,char);
5750 sv_chop(bigstr,midend);
5756 =for apidoc sv_replace
5758 Make the first argument a copy of the second, then delete the original.
5759 The target SV physically takes over ownership of the body of the source SV
5760 and inherits its flags; however, the target keeps any magic it owns,
5761 and any magic in the source is discarded.
5762 Note that this is a rather specialist SV copying operation; most of the
5763 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5769 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5771 const U32 refcnt = SvREFCNT(sv);
5772 SV_CHECK_THINKFIRST_COW_DROP(sv);
5773 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
5774 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
5775 if (SvMAGICAL(sv)) {
5779 sv_upgrade(nsv, SVt_PVMG);
5780 SvMAGIC_set(nsv, SvMAGIC(sv));
5781 SvFLAGS(nsv) |= SvMAGICAL(sv);
5783 SvMAGIC_set(sv, NULL);
5787 assert(!SvREFCNT(sv));
5788 #ifdef DEBUG_LEAKING_SCALARS
5789 sv->sv_flags = nsv->sv_flags;
5790 sv->sv_any = nsv->sv_any;
5791 sv->sv_refcnt = nsv->sv_refcnt;
5793 StructCopy(nsv,sv,SV);
5795 /* Currently could join these into one piece of pointer arithmetic, but
5796 it would be unclear. */
5797 if(SvTYPE(sv) == SVt_IV)
5799 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5800 else if (SvTYPE(sv) == SVt_RV) {
5801 SvANY(sv) = &sv->sv_u.svu_rv;
5805 #ifdef PERL_COPY_ON_WRITE
5806 if (SvIsCOW_normal(nsv)) {
5807 /* We need to follow the pointers around the loop to make the
5808 previous SV point to sv, rather than nsv. */
5811 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5814 assert(SvPVX_const(current) == SvPVX_const(nsv));
5816 /* Make the SV before us point to the SV after us. */
5818 PerlIO_printf(Perl_debug_log, "previous is\n");
5820 PerlIO_printf(Perl_debug_log,
5821 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5822 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5824 SV_COW_NEXT_SV_SET(current, sv);
5827 SvREFCNT(sv) = refcnt;
5828 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5834 =for apidoc sv_clear
5836 Clear an SV: call any destructors, free up any memory used by the body,
5837 and free the body itself. The SV's head is I<not> freed, although
5838 its type is set to all 1's so that it won't inadvertently be assumed
5839 to be live during global destruction etc.
5840 This function should only be called when REFCNT is zero. Most of the time
5841 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5848 Perl_sv_clear(pTHX_ register SV *sv)
5853 assert(SvREFCNT(sv) == 0);
5856 if (PL_defstash) { /* Still have a symbol table? */
5860 stash = SvSTASH(sv);
5861 destructor = StashHANDLER(stash,DESTROY);
5863 SV* tmpref = newRV(sv);
5864 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5866 PUSHSTACKi(PERLSI_DESTROY);
5871 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5877 if(SvREFCNT(tmpref) < 2) {
5878 /* tmpref is not kept alive! */
5880 SvRV_set(tmpref, NULL);
5883 SvREFCNT_dec(tmpref);
5885 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5889 if (PL_in_clean_objs)
5890 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5892 /* DESTROY gave object new lease on life */
5898 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5899 SvOBJECT_off(sv); /* Curse the object. */
5900 if (SvTYPE(sv) != SVt_PVIO)
5901 --PL_sv_objcount; /* XXX Might want something more general */
5904 if (SvTYPE(sv) >= SVt_PVMG) {
5907 if (SvTYPE(sv) == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
5908 SvREFCNT_dec(SvSTASH(sv));
5911 switch (SvTYPE(sv)) {
5914 IoIFP(sv) != PerlIO_stdin() &&
5915 IoIFP(sv) != PerlIO_stdout() &&
5916 IoIFP(sv) != PerlIO_stderr())
5918 io_close((IO*)sv, FALSE);
5920 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5921 PerlDir_close(IoDIRP(sv));
5922 IoDIRP(sv) = (DIR*)NULL;
5923 Safefree(IoTOP_NAME(sv));
5924 Safefree(IoFMT_NAME(sv));
5925 Safefree(IoBOTTOM_NAME(sv));
5940 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5941 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5942 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5943 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5945 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5946 SvREFCNT_dec(LvTARG(sv));
5950 Safefree(GvNAME(sv));
5951 /* cannot decrease stash refcount yet, as we might recursively delete
5952 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
5953 of stash until current sv is completely gone.
5954 -- JohnPC, 27 Mar 1998 */
5955 stash = GvSTASH(sv);
5961 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5963 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
5964 /* Don't even bother with turning off the OOK flag. */
5973 SvREFCNT_dec(SvRV(sv));
5975 #ifdef PERL_COPY_ON_WRITE
5976 else if (SvPVX_const(sv)) {
5978 /* I believe I need to grab the global SV mutex here and
5979 then recheck the COW status. */
5981 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5984 sv_release_COW(sv, SvPVX_const(sv), SvCUR(sv), SvLEN(sv),
5985 SvUVX(sv), SV_COW_NEXT_SV(sv));
5986 /* And drop it here. */
5988 } else if (SvLEN(sv)) {
5989 Safefree(SvPVX_const(sv));
5993 else if (SvPVX_const(sv) && SvLEN(sv))
5994 Safefree(SvPVX_const(sv));
5995 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5996 unsharepvn(SvPVX_const(sv),
5997 SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
6011 switch (SvTYPE(sv)) {
6025 del_XPVIV(SvANY(sv));
6028 del_XPVNV(SvANY(sv));
6031 del_XPVMG(SvANY(sv));
6034 del_XPVLV(SvANY(sv));
6037 del_XPVAV(SvANY(sv));
6040 del_XPVHV(SvANY(sv));
6043 del_XPVCV(SvANY(sv));
6046 del_XPVGV(SvANY(sv));
6047 /* code duplication for increased performance. */
6048 SvFLAGS(sv) &= SVf_BREAK;
6049 SvFLAGS(sv) |= SVTYPEMASK;
6050 /* decrease refcount of the stash that owns this GV, if any */
6052 SvREFCNT_dec(stash);
6053 return; /* not break, SvFLAGS reset already happened */
6055 del_XPVBM(SvANY(sv));
6058 del_XPVFM(SvANY(sv));
6061 del_XPVIO(SvANY(sv));
6064 SvFLAGS(sv) &= SVf_BREAK;
6065 SvFLAGS(sv) |= SVTYPEMASK;
6069 =for apidoc sv_newref
6071 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
6078 Perl_sv_newref(pTHX_ SV *sv)
6088 Decrement an SV's reference count, and if it drops to zero, call
6089 C<sv_clear> to invoke destructors and free up any memory used by
6090 the body; finally, deallocate the SV's head itself.
6091 Normally called via a wrapper macro C<SvREFCNT_dec>.
6097 Perl_sv_free(pTHX_ SV *sv)
6102 if (SvREFCNT(sv) == 0) {
6103 if (SvFLAGS(sv) & SVf_BREAK)
6104 /* this SV's refcnt has been artificially decremented to
6105 * trigger cleanup */
6107 if (PL_in_clean_all) /* All is fair */
6109 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6110 /* make sure SvREFCNT(sv)==0 happens very seldom */
6111 SvREFCNT(sv) = (~(U32)0)/2;
6114 if (ckWARN_d(WARN_INTERNAL))
6115 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6116 "Attempt to free unreferenced scalar: SV 0x%"UVxf
6117 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6120 if (--(SvREFCNT(sv)) > 0)
6122 Perl_sv_free2(aTHX_ sv);
6126 Perl_sv_free2(pTHX_ SV *sv)
6131 if (ckWARN_d(WARN_DEBUGGING))
6132 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
6133 "Attempt to free temp prematurely: SV 0x%"UVxf
6134 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6138 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6139 /* make sure SvREFCNT(sv)==0 happens very seldom */
6140 SvREFCNT(sv) = (~(U32)0)/2;
6151 Returns the length of the string in the SV. Handles magic and type
6152 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
6158 Perl_sv_len(pTHX_ register SV *sv)
6166 len = mg_length(sv);
6168 (void)SvPV_const(sv, len);
6173 =for apidoc sv_len_utf8
6175 Returns the number of characters in the string in an SV, counting wide
6176 UTF-8 bytes as a single character. Handles magic and type coercion.
6182 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
6183 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
6184 * (Note that the mg_len is not the length of the mg_ptr field.)
6189 Perl_sv_len_utf8(pTHX_ register SV *sv)
6195 return mg_length(sv);
6199 const U8 *s = (U8*)SvPV_const(sv, len);
6200 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
6202 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
6204 #ifdef PERL_UTF8_CACHE_ASSERT
6205 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
6209 ulen = Perl_utf8_length(aTHX_ s, s + len);
6210 if (!mg && !SvREADONLY(sv)) {
6211 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6212 mg = mg_find(sv, PERL_MAGIC_utf8);
6222 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
6223 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
6224 * between UTF-8 and byte offsets. There are two (substr offset and substr
6225 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
6226 * and byte offset) cache positions.
6228 * The mg_len field is used by sv_len_utf8(), see its comments.
6229 * Note that the mg_len is not the length of the mg_ptr field.
6233 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i,
6234 I32 offsetp, const U8 *s, const U8 *start)
6238 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6240 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
6244 *cachep = (STRLEN *) (*mgp)->mg_ptr;
6246 Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6247 (*mgp)->mg_ptr = (char *) *cachep;
6251 (*cachep)[i] = offsetp;
6252 (*cachep)[i+1] = s - start;
6260 * S_utf8_mg_pos() is used to query and update mg_ptr field of
6261 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
6262 * between UTF-8 and byte offsets. See also the comments of
6263 * S_utf8_mg_pos_init().
6267 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)
6271 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6273 *mgp = mg_find(sv, PERL_MAGIC_utf8);
6274 if (*mgp && (*mgp)->mg_ptr) {
6275 *cachep = (STRLEN *) (*mgp)->mg_ptr;
6276 ASSERT_UTF8_CACHE(*cachep);
6277 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
6279 else { /* We will skip to the right spot. */
6284 /* The assumption is that going backward is half
6285 * the speed of going forward (that's where the
6286 * 2 * backw in the below comes from). (The real
6287 * figure of course depends on the UTF-8 data.) */
6289 if ((*cachep)[i] > (STRLEN)uoff) {
6291 backw = (*cachep)[i] - (STRLEN)uoff;
6293 if (forw < 2 * backw)
6296 p = start + (*cachep)[i+1];
6298 /* Try this only for the substr offset (i == 0),
6299 * not for the substr length (i == 2). */
6300 else if (i == 0) { /* (*cachep)[i] < uoff */
6301 const STRLEN ulen = sv_len_utf8(sv);
6303 if ((STRLEN)uoff < ulen) {
6304 forw = (STRLEN)uoff - (*cachep)[i];
6305 backw = ulen - (STRLEN)uoff;
6307 if (forw < 2 * backw)
6308 p = start + (*cachep)[i+1];
6313 /* If the string is not long enough for uoff,
6314 * we could extend it, but not at this low a level. */
6318 if (forw < 2 * backw) {
6325 while (UTF8_IS_CONTINUATION(*p))
6330 /* Update the cache. */
6331 (*cachep)[i] = (STRLEN)uoff;
6332 (*cachep)[i+1] = p - start;
6334 /* Drop the stale "length" cache */
6343 if (found) { /* Setup the return values. */
6344 *offsetp = (*cachep)[i+1];
6345 *sp = start + *offsetp;
6348 *offsetp = send - start;
6350 else if (*sp < start) {
6356 #ifdef PERL_UTF8_CACHE_ASSERT
6361 while (n-- && s < send)
6365 assert(*offsetp == s - start);
6366 assert((*cachep)[0] == (STRLEN)uoff);
6367 assert((*cachep)[1] == *offsetp);
6369 ASSERT_UTF8_CACHE(*cachep);
6378 =for apidoc sv_pos_u2b
6380 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6381 the start of the string, to a count of the equivalent number of bytes; if
6382 lenp is non-zero, it does the same to lenp, but this time starting from
6383 the offset, rather than from the start of the string. Handles magic and
6390 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6391 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6392 * byte offsets. See also the comments of S_utf8_mg_pos().
6397 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
6405 start = (U8*)SvPV_const(sv, len);
6409 const U8 *s = start;
6410 I32 uoffset = *offsetp;
6411 const U8 *send = s + len;
6415 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
6417 if (!found && uoffset > 0) {
6418 while (s < send && uoffset--)
6422 if (utf8_mg_pos_init(sv, &mg, &cache, 0, *offsetp, s, start))
6424 *offsetp = s - start;
6429 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) {
6433 if (!found && *lenp > 0) {
6436 while (s < send && ulen--)
6440 utf8_mg_pos_init(sv, &mg, &cache, 2, *lenp, s, start);
6444 ASSERT_UTF8_CACHE(cache);
6456 =for apidoc sv_pos_b2u
6458 Converts the value pointed to by offsetp from a count of bytes from the
6459 start of the string, to a count of the equivalent number of UTF-8 chars.
6460 Handles magic and type coercion.
6466 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6467 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6468 * byte offsets. See also the comments of S_utf8_mg_pos().
6473 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
6481 s = (U8*)SvPV(sv, len);
6482 if ((I32)len < *offsetp)
6483 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6485 U8* send = s + *offsetp;
6487 STRLEN *cache = NULL;
6491 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6492 mg = mg_find(sv, PERL_MAGIC_utf8);
6493 if (mg && mg->mg_ptr) {
6494 cache = (STRLEN *) mg->mg_ptr;
6495 if (cache[1] == (STRLEN)*offsetp) {
6496 /* An exact match. */
6497 *offsetp = cache[0];
6501 else if (cache[1] < (STRLEN)*offsetp) {
6502 /* We already know part of the way. */
6505 /* Let the below loop do the rest. */
6507 else { /* cache[1] > *offsetp */
6508 /* We already know all of the way, now we may
6509 * be able to walk back. The same assumption
6510 * is made as in S_utf8_mg_pos(), namely that
6511 * walking backward is twice slower than
6512 * walking forward. */
6513 STRLEN forw = *offsetp;
6514 STRLEN backw = cache[1] - *offsetp;
6516 if (!(forw < 2 * backw)) {
6517 U8 *p = s + cache[1];
6524 while (UTF8_IS_CONTINUATION(*p)) {
6532 *offsetp = cache[0];
6534 /* Drop the stale "length" cache */
6542 ASSERT_UTF8_CACHE(cache);
6548 /* Call utf8n_to_uvchr() to validate the sequence
6549 * (unless a simple non-UTF character) */
6550 if (!UTF8_IS_INVARIANT(*s))
6551 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
6560 if (!SvREADONLY(sv)) {
6562 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6563 mg = mg_find(sv, PERL_MAGIC_utf8);
6568 Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6569 mg->mg_ptr = (char *) cache;
6574 cache[1] = *offsetp;
6575 /* Drop the stale "length" cache */
6588 Returns a boolean indicating whether the strings in the two SVs are
6589 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6590 coerce its args to strings if necessary.
6596 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6604 SV* svrecode = Nullsv;
6611 pv1 = SvPV_const(sv1, cur1);
6618 pv2 = SvPV_const(sv2, cur2);
6620 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6621 /* Differing utf8ness.
6622 * Do not UTF8size the comparands as a side-effect. */
6625 svrecode = newSVpvn(pv2, cur2);
6626 sv_recode_to_utf8(svrecode, PL_encoding);
6627 pv2 = SvPV(svrecode, cur2);
6630 svrecode = newSVpvn(pv1, cur1);
6631 sv_recode_to_utf8(svrecode, PL_encoding);
6632 pv1 = SvPV(svrecode, cur1);
6634 /* Now both are in UTF-8. */
6636 SvREFCNT_dec(svrecode);
6641 bool is_utf8 = TRUE;
6644 /* sv1 is the UTF-8 one,
6645 * if is equal it must be downgrade-able */
6646 char *pv = (char*)bytes_from_utf8((const U8*)pv1,
6652 /* sv2 is the UTF-8 one,
6653 * if is equal it must be downgrade-able */
6654 char *pv = (char *)bytes_from_utf8((const U8*)pv2,
6660 /* Downgrade not possible - cannot be eq */
6668 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6671 SvREFCNT_dec(svrecode);
6682 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6683 string in C<sv1> is less than, equal to, or greater than the string in
6684 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6685 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6691 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6694 const char *pv1, *pv2;
6697 SV *svrecode = Nullsv;
6704 pv1 = SvPV_const(sv1, cur1);
6711 pv2 = SvPV_const(sv2, cur2);
6713 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6714 /* Differing utf8ness.
6715 * Do not UTF8size the comparands as a side-effect. */
6718 svrecode = newSVpvn(pv2, cur2);
6719 sv_recode_to_utf8(svrecode, PL_encoding);
6720 pv2 = SvPV(svrecode, cur2);
6723 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6728 svrecode = newSVpvn(pv1, cur1);
6729 sv_recode_to_utf8(svrecode, PL_encoding);
6730 pv1 = SvPV(svrecode, cur1);
6733 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6739 cmp = cur2 ? -1 : 0;
6743 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6746 cmp = retval < 0 ? -1 : 1;
6747 } else if (cur1 == cur2) {
6750 cmp = cur1 < cur2 ? -1 : 1;
6755 SvREFCNT_dec(svrecode);
6764 =for apidoc sv_cmp_locale
6766 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6767 'use bytes' aware, handles get magic, and will coerce its args to strings
6768 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6774 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6776 #ifdef USE_LOCALE_COLLATE
6782 if (PL_collation_standard)
6786 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6788 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6790 if (!pv1 || !len1) {
6801 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6804 return retval < 0 ? -1 : 1;
6807 * When the result of collation is equality, that doesn't mean
6808 * that there are no differences -- some locales exclude some
6809 * characters from consideration. So to avoid false equalities,
6810 * we use the raw string as a tiebreaker.
6816 #endif /* USE_LOCALE_COLLATE */
6818 return sv_cmp(sv1, sv2);
6822 #ifdef USE_LOCALE_COLLATE
6825 =for apidoc sv_collxfrm
6827 Add Collate Transform magic to an SV if it doesn't already have it.
6829 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6830 scalar data of the variable, but transformed to such a format that a normal
6831 memory comparison can be used to compare the data according to the locale
6838 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6842 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6843 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6848 Safefree(mg->mg_ptr);
6850 if ((xf = mem_collxfrm(s, len, &xlen))) {
6851 if (SvREADONLY(sv)) {
6854 return xf + sizeof(PL_collation_ix);
6857 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6858 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6871 if (mg && mg->mg_ptr) {
6873 return mg->mg_ptr + sizeof(PL_collation_ix);
6881 #endif /* USE_LOCALE_COLLATE */
6886 Get a line from the filehandle and store it into the SV, optionally
6887 appending to the currently-stored string.
6893 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6897 register STDCHAR rslast;
6898 register STDCHAR *bp;
6904 if (SvTHINKFIRST(sv))
6905 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6906 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6908 However, perlbench says it's slower, because the existing swipe code
6909 is faster than copy on write.
6910 Swings and roundabouts. */
6911 SvUPGRADE(sv, SVt_PV);
6916 if (PerlIO_isutf8(fp)) {
6918 sv_utf8_upgrade_nomg(sv);
6919 sv_pos_u2b(sv,&append,0);
6921 } else if (SvUTF8(sv)) {
6922 SV *tsv = NEWSV(0,0);
6923 sv_gets(tsv, fp, 0);
6924 sv_utf8_upgrade_nomg(tsv);
6925 SvCUR_set(sv,append);
6928 goto return_string_or_null;
6933 if (PerlIO_isutf8(fp))
6936 if (IN_PERL_COMPILETIME) {
6937 /* we always read code in line mode */
6941 else if (RsSNARF(PL_rs)) {
6942 /* If it is a regular disk file use size from stat() as estimate
6943 of amount we are going to read - may result in malloc-ing
6944 more memory than we realy need if layers bellow reduce
6945 size we read (e.g. CRLF or a gzip layer)
6948 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6949 const Off_t offset = PerlIO_tell(fp);
6950 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6951 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6957 else if (RsRECORD(PL_rs)) {
6961 /* Grab the size of the record we're getting */
6962 recsize = SvIV(SvRV(PL_rs));
6963 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6966 /* VMS wants read instead of fread, because fread doesn't respect */
6967 /* RMS record boundaries. This is not necessarily a good thing to be */
6968 /* doing, but we've got no other real choice - except avoid stdio
6969 as implementation - perhaps write a :vms layer ?
6971 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6973 bytesread = PerlIO_read(fp, buffer, recsize);
6977 SvCUR_set(sv, bytesread += append);
6978 buffer[bytesread] = '\0';
6979 goto return_string_or_null;
6981 else if (RsPARA(PL_rs)) {
6987 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6988 if (PerlIO_isutf8(fp)) {
6989 rsptr = SvPVutf8(PL_rs, rslen);
6992 if (SvUTF8(PL_rs)) {
6993 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6994 Perl_croak(aTHX_ "Wide character in $/");
6997 rsptr = SvPV(PL_rs, rslen);
7001 rslast = rslen ? rsptr[rslen - 1] : '\0';
7003 if (rspara) { /* have to do this both before and after */
7004 do { /* to make sure file boundaries work right */
7007 i = PerlIO_getc(fp);
7011 PerlIO_ungetc(fp,i);
7017 /* See if we know enough about I/O mechanism to cheat it ! */
7019 /* This used to be #ifdef test - it is made run-time test for ease
7020 of abstracting out stdio interface. One call should be cheap
7021 enough here - and may even be a macro allowing compile
7025 if (PerlIO_fast_gets(fp)) {
7028 * We're going to steal some values from the stdio struct
7029 * and put EVERYTHING in the innermost loop into registers.
7031 register STDCHAR *ptr;
7035 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7036 /* An ungetc()d char is handled separately from the regular
7037 * buffer, so we getc() it back out and stuff it in the buffer.
7039 i = PerlIO_getc(fp);
7040 if (i == EOF) return 0;
7041 *(--((*fp)->_ptr)) = (unsigned char) i;
7045 /* Here is some breathtakingly efficient cheating */
7047 cnt = PerlIO_get_cnt(fp); /* get count into register */
7048 /* make sure we have the room */
7049 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7050 /* Not room for all of it
7051 if we are looking for a separator and room for some
7053 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7054 /* just process what we have room for */
7055 shortbuffered = cnt - SvLEN(sv) + append + 1;
7056 cnt -= shortbuffered;
7060 /* remember that cnt can be negative */
7061 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7066 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
7067 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7068 DEBUG_P(PerlIO_printf(Perl_debug_log,
7069 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7070 DEBUG_P(PerlIO_printf(Perl_debug_log,
7071 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7072 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7073 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7078 while (cnt > 0) { /* this | eat */
7080 if ((*bp++ = *ptr++) == rslast) /* really | dust */
7081 goto thats_all_folks; /* screams | sed :-) */
7085 Copy(ptr, bp, cnt, char); /* this | eat */
7086 bp += cnt; /* screams | dust */
7087 ptr += cnt; /* louder | sed :-) */
7092 if (shortbuffered) { /* oh well, must extend */
7093 cnt = shortbuffered;
7095 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7097 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7098 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7102 DEBUG_P(PerlIO_printf(Perl_debug_log,
7103 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7104 PTR2UV(ptr),(long)cnt));
7105 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7107 DEBUG_P(PerlIO_printf(Perl_debug_log,
7108 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7109 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7110 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7112 /* This used to call 'filbuf' in stdio form, but as that behaves like
7113 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7114 another abstraction. */
7115 i = PerlIO_getc(fp); /* get more characters */
7117 DEBUG_P(PerlIO_printf(Perl_debug_log,
7118 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7119 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7120 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7122 cnt = PerlIO_get_cnt(fp);
7123 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
7124 DEBUG_P(PerlIO_printf(Perl_debug_log,
7125 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7127 if (i == EOF) /* all done for ever? */
7128 goto thats_really_all_folks;
7130 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
7132 SvGROW(sv, bpx + cnt + 2);
7133 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
7135 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
7137 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
7138 goto thats_all_folks;
7142 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
7143 memNE((char*)bp - rslen, rsptr, rslen))
7144 goto screamer; /* go back to the fray */
7145 thats_really_all_folks:
7147 cnt += shortbuffered;
7148 DEBUG_P(PerlIO_printf(Perl_debug_log,
7149 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7150 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
7151 DEBUG_P(PerlIO_printf(Perl_debug_log,
7152 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7153 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7154 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7156 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
7157 DEBUG_P(PerlIO_printf(Perl_debug_log,
7158 "Screamer: done, len=%ld, string=|%.*s|\n",
7159 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
7163 /*The big, slow, and stupid way. */
7164 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
7166 New(0, buf, 8192, STDCHAR);
7174 const register STDCHAR *bpe = buf + sizeof(buf);
7176 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7177 ; /* keep reading */
7181 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7182 /* Accomodate broken VAXC compiler, which applies U8 cast to
7183 * both args of ?: operator, causing EOF to change into 255
7186 i = (U8)buf[cnt - 1];
7192 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
7194 sv_catpvn(sv, (char *) buf, cnt);
7196 sv_setpvn(sv, (char *) buf, cnt);
7198 if (i != EOF && /* joy */
7200 SvCUR(sv) < rslen ||
7201 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7205 * If we're reading from a TTY and we get a short read,
7206 * indicating that the user hit his EOF character, we need
7207 * to notice it now, because if we try to read from the TTY
7208 * again, the EOF condition will disappear.
7210 * The comparison of cnt to sizeof(buf) is an optimization
7211 * that prevents unnecessary calls to feof().
7215 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
7219 #ifdef USE_HEAP_INSTEAD_OF_STACK
7224 if (rspara) { /* have to do this both before and after */
7225 while (i != EOF) { /* to make sure file boundaries work right */
7226 i = PerlIO_getc(fp);
7228 PerlIO_ungetc(fp,i);
7234 return_string_or_null:
7235 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
7241 Auto-increment of the value in the SV, doing string to numeric conversion
7242 if necessary. Handles 'get' magic.
7248 Perl_sv_inc(pTHX_ register SV *sv)
7257 if (SvTHINKFIRST(sv)) {
7259 sv_force_normal_flags(sv, 0);
7260 if (SvREADONLY(sv)) {
7261 if (IN_PERL_RUNTIME)
7262 Perl_croak(aTHX_ PL_no_modify);
7266 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7268 i = PTR2IV(SvRV(sv));
7273 flags = SvFLAGS(sv);
7274 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7275 /* It's (privately or publicly) a float, but not tested as an
7276 integer, so test it to see. */
7278 flags = SvFLAGS(sv);
7280 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7281 /* It's publicly an integer, or privately an integer-not-float */
7282 #ifdef PERL_PRESERVE_IVUV
7286 if (SvUVX(sv) == UV_MAX)
7287 sv_setnv(sv, UV_MAX_P1);
7289 (void)SvIOK_only_UV(sv);
7290 SvUV_set(sv, SvUVX(sv) + 1);
7292 if (SvIVX(sv) == IV_MAX)
7293 sv_setuv(sv, (UV)IV_MAX + 1);
7295 (void)SvIOK_only(sv);
7296 SvIV_set(sv, SvIVX(sv) + 1);
7301 if (flags & SVp_NOK) {
7302 (void)SvNOK_only(sv);
7303 SvNV_set(sv, SvNVX(sv) + 1.0);
7307 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
7308 if ((flags & SVTYPEMASK) < SVt_PVIV)
7309 sv_upgrade(sv, SVt_IV);
7310 (void)SvIOK_only(sv);
7315 while (isALPHA(*d)) d++;
7316 while (isDIGIT(*d)) d++;
7318 #ifdef PERL_PRESERVE_IVUV
7319 /* Got to punt this as an integer if needs be, but we don't issue
7320 warnings. Probably ought to make the sv_iv_please() that does
7321 the conversion if possible, and silently. */
7322 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7323 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7324 /* Need to try really hard to see if it's an integer.
7325 9.22337203685478e+18 is an integer.
7326 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7327 so $a="9.22337203685478e+18"; $a+0; $a++
7328 needs to be the same as $a="9.22337203685478e+18"; $a++
7335 /* sv_2iv *should* have made this an NV */
7336 if (flags & SVp_NOK) {
7337 (void)SvNOK_only(sv);
7338 SvNV_set(sv, SvNVX(sv) + 1.0);
7341 /* I don't think we can get here. Maybe I should assert this
7342 And if we do get here I suspect that sv_setnv will croak. NWC
7344 #if defined(USE_LONG_DOUBLE)
7345 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",
7346 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7348 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7349 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7352 #endif /* PERL_PRESERVE_IVUV */
7353 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
7357 while (d >= SvPVX_const(sv)) {
7365 /* MKS: The original code here died if letters weren't consecutive.
7366 * at least it didn't have to worry about non-C locales. The
7367 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7368 * arranged in order (although not consecutively) and that only
7369 * [A-Za-z] are accepted by isALPHA in the C locale.
7371 if (*d != 'z' && *d != 'Z') {
7372 do { ++*d; } while (!isALPHA(*d));
7375 *(d--) -= 'z' - 'a';
7380 *(d--) -= 'z' - 'a' + 1;
7384 /* oh,oh, the number grew */
7385 SvGROW(sv, SvCUR(sv) + 2);
7386 SvCUR_set(sv, SvCUR(sv) + 1);
7387 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7398 Auto-decrement of the value in the SV, doing string to numeric conversion
7399 if necessary. Handles 'get' magic.
7405 Perl_sv_dec(pTHX_ register SV *sv)
7413 if (SvTHINKFIRST(sv)) {
7415 sv_force_normal_flags(sv, 0);
7416 if (SvREADONLY(sv)) {
7417 if (IN_PERL_RUNTIME)
7418 Perl_croak(aTHX_ PL_no_modify);
7422 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7424 i = PTR2IV(SvRV(sv));
7429 /* Unlike sv_inc we don't have to worry about string-never-numbers
7430 and keeping them magic. But we mustn't warn on punting */
7431 flags = SvFLAGS(sv);
7432 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7433 /* It's publicly an integer, or privately an integer-not-float */
7434 #ifdef PERL_PRESERVE_IVUV
7438 if (SvUVX(sv) == 0) {
7439 (void)SvIOK_only(sv);
7443 (void)SvIOK_only_UV(sv);
7444 SvUV_set(sv, SvUVX(sv) + 1);
7447 if (SvIVX(sv) == IV_MIN)
7448 sv_setnv(sv, (NV)IV_MIN - 1.0);
7450 (void)SvIOK_only(sv);
7451 SvIV_set(sv, SvIVX(sv) - 1);
7456 if (flags & SVp_NOK) {
7457 SvNV_set(sv, SvNVX(sv) - 1.0);
7458 (void)SvNOK_only(sv);
7461 if (!(flags & SVp_POK)) {
7462 if ((flags & SVTYPEMASK) < SVt_PVNV)
7463 sv_upgrade(sv, SVt_NV);
7465 (void)SvNOK_only(sv);
7468 #ifdef PERL_PRESERVE_IVUV
7470 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7471 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7472 /* Need to try really hard to see if it's an integer.
7473 9.22337203685478e+18 is an integer.
7474 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7475 so $a="9.22337203685478e+18"; $a+0; $a--
7476 needs to be the same as $a="9.22337203685478e+18"; $a--
7483 /* sv_2iv *should* have made this an NV */
7484 if (flags & SVp_NOK) {
7485 (void)SvNOK_only(sv);
7486 SvNV_set(sv, SvNVX(sv) - 1.0);
7489 /* I don't think we can get here. Maybe I should assert this
7490 And if we do get here I suspect that sv_setnv will croak. NWC
7492 #if defined(USE_LONG_DOUBLE)
7493 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",
7494 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7496 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7497 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7501 #endif /* PERL_PRESERVE_IVUV */
7502 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
7506 =for apidoc sv_mortalcopy
7508 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7509 The new SV is marked as mortal. It will be destroyed "soon", either by an
7510 explicit call to FREETMPS, or by an implicit call at places such as
7511 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7516 /* Make a string that will exist for the duration of the expression
7517 * evaluation. Actually, it may have to last longer than that, but
7518 * hopefully we won't free it until it has been assigned to a
7519 * permanent location. */
7522 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
7527 sv_setsv(sv,oldstr);
7529 PL_tmps_stack[++PL_tmps_ix] = sv;
7535 =for apidoc sv_newmortal
7537 Creates a new null SV which is mortal. The reference count of the SV is
7538 set to 1. It will be destroyed "soon", either by an explicit call to
7539 FREETMPS, or by an implicit call at places such as statement boundaries.
7540 See also C<sv_mortalcopy> and C<sv_2mortal>.
7546 Perl_sv_newmortal(pTHX)
7551 SvFLAGS(sv) = SVs_TEMP;
7553 PL_tmps_stack[++PL_tmps_ix] = sv;
7558 =for apidoc sv_2mortal
7560 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7561 by an explicit call to FREETMPS, or by an implicit call at places such as
7562 statement boundaries. SvTEMP() is turned on which means that the SV's
7563 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7564 and C<sv_mortalcopy>.
7570 Perl_sv_2mortal(pTHX_ register SV *sv)
7575 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7578 PL_tmps_stack[++PL_tmps_ix] = sv;
7586 Creates a new SV and copies a string into it. The reference count for the
7587 SV is set to 1. If C<len> is zero, Perl will compute the length using
7588 strlen(). For efficiency, consider using C<newSVpvn> instead.
7594 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
7599 sv_setpvn(sv,s,len ? len : strlen(s));
7604 =for apidoc newSVpvn
7606 Creates a new SV and copies a string into it. The reference count for the
7607 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7608 string. You are responsible for ensuring that the source string is at least
7609 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7615 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7620 sv_setpvn(sv,s,len);
7626 =for apidoc newSVhek
7628 Creates a new SV from the hash key structure. It will generate scalars that
7629 point to the shared string table where possible. Returns a new (undefined)
7630 SV if the hek is NULL.
7636 Perl_newSVhek(pTHX_ const HEK *hek)
7645 if (HEK_LEN(hek) == HEf_SVKEY) {
7646 return newSVsv(*(SV**)HEK_KEY(hek));
7648 const int flags = HEK_FLAGS(hek);
7649 if (flags & HVhek_WASUTF8) {
7651 Andreas would like keys he put in as utf8 to come back as utf8
7653 STRLEN utf8_len = HEK_LEN(hek);
7654 U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7655 SV *sv = newSVpvn ((char*)as_utf8, utf8_len);
7658 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7660 } else if (flags & HVhek_REHASH) {
7661 /* We don't have a pointer to the hv, so we have to replicate the
7662 flag into every HEK. This hv is using custom a hasing
7663 algorithm. Hence we can't return a shared string scalar, as
7664 that would contain the (wrong) hash value, and might get passed
7665 into an hv routine with a regular hash */
7667 SV *sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7672 /* This will be overwhelminly the most common case. */
7673 return newSVpvn_share(HEK_KEY(hek),
7674 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
7680 =for apidoc newSVpvn_share
7682 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7683 table. If the string does not already exist in the table, it is created
7684 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
7685 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
7686 otherwise the hash is computed. The idea here is that as the string table
7687 is used for shared hash keys these strings will have SvPVX_const == HeKEY and
7688 hash lookup will avoid string compare.
7694 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7697 bool is_utf8 = FALSE;
7699 STRLEN tmplen = -len;
7701 /* See the note in hv.c:hv_fetch() --jhi */
7702 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7706 PERL_HASH(hash, src, len);
7708 sv_upgrade(sv, SVt_PVIV);
7709 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7722 #if defined(PERL_IMPLICIT_CONTEXT)
7724 /* pTHX_ magic can't cope with varargs, so this is a no-context
7725 * version of the main function, (which may itself be aliased to us).
7726 * Don't access this version directly.
7730 Perl_newSVpvf_nocontext(const char* pat, ...)
7735 va_start(args, pat);
7736 sv = vnewSVpvf(pat, &args);
7743 =for apidoc newSVpvf
7745 Creates a new SV and initializes it with the string formatted like
7752 Perl_newSVpvf(pTHX_ const char* pat, ...)
7756 va_start(args, pat);
7757 sv = vnewSVpvf(pat, &args);
7762 /* backend for newSVpvf() and newSVpvf_nocontext() */
7765 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7769 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7776 Creates a new SV and copies a floating point value into it.
7777 The reference count for the SV is set to 1.
7783 Perl_newSVnv(pTHX_ NV n)
7795 Creates a new SV and copies an integer into it. The reference count for the
7802 Perl_newSViv(pTHX_ IV i)
7814 Creates a new SV and copies an unsigned integer into it.
7815 The reference count for the SV is set to 1.
7821 Perl_newSVuv(pTHX_ UV u)
7831 =for apidoc newRV_noinc
7833 Creates an RV wrapper for an SV. The reference count for the original
7834 SV is B<not> incremented.
7840 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7845 sv_upgrade(sv, SVt_RV);
7847 SvRV_set(sv, tmpRef);
7852 /* newRV_inc is the official function name to use now.
7853 * newRV_inc is in fact #defined to newRV in sv.h
7857 Perl_newRV(pTHX_ SV *tmpRef)
7859 return newRV_noinc(SvREFCNT_inc(tmpRef));
7865 Creates a new SV which is an exact duplicate of the original SV.
7872 Perl_newSVsv(pTHX_ register SV *old)
7878 if (SvTYPE(old) == SVTYPEMASK) {
7879 if (ckWARN_d(WARN_INTERNAL))
7880 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7884 /* SV_GMAGIC is the default for sv_setv()
7885 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7886 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7887 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7892 =for apidoc sv_reset
7894 Underlying implementation for the C<reset> Perl function.
7895 Note that the perl-level function is vaguely deprecated.
7901 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
7904 char todo[PERL_UCHAR_MAX+1];
7909 if (!*s) { /* reset ?? searches */
7910 MAGIC *mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
7912 PMOP *pm = (PMOP *) mg->mg_obj;
7914 pm->op_pmdynflags &= ~PMdf_USED;
7921 /* reset variables */
7923 if (!HvARRAY(stash))
7926 Zero(todo, 256, char);
7929 I32 i = (unsigned char)*s;
7933 max = (unsigned char)*s++;
7934 for ( ; i <= max; i++) {
7937 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7939 for (entry = HvARRAY(stash)[i];
7941 entry = HeNEXT(entry))
7946 if (!todo[(U8)*HeKEY(entry)])
7948 gv = (GV*)HeVAL(entry);
7950 if (SvTHINKFIRST(sv)) {
7951 if (!SvREADONLY(sv) && SvROK(sv))
7956 if (SvTYPE(sv) >= SVt_PV) {
7958 if (SvPVX_const(sv) != Nullch)
7965 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
7968 #ifdef USE_ENVIRON_ARRAY
7970 # ifdef USE_ITHREADS
7971 && PL_curinterp == aTHX
7975 environ[0] = Nullch;
7978 #endif /* !PERL_MICRO */
7988 Using various gambits, try to get an IO from an SV: the IO slot if its a
7989 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7990 named after the PV if we're a string.
7996 Perl_sv_2io(pTHX_ SV *sv)
8001 switch (SvTYPE(sv)) {
8009 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8013 Perl_croak(aTHX_ PL_no_usym, "filehandle");
8015 return sv_2io(SvRV(sv));
8016 gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
8022 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
8031 Using various gambits, try to get a CV from an SV; in addition, try if
8032 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8038 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
8045 return *gvp = Nullgv, Nullcv;
8046 switch (SvTYPE(sv)) {
8065 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
8066 tryAMAGICunDEREF(to_cv);
8069 if (SvTYPE(sv) == SVt_PVCV) {
8078 Perl_croak(aTHX_ "Not a subroutine reference");
8083 gv = gv_fetchsv(sv, lref, SVt_PVCV);
8089 if (lref && !GvCVu(gv)) {
8092 tmpsv = NEWSV(704,0);
8093 gv_efullname3(tmpsv, gv, Nullch);
8094 /* XXX this is probably not what they think they're getting.
8095 * It has the same effect as "sub name;", i.e. just a forward
8097 newSUB(start_subparse(FALSE, 0),
8098 newSVOP(OP_CONST, 0, tmpsv),
8103 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8113 Returns true if the SV has a true value by Perl's rules.
8114 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8115 instead use an in-line version.
8121 Perl_sv_true(pTHX_ register SV *sv)
8126 const register XPV* tXpv;
8127 if ((tXpv = (XPV*)SvANY(sv)) &&
8128 (tXpv->xpv_cur > 1 ||
8129 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
8136 return SvIVX(sv) != 0;
8139 return SvNVX(sv) != 0.0;
8141 return sv_2bool(sv);
8149 A private implementation of the C<SvIVx> macro for compilers which can't
8150 cope with complex macro expressions. Always use the macro instead.
8156 Perl_sv_iv(pTHX_ register SV *sv)
8160 return (IV)SvUVX(sv);
8169 A private implementation of the C<SvUVx> macro for compilers which can't
8170 cope with complex macro expressions. Always use the macro instead.
8176 Perl_sv_uv(pTHX_ register SV *sv)
8181 return (UV)SvIVX(sv);
8189 A private implementation of the C<SvNVx> macro for compilers which can't
8190 cope with complex macro expressions. Always use the macro instead.
8196 Perl_sv_nv(pTHX_ register SV *sv)
8203 /* sv_pv() is now a macro using SvPV_nolen();
8204 * this function provided for binary compatibility only
8208 Perl_sv_pv(pTHX_ SV *sv)
8215 return sv_2pv(sv, &n_a);
8221 Use the C<SvPV_nolen> macro instead
8225 A private implementation of the C<SvPV> macro for compilers which can't
8226 cope with complex macro expressions. Always use the macro instead.
8232 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
8238 return sv_2pv(sv, lp);
8243 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
8249 return sv_2pv_flags(sv, lp, 0);
8252 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
8253 * this function provided for binary compatibility only
8257 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
8259 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
8263 =for apidoc sv_pvn_force
8265 Get a sensible string out of the SV somehow.
8266 A private implementation of the C<SvPV_force> macro for compilers which
8267 can't cope with complex macro expressions. Always use the macro instead.
8269 =for apidoc sv_pvn_force_flags
8271 Get a sensible string out of the SV somehow.
8272 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8273 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8274 implemented in terms of this function.
8275 You normally want to use the various wrapper macros instead: see
8276 C<SvPV_force> and C<SvPV_force_nomg>
8282 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
8285 if (SvTHINKFIRST(sv) && !SvROK(sv))
8286 sv_force_normal_flags(sv, 0);
8294 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
8296 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
8297 sv_reftype(sv,0), OP_NAME(PL_op));
8299 Perl_croak(aTHX_ "Can't coerce readonly %s to string",
8302 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
8303 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8307 s = sv_2pv_flags(sv, lp, flags);
8308 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
8309 const STRLEN len = *lp;
8313 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
8314 SvGROW(sv, len + 1);
8315 Move(s,SvPVX_const(sv),len,char);
8320 SvPOK_on(sv); /* validate pointer */
8322 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8323 PTR2UV(sv),SvPVX_const(sv)));
8326 return SvPVX_mutable(sv);
8329 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
8330 * this function provided for binary compatibility only
8334 Perl_sv_pvbyte(pTHX_ SV *sv)
8336 sv_utf8_downgrade(sv,0);
8341 =for apidoc sv_pvbyte
8343 Use C<SvPVbyte_nolen> instead.
8345 =for apidoc sv_pvbyten
8347 A private implementation of the C<SvPVbyte> macro for compilers
8348 which can't cope with complex macro expressions. Always use the macro
8355 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
8357 sv_utf8_downgrade(sv,0);
8358 return sv_pvn(sv,lp);
8362 =for apidoc sv_pvbyten_force
8364 A private implementation of the C<SvPVbytex_force> macro for compilers
8365 which can't cope with complex macro expressions. Always use the macro
8372 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
8374 sv_pvn_force(sv,lp);
8375 sv_utf8_downgrade(sv,0);
8380 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
8381 * this function provided for binary compatibility only
8385 Perl_sv_pvutf8(pTHX_ SV *sv)
8387 sv_utf8_upgrade(sv);
8392 =for apidoc sv_pvutf8
8394 Use the C<SvPVutf8_nolen> macro instead
8396 =for apidoc sv_pvutf8n
8398 A private implementation of the C<SvPVutf8> macro for compilers
8399 which can't cope with complex macro expressions. Always use the macro
8406 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
8408 sv_utf8_upgrade(sv);
8409 return sv_pvn(sv,lp);
8413 =for apidoc sv_pvutf8n_force
8415 A private implementation of the C<SvPVutf8_force> macro for compilers
8416 which can't cope with complex macro expressions. Always use the macro
8423 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
8425 sv_pvn_force(sv,lp);
8426 sv_utf8_upgrade(sv);
8432 =for apidoc sv_reftype
8434 Returns a string describing what the SV is a reference to.
8440 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
8442 /* The fact that I don't need to downcast to char * everywhere, only in ?:
8443 inside return suggests a const propagation bug in g++. */
8444 if (ob && SvOBJECT(sv)) {
8445 char *name = HvNAME_get(SvSTASH(sv));
8446 return name ? name : (char *) "__ANON__";
8449 switch (SvTYPE(sv)) {
8466 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
8467 /* tied lvalues should appear to be
8468 * scalars for backwards compatitbility */
8469 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8470 ? "SCALAR" : "LVALUE");
8471 case SVt_PVAV: return "ARRAY";
8472 case SVt_PVHV: return "HASH";
8473 case SVt_PVCV: return "CODE";
8474 case SVt_PVGV: return "GLOB";
8475 case SVt_PVFM: return "FORMAT";
8476 case SVt_PVIO: return "IO";
8477 default: return "UNKNOWN";
8483 =for apidoc sv_isobject
8485 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8486 object. If the SV is not an RV, or if the object is not blessed, then this
8493 Perl_sv_isobject(pTHX_ SV *sv)
8510 Returns a boolean indicating whether the SV is blessed into the specified
8511 class. This does not check for subtypes; use C<sv_derived_from> to verify
8512 an inheritance relationship.
8518 Perl_sv_isa(pTHX_ SV *sv, const char *name)
8530 hvname = HvNAME_get(SvSTASH(sv));
8534 return strEQ(hvname, name);
8540 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
8541 it will be upgraded to one. If C<classname> is non-null then the new SV will
8542 be blessed in the specified package. The new SV is returned and its
8543 reference count is 1.
8549 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
8555 SV_CHECK_THINKFIRST_COW_DROP(rv);
8558 if (SvTYPE(rv) >= SVt_PVMG) {
8559 const U32 refcnt = SvREFCNT(rv);
8563 SvREFCNT(rv) = refcnt;
8566 if (SvTYPE(rv) < SVt_RV)
8567 sv_upgrade(rv, SVt_RV);
8568 else if (SvTYPE(rv) > SVt_RV) {
8579 HV* stash = gv_stashpv(classname, TRUE);
8580 (void)sv_bless(rv, stash);
8586 =for apidoc sv_setref_pv
8588 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
8589 argument will be upgraded to an RV. That RV will be modified to point to
8590 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8591 into the SV. The C<classname> argument indicates the package for the
8592 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8593 will have a reference count of 1, and the RV will be returned.
8595 Do not use with other Perl types such as HV, AV, SV, CV, because those
8596 objects will become corrupted by the pointer copy process.
8598 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8604 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
8607 sv_setsv(rv, &PL_sv_undef);
8611 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8616 =for apidoc sv_setref_iv
8618 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
8619 argument will be upgraded to an RV. That RV will be modified to point to
8620 the new SV. The C<classname> argument indicates the package for the
8621 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8622 will have a reference count of 1, and the RV will be returned.
8628 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
8630 sv_setiv(newSVrv(rv,classname), iv);
8635 =for apidoc sv_setref_uv
8637 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
8638 argument will be upgraded to an RV. That RV will be modified to point to
8639 the new SV. The C<classname> argument indicates the package for the
8640 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8641 will have a reference count of 1, and the RV will be returned.
8647 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
8649 sv_setuv(newSVrv(rv,classname), uv);
8654 =for apidoc sv_setref_nv
8656 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8657 argument will be upgraded to an RV. That RV will be modified to point to
8658 the new SV. The C<classname> argument indicates the package for the
8659 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8660 will have a reference count of 1, and the RV will be returned.
8666 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
8668 sv_setnv(newSVrv(rv,classname), nv);
8673 =for apidoc sv_setref_pvn
8675 Copies a string into a new SV, optionally blessing the SV. The length of the
8676 string must be specified with C<n>. The C<rv> argument will be upgraded to
8677 an RV. That RV will be modified to point to the new SV. The C<classname>
8678 argument indicates the package for the blessing. Set C<classname> to
8679 C<Nullch> to avoid the blessing. The new SV will have a reference count
8680 of 1, and the RV will be returned.
8682 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8688 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
8690 sv_setpvn(newSVrv(rv,classname), pv, n);
8695 =for apidoc sv_bless
8697 Blesses an SV into a specified package. The SV must be an RV. The package
8698 must be designated by its stash (see C<gv_stashpv()>). The reference count
8699 of the SV is unaffected.
8705 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8709 Perl_croak(aTHX_ "Can't bless non-reference value");
8711 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8712 if (SvREADONLY(tmpRef))
8713 Perl_croak(aTHX_ PL_no_modify);
8714 if (SvOBJECT(tmpRef)) {
8715 if (SvTYPE(tmpRef) != SVt_PVIO)
8717 SvREFCNT_dec(SvSTASH(tmpRef));
8720 SvOBJECT_on(tmpRef);
8721 if (SvTYPE(tmpRef) != SVt_PVIO)
8723 SvUPGRADE(tmpRef, SVt_PVMG);
8724 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
8731 if(SvSMAGICAL(tmpRef))
8732 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8740 /* Downgrades a PVGV to a PVMG.
8744 S_sv_unglob(pTHX_ SV *sv)
8748 assert(SvTYPE(sv) == SVt_PVGV);
8753 SvREFCNT_dec(GvSTASH(sv));
8754 GvSTASH(sv) = Nullhv;
8756 sv_unmagic(sv, PERL_MAGIC_glob);
8757 Safefree(GvNAME(sv));
8760 /* need to keep SvANY(sv) in the right arena */
8761 xpvmg = new_XPVMG();
8762 StructCopy(SvANY(sv), xpvmg, XPVMG);
8763 del_XPVGV(SvANY(sv));
8766 SvFLAGS(sv) &= ~SVTYPEMASK;
8767 SvFLAGS(sv) |= SVt_PVMG;
8771 =for apidoc sv_unref_flags
8773 Unsets the RV status of the SV, and decrements the reference count of
8774 whatever was being referenced by the RV. This can almost be thought of
8775 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8776 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8777 (otherwise the decrementing is conditional on the reference count being
8778 different from one or the reference being a readonly SV).
8785 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
8789 if (SvWEAKREF(sv)) {
8797 /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
8798 assigned to as BEGIN {$a = \"Foo"} will fail. */
8799 if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
8801 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8802 sv_2mortal(rv); /* Schedule for freeing later */
8806 =for apidoc sv_unref
8808 Unsets the RV status of the SV, and decrements the reference count of
8809 whatever was being referenced by the RV. This can almost be thought of
8810 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
8811 being zero. See C<SvROK_off>.
8817 Perl_sv_unref(pTHX_ SV *sv)
8819 sv_unref_flags(sv, 0);
8823 =for apidoc sv_taint
8825 Taint an SV. Use C<SvTAINTED_on> instead.
8830 Perl_sv_taint(pTHX_ SV *sv)
8832 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
8836 =for apidoc sv_untaint
8838 Untaint an SV. Use C<SvTAINTED_off> instead.
8843 Perl_sv_untaint(pTHX_ SV *sv)
8845 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8846 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8853 =for apidoc sv_tainted
8855 Test an SV for taintedness. Use C<SvTAINTED> instead.
8860 Perl_sv_tainted(pTHX_ SV *sv)
8862 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8863 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8864 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
8871 =for apidoc sv_setpviv
8873 Copies an integer into the given SV, also updating its string value.
8874 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8880 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8882 char buf[TYPE_CHARS(UV)];
8884 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8886 sv_setpvn(sv, ptr, ebuf - ptr);
8890 =for apidoc sv_setpviv_mg
8892 Like C<sv_setpviv>, but also handles 'set' magic.
8898 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8900 char buf[TYPE_CHARS(UV)];
8902 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8904 sv_setpvn(sv, ptr, ebuf - ptr);
8908 #if defined(PERL_IMPLICIT_CONTEXT)
8910 /* pTHX_ magic can't cope with varargs, so this is a no-context
8911 * version of the main function, (which may itself be aliased to us).
8912 * Don't access this version directly.
8916 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8920 va_start(args, pat);
8921 sv_vsetpvf(sv, pat, &args);
8925 /* pTHX_ magic can't cope with varargs, so this is a no-context
8926 * version of the main function, (which may itself be aliased to us).
8927 * Don't access this version directly.
8931 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8935 va_start(args, pat);
8936 sv_vsetpvf_mg(sv, pat, &args);
8942 =for apidoc sv_setpvf
8944 Works like C<sv_catpvf> but copies the text into the SV instead of
8945 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8951 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8954 va_start(args, pat);
8955 sv_vsetpvf(sv, pat, &args);
8960 =for apidoc sv_vsetpvf
8962 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8963 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8965 Usually used via its frontend C<sv_setpvf>.
8971 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8973 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8977 =for apidoc sv_setpvf_mg
8979 Like C<sv_setpvf>, but also handles 'set' magic.
8985 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8988 va_start(args, pat);
8989 sv_vsetpvf_mg(sv, pat, &args);
8994 =for apidoc sv_vsetpvf_mg
8996 Like C<sv_vsetpvf>, but also handles 'set' magic.
8998 Usually used via its frontend C<sv_setpvf_mg>.
9004 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
9006 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9010 #if defined(PERL_IMPLICIT_CONTEXT)
9012 /* pTHX_ magic can't cope with varargs, so this is a no-context
9013 * version of the main function, (which may itself be aliased to us).
9014 * Don't access this version directly.
9018 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
9022 va_start(args, pat);
9023 sv_vcatpvf(sv, pat, &args);
9027 /* pTHX_ magic can't cope with varargs, so this is a no-context
9028 * version of the main function, (which may itself be aliased to us).
9029 * Don't access this version directly.
9033 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
9037 va_start(args, pat);
9038 sv_vcatpvf_mg(sv, pat, &args);
9044 =for apidoc sv_catpvf
9046 Processes its arguments like C<sprintf> and appends the formatted
9047 output to an SV. If the appended data contains "wide" characters
9048 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9049 and characters >255 formatted with %c), the original SV might get
9050 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
9051 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9052 valid UTF-8; if the original SV was bytes, the pattern should be too.
9057 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
9060 va_start(args, pat);
9061 sv_vcatpvf(sv, pat, &args);
9066 =for apidoc sv_vcatpvf
9068 Processes its arguments like C<vsprintf> and appends the formatted output
9069 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
9071 Usually used via its frontend C<sv_catpvf>.
9077 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
9079 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9083 =for apidoc sv_catpvf_mg
9085 Like C<sv_catpvf>, but also handles 'set' magic.
9091 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
9094 va_start(args, pat);
9095 sv_vcatpvf_mg(sv, pat, &args);
9100 =for apidoc sv_vcatpvf_mg
9102 Like C<sv_vcatpvf>, but also handles 'set' magic.
9104 Usually used via its frontend C<sv_catpvf_mg>.
9110 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
9112 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9117 =for apidoc sv_vsetpvfn
9119 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9122 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9128 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
9130 sv_setpvn(sv, "", 0);
9131 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9134 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
9137 S_expect_number(pTHX_ char** pattern)
9140 switch (**pattern) {
9141 case '1': case '2': case '3':
9142 case '4': case '5': case '6':
9143 case '7': case '8': case '9':
9144 while (isDIGIT(**pattern))
9145 var = var * 10 + (*(*pattern)++ - '0');
9149 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
9152 F0convert(NV nv, char *endbuf, STRLEN *len)
9154 const int neg = nv < 0;
9163 if (uv & 1 && uv == nv)
9164 uv--; /* Round to even */
9166 const unsigned dig = uv % 10;
9179 =for apidoc sv_vcatpvfn
9181 Processes its arguments like C<vsprintf> and appends the formatted output
9182 to an SV. Uses an array of SVs if the C style variable argument list is
9183 missing (NULL). When running with taint checks enabled, indicates via
9184 C<maybe_tainted> if results are untrustworthy (often due to the use of
9187 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9192 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9195 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
9202 static const char nullstr[] = "(null)";
9204 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
9205 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
9207 /* Times 4: a decimal digit takes more than 3 binary digits.
9208 * NV_DIG: mantissa takes than many decimal digits.
9209 * Plus 32: Playing safe. */
9210 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9211 /* large enough for "%#.#f" --chip */
9212 /* what about long double NVs? --jhi */
9214 /* no matter what, this is a string now */
9215 (void)SvPV_force(sv, origlen);
9217 /* special-case "", "%s", and "%-p" (SVf) */
9220 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9222 const char *s = va_arg(*args, char*);
9223 sv_catpv(sv, s ? s : nullstr);
9225 else if (svix < svmax) {
9226 sv_catsv(sv, *svargs);
9227 if (DO_UTF8(*svargs))
9232 if (patlen == 3 && pat[0] == '%' &&
9233 pat[1] == '-' && pat[2] == 'p') {
9235 argsv = va_arg(*args, SV*);
9236 sv_catsv(sv, argsv);
9243 #ifndef USE_LONG_DOUBLE
9244 /* special-case "%.<number>[gf]" */
9245 if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9246 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9247 unsigned digits = 0;
9251 while (*pp >= '0' && *pp <= '9')
9252 digits = 10 * digits + (*pp++ - '0');
9253 if (pp - pat == (int)patlen - 1) {
9257 nv = (NV)va_arg(*args, double);
9258 else if (svix < svmax)
9263 /* Add check for digits != 0 because it seems that some
9264 gconverts are buggy in this case, and we don't yet have
9265 a Configure test for this. */
9266 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9267 /* 0, point, slack */
9268 Gconvert(nv, (int)digits, 0, ebuf);
9270 if (*ebuf) /* May return an empty string for digits==0 */
9273 } else if (!digits) {
9276 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9277 sv_catpvn(sv, p, l);
9283 #endif /* !USE_LONG_DOUBLE */
9285 if (!args && svix < svmax && DO_UTF8(*svargs))
9288 patend = (char*)pat + patlen;
9289 for (p = (char*)pat; p < patend; p = q) {
9292 bool vectorize = FALSE;
9293 bool vectorarg = FALSE;
9294 bool vec_utf8 = FALSE;
9300 bool has_precis = FALSE;
9303 bool is_utf8 = FALSE; /* is this item utf8? */
9304 #ifdef HAS_LDBL_SPRINTF_BUG
9305 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9306 with sfio - Allen <allens@cpan.org> */
9307 bool fix_ldbl_sprintf_bug = FALSE;
9311 U8 utf8buf[UTF8_MAXBYTES+1];
9312 STRLEN esignlen = 0;
9314 const char *eptr = Nullch;
9317 const U8 *vecstr = Null(U8*);
9324 /* we need a long double target in case HAS_LONG_DOUBLE but
9327 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9335 const char *dotstr = ".";
9336 STRLEN dotstrlen = 1;
9337 I32 efix = 0; /* explicit format parameter index */
9338 I32 ewix = 0; /* explicit width index */
9339 I32 epix = 0; /* explicit precision index */
9340 I32 evix = 0; /* explicit vector index */
9341 bool asterisk = FALSE;
9343 /* echo everything up to the next format specification */
9344 for (q = p; q < patend && *q != '%'; ++q) ;
9346 if (has_utf8 && !pat_utf8)
9347 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9349 sv_catpvn(sv, p, q - p);
9356 We allow format specification elements in this order:
9357 \d+\$ explicit format parameter index
9359 v|\*(\d+\$)?v vector with optional (optionally specified) arg
9360 0 flag (as above): repeated to allow "v02"
9361 \d+|\*(\d+\$)? width using optional (optionally specified) arg
9362 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9364 [%bcdefginopsux_DFOUX] format (mandatory)
9366 if (EXPECT_NUMBER(q, width)) {
9407 if (EXPECT_NUMBER(q, ewix))
9416 if ((vectorarg = asterisk)) {
9428 EXPECT_NUMBER(q, width);
9433 vecsv = va_arg(*args, SV*);
9435 vecsv = (evix ? evix <= svmax : svix < svmax) ?
9436 svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
9437 dotstr = SvPV_const(vecsv, dotstrlen);
9442 vecsv = va_arg(*args, SV*);
9443 vecstr = (U8*)SvPV_const(vecsv,veclen);
9444 vec_utf8 = DO_UTF8(vecsv);
9446 else if (efix ? efix <= svmax : svix < svmax) {
9447 vecsv = svargs[efix ? efix-1 : svix++];
9448 vecstr = (U8*)SvPV_const(vecsv,veclen);
9449 vec_utf8 = DO_UTF8(vecsv);
9450 /* if this is a version object, we need to return the
9451 * stringified representation (which the SvPVX_const has
9452 * already done for us), but not vectorize the args
9454 if ( *q == 'd' && sv_derived_from(vecsv,"version") )
9456 q++; /* skip past the rest of the %vd format */
9457 eptr = (const char *) vecstr;
9458 elen = strlen(eptr);
9471 i = va_arg(*args, int);
9473 i = (ewix ? ewix <= svmax : svix < svmax) ?
9474 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9476 width = (i < 0) ? -i : i;
9486 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
9488 /* XXX: todo, support specified precision parameter */
9492 i = va_arg(*args, int);
9494 i = (ewix ? ewix <= svmax : svix < svmax)
9495 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9496 precis = (i < 0) ? 0 : i;
9501 precis = precis * 10 + (*q++ - '0');
9510 case 'I': /* Ix, I32x, and I64x */
9512 if (q[1] == '6' && q[2] == '4') {
9518 if (q[1] == '3' && q[2] == '2') {
9528 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9539 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9540 if (*(q + 1) == 'l') { /* lld, llf */
9565 argsv = (efix ? efix <= svmax : svix < svmax) ?
9566 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
9573 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
9575 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9577 eptr = (char*)utf8buf;
9578 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9589 if (args && !vectorize) {
9590 eptr = va_arg(*args, char*);
9592 #ifdef MACOS_TRADITIONAL
9593 /* On MacOS, %#s format is used for Pascal strings */
9598 elen = strlen(eptr);
9600 eptr = (char *)nullstr;
9601 elen = sizeof nullstr - 1;
9605 eptr = SvPVx_const(argsv, elen);
9606 if (DO_UTF8(argsv)) {
9607 if (has_precis && precis < elen) {
9609 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9612 if (width) { /* fudge width (can't fudge elen) */
9613 width += elen - sv_len_utf8(argsv);
9621 if (has_precis && elen > precis)
9628 if (left && args) { /* SVf */
9637 argsv = va_arg(*args, SV*);
9638 eptr = SvPVx_const(argsv, elen);
9643 if (alt || vectorize)
9645 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9663 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9672 esignbuf[esignlen++] = plus;
9676 case 'h': iv = (short)va_arg(*args, int); break;
9677 case 'l': iv = va_arg(*args, long); break;
9678 case 'V': iv = va_arg(*args, IV); break;
9679 default: iv = va_arg(*args, int); break;
9681 case 'q': iv = va_arg(*args, Quad_t); break;
9686 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
9688 case 'h': iv = (short)tiv; break;
9689 case 'l': iv = (long)tiv; break;
9691 default: iv = tiv; break;
9693 case 'q': iv = (Quad_t)tiv; break;
9697 if ( !vectorize ) /* we already set uv above */
9702 esignbuf[esignlen++] = plus;
9706 esignbuf[esignlen++] = '-';
9749 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9760 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9761 case 'l': uv = va_arg(*args, unsigned long); break;
9762 case 'V': uv = va_arg(*args, UV); break;
9763 default: uv = va_arg(*args, unsigned); break;
9765 case 'q': uv = va_arg(*args, Uquad_t); break;
9770 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9772 case 'h': uv = (unsigned short)tuv; break;
9773 case 'l': uv = (unsigned long)tuv; break;
9775 default: uv = tuv; break;
9777 case 'q': uv = (Uquad_t)tuv; break;
9784 char *ptr = ebuf + sizeof ebuf;
9790 p = (char*)((c == 'X')
9791 ? "0123456789ABCDEF" : "0123456789abcdef");
9797 esignbuf[esignlen++] = '0';
9798 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9806 if (alt && *ptr != '0')
9815 esignbuf[esignlen++] = '0';
9816 esignbuf[esignlen++] = 'b';
9819 default: /* it had better be ten or less */
9823 } while (uv /= base);
9826 elen = (ebuf + sizeof ebuf) - ptr;
9830 zeros = precis - elen;
9831 else if (precis == 0 && elen == 1 && *eptr == '0')
9837 /* FLOATING POINT */
9840 c = 'f'; /* maybe %F isn't supported here */
9846 /* This is evil, but floating point is even more evil */
9848 /* for SV-style calling, we can only get NV
9849 for C-style calling, we assume %f is double;
9850 for simplicity we allow any of %Lf, %llf, %qf for long double
9854 #if defined(USE_LONG_DOUBLE)
9858 /* [perl #20339] - we should accept and ignore %lf rather than die */
9862 #if defined(USE_LONG_DOUBLE)
9863 intsize = args ? 0 : 'q';
9867 #if defined(HAS_LONG_DOUBLE)
9876 /* now we need (long double) if intsize == 'q', else (double) */
9877 nv = (args && !vectorize) ?
9878 #if LONG_DOUBLESIZE > DOUBLESIZE
9880 va_arg(*args, long double) :
9881 va_arg(*args, double)
9883 va_arg(*args, double)
9889 if (c != 'e' && c != 'E') {
9891 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9892 will cast our (long double) to (double) */
9893 (void)Perl_frexp(nv, &i);
9894 if (i == PERL_INT_MIN)
9895 Perl_die(aTHX_ "panic: frexp");
9897 need = BIT_DIGITS(i);
9899 need += has_precis ? precis : 6; /* known default */
9904 #ifdef HAS_LDBL_SPRINTF_BUG
9905 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9906 with sfio - Allen <allens@cpan.org> */
9909 # define MY_DBL_MAX DBL_MAX
9910 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9911 # if DOUBLESIZE >= 8
9912 # define MY_DBL_MAX 1.7976931348623157E+308L
9914 # define MY_DBL_MAX 3.40282347E+38L
9918 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9919 # define MY_DBL_MAX_BUG 1L
9921 # define MY_DBL_MAX_BUG MY_DBL_MAX
9925 # define MY_DBL_MIN DBL_MIN
9926 # else /* XXX guessing! -Allen */
9927 # if DOUBLESIZE >= 8
9928 # define MY_DBL_MIN 2.2250738585072014E-308L
9930 # define MY_DBL_MIN 1.17549435E-38L
9934 if ((intsize == 'q') && (c == 'f') &&
9935 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9937 /* it's going to be short enough that
9938 * long double precision is not needed */
9940 if ((nv <= 0L) && (nv >= -0L))
9941 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9943 /* would use Perl_fp_class as a double-check but not
9944 * functional on IRIX - see perl.h comments */
9946 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9947 /* It's within the range that a double can represent */
9948 #if defined(DBL_MAX) && !defined(DBL_MIN)
9949 if ((nv >= ((long double)1/DBL_MAX)) ||
9950 (nv <= (-(long double)1/DBL_MAX)))
9952 fix_ldbl_sprintf_bug = TRUE;
9955 if (fix_ldbl_sprintf_bug == TRUE) {
9965 # undef MY_DBL_MAX_BUG
9968 #endif /* HAS_LDBL_SPRINTF_BUG */
9970 need += 20; /* fudge factor */
9971 if (PL_efloatsize < need) {
9972 Safefree(PL_efloatbuf);
9973 PL_efloatsize = need + 20; /* more fudge */
9974 New(906, PL_efloatbuf, PL_efloatsize, char);
9975 PL_efloatbuf[0] = '\0';
9978 if ( !(width || left || plus || alt) && fill != '0'
9979 && has_precis && intsize != 'q' ) { /* Shortcuts */
9980 /* See earlier comment about buggy Gconvert when digits,
9982 if ( c == 'g' && precis) {
9983 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9984 if (*PL_efloatbuf) /* May return an empty string for digits==0 */
9985 goto float_converted;
9986 } else if ( c == 'f' && !precis) {
9987 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9992 char *ptr = ebuf + sizeof ebuf;
9995 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9996 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9997 if (intsize == 'q') {
9998 /* Copy the one or more characters in a long double
9999 * format before the 'base' ([efgEFG]) character to
10000 * the format string. */
10001 static char const prifldbl[] = PERL_PRIfldbl;
10002 char const *p = prifldbl + sizeof(prifldbl) - 3;
10003 while (p >= prifldbl) { *--ptr = *p--; }
10008 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10013 do { *--ptr = '0' + (base % 10); } while (base /= 10);
10025 /* No taint. Otherwise we are in the strange situation
10026 * where printf() taints but print($float) doesn't.
10028 #if defined(HAS_LONG_DOUBLE)
10029 if (intsize == 'q')
10030 (void)sprintf(PL_efloatbuf, ptr, nv);
10032 (void)sprintf(PL_efloatbuf, ptr, (double)nv);
10034 (void)sprintf(PL_efloatbuf, ptr, nv);
10038 eptr = PL_efloatbuf;
10039 elen = strlen(PL_efloatbuf);
10045 i = SvCUR(sv) - origlen;
10046 if (args && !vectorize) {
10048 case 'h': *(va_arg(*args, short*)) = i; break;
10049 default: *(va_arg(*args, int*)) = i; break;
10050 case 'l': *(va_arg(*args, long*)) = i; break;
10051 case 'V': *(va_arg(*args, IV*)) = i; break;
10053 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
10058 sv_setuv_mg(argsv, (UV)i);
10060 continue; /* not "break" */
10066 if (!args && ckWARN(WARN_PRINTF) &&
10067 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
10068 SV *msg = sv_newmortal();
10069 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10070 (PL_op->op_type == OP_PRTF) ? "" : "s");
10073 Perl_sv_catpvf(aTHX_ msg,
10074 "\"%%%c\"", c & 0xFF);
10076 Perl_sv_catpvf(aTHX_ msg,
10077 "\"%%\\%03"UVof"\"",
10080 sv_catpv(msg, "end of string");
10081 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
10084 /* output mangled stuff ... */
10090 /* ... right here, because formatting flags should not apply */
10091 SvGROW(sv, SvCUR(sv) + elen + 1);
10093 Copy(eptr, p, elen, char);
10096 SvCUR_set(sv, p - SvPVX_const(sv));
10098 continue; /* not "break" */
10101 /* calculate width before utf8_upgrade changes it */
10102 have = esignlen + zeros + elen;
10104 if (is_utf8 != has_utf8) {
10107 sv_utf8_upgrade(sv);
10110 SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
10111 sv_utf8_upgrade(nsv);
10115 SvGROW(sv, SvCUR(sv) + elen + 1);
10120 need = (have > width ? have : width);
10123 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10125 if (esignlen && fill == '0') {
10126 for (i = 0; i < (int)esignlen; i++)
10127 *p++ = esignbuf[i];
10129 if (gap && !left) {
10130 memset(p, fill, gap);
10133 if (esignlen && fill != '0') {
10134 for (i = 0; i < (int)esignlen; i++)
10135 *p++ = esignbuf[i];
10138 for (i = zeros; i; i--)
10142 Copy(eptr, p, elen, char);
10146 memset(p, ' ', gap);
10151 Copy(dotstr, p, dotstrlen, char);
10155 vectorize = FALSE; /* done iterating over vecstr */
10162 SvCUR_set(sv, p - SvPVX_const(sv));
10170 /* =========================================================================
10172 =head1 Cloning an interpreter
10174 All the macros and functions in this section are for the private use of
10175 the main function, perl_clone().
10177 The foo_dup() functions make an exact copy of an existing foo thinngy.
10178 During the course of a cloning, a hash table is used to map old addresses
10179 to new addresses. The table is created and manipulated with the
10180 ptr_table_* functions.
10184 ============================================================================*/
10187 #if defined(USE_ITHREADS)
10189 #ifndef GpREFCNT_inc
10190 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10194 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10195 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
10196 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10197 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
10198 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10199 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
10200 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10201 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
10202 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
10203 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
10204 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10205 #define SAVEPV(p) (p ? savepv(p) : Nullch)
10206 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
10209 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
10210 regcomp.c. AMS 20010712 */
10213 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
10218 struct reg_substr_datum *s;
10221 return (REGEXP *)NULL;
10223 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
10226 len = r->offsets[0];
10227 npar = r->nparens+1;
10229 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
10230 Copy(r->program, ret->program, len+1, regnode);
10232 New(0, ret->startp, npar, I32);
10233 Copy(r->startp, ret->startp, npar, I32);
10234 New(0, ret->endp, npar, I32);
10235 Copy(r->startp, ret->startp, npar, I32);
10237 New(0, ret->substrs, 1, struct reg_substr_data);
10238 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
10239 s->min_offset = r->substrs->data[i].min_offset;
10240 s->max_offset = r->substrs->data[i].max_offset;
10241 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
10242 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
10245 ret->regstclass = NULL;
10247 struct reg_data *d;
10248 const int count = r->data->count;
10250 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
10251 char, struct reg_data);
10252 New(0, d->what, count, U8);
10255 for (i = 0; i < count; i++) {
10256 d->what[i] = r->data->what[i];
10257 switch (d->what[i]) {
10258 /* legal options are one of: sfpont
10259 see also regcomp.h and pregfree() */
10261 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
10264 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
10267 /* This is cheating. */
10268 New(0, d->data[i], 1, struct regnode_charclass_class);
10269 StructCopy(r->data->data[i], d->data[i],
10270 struct regnode_charclass_class);
10271 ret->regstclass = (regnode*)d->data[i];
10274 /* Compiled op trees are readonly, and can thus be
10275 shared without duplication. */
10277 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
10281 d->data[i] = r->data->data[i];
10284 d->data[i] = r->data->data[i];
10286 ((reg_trie_data*)d->data[i])->refcount++;
10290 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
10299 New(0, ret->offsets, 2*len+1, U32);
10300 Copy(r->offsets, ret->offsets, 2*len+1, U32);
10302 ret->precomp = SAVEPVN(r->precomp, r->prelen);
10303 ret->refcnt = r->refcnt;
10304 ret->minlen = r->minlen;
10305 ret->prelen = r->prelen;
10306 ret->nparens = r->nparens;
10307 ret->lastparen = r->lastparen;
10308 ret->lastcloseparen = r->lastcloseparen;
10309 ret->reganch = r->reganch;
10311 ret->sublen = r->sublen;
10313 if (RX_MATCH_COPIED(ret))
10314 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
10316 ret->subbeg = Nullch;
10317 #ifdef PERL_COPY_ON_WRITE
10318 ret->saved_copy = Nullsv;
10321 ptr_table_store(PL_ptr_table, r, ret);
10325 /* duplicate a file handle */
10328 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
10334 return (PerlIO*)NULL;
10336 /* look for it in the table first */
10337 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10341 /* create anew and remember what it is */
10342 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10343 ptr_table_store(PL_ptr_table, fp, ret);
10347 /* duplicate a directory handle */
10350 Perl_dirp_dup(pTHX_ DIR *dp)
10358 /* duplicate a typeglob */
10361 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
10366 /* look for it in the table first */
10367 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10371 /* create anew and remember what it is */
10372 Newz(0, ret, 1, GP);
10373 ptr_table_store(PL_ptr_table, gp, ret);
10376 ret->gp_refcnt = 0; /* must be before any other dups! */
10377 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
10378 ret->gp_io = io_dup_inc(gp->gp_io, param);
10379 ret->gp_form = cv_dup_inc(gp->gp_form, param);
10380 ret->gp_av = av_dup_inc(gp->gp_av, param);
10381 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
10382 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10383 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
10384 ret->gp_cvgen = gp->gp_cvgen;
10385 ret->gp_flags = gp->gp_flags;
10386 ret->gp_line = gp->gp_line;
10387 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
10391 /* duplicate a chain of magic */
10394 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
10396 MAGIC *mgprev = (MAGIC*)NULL;
10399 return (MAGIC*)NULL;
10400 /* look for it in the table first */
10401 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
10405 for (; mg; mg = mg->mg_moremagic) {
10407 Newz(0, nmg, 1, MAGIC);
10409 mgprev->mg_moremagic = nmg;
10412 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
10413 nmg->mg_private = mg->mg_private;
10414 nmg->mg_type = mg->mg_type;
10415 nmg->mg_flags = mg->mg_flags;
10416 if (mg->mg_type == PERL_MAGIC_qr) {
10417 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
10419 else if(mg->mg_type == PERL_MAGIC_backref) {
10420 const AV * const av = (AV*) mg->mg_obj;
10423 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
10425 for (i = AvFILLp(av); i >= 0; i--) {
10426 if (!svp[i]) continue;
10427 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
10430 else if (mg->mg_type == PERL_MAGIC_symtab) {
10431 nmg->mg_obj = mg->mg_obj;
10434 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
10435 ? sv_dup_inc(mg->mg_obj, param)
10436 : sv_dup(mg->mg_obj, param);
10438 nmg->mg_len = mg->mg_len;
10439 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
10440 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
10441 if (mg->mg_len > 0) {
10442 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
10443 if (mg->mg_type == PERL_MAGIC_overload_table &&
10444 AMT_AMAGIC((AMT*)mg->mg_ptr))
10446 AMT *amtp = (AMT*)mg->mg_ptr;
10447 AMT *namtp = (AMT*)nmg->mg_ptr;
10449 for (i = 1; i < NofAMmeth; i++) {
10450 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
10454 else if (mg->mg_len == HEf_SVKEY)
10455 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
10457 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
10458 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10465 /* create a new pointer-mapping table */
10468 Perl_ptr_table_new(pTHX)
10471 Newz(0, tbl, 1, PTR_TBL_t);
10472 tbl->tbl_max = 511;
10473 tbl->tbl_items = 0;
10474 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10479 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
10481 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
10489 struct ptr_tbl_ent* pte;
10490 struct ptr_tbl_ent* pteend;
10491 New(0, pte, PERL_ARENA_SIZE/sizeof(struct ptr_tbl_ent), struct ptr_tbl_ent);
10492 pte->next = PL_pte_arenaroot;
10493 PL_pte_arenaroot = pte;
10495 pteend = &pte[PERL_ARENA_SIZE / sizeof(struct ptr_tbl_ent) - 1];
10496 PL_pte_root = ++pte;
10497 while (pte < pteend) {
10498 pte->next = pte + 1;
10504 STATIC struct ptr_tbl_ent*
10507 struct ptr_tbl_ent* pte;
10511 PL_pte_root = pte->next;
10516 S_del_pte(pTHX_ struct ptr_tbl_ent*p)
10518 p->next = PL_pte_root;
10522 /* map an existing pointer using a table */
10525 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
10527 PTR_TBL_ENT_t *tblent;
10528 const UV hash = PTR_TABLE_HASH(sv);
10530 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10531 for (; tblent; tblent = tblent->next) {
10532 if (tblent->oldval == sv)
10533 return tblent->newval;
10535 return (void*)NULL;
10538 /* add a new entry to a pointer-mapping table */
10541 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
10543 PTR_TBL_ENT_t *tblent, **otblent;
10544 /* XXX this may be pessimal on platforms where pointers aren't good
10545 * hash values e.g. if they grow faster in the most significant
10547 const UV hash = PTR_TABLE_HASH(oldv);
10551 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
10552 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
10553 if (tblent->oldval == oldv) {
10554 tblent->newval = newv;
10558 tblent = S_new_pte(aTHX);
10559 tblent->oldval = oldv;
10560 tblent->newval = newv;
10561 tblent->next = *otblent;
10564 if (!empty && tbl->tbl_items > tbl->tbl_max)
10565 ptr_table_split(tbl);
10568 /* double the hash bucket size of an existing ptr table */
10571 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
10573 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10574 const UV oldsize = tbl->tbl_max + 1;
10575 UV newsize = oldsize * 2;
10578 Renew(ary, newsize, PTR_TBL_ENT_t*);
10579 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10580 tbl->tbl_max = --newsize;
10581 tbl->tbl_ary = ary;
10582 for (i=0; i < oldsize; i++, ary++) {
10583 PTR_TBL_ENT_t **curentp, **entp, *ent;
10586 curentp = ary + oldsize;
10587 for (entp = ary, ent = *ary; ent; ent = *entp) {
10588 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10590 ent->next = *curentp;
10600 /* remove all the entries from a ptr table */
10603 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
10605 register PTR_TBL_ENT_t **array;
10606 register PTR_TBL_ENT_t *entry;
10610 if (!tbl || !tbl->tbl_items) {
10614 array = tbl->tbl_ary;
10616 max = tbl->tbl_max;
10620 PTR_TBL_ENT_t *oentry = entry;
10621 entry = entry->next;
10622 S_del_pte(aTHX_ oentry);
10625 if (++riter > max) {
10628 entry = array[riter];
10632 tbl->tbl_items = 0;
10635 /* clear and free a ptr table */
10638 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
10643 ptr_table_clear(tbl);
10644 Safefree(tbl->tbl_ary);
10648 /* attempt to make everything in the typeglob readonly */
10651 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
10653 GV *gv = (GV*)sstr;
10654 SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */
10656 if (GvIO(gv) || GvFORM(gv)) {
10657 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
10659 else if (!GvCV(gv)) {
10660 GvCV(gv) = (CV*)sv;
10663 /* CvPADLISTs cannot be shared */
10664 if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
10669 if (!GvUNIQUE(gv)) {
10671 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
10672 HvNAME_get(GvSTASH(gv)), GvNAME(gv));
10678 * write attempts will die with
10679 * "Modification of a read-only value attempted"
10685 SvREADONLY_on(GvSV(gv));
10689 GvAV(gv) = (AV*)sv;
10692 SvREADONLY_on(GvAV(gv));
10696 GvHV(gv) = (HV*)sv;
10699 SvREADONLY_on(GvHV(gv));
10702 return sstr; /* he_dup() will SvREFCNT_inc() */
10705 /* duplicate an SV of any type (including AV, HV etc) */
10708 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
10711 SvRV_set(dstr, SvWEAKREF(sstr)
10712 ? sv_dup(SvRV(sstr), param)
10713 : sv_dup_inc(SvRV(sstr), param));
10716 else if (SvPVX_const(sstr)) {
10717 /* Has something there */
10719 /* Normal PV - clone whole allocated space */
10720 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
10721 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10722 /* Not that normal - actually sstr is copy on write.
10723 But we are a true, independant SV, so: */
10724 SvREADONLY_off(dstr);
10729 /* Special case - not normally malloced for some reason */
10730 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10731 /* A "shared" PV - clone it as unshared string */
10732 if(SvPADTMP(sstr)) {
10733 /* However, some of them live in the pad
10734 and they should not have these flags
10737 SvPV_set(dstr, sharepvn(SvPVX_const(sstr), SvCUR(sstr),
10739 SvUV_set(dstr, SvUVX(sstr));
10742 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvCUR(sstr)));
10744 SvREADONLY_off(dstr);
10748 /* Some other special case - random pointer */
10749 SvPV_set(dstr, SvPVX(sstr));
10754 /* Copy the Null */
10755 if (SvTYPE(dstr) == SVt_RV)
10756 SvRV_set(dstr, NULL);
10763 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
10768 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10770 /* look for it in the table first */
10771 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10775 if(param->flags & CLONEf_JOIN_IN) {
10776 /** We are joining here so we don't want do clone
10777 something that is bad **/
10778 const char *hvname;
10780 if(SvTYPE(sstr) == SVt_PVHV &&
10781 (hvname = HvNAME_get(sstr))) {
10782 /** don't clone stashes if they already exist **/
10783 HV* old_stash = gv_stashpv(hvname,0);
10784 return (SV*) old_stash;
10788 /* create anew and remember what it is */
10791 #ifdef DEBUG_LEAKING_SCALARS
10792 dstr->sv_debug_optype = sstr->sv_debug_optype;
10793 dstr->sv_debug_line = sstr->sv_debug_line;
10794 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10795 dstr->sv_debug_cloned = 1;
10797 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10799 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
10803 ptr_table_store(PL_ptr_table, sstr, dstr);
10806 SvFLAGS(dstr) = SvFLAGS(sstr);
10807 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10808 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10811 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
10812 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10813 PL_watch_pvx, SvPVX_const(sstr));
10816 /* don't clone objects whose class has asked us not to */
10817 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10818 SvFLAGS(dstr) &= ~SVTYPEMASK;
10819 SvOBJECT_off(dstr);
10823 switch (SvTYPE(sstr)) {
10825 SvANY(dstr) = NULL;
10828 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
10829 SvIV_set(dstr, SvIVX(sstr));
10832 SvANY(dstr) = new_XNV();
10833 SvNV_set(dstr, SvNVX(sstr));
10836 SvANY(dstr) = &(dstr->sv_u.svu_rv);
10837 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10840 SvANY(dstr) = new_XPV();
10841 SvCUR_set(dstr, SvCUR(sstr));
10842 SvLEN_set(dstr, SvLEN(sstr));
10843 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10846 SvANY(dstr) = new_XPVIV();
10847 SvCUR_set(dstr, SvCUR(sstr));
10848 SvLEN_set(dstr, SvLEN(sstr));
10849 SvIV_set(dstr, SvIVX(sstr));
10850 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10853 SvANY(dstr) = new_XPVNV();
10854 SvCUR_set(dstr, SvCUR(sstr));
10855 SvLEN_set(dstr, SvLEN(sstr));
10856 SvIV_set(dstr, SvIVX(sstr));
10857 SvNV_set(dstr, SvNVX(sstr));
10858 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10861 SvANY(dstr) = new_XPVMG();
10862 SvCUR_set(dstr, SvCUR(sstr));
10863 SvLEN_set(dstr, SvLEN(sstr));
10864 SvIV_set(dstr, SvIVX(sstr));
10865 SvNV_set(dstr, SvNVX(sstr));
10866 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10867 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10868 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10871 SvANY(dstr) = new_XPVBM();
10872 SvCUR_set(dstr, SvCUR(sstr));
10873 SvLEN_set(dstr, SvLEN(sstr));
10874 SvIV_set(dstr, SvIVX(sstr));
10875 SvNV_set(dstr, SvNVX(sstr));
10876 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10877 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10878 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10879 BmRARE(dstr) = BmRARE(sstr);
10880 BmUSEFUL(dstr) = BmUSEFUL(sstr);
10881 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
10884 SvANY(dstr) = new_XPVLV();
10885 SvCUR_set(dstr, SvCUR(sstr));
10886 SvLEN_set(dstr, SvLEN(sstr));
10887 SvIV_set(dstr, SvIVX(sstr));
10888 SvNV_set(dstr, SvNVX(sstr));
10889 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10890 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10891 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10892 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
10893 LvTARGLEN(dstr) = LvTARGLEN(sstr);
10894 if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */
10895 LvTARG(dstr) = dstr;
10896 else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */
10897 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param);
10899 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
10900 LvTYPE(dstr) = LvTYPE(sstr);
10903 if (GvUNIQUE((GV*)sstr)) {
10905 if ((share = gv_share(sstr, param))) {
10908 ptr_table_store(PL_ptr_table, sstr, dstr);
10910 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
10911 HvNAME_get(GvSTASH(share)), GvNAME(share));
10916 SvANY(dstr) = new_XPVGV();
10917 SvCUR_set(dstr, SvCUR(sstr));
10918 SvLEN_set(dstr, SvLEN(sstr));
10919 SvIV_set(dstr, SvIVX(sstr));
10920 SvNV_set(dstr, SvNVX(sstr));
10921 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10922 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10923 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10924 GvNAMELEN(dstr) = GvNAMELEN(sstr);
10925 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
10926 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
10927 GvFLAGS(dstr) = GvFLAGS(sstr);
10928 GvGP(dstr) = gp_dup(GvGP(sstr), param);
10929 (void)GpREFCNT_inc(GvGP(dstr));
10932 SvANY(dstr) = new_XPVIO();
10933 SvCUR_set(dstr, SvCUR(sstr));
10934 SvLEN_set(dstr, SvLEN(sstr));
10935 SvIV_set(dstr, SvIVX(sstr));
10936 SvNV_set(dstr, SvNVX(sstr));
10937 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10938 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10939 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10940 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
10941 if (IoOFP(sstr) == IoIFP(sstr))
10942 IoOFP(dstr) = IoIFP(dstr);
10944 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
10945 /* PL_rsfp_filters entries have fake IoDIRP() */
10946 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
10947 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
10949 IoDIRP(dstr) = IoDIRP(sstr);
10950 IoLINES(dstr) = IoLINES(sstr);
10951 IoPAGE(dstr) = IoPAGE(sstr);
10952 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
10953 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
10954 if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
10955 /* I have no idea why fake dirp (rsfps)
10956 should be treaded differently but otherwise
10957 we end up with leaks -- sky*/
10958 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(sstr), param);
10959 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(sstr), param);
10960 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(sstr), param);
10962 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
10963 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
10964 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
10966 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
10967 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
10968 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
10969 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
10970 IoTYPE(dstr) = IoTYPE(sstr);
10971 IoFLAGS(dstr) = IoFLAGS(sstr);
10974 SvANY(dstr) = new_XPVAV();
10975 SvCUR_set(dstr, SvCUR(sstr));
10976 SvLEN_set(dstr, SvLEN(sstr));
10977 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10978 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10979 if (AvARRAY((AV*)sstr)) {
10980 SV **dst_ary, **src_ary;
10981 SSize_t items = AvFILLp((AV*)sstr) + 1;
10983 src_ary = AvARRAY((AV*)sstr);
10984 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
10985 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10986 SvPV_set(dstr, (char*)dst_ary);
10987 AvALLOC((AV*)dstr) = dst_ary;
10988 if (AvREAL((AV*)sstr)) {
10989 while (items-- > 0)
10990 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10993 while (items-- > 0)
10994 *dst_ary++ = sv_dup(*src_ary++, param);
10996 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10997 while (items-- > 0) {
10998 *dst_ary++ = &PL_sv_undef;
11002 SvPV_set(dstr, Nullch);
11003 AvALLOC((AV*)dstr) = (SV**)NULL;
11007 SvANY(dstr) = new_XPVHV();
11008 SvCUR_set(dstr, SvCUR(sstr));
11009 SvLEN_set(dstr, SvLEN(sstr));
11010 HvTOTALKEYS(dstr) = HvTOTALKEYS(sstr);
11011 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
11012 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
11016 if (HvARRAY((HV*)sstr)) {
11018 const bool sharekeys = !!HvSHAREKEYS(sstr);
11019 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
11020 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
11023 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
11024 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0), char);
11025 HvARRAY(dstr) = (HE**)darray;
11026 while (i <= sxhv->xhv_max) {
11027 HE *source = HvARRAY(sstr)[i];
11029 = source ? he_dup(source, sharekeys, param) : 0;
11033 struct xpvhv_aux *saux = HvAUX(sstr);
11034 struct xpvhv_aux *daux = HvAUX(dstr);
11035 /* This flag isn't copied. */
11036 /* SvOOK_on(hv) attacks the IV flags. */
11037 SvFLAGS(dstr) |= SVf_OOK;
11039 hvname = saux->xhv_name;
11040 daux->xhv_name = hvname ? hek_dup(hvname, param) : hvname;
11042 daux->xhv_riter = saux->xhv_riter;
11043 daux->xhv_eiter = saux->xhv_eiter
11044 ? he_dup(saux->xhv_eiter, (bool)!!HvSHAREKEYS(sstr),
11049 SvPV_set(dstr, Nullch);
11051 /* Record stashes for possible cloning in Perl_clone(). */
11053 av_push(param->stashes, dstr);
11057 SvANY(dstr) = new_XPVFM();
11058 FmLINES(dstr) = FmLINES(sstr);
11062 SvANY(dstr) = new_XPVCV();
11064 SvCUR_set(dstr, SvCUR(sstr));
11065 SvLEN_set(dstr, SvLEN(sstr));
11066 SvIV_set(dstr, SvIVX(sstr));
11067 SvNV_set(dstr, SvNVX(sstr));
11068 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
11069 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
11070 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11071 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
11072 CvSTART(dstr) = CvSTART(sstr);
11074 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
11076 CvXSUB(dstr) = CvXSUB(sstr);
11077 CvXSUBANY(dstr) = CvXSUBANY(sstr);
11078 if (CvCONST(sstr)) {
11079 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
11080 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
11081 sv_dup_inc((SV *)CvXSUBANY(sstr).any_ptr, param);
11083 /* don't dup if copying back - CvGV isn't refcounted, so the
11084 * duped GV may never be freed. A bit of a hack! DAPM */
11085 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
11086 Nullgv : gv_dup(CvGV(sstr), param) ;
11087 if (param->flags & CLONEf_COPY_STACKS) {
11088 CvDEPTH(dstr) = CvDEPTH(sstr);
11092 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
11093 CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
11095 CvWEAKOUTSIDE(sstr)
11096 ? cv_dup( CvOUTSIDE(sstr), param)
11097 : cv_dup_inc(CvOUTSIDE(sstr), param);
11098 CvFLAGS(dstr) = CvFLAGS(sstr);
11099 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
11102 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11106 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
11112 /* duplicate a context */
11115 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
11117 PERL_CONTEXT *ncxs;
11120 return (PERL_CONTEXT*)NULL;
11122 /* look for it in the table first */
11123 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
11127 /* create anew and remember what it is */
11128 Newz(56, ncxs, max + 1, PERL_CONTEXT);
11129 ptr_table_store(PL_ptr_table, cxs, ncxs);
11132 PERL_CONTEXT *cx = &cxs[ix];
11133 PERL_CONTEXT *ncx = &ncxs[ix];
11134 ncx->cx_type = cx->cx_type;
11135 if (CxTYPE(cx) == CXt_SUBST) {
11136 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
11139 ncx->blk_oldsp = cx->blk_oldsp;
11140 ncx->blk_oldcop = cx->blk_oldcop;
11141 ncx->blk_oldmarksp = cx->blk_oldmarksp;
11142 ncx->blk_oldscopesp = cx->blk_oldscopesp;
11143 ncx->blk_oldpm = cx->blk_oldpm;
11144 ncx->blk_gimme = cx->blk_gimme;
11145 switch (CxTYPE(cx)) {
11147 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
11148 ? cv_dup_inc(cx->blk_sub.cv, param)
11149 : cv_dup(cx->blk_sub.cv,param));
11150 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
11151 ? av_dup_inc(cx->blk_sub.argarray, param)
11153 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
11154 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
11155 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
11156 ncx->blk_sub.lval = cx->blk_sub.lval;
11157 ncx->blk_sub.retop = cx->blk_sub.retop;
11160 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
11161 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
11162 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
11163 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
11164 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
11165 ncx->blk_eval.retop = cx->blk_eval.retop;
11168 ncx->blk_loop.label = cx->blk_loop.label;
11169 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
11170 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
11171 ncx->blk_loop.next_op = cx->blk_loop.next_op;
11172 ncx->blk_loop.last_op = cx->blk_loop.last_op;
11173 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
11174 ? cx->blk_loop.iterdata
11175 : gv_dup((GV*)cx->blk_loop.iterdata, param));
11176 ncx->blk_loop.oldcomppad
11177 = (PAD*)ptr_table_fetch(PL_ptr_table,
11178 cx->blk_loop.oldcomppad);
11179 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
11180 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
11181 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
11182 ncx->blk_loop.iterix = cx->blk_loop.iterix;
11183 ncx->blk_loop.itermax = cx->blk_loop.itermax;
11186 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
11187 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
11188 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
11189 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
11190 ncx->blk_sub.retop = cx->blk_sub.retop;
11202 /* duplicate a stack info structure */
11205 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11210 return (PERL_SI*)NULL;
11212 /* look for it in the table first */
11213 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11217 /* create anew and remember what it is */
11218 Newz(56, nsi, 1, PERL_SI);
11219 ptr_table_store(PL_ptr_table, si, nsi);
11221 nsi->si_stack = av_dup_inc(si->si_stack, param);
11222 nsi->si_cxix = si->si_cxix;
11223 nsi->si_cxmax = si->si_cxmax;
11224 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11225 nsi->si_type = si->si_type;
11226 nsi->si_prev = si_dup(si->si_prev, param);
11227 nsi->si_next = si_dup(si->si_next, param);
11228 nsi->si_markoff = si->si_markoff;
11233 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
11234 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
11235 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
11236 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
11237 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
11238 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
11239 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
11240 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
11241 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
11242 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
11243 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
11244 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
11245 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11246 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11249 #define pv_dup_inc(p) SAVEPV(p)
11250 #define pv_dup(p) SAVEPV(p)
11251 #define svp_dup_inc(p,pp) any_dup(p,pp)
11253 /* map any object to the new equivent - either something in the
11254 * ptr table, or something in the interpreter structure
11258 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
11263 return (void*)NULL;
11265 /* look for it in the table first */
11266 ret = ptr_table_fetch(PL_ptr_table, v);
11270 /* see if it is part of the interpreter structure */
11271 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11272 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11280 /* duplicate the save stack */
11283 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11285 ANY *ss = proto_perl->Tsavestack;
11286 I32 ix = proto_perl->Tsavestack_ix;
11287 I32 max = proto_perl->Tsavestack_max;
11299 void (*dptr) (void*);
11300 void (*dxptr) (pTHX_ void*);
11302 /* Unions for circumventing strict ANSI C89 casting rules. */
11303 union { void *vptr; void (*dptr)(void*); } u1, u2;
11304 union { void *vptr; void (*dxptr)(pTHX_ void*); } u3, u4;
11306 Newz(54, nss, max, ANY);
11309 I32 i = POPINT(ss,ix);
11310 TOPINT(nss,ix) = i;
11312 case SAVEt_ITEM: /* normal string */
11313 sv = (SV*)POPPTR(ss,ix);
11314 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11315 sv = (SV*)POPPTR(ss,ix);
11316 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11318 case SAVEt_SV: /* scalar reference */
11319 sv = (SV*)POPPTR(ss,ix);
11320 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11321 gv = (GV*)POPPTR(ss,ix);
11322 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11324 case SAVEt_GENERIC_PVREF: /* generic char* */
11325 c = (char*)POPPTR(ss,ix);
11326 TOPPTR(nss,ix) = pv_dup(c);
11327 ptr = POPPTR(ss,ix);
11328 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11330 case SAVEt_SHARED_PVREF: /* char* in shared space */
11331 c = (char*)POPPTR(ss,ix);
11332 TOPPTR(nss,ix) = savesharedpv(c);
11333 ptr = POPPTR(ss,ix);
11334 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11336 case SAVEt_GENERIC_SVREF: /* generic sv */
11337 case SAVEt_SVREF: /* scalar reference */
11338 sv = (SV*)POPPTR(ss,ix);
11339 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11340 ptr = POPPTR(ss,ix);
11341 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11343 case SAVEt_AV: /* array reference */
11344 av = (AV*)POPPTR(ss,ix);
11345 TOPPTR(nss,ix) = av_dup_inc(av, param);
11346 gv = (GV*)POPPTR(ss,ix);
11347 TOPPTR(nss,ix) = gv_dup(gv, param);
11349 case SAVEt_HV: /* hash reference */
11350 hv = (HV*)POPPTR(ss,ix);
11351 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11352 gv = (GV*)POPPTR(ss,ix);
11353 TOPPTR(nss,ix) = gv_dup(gv, param);
11355 case SAVEt_INT: /* int reference */
11356 ptr = POPPTR(ss,ix);
11357 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11358 intval = (int)POPINT(ss,ix);
11359 TOPINT(nss,ix) = intval;
11361 case SAVEt_LONG: /* long reference */
11362 ptr = POPPTR(ss,ix);
11363 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11364 longval = (long)POPLONG(ss,ix);
11365 TOPLONG(nss,ix) = longval;
11367 case SAVEt_I32: /* I32 reference */
11368 case SAVEt_I16: /* I16 reference */
11369 case SAVEt_I8: /* I8 reference */
11370 ptr = POPPTR(ss,ix);
11371 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11373 TOPINT(nss,ix) = i;
11375 case SAVEt_IV: /* IV reference */
11376 ptr = POPPTR(ss,ix);
11377 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11379 TOPIV(nss,ix) = iv;
11381 case SAVEt_SPTR: /* SV* reference */
11382 ptr = POPPTR(ss,ix);
11383 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11384 sv = (SV*)POPPTR(ss,ix);
11385 TOPPTR(nss,ix) = sv_dup(sv, param);
11387 case SAVEt_VPTR: /* random* reference */
11388 ptr = POPPTR(ss,ix);
11389 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11390 ptr = POPPTR(ss,ix);
11391 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11393 case SAVEt_PPTR: /* char* reference */
11394 ptr = POPPTR(ss,ix);
11395 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11396 c = (char*)POPPTR(ss,ix);
11397 TOPPTR(nss,ix) = pv_dup(c);
11399 case SAVEt_HPTR: /* HV* reference */
11400 ptr = POPPTR(ss,ix);
11401 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11402 hv = (HV*)POPPTR(ss,ix);
11403 TOPPTR(nss,ix) = hv_dup(hv, param);
11405 case SAVEt_APTR: /* AV* reference */
11406 ptr = POPPTR(ss,ix);
11407 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11408 av = (AV*)POPPTR(ss,ix);
11409 TOPPTR(nss,ix) = av_dup(av, param);
11412 gv = (GV*)POPPTR(ss,ix);
11413 TOPPTR(nss,ix) = gv_dup(gv, param);
11415 case SAVEt_GP: /* scalar reference */
11416 gp = (GP*)POPPTR(ss,ix);
11417 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11418 (void)GpREFCNT_inc(gp);
11419 gv = (GV*)POPPTR(ss,ix);
11420 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11421 c = (char*)POPPTR(ss,ix);
11422 TOPPTR(nss,ix) = pv_dup(c);
11424 TOPIV(nss,ix) = iv;
11426 TOPIV(nss,ix) = iv;
11429 case SAVEt_MORTALIZESV:
11430 sv = (SV*)POPPTR(ss,ix);
11431 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11434 ptr = POPPTR(ss,ix);
11435 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11436 /* these are assumed to be refcounted properly */
11437 switch (((OP*)ptr)->op_type) {
11439 case OP_LEAVESUBLV:
11443 case OP_LEAVEWRITE:
11444 TOPPTR(nss,ix) = ptr;
11449 TOPPTR(nss,ix) = Nullop;
11454 TOPPTR(nss,ix) = Nullop;
11457 c = (char*)POPPTR(ss,ix);
11458 TOPPTR(nss,ix) = pv_dup_inc(c);
11460 case SAVEt_CLEARSV:
11461 longval = POPLONG(ss,ix);
11462 TOPLONG(nss,ix) = longval;
11465 hv = (HV*)POPPTR(ss,ix);
11466 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11467 c = (char*)POPPTR(ss,ix);
11468 TOPPTR(nss,ix) = pv_dup_inc(c);
11470 TOPINT(nss,ix) = i;
11472 case SAVEt_DESTRUCTOR:
11473 ptr = POPPTR(ss,ix);
11474 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11475 dptr = POPDPTR(ss,ix);
11477 u2.vptr = any_dup(u1.vptr, proto_perl);
11478 TOPDPTR(nss,ix) = u2.dptr;
11480 case SAVEt_DESTRUCTOR_X:
11481 ptr = POPPTR(ss,ix);
11482 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11483 dxptr = POPDXPTR(ss,ix);
11485 u4.vptr = any_dup(u3.vptr, proto_perl);;
11486 TOPDXPTR(nss,ix) = u4.dxptr;
11488 case SAVEt_REGCONTEXT:
11491 TOPINT(nss,ix) = i;
11494 case SAVEt_STACK_POS: /* Position on Perl stack */
11496 TOPINT(nss,ix) = i;
11498 case SAVEt_AELEM: /* array element */
11499 sv = (SV*)POPPTR(ss,ix);
11500 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11502 TOPINT(nss,ix) = i;
11503 av = (AV*)POPPTR(ss,ix);
11504 TOPPTR(nss,ix) = av_dup_inc(av, param);
11506 case SAVEt_HELEM: /* hash element */
11507 sv = (SV*)POPPTR(ss,ix);
11508 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11509 sv = (SV*)POPPTR(ss,ix);
11510 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11511 hv = (HV*)POPPTR(ss,ix);
11512 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11515 ptr = POPPTR(ss,ix);
11516 TOPPTR(nss,ix) = ptr;
11520 TOPINT(nss,ix) = i;
11522 case SAVEt_COMPPAD:
11523 av = (AV*)POPPTR(ss,ix);
11524 TOPPTR(nss,ix) = av_dup(av, param);
11527 longval = (long)POPLONG(ss,ix);
11528 TOPLONG(nss,ix) = longval;
11529 ptr = POPPTR(ss,ix);
11530 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11531 sv = (SV*)POPPTR(ss,ix);
11532 TOPPTR(nss,ix) = sv_dup(sv, param);
11535 ptr = POPPTR(ss,ix);
11536 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11537 longval = (long)POPBOOL(ss,ix);
11538 TOPBOOL(nss,ix) = (bool)longval;
11540 case SAVEt_SET_SVFLAGS:
11542 TOPINT(nss,ix) = i;
11544 TOPINT(nss,ix) = i;
11545 sv = (SV*)POPPTR(ss,ix);
11546 TOPPTR(nss,ix) = sv_dup(sv, param);
11549 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
11557 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11558 * flag to the result. This is done for each stash before cloning starts,
11559 * so we know which stashes want their objects cloned */
11562 do_mark_cloneable_stash(pTHX_ SV *sv)
11564 const HEK *hvname = HvNAME_HEK((HV*)sv);
11566 GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
11567 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11568 if (cloner && GvCV(cloner)) {
11575 XPUSHs(sv_2mortal(newSVhek(hvname)));
11577 call_sv((SV*)GvCV(cloner), G_SCALAR);
11584 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11592 =for apidoc perl_clone
11594 Create and return a new interpreter by cloning the current one.
11596 perl_clone takes these flags as parameters:
11598 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11599 without it we only clone the data and zero the stacks,
11600 with it we copy the stacks and the new perl interpreter is
11601 ready to run at the exact same point as the previous one.
11602 The pseudo-fork code uses COPY_STACKS while the
11603 threads->new doesn't.
11605 CLONEf_KEEP_PTR_TABLE
11606 perl_clone keeps a ptr_table with the pointer of the old
11607 variable as a key and the new variable as a value,
11608 this allows it to check if something has been cloned and not
11609 clone it again but rather just use the value and increase the
11610 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11611 the ptr_table using the function
11612 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11613 reason to keep it around is if you want to dup some of your own
11614 variable who are outside the graph perl scans, example of this
11615 code is in threads.xs create
11618 This is a win32 thing, it is ignored on unix, it tells perls
11619 win32host code (which is c++) to clone itself, this is needed on
11620 win32 if you want to run two threads at the same time,
11621 if you just want to do some stuff in a separate perl interpreter
11622 and then throw it away and return to the original one,
11623 you don't need to do anything.
11628 /* XXX the above needs expanding by someone who actually understands it ! */
11629 EXTERN_C PerlInterpreter *
11630 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11633 perl_clone(PerlInterpreter *proto_perl, UV flags)
11636 #ifdef PERL_IMPLICIT_SYS
11638 /* perlhost.h so we need to call into it
11639 to clone the host, CPerlHost should have a c interface, sky */
11641 if (flags & CLONEf_CLONE_HOST) {
11642 return perl_clone_host(proto_perl,flags);
11644 return perl_clone_using(proto_perl, flags,
11646 proto_perl->IMemShared,
11647 proto_perl->IMemParse,
11649 proto_perl->IStdIO,
11653 proto_perl->IProc);
11657 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11658 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11659 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11660 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11661 struct IPerlDir* ipD, struct IPerlSock* ipS,
11662 struct IPerlProc* ipP)
11664 /* XXX many of the string copies here can be optimized if they're
11665 * constants; they need to be allocated as common memory and just
11666 * their pointers copied. */
11669 CLONE_PARAMS clone_params;
11670 CLONE_PARAMS* param = &clone_params;
11672 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11673 /* for each stash, determine whether its objects should be cloned */
11674 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11675 PERL_SET_THX(my_perl);
11678 Poison(my_perl, 1, PerlInterpreter);
11680 PL_curcop = (COP *)Nullop;
11684 PL_savestack_ix = 0;
11685 PL_savestack_max = -1;
11686 PL_sig_pending = 0;
11687 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11688 # else /* !DEBUGGING */
11689 Zero(my_perl, 1, PerlInterpreter);
11690 # endif /* DEBUGGING */
11692 /* host pointers */
11694 PL_MemShared = ipMS;
11695 PL_MemParse = ipMP;
11702 #else /* !PERL_IMPLICIT_SYS */
11704 CLONE_PARAMS clone_params;
11705 CLONE_PARAMS* param = &clone_params;
11706 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11707 /* for each stash, determine whether its objects should be cloned */
11708 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11709 PERL_SET_THX(my_perl);
11712 Poison(my_perl, 1, PerlInterpreter);
11714 PL_curcop = (COP *)Nullop;
11718 PL_savestack_ix = 0;
11719 PL_savestack_max = -1;
11720 PL_sig_pending = 0;
11721 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11722 # else /* !DEBUGGING */
11723 Zero(my_perl, 1, PerlInterpreter);
11724 # endif /* DEBUGGING */
11725 #endif /* PERL_IMPLICIT_SYS */
11726 param->flags = flags;
11727 param->proto_perl = proto_perl;
11730 PL_xnv_arenaroot = NULL;
11731 PL_xnv_root = NULL;
11732 PL_xpv_arenaroot = NULL;
11733 PL_xpv_root = NULL;
11734 PL_xpviv_arenaroot = NULL;
11735 PL_xpviv_root = NULL;
11736 PL_xpvnv_arenaroot = NULL;
11737 PL_xpvnv_root = NULL;
11738 PL_xpvcv_arenaroot = NULL;
11739 PL_xpvcv_root = NULL;
11740 PL_xpvav_arenaroot = NULL;
11741 PL_xpvav_root = NULL;
11742 PL_xpvhv_arenaroot = NULL;
11743 PL_xpvhv_root = NULL;
11744 PL_xpvmg_arenaroot = NULL;
11745 PL_xpvmg_root = NULL;
11746 PL_xpvgv_arenaroot = NULL;
11747 PL_xpvgv_root = NULL;
11748 PL_xpvlv_arenaroot = NULL;
11749 PL_xpvlv_root = NULL;
11750 PL_xpvbm_arenaroot = NULL;
11751 PL_xpvbm_root = NULL;
11752 PL_he_arenaroot = NULL;
11754 #if defined(USE_ITHREADS)
11755 PL_pte_arenaroot = NULL;
11756 PL_pte_root = NULL;
11758 PL_nice_chunk = NULL;
11759 PL_nice_chunk_size = 0;
11761 PL_sv_objcount = 0;
11762 PL_sv_root = Nullsv;
11763 PL_sv_arenaroot = Nullsv;
11765 PL_debug = proto_perl->Idebug;
11767 PL_hash_seed = proto_perl->Ihash_seed;
11768 PL_rehash_seed = proto_perl->Irehash_seed;
11770 #ifdef USE_REENTRANT_API
11771 /* XXX: things like -Dm will segfault here in perlio, but doing
11772 * PERL_SET_CONTEXT(proto_perl);
11773 * breaks too many other things
11775 Perl_reentrant_init(aTHX);
11778 /* create SV map for pointer relocation */
11779 PL_ptr_table = ptr_table_new();
11780 /* and one for finding shared hash keys quickly */
11781 PL_shared_hek_table = ptr_table_new();
11783 /* initialize these special pointers as early as possible */
11784 SvANY(&PL_sv_undef) = NULL;
11785 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11786 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11787 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11789 SvANY(&PL_sv_no) = new_XPVNV();
11790 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11791 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11792 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11793 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
11794 SvCUR_set(&PL_sv_no, 0);
11795 SvLEN_set(&PL_sv_no, 1);
11796 SvIV_set(&PL_sv_no, 0);
11797 SvNV_set(&PL_sv_no, 0);
11798 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11800 SvANY(&PL_sv_yes) = new_XPVNV();
11801 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11802 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11803 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11804 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
11805 SvCUR_set(&PL_sv_yes, 1);
11806 SvLEN_set(&PL_sv_yes, 2);
11807 SvIV_set(&PL_sv_yes, 1);
11808 SvNV_set(&PL_sv_yes, 1);
11809 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11811 /* create (a non-shared!) shared string table */
11812 PL_strtab = newHV();
11813 HvSHAREKEYS_off(PL_strtab);
11814 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
11815 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11817 PL_compiling = proto_perl->Icompiling;
11819 /* These two PVs will be free'd special way so must set them same way op.c does */
11820 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11821 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11823 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11824 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11826 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11827 if (!specialWARN(PL_compiling.cop_warnings))
11828 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
11829 if (!specialCopIO(PL_compiling.cop_io))
11830 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
11831 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
11833 /* pseudo environmental stuff */
11834 PL_origargc = proto_perl->Iorigargc;
11835 PL_origargv = proto_perl->Iorigargv;
11837 param->stashes = newAV(); /* Setup array of objects to call clone on */
11839 #ifdef PERLIO_LAYERS
11840 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11841 PerlIO_clone(aTHX_ proto_perl, param);
11844 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11845 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11846 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11847 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11848 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11849 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11852 PL_minus_c = proto_perl->Iminus_c;
11853 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11854 PL_localpatches = proto_perl->Ilocalpatches;
11855 PL_splitstr = proto_perl->Isplitstr;
11856 PL_preprocess = proto_perl->Ipreprocess;
11857 PL_minus_n = proto_perl->Iminus_n;
11858 PL_minus_p = proto_perl->Iminus_p;
11859 PL_minus_l = proto_perl->Iminus_l;
11860 PL_minus_a = proto_perl->Iminus_a;
11861 PL_minus_F = proto_perl->Iminus_F;
11862 PL_doswitches = proto_perl->Idoswitches;
11863 PL_dowarn = proto_perl->Idowarn;
11864 PL_doextract = proto_perl->Idoextract;
11865 PL_sawampersand = proto_perl->Isawampersand;
11866 PL_unsafe = proto_perl->Iunsafe;
11867 PL_inplace = SAVEPV(proto_perl->Iinplace);
11868 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11869 PL_perldb = proto_perl->Iperldb;
11870 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11871 PL_exit_flags = proto_perl->Iexit_flags;
11873 /* magical thingies */
11874 /* XXX time(&PL_basetime) when asked for? */
11875 PL_basetime = proto_perl->Ibasetime;
11876 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11878 PL_maxsysfd = proto_perl->Imaxsysfd;
11879 PL_multiline = proto_perl->Imultiline;
11880 PL_statusvalue = proto_perl->Istatusvalue;
11882 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11884 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11886 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11887 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11888 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11890 /* Clone the regex array */
11891 PL_regex_padav = newAV();
11893 const I32 len = av_len((AV*)proto_perl->Iregex_padav);
11894 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11896 av_push(PL_regex_padav,
11897 sv_dup_inc(regexen[0],param));
11898 for(i = 1; i <= len; i++) {
11899 if(SvREPADTMP(regexen[i])) {
11900 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11902 av_push(PL_regex_padav,
11904 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11905 SvIVX(regexen[i])), param)))
11910 PL_regex_pad = AvARRAY(PL_regex_padav);
11912 /* shortcuts to various I/O objects */
11913 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11914 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11915 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11916 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11917 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11918 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11920 /* shortcuts to regexp stuff */
11921 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11923 /* shortcuts to misc objects */
11924 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11926 /* shortcuts to debugging objects */
11927 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11928 PL_DBline = gv_dup(proto_perl->IDBline, param);
11929 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11930 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11931 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11932 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11933 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11934 PL_lineary = av_dup(proto_perl->Ilineary, param);
11935 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11937 /* symbol tables */
11938 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11939 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11940 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11941 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11942 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11944 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11945 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11946 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11947 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11948 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11949 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11951 PL_sub_generation = proto_perl->Isub_generation;
11953 /* funky return mechanisms */
11954 PL_forkprocess = proto_perl->Iforkprocess;
11956 /* subprocess state */
11957 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11959 /* internal state */
11960 PL_tainting = proto_perl->Itainting;
11961 PL_taint_warn = proto_perl->Itaint_warn;
11962 PL_maxo = proto_perl->Imaxo;
11963 if (proto_perl->Iop_mask)
11964 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11966 PL_op_mask = Nullch;
11967 /* PL_asserting = proto_perl->Iasserting; */
11969 /* current interpreter roots */
11970 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11971 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11972 PL_main_start = proto_perl->Imain_start;
11973 PL_eval_root = proto_perl->Ieval_root;
11974 PL_eval_start = proto_perl->Ieval_start;
11976 /* runtime control stuff */
11977 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11978 PL_copline = proto_perl->Icopline;
11980 PL_filemode = proto_perl->Ifilemode;
11981 PL_lastfd = proto_perl->Ilastfd;
11982 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11985 PL_gensym = proto_perl->Igensym;
11986 PL_preambled = proto_perl->Ipreambled;
11987 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11988 PL_laststatval = proto_perl->Ilaststatval;
11989 PL_laststype = proto_perl->Ilaststype;
11990 PL_mess_sv = Nullsv;
11992 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11993 PL_ofmt = SAVEPV(proto_perl->Iofmt);
11995 /* interpreter atexit processing */
11996 PL_exitlistlen = proto_perl->Iexitlistlen;
11997 if (PL_exitlistlen) {
11998 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11999 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
12002 PL_exitlist = (PerlExitListEntry*)NULL;
12003 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
12004 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
12005 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
12007 PL_profiledata = NULL;
12008 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
12009 /* PL_rsfp_filters entries have fake IoDIRP() */
12010 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
12012 PL_compcv = cv_dup(proto_perl->Icompcv, param);
12014 PAD_CLONE_VARS(proto_perl, param);
12016 #ifdef HAVE_INTERP_INTERN
12017 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
12020 /* more statics moved here */
12021 PL_generation = proto_perl->Igeneration;
12022 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
12024 PL_in_clean_objs = proto_perl->Iin_clean_objs;
12025 PL_in_clean_all = proto_perl->Iin_clean_all;
12027 PL_uid = proto_perl->Iuid;
12028 PL_euid = proto_perl->Ieuid;
12029 PL_gid = proto_perl->Igid;
12030 PL_egid = proto_perl->Iegid;
12031 PL_nomemok = proto_perl->Inomemok;
12032 PL_an = proto_perl->Ian;
12033 PL_evalseq = proto_perl->Ievalseq;
12034 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
12035 PL_origalen = proto_perl->Iorigalen;
12036 PL_pidstatus = newHV(); /* XXX flag for cloning? */
12037 PL_osname = SAVEPV(proto_perl->Iosname);
12038 PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */
12039 PL_sighandlerp = proto_perl->Isighandlerp;
12042 PL_runops = proto_perl->Irunops;
12044 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
12047 PL_cshlen = proto_perl->Icshlen;
12048 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
12051 PL_lex_state = proto_perl->Ilex_state;
12052 PL_lex_defer = proto_perl->Ilex_defer;
12053 PL_lex_expect = proto_perl->Ilex_expect;
12054 PL_lex_formbrack = proto_perl->Ilex_formbrack;
12055 PL_lex_dojoin = proto_perl->Ilex_dojoin;
12056 PL_lex_starts = proto_perl->Ilex_starts;
12057 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
12058 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
12059 PL_lex_op = proto_perl->Ilex_op;
12060 PL_lex_inpat = proto_perl->Ilex_inpat;
12061 PL_lex_inwhat = proto_perl->Ilex_inwhat;
12062 PL_lex_brackets = proto_perl->Ilex_brackets;
12063 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
12064 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
12065 PL_lex_casemods = proto_perl->Ilex_casemods;
12066 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
12067 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
12069 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
12070 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
12071 PL_nexttoke = proto_perl->Inexttoke;
12073 /* XXX This is probably masking the deeper issue of why
12074 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
12075 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
12076 * (A little debugging with a watchpoint on it may help.)
12078 if (SvANY(proto_perl->Ilinestr)) {
12079 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
12080 i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
12081 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12082 i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
12083 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12084 i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
12085 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12086 i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
12087 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12090 PL_linestr = NEWSV(65,79);
12091 sv_upgrade(PL_linestr,SVt_PVIV);
12092 sv_setpvn(PL_linestr,"",0);
12093 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
12095 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12096 PL_pending_ident = proto_perl->Ipending_ident;
12097 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
12099 PL_expect = proto_perl->Iexpect;
12101 PL_multi_start = proto_perl->Imulti_start;
12102 PL_multi_end = proto_perl->Imulti_end;
12103 PL_multi_open = proto_perl->Imulti_open;
12104 PL_multi_close = proto_perl->Imulti_close;
12106 PL_error_count = proto_perl->Ierror_count;
12107 PL_subline = proto_perl->Isubline;
12108 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
12110 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
12111 if (SvANY(proto_perl->Ilinestr)) {
12112 i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
12113 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12114 i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
12115 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12116 PL_last_lop_op = proto_perl->Ilast_lop_op;
12119 PL_last_uni = SvPVX(PL_linestr);
12120 PL_last_lop = SvPVX(PL_linestr);
12121 PL_last_lop_op = 0;
12123 PL_in_my = proto_perl->Iin_my;
12124 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
12126 PL_cryptseen = proto_perl->Icryptseen;
12129 PL_hints = proto_perl->Ihints;
12131 PL_amagic_generation = proto_perl->Iamagic_generation;
12133 #ifdef USE_LOCALE_COLLATE
12134 PL_collation_ix = proto_perl->Icollation_ix;
12135 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
12136 PL_collation_standard = proto_perl->Icollation_standard;
12137 PL_collxfrm_base = proto_perl->Icollxfrm_base;
12138 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
12139 #endif /* USE_LOCALE_COLLATE */
12141 #ifdef USE_LOCALE_NUMERIC
12142 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
12143 PL_numeric_standard = proto_perl->Inumeric_standard;
12144 PL_numeric_local = proto_perl->Inumeric_local;
12145 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12146 #endif /* !USE_LOCALE_NUMERIC */
12148 /* utf8 character classes */
12149 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12150 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
12151 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12152 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12153 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
12154 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12155 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
12156 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
12157 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
12158 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
12159 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
12160 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
12161 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12162 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
12163 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
12164 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
12165 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
12166 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
12167 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
12168 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
12170 /* Did the locale setup indicate UTF-8? */
12171 PL_utf8locale = proto_perl->Iutf8locale;
12172 /* Unicode features (see perlrun/-C) */
12173 PL_unicode = proto_perl->Iunicode;
12175 /* Pre-5.8 signals control */
12176 PL_signals = proto_perl->Isignals;
12178 /* times() ticks per second */
12179 PL_clocktick = proto_perl->Iclocktick;
12181 /* Recursion stopper for PerlIO_find_layer */
12182 PL_in_load_module = proto_perl->Iin_load_module;
12184 /* sort() routine */
12185 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
12187 /* Not really needed/useful since the reenrant_retint is "volatile",
12188 * but do it for consistency's sake. */
12189 PL_reentrant_retint = proto_perl->Ireentrant_retint;
12191 /* Hooks to shared SVs and locks. */
12192 PL_sharehook = proto_perl->Isharehook;
12193 PL_lockhook = proto_perl->Ilockhook;
12194 PL_unlockhook = proto_perl->Iunlockhook;
12195 PL_threadhook = proto_perl->Ithreadhook;
12197 PL_runops_std = proto_perl->Irunops_std;
12198 PL_runops_dbg = proto_perl->Irunops_dbg;
12200 #ifdef THREADS_HAVE_PIDS
12201 PL_ppid = proto_perl->Ippid;
12205 PL_last_swash_hv = Nullhv; /* reinits on demand */
12206 PL_last_swash_klen = 0;
12207 PL_last_swash_key[0]= '\0';
12208 PL_last_swash_tmps = (U8*)NULL;
12209 PL_last_swash_slen = 0;
12211 PL_glob_index = proto_perl->Iglob_index;
12212 PL_srand_called = proto_perl->Isrand_called;
12213 PL_uudmap['M'] = 0; /* reinits on demand */
12214 PL_bitcount = Nullch; /* reinits on demand */
12216 if (proto_perl->Ipsig_pend) {
12217 Newz(0, PL_psig_pend, SIG_SIZE, int);
12220 PL_psig_pend = (int*)NULL;
12223 if (proto_perl->Ipsig_ptr) {
12224 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
12225 Newz(0, PL_psig_name, SIG_SIZE, SV*);
12226 for (i = 1; i < SIG_SIZE; i++) {
12227 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
12228 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
12232 PL_psig_ptr = (SV**)NULL;
12233 PL_psig_name = (SV**)NULL;
12236 /* thrdvar.h stuff */
12238 if (flags & CLONEf_COPY_STACKS) {
12239 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12240 PL_tmps_ix = proto_perl->Ttmps_ix;
12241 PL_tmps_max = proto_perl->Ttmps_max;
12242 PL_tmps_floor = proto_perl->Ttmps_floor;
12243 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
12245 while (i <= PL_tmps_ix) {
12246 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
12250 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12251 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
12252 Newz(54, PL_markstack, i, I32);
12253 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
12254 - proto_perl->Tmarkstack);
12255 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
12256 - proto_perl->Tmarkstack);
12257 Copy(proto_perl->Tmarkstack, PL_markstack,
12258 PL_markstack_ptr - PL_markstack + 1, I32);
12260 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12261 * NOTE: unlike the others! */
12262 PL_scopestack_ix = proto_perl->Tscopestack_ix;
12263 PL_scopestack_max = proto_perl->Tscopestack_max;
12264 Newz(54, PL_scopestack, PL_scopestack_max, I32);
12265 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
12267 /* NOTE: si_dup() looks at PL_markstack */
12268 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
12270 /* PL_curstack = PL_curstackinfo->si_stack; */
12271 PL_curstack = av_dup(proto_perl->Tcurstack, param);
12272 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
12274 /* next PUSHs() etc. set *(PL_stack_sp+1) */
12275 PL_stack_base = AvARRAY(PL_curstack);
12276 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
12277 - proto_perl->Tstack_base);
12278 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
12280 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12281 * NOTE: unlike the others! */
12282 PL_savestack_ix = proto_perl->Tsavestack_ix;
12283 PL_savestack_max = proto_perl->Tsavestack_max;
12284 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
12285 PL_savestack = ss_dup(proto_perl, param);
12289 ENTER; /* perl_destruct() wants to LEAVE; */
12292 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
12293 PL_top_env = &PL_start_env;
12295 PL_op = proto_perl->Top;
12298 PL_Xpv = (XPV*)NULL;
12299 PL_na = proto_perl->Tna;
12301 PL_statbuf = proto_perl->Tstatbuf;
12302 PL_statcache = proto_perl->Tstatcache;
12303 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
12304 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
12306 PL_timesbuf = proto_perl->Ttimesbuf;
12309 PL_tainted = proto_perl->Ttainted;
12310 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
12311 PL_rs = sv_dup_inc(proto_perl->Trs, param);
12312 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
12313 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
12314 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
12315 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
12316 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
12317 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
12318 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
12320 PL_restartop = proto_perl->Trestartop;
12321 PL_in_eval = proto_perl->Tin_eval;
12322 PL_delaymagic = proto_perl->Tdelaymagic;
12323 PL_dirty = proto_perl->Tdirty;
12324 PL_localizing = proto_perl->Tlocalizing;
12326 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
12327 PL_hv_fetch_ent_mh = Nullhe;
12328 PL_modcount = proto_perl->Tmodcount;
12329 PL_lastgotoprobe = Nullop;
12330 PL_dumpindent = proto_perl->Tdumpindent;
12332 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
12333 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
12334 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
12335 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
12336 PL_sortcxix = proto_perl->Tsortcxix;
12337 PL_efloatbuf = Nullch; /* reinits on demand */
12338 PL_efloatsize = 0; /* reinits on demand */
12342 PL_screamfirst = NULL;
12343 PL_screamnext = NULL;
12344 PL_maxscream = -1; /* reinits on demand */
12345 PL_lastscream = Nullsv;
12347 PL_watchaddr = NULL;
12348 PL_watchok = Nullch;
12350 PL_regdummy = proto_perl->Tregdummy;
12351 PL_regprecomp = Nullch;
12354 PL_colorset = 0; /* reinits PL_colors[] */
12355 /*PL_colors[6] = {0,0,0,0,0,0};*/
12356 PL_reginput = Nullch;
12357 PL_regbol = Nullch;
12358 PL_regeol = Nullch;
12359 PL_regstartp = (I32*)NULL;
12360 PL_regendp = (I32*)NULL;
12361 PL_reglastparen = (U32*)NULL;
12362 PL_reglastcloseparen = (U32*)NULL;
12363 PL_regtill = Nullch;
12364 PL_reg_start_tmp = (char**)NULL;
12365 PL_reg_start_tmpl = 0;
12366 PL_regdata = (struct reg_data*)NULL;
12369 PL_reg_eval_set = 0;
12371 PL_regprogram = (regnode*)NULL;
12373 PL_regcc = (CURCUR*)NULL;
12374 PL_reg_call_cc = (struct re_cc_state*)NULL;
12375 PL_reg_re = (regexp*)NULL;
12376 PL_reg_ganch = Nullch;
12377 PL_reg_sv = Nullsv;
12378 PL_reg_match_utf8 = FALSE;
12379 PL_reg_magic = (MAGIC*)NULL;
12381 PL_reg_oldcurpm = (PMOP*)NULL;
12382 PL_reg_curpm = (PMOP*)NULL;
12383 PL_reg_oldsaved = Nullch;
12384 PL_reg_oldsavedlen = 0;
12385 #ifdef PERL_COPY_ON_WRITE
12388 PL_reg_maxiter = 0;
12389 PL_reg_leftiter = 0;
12390 PL_reg_poscache = Nullch;
12391 PL_reg_poscache_size= 0;
12393 /* RE engine - function pointers */
12394 PL_regcompp = proto_perl->Tregcompp;
12395 PL_regexecp = proto_perl->Tregexecp;
12396 PL_regint_start = proto_perl->Tregint_start;
12397 PL_regint_string = proto_perl->Tregint_string;
12398 PL_regfree = proto_perl->Tregfree;
12400 PL_reginterp_cnt = 0;
12401 PL_reg_starttry = 0;
12403 /* Pluggable optimizer */
12404 PL_peepp = proto_perl->Tpeepp;
12406 PL_stashcache = newHV();
12408 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12409 ptr_table_free(PL_ptr_table);
12410 PL_ptr_table = NULL;
12411 ptr_table_free(PL_shared_hek_table);
12412 PL_shared_hek_table = NULL;
12415 /* Call the ->CLONE method, if it exists, for each of the stashes
12416 identified by sv_dup() above.
12418 while(av_len(param->stashes) != -1) {
12419 HV* stash = (HV*) av_shift(param->stashes);
12420 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12421 if (cloner && GvCV(cloner)) {
12426 XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
12428 call_sv((SV*)GvCV(cloner), G_DISCARD);
12434 SvREFCNT_dec(param->stashes);
12436 /* orphaned? eg threads->new inside BEGIN or use */
12437 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
12438 (void)SvREFCNT_inc(PL_compcv);
12439 SAVEFREESV(PL_compcv);
12445 #endif /* USE_ITHREADS */
12448 =head1 Unicode Support
12450 =for apidoc sv_recode_to_utf8
12452 The encoding is assumed to be an Encode object, on entry the PV
12453 of the sv is assumed to be octets in that encoding, and the sv
12454 will be converted into Unicode (and UTF-8).
12456 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12457 is not a reference, nothing is done to the sv. If the encoding is not
12458 an C<Encode::XS> Encoding object, bad things will happen.
12459 (See F<lib/encoding.pm> and L<Encode>).
12461 The PV of the sv is returned.
12466 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12469 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12483 Passing sv_yes is wrong - it needs to be or'ed set of constants
12484 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12485 remove converted chars from source.
12487 Both will default the value - let them.
12489 XPUSHs(&PL_sv_yes);
12492 call_method("decode", G_SCALAR);
12496 s = SvPV(uni, len);
12497 if (s != SvPVX_const(sv)) {
12498 SvGROW(sv, len + 1);
12499 Move(s, SvPVX_const(sv), len, char);
12500 SvCUR_set(sv, len);
12501 SvPVX(sv)[len] = 0;
12508 return SvPOKp(sv) ? SvPVX(sv) : NULL;
12512 =for apidoc sv_cat_decode
12514 The encoding is assumed to be an Encode object, the PV of the ssv is
12515 assumed to be octets in that encoding and decoding the input starts
12516 from the position which (PV + *offset) pointed to. The dsv will be
12517 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
12518 when the string tstr appears in decoding output or the input ends on
12519 the PV of the ssv. The value which the offset points will be modified
12520 to the last input position on the ssv.
12522 Returns TRUE if the terminator was found, else returns FALSE.
12527 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12528 SV *ssv, int *offset, char *tstr, int tlen)
12532 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12543 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
12544 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
12546 call_method("cat_decode", G_SCALAR);
12548 ret = SvTRUE(TOPs);
12549 *offset = SvIV(offsv);
12555 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12561 * c-indentation-style: bsd
12562 * c-basic-offset: 4
12563 * indent-tabs-mode: t
12566 * ex: set ts=8 sts=4 sw=4 noet: