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 XPV *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);
537 Safefree((void *)sva);
540 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
541 arenanext = (XPV*)arena->xpv_pv;
544 PL_xiv_arenaroot = 0;
547 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
548 arenanext = (XPV*)arena->xpv_pv;
551 PL_xnv_arenaroot = 0;
554 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
555 arenanext = (XPV*)arena->xpv_pv;
558 PL_xrv_arenaroot = 0;
561 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
562 arenanext = (XPV*)arena->xpv_pv;
565 PL_xpv_arenaroot = 0;
568 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
569 arenanext = (XPV*)arena->xpv_pv;
572 PL_xpviv_arenaroot = 0;
575 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
576 arenanext = (XPV*)arena->xpv_pv;
579 PL_xpvnv_arenaroot = 0;
582 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
583 arenanext = (XPV*)arena->xpv_pv;
586 PL_xpvcv_arenaroot = 0;
589 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
590 arenanext = (XPV*)arena->xpv_pv;
593 PL_xpvav_arenaroot = 0;
596 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
597 arenanext = (XPV*)arena->xpv_pv;
600 PL_xpvhv_arenaroot = 0;
603 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
604 arenanext = (XPV*)arena->xpv_pv;
607 PL_xpvmg_arenaroot = 0;
610 for (arena = (XPV*)PL_xpvgv_arenaroot; arena; arena = arenanext) {
611 arenanext = (XPV*)arena->xpv_pv;
614 PL_xpvgv_arenaroot = 0;
617 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
618 arenanext = (XPV*)arena->xpv_pv;
621 PL_xpvlv_arenaroot = 0;
624 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
625 arenanext = (XPV*)arena->xpv_pv;
628 PL_xpvbm_arenaroot = 0;
634 for (he = PL_he_arenaroot; he; he = he_next) {
635 he_next = HeNEXT(he);
642 #if defined(USE_ITHREADS)
644 struct ptr_tbl_ent *pte;
645 struct ptr_tbl_ent *pte_next;
646 for (pte = PL_pte_arenaroot; pte; pte = pte_next) {
647 pte_next = pte->next;
651 PL_pte_arenaroot = 0;
656 Safefree(PL_nice_chunk);
657 PL_nice_chunk = Nullch;
658 PL_nice_chunk_size = 0;
663 /* ---------------------------------------------------------------------
665 * support functions for report_uninit()
668 /* the maxiumum size of array or hash where we will scan looking
669 * for the undefined element that triggered the warning */
671 #define FUV_MAX_SEARCH_SIZE 1000
673 /* Look for an entry in the hash whose value has the same SV as val;
674 * If so, return a mortal copy of the key. */
677 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
683 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
684 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
689 for (i=HvMAX(hv); i>0; i--) {
691 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
692 if (HeVAL(entry) != val)
694 if ( HeVAL(entry) == &PL_sv_undef ||
695 HeVAL(entry) == &PL_sv_placeholder)
699 if (HeKLEN(entry) == HEf_SVKEY)
700 return sv_mortalcopy(HeKEY_sv(entry));
701 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
707 /* Look for an entry in the array whose value has the same SV as val;
708 * If so, return the index, otherwise return -1. */
711 S_find_array_subscript(pTHX_ AV *av, SV* val)
715 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
716 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
720 for (i=AvFILLp(av); i>=0; i--) {
721 if (svp[i] == val && svp[i] != &PL_sv_undef)
727 /* S_varname(): return the name of a variable, optionally with a subscript.
728 * If gv is non-zero, use the name of that global, along with gvtype (one
729 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
730 * targ. Depending on the value of the subscript_type flag, return:
733 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
734 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
735 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
736 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
739 S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ,
740 SV* keyname, I32 aindex, int subscript_type)
745 SV * const name = sv_newmortal();
748 /* simulate gv_fullname4(), but add literal '^' for $^FOO names
749 * XXX get rid of all this if gv_fullnameX() ever supports this
753 HV *hv = GvSTASH(gv);
754 sv_setpv(name, gvtype);
757 else if (!(p=HvNAME(hv)))
759 if (strNE(p, "main")) {
761 sv_catpvn(name,"::", 2);
763 if (GvNAMELEN(gv)>= 1 &&
764 ((unsigned int)*GvNAME(gv)) <= 26)
766 Perl_sv_catpvf(aTHX_ name,"^%c", *GvNAME(gv) + 'A' - 1);
767 sv_catpvn(name,GvNAME(gv)+1,GvNAMELEN(gv)-1);
770 sv_catpvn(name,GvNAME(gv),GvNAMELEN(gv));
774 CV *cv = find_runcv(&u);
775 if (!cv || !CvPADLIST(cv))
777 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
778 sv = *av_fetch(av, targ, FALSE);
779 /* SvLEN in a pad name is not to be trusted */
780 sv_setpv(name, SvPV_nolen(sv));
783 if (subscript_type == FUV_SUBSCRIPT_HASH) {
786 Perl_sv_catpvf(aTHX_ name, "{%s}",
787 pv_display(sv,SvPVX(keyname), SvCUR(keyname), 0, 32));
790 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
792 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
794 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
795 sv_insert(name, 0, 0, "within ", 7);
802 =for apidoc find_uninit_var
804 Find the name of the undefined variable (if any) that caused the operator o
805 to issue a "Use of uninitialized value" warning.
806 If match is true, only return a name if it's value matches uninit_sv.
807 So roughly speaking, if a unary operator (such as OP_COS) generates a
808 warning, then following the direct child of the op may yield an
809 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
810 other hand, with OP_ADD there are two branches to follow, so we only print
811 the variable name if we get an exact match.
813 The name is returned as a mortal SV.
815 Assumes that PL_op is the op that originally triggered the error, and that
816 PL_comppad/PL_curpad points to the currently executing pad.
822 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
831 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
832 uninit_sv == &PL_sv_placeholder)))
835 switch (obase->op_type) {
842 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
843 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
846 int subscript_type = FUV_SUBSCRIPT_WITHIN;
848 if (pad) { /* @lex, %lex */
849 sv = PAD_SVl(obase->op_targ);
853 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
854 /* @global, %global */
855 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
858 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
860 else /* @{expr}, %{expr} */
861 return find_uninit_var(cUNOPx(obase)->op_first,
865 /* attempt to find a match within the aggregate */
867 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
869 subscript_type = FUV_SUBSCRIPT_HASH;
872 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
874 subscript_type = FUV_SUBSCRIPT_ARRAY;
877 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
880 return S_varname(aTHX_ gv, hash ? "%" : "@", obase->op_targ,
881 keysv, index, subscript_type);
885 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
887 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
888 Nullsv, 0, FUV_SUBSCRIPT_NONE);
891 gv = cGVOPx_gv(obase);
892 if (!gv || (match && GvSV(gv) != uninit_sv))
894 return S_varname(aTHX_ gv, "$", 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
897 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
899 av = (AV*)PAD_SV(obase->op_targ);
900 if (!av || SvRMAGICAL(av))
902 svp = av_fetch(av, (I32)obase->op_private, FALSE);
903 if (!svp || *svp != uninit_sv)
906 return S_varname(aTHX_ Nullgv, "$", obase->op_targ,
907 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
910 gv = cGVOPx_gv(obase);
915 if (!av || SvRMAGICAL(av))
917 svp = av_fetch(av, (I32)obase->op_private, FALSE);
918 if (!svp || *svp != uninit_sv)
921 return S_varname(aTHX_ gv, "$", 0,
922 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
927 o = cUNOPx(obase)->op_first;
928 if (!o || o->op_type != OP_NULL ||
929 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
931 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
936 /* $a[uninit_expr] or $h{uninit_expr} */
937 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
940 o = cBINOPx(obase)->op_first;
941 kid = cBINOPx(obase)->op_last;
943 /* get the av or hv, and optionally the gv */
945 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
946 sv = PAD_SV(o->op_targ);
948 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
949 && cUNOPo->op_first->op_type == OP_GV)
951 gv = cGVOPx_gv(cUNOPo->op_first);
954 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
959 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
960 /* index is constant */
964 if (obase->op_type == OP_HELEM) {
965 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
966 if (!he || HeVAL(he) != uninit_sv)
970 svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
971 if (!svp || *svp != uninit_sv)
975 if (obase->op_type == OP_HELEM)
976 return S_varname(aTHX_ gv, "%", o->op_targ,
977 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
979 return S_varname(aTHX_ gv, "@", o->op_targ, Nullsv,
980 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
984 /* index is an expression;
985 * attempt to find a match within the aggregate */
986 if (obase->op_type == OP_HELEM) {
987 SV *keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
989 return S_varname(aTHX_ gv, "%", o->op_targ,
990 keysv, 0, FUV_SUBSCRIPT_HASH);
993 const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
995 return S_varname(aTHX_ gv, "@", o->op_targ,
996 Nullsv, index, FUV_SUBSCRIPT_ARRAY);
1000 return S_varname(aTHX_ gv,
1001 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
1003 o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
1009 /* only examine RHS */
1010 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
1013 o = cUNOPx(obase)->op_first;
1014 if (o->op_type == OP_PUSHMARK)
1017 if (!o->op_sibling) {
1018 /* one-arg version of open is highly magical */
1020 if (o->op_type == OP_GV) { /* open FOO; */
1022 if (match && GvSV(gv) != uninit_sv)
1024 return S_varname(aTHX_ gv, "$", 0,
1025 Nullsv, 0, FUV_SUBSCRIPT_NONE);
1027 /* other possibilities not handled are:
1028 * open $x; or open my $x; should return '${*$x}'
1029 * open expr; should return '$'.expr ideally
1035 /* ops where $_ may be an implicit arg */
1039 if ( !(obase->op_flags & OPf_STACKED)) {
1040 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
1041 ? PAD_SVl(obase->op_targ)
1044 sv = sv_newmortal();
1053 /* skip filehandle as it can't produce 'undef' warning */
1054 o = cUNOPx(obase)->op_first;
1055 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
1056 o = o->op_sibling->op_sibling;
1063 match = 1; /* XS or custom code could trigger random warnings */
1068 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
1069 return sv_2mortal(newSVpv("${$/}", 0));
1074 if (!(obase->op_flags & OPf_KIDS))
1076 o = cUNOPx(obase)->op_first;
1082 /* if all except one arg are constant, or have no side-effects,
1083 * or are optimized away, then it's unambiguous */
1085 for (kid=o; kid; kid = kid->op_sibling) {
1087 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
1088 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
1089 || (kid->op_type == OP_PUSHMARK)
1093 if (o2) { /* more than one found */
1100 return find_uninit_var(o2, uninit_sv, match);
1104 sv = find_uninit_var(o, uninit_sv, 1);
1116 =for apidoc report_uninit
1118 Print appropriate "Use of uninitialized variable" warning
1124 Perl_report_uninit(pTHX_ SV* uninit_sv)
1127 SV* varname = Nullsv;
1129 varname = find_uninit_var(PL_op, uninit_sv,0);
1131 sv_insert(varname, 0, 0, " ", 1);
1133 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1134 varname ? SvPV_nolen(varname) : "",
1135 " in ", OP_DESC(PL_op));
1138 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1143 /* allocate another arena's worth of struct xrv */
1151 New(712, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV);
1152 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
1153 PL_xrv_arenaroot = ptr;
1156 xrvend = &xrv[PERL_ARENA_SIZE / sizeof(XRV) - 1];
1157 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
1159 while (xrv < xrvend) {
1160 xrv->xrv_rv = (SV*)(xrv + 1);
1166 /* allocate another arena's worth of IV bodies */
1174 New(705, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV);
1175 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
1176 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
1179 xivend = &xiv[PERL_ARENA_SIZE / sizeof(IV) - 1];
1180 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
1182 while (xiv < xivend) {
1183 *(IV**)xiv = (IV *)(xiv + 1);
1189 /* allocate another arena's worth of NV bodies */
1197 New(711, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV);
1198 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
1199 PL_xnv_arenaroot = ptr;
1202 xnvend = &xnv[PERL_ARENA_SIZE / sizeof(NV) - 1];
1203 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
1205 while (xnv < xnvend) {
1206 *(NV**)xnv = (NV*)(xnv + 1);
1212 /* allocate another arena's worth of struct xpv */
1219 New(713, xpv, PERL_ARENA_SIZE/sizeof(XPV), XPV);
1220 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
1221 PL_xpv_arenaroot = xpv;
1223 xpvend = &xpv[PERL_ARENA_SIZE / sizeof(XPV) - 1];
1224 PL_xpv_root = ++xpv;
1225 while (xpv < xpvend) {
1226 xpv->xpv_pv = (char*)(xpv + 1);
1232 /* allocate another arena's worth of struct xpviv */
1239 New(714, xpviv, PERL_ARENA_SIZE/sizeof(XPVIV), XPVIV);
1240 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
1241 PL_xpviv_arenaroot = xpviv;
1243 xpvivend = &xpviv[PERL_ARENA_SIZE / sizeof(XPVIV) - 1];
1244 PL_xpviv_root = ++xpviv;
1245 while (xpviv < xpvivend) {
1246 xpviv->xpv_pv = (char*)(xpviv + 1);
1252 /* allocate another arena's worth of struct xpvnv */
1259 New(715, xpvnv, PERL_ARENA_SIZE/sizeof(XPVNV), XPVNV);
1260 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
1261 PL_xpvnv_arenaroot = xpvnv;
1263 xpvnvend = &xpvnv[PERL_ARENA_SIZE / sizeof(XPVNV) - 1];
1264 PL_xpvnv_root = ++xpvnv;
1265 while (xpvnv < xpvnvend) {
1266 xpvnv->xpv_pv = (char*)(xpvnv + 1);
1272 /* allocate another arena's worth of struct xpvcv */
1279 New(716, xpvcv, PERL_ARENA_SIZE/sizeof(XPVCV), XPVCV);
1280 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
1281 PL_xpvcv_arenaroot = xpvcv;
1283 xpvcvend = &xpvcv[PERL_ARENA_SIZE / sizeof(XPVCV) - 1];
1284 PL_xpvcv_root = ++xpvcv;
1285 while (xpvcv < xpvcvend) {
1286 xpvcv->xpv_pv = (char*)(xpvcv + 1);
1292 /* allocate another arena's worth of struct xpvav */
1299 New(717, xpvav, PERL_ARENA_SIZE/sizeof(XPVAV), XPVAV);
1300 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
1301 PL_xpvav_arenaroot = xpvav;
1303 xpvavend = &xpvav[PERL_ARENA_SIZE / sizeof(XPVAV) - 1];
1304 PL_xpvav_root = ++xpvav;
1305 while (xpvav < xpvavend) {
1306 xpvav->xav_array = (char*)(xpvav + 1);
1309 xpvav->xav_array = 0;
1312 /* allocate another arena's worth of struct xpvhv */
1319 New(718, xpvhv, PERL_ARENA_SIZE/sizeof(XPVHV), XPVHV);
1320 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
1321 PL_xpvhv_arenaroot = xpvhv;
1323 xpvhvend = &xpvhv[PERL_ARENA_SIZE / sizeof(XPVHV) - 1];
1324 PL_xpvhv_root = ++xpvhv;
1325 while (xpvhv < xpvhvend) {
1326 xpvhv->xhv_array = (char*)(xpvhv + 1);
1329 xpvhv->xhv_array = 0;
1332 /* allocate another arena's worth of struct xpvmg */
1339 New(719, xpvmg, PERL_ARENA_SIZE/sizeof(XPVMG), XPVMG);
1340 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
1341 PL_xpvmg_arenaroot = xpvmg;
1343 xpvmgend = &xpvmg[PERL_ARENA_SIZE / sizeof(XPVMG) - 1];
1344 PL_xpvmg_root = ++xpvmg;
1345 while (xpvmg < xpvmgend) {
1346 xpvmg->xpv_pv = (char*)(xpvmg + 1);
1352 /* allocate another arena's worth of struct xpvgv */
1359 New(720, xpvgv, PERL_ARENA_SIZE/sizeof(XPVGV), XPVGV);
1360 xpvgv->xpv_pv = (char*)PL_xpvgv_arenaroot;
1361 PL_xpvgv_arenaroot = xpvgv;
1363 xpvgvend = &xpvgv[PERL_ARENA_SIZE / sizeof(XPVGV) - 1];
1364 PL_xpvgv_root = ++xpvgv;
1365 while (xpvgv < xpvgvend) {
1366 xpvgv->xpv_pv = (char*)(xpvgv + 1);
1372 /* allocate another arena's worth of struct xpvlv */
1379 New(720, xpvlv, PERL_ARENA_SIZE/sizeof(XPVLV), XPVLV);
1380 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
1381 PL_xpvlv_arenaroot = xpvlv;
1383 xpvlvend = &xpvlv[PERL_ARENA_SIZE / sizeof(XPVLV) - 1];
1384 PL_xpvlv_root = ++xpvlv;
1385 while (xpvlv < xpvlvend) {
1386 xpvlv->xpv_pv = (char*)(xpvlv + 1);
1392 /* allocate another arena's worth of struct xpvbm */
1399 New(721, xpvbm, PERL_ARENA_SIZE/sizeof(XPVBM), XPVBM);
1400 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
1401 PL_xpvbm_arenaroot = xpvbm;
1403 xpvbmend = &xpvbm[PERL_ARENA_SIZE / sizeof(XPVBM) - 1];
1404 PL_xpvbm_root = ++xpvbm;
1405 while (xpvbm < xpvbmend) {
1406 xpvbm->xpv_pv = (char*)(xpvbm + 1);
1412 /* grab a new struct xrv from the free list, allocating more if necessary */
1422 PL_xrv_root = (XRV*)xrv->xrv_rv;
1427 /* return a struct xrv to the free list */
1430 S_del_xrv(pTHX_ XRV *p)
1433 p->xrv_rv = (SV*)PL_xrv_root;
1438 /* grab a new IV body from the free list, allocating more if necessary */
1449 * See comment in more_xiv() -- RAM.
1451 PL_xiv_root = *(IV**)xiv;
1453 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
1456 /* return an IV body to the free list */
1459 S_del_xiv(pTHX_ XPVIV *p)
1461 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
1463 *(IV**)xiv = PL_xiv_root;
1468 /* grab a new NV body from the free list, allocating more if necessary */
1478 PL_xnv_root = *(NV**)xnv;
1480 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
1483 /* return an NV body to the free list */
1486 S_del_xnv(pTHX_ XPVNV *p)
1488 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
1490 *(NV**)xnv = PL_xnv_root;
1495 /* grab a new struct xpv from the free list, allocating more if necessary */
1505 PL_xpv_root = (XPV*)xpv->xpv_pv;
1510 /* return a struct xpv to the free list */
1513 S_del_xpv(pTHX_ XPV *p)
1516 p->xpv_pv = (char*)PL_xpv_root;
1521 /* grab a new struct xpviv from the free list, allocating more if necessary */
1530 xpviv = PL_xpviv_root;
1531 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
1536 /* return a struct xpviv to the free list */
1539 S_del_xpviv(pTHX_ XPVIV *p)
1542 p->xpv_pv = (char*)PL_xpviv_root;
1547 /* grab a new struct xpvnv from the free list, allocating more if necessary */
1556 xpvnv = PL_xpvnv_root;
1557 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
1562 /* return a struct xpvnv to the free list */
1565 S_del_xpvnv(pTHX_ XPVNV *p)
1568 p->xpv_pv = (char*)PL_xpvnv_root;
1573 /* grab a new struct xpvcv from the free list, allocating more if necessary */
1582 xpvcv = PL_xpvcv_root;
1583 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
1588 /* return a struct xpvcv to the free list */
1591 S_del_xpvcv(pTHX_ XPVCV *p)
1594 p->xpv_pv = (char*)PL_xpvcv_root;
1599 /* grab a new struct xpvav from the free list, allocating more if necessary */
1608 xpvav = PL_xpvav_root;
1609 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
1614 /* return a struct xpvav to the free list */
1617 S_del_xpvav(pTHX_ XPVAV *p)
1620 p->xav_array = (char*)PL_xpvav_root;
1625 /* grab a new struct xpvhv from the free list, allocating more if necessary */
1634 xpvhv = PL_xpvhv_root;
1635 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
1640 /* return a struct xpvhv to the free list */
1643 S_del_xpvhv(pTHX_ XPVHV *p)
1646 p->xhv_array = (char*)PL_xpvhv_root;
1651 /* grab a new struct xpvmg from the free list, allocating more if necessary */
1660 xpvmg = PL_xpvmg_root;
1661 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
1666 /* return a struct xpvmg to the free list */
1669 S_del_xpvmg(pTHX_ XPVMG *p)
1672 p->xpv_pv = (char*)PL_xpvmg_root;
1677 /* grab a new struct xpvgv from the free list, allocating more if necessary */
1686 xpvgv = PL_xpvgv_root;
1687 PL_xpvgv_root = (XPVGV*)xpvgv->xpv_pv;
1692 /* return a struct xpvgv to the free list */
1695 S_del_xpvgv(pTHX_ XPVGV *p)
1698 p->xpv_pv = (char*)PL_xpvgv_root;
1703 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1712 xpvlv = PL_xpvlv_root;
1713 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
1718 /* return a struct xpvlv to the free list */
1721 S_del_xpvlv(pTHX_ XPVLV *p)
1724 p->xpv_pv = (char*)PL_xpvlv_root;
1729 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1738 xpvbm = PL_xpvbm_root;
1739 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
1744 /* return a struct xpvbm to the free list */
1747 S_del_xpvbm(pTHX_ XPVBM *p)
1750 p->xpv_pv = (char*)PL_xpvbm_root;
1755 #define my_safemalloc(s) (void*)safemalloc(s)
1756 #define my_safefree(p) safefree((char*)p)
1760 #define new_XIV() my_safemalloc(sizeof(XPVIV))
1761 #define del_XIV(p) my_safefree(p)
1763 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1764 #define del_XNV(p) my_safefree(p)
1766 #define new_XRV() my_safemalloc(sizeof(XRV))
1767 #define del_XRV(p) my_safefree(p)
1769 #define new_XPV() my_safemalloc(sizeof(XPV))
1770 #define del_XPV(p) my_safefree(p)
1772 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1773 #define del_XPVIV(p) my_safefree(p)
1775 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1776 #define del_XPVNV(p) my_safefree(p)
1778 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1779 #define del_XPVCV(p) my_safefree(p)
1781 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1782 #define del_XPVAV(p) my_safefree(p)
1784 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1785 #define del_XPVHV(p) my_safefree(p)
1787 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1788 #define del_XPVMG(p) my_safefree(p)
1790 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1791 #define del_XPVGV(p) my_safefree(p)
1793 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1794 #define del_XPVLV(p) my_safefree(p)
1796 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1797 #define del_XPVBM(p) my_safefree(p)
1801 #define new_XIV() (void*)new_xiv()
1802 #define del_XIV(p) del_xiv((XPVIV*) p)
1804 #define new_XNV() (void*)new_xnv()
1805 #define del_XNV(p) del_xnv((XPVNV*) p)
1807 #define new_XRV() (void*)new_xrv()
1808 #define del_XRV(p) del_xrv((XRV*) p)
1810 #define new_XPV() (void*)new_xpv()
1811 #define del_XPV(p) del_xpv((XPV *)p)
1813 #define new_XPVIV() (void*)new_xpviv()
1814 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
1816 #define new_XPVNV() (void*)new_xpvnv()
1817 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
1819 #define new_XPVCV() (void*)new_xpvcv()
1820 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
1822 #define new_XPVAV() (void*)new_xpvav()
1823 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
1825 #define new_XPVHV() (void*)new_xpvhv()
1826 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
1828 #define new_XPVMG() (void*)new_xpvmg()
1829 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
1831 #define new_XPVGV() (void*)new_xpvgv()
1832 #define del_XPVGV(p) del_xpvgv((XPVGV *)p)
1834 #define new_XPVLV() (void*)new_xpvlv()
1835 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
1837 #define new_XPVBM() (void*)new_xpvbm()
1838 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
1842 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1843 #define del_XPVFM(p) my_safefree(p)
1845 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1846 #define del_XPVIO(p) my_safefree(p)
1849 =for apidoc sv_upgrade
1851 Upgrade an SV to a more complex form. Generally adds a new body type to the
1852 SV, then copies across as much information as possible from the old body.
1853 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1859 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1870 if (mt != SVt_PV && SvIsCOW(sv)) {
1871 sv_force_normal_flags(sv, 0);
1874 if (SvTYPE(sv) == mt)
1885 switch (SvTYPE(sv)) {
1893 else if (mt < SVt_PVIV)
1903 pv = (char*)SvRV(sv);
1913 else if (mt == SVt_NV)
1921 del_XPVIV(SvANY(sv));
1929 del_XPVNV(SvANY(sv));
1932 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1933 there's no way that it can be safely upgraded, because perl.c
1934 expects to Safefree(SvANY(PL_mess_sv)) */
1935 assert(sv != PL_mess_sv);
1936 /* This flag bit is used to mean other things in other scalar types.
1937 Given that it only has meaning inside the pad, it shouldn't be set
1938 on anything that can get upgraded. */
1939 assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
1945 magic = SvMAGIC(sv);
1946 stash = SvSTASH(sv);
1947 del_XPVMG(SvANY(sv));
1950 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1953 SvFLAGS(sv) &= ~SVTYPEMASK;
1958 Perl_croak(aTHX_ "Can't upgrade to undef");
1960 SvANY(sv) = new_XIV();
1964 SvANY(sv) = new_XNV();
1968 SvANY(sv) = new_XRV();
1969 SvRV_set(sv, (SV*)pv);
1972 SvANY(sv) = new_XPVHV();
1978 HvTOTALKEYS(sv) = 0;
1979 HvPLACEHOLDERS(sv) = 0;
1981 /* Fall through... */
1984 SvANY(sv) = new_XPVAV();
1994 /* XXX? Only SVt_NULL is ever upgraded to AV or HV? */
1996 /* FIXME. Should be able to remove all this if()... if the above
1997 assertion is genuinely always true. */
2000 SvFLAGS(sv) &= ~SVf_OOK;
2003 SvPV_set(sv, (char*)0);
2004 SvMAGIC_set(sv, magic);
2005 SvSTASH_set(sv, stash);
2009 SvANY(sv) = new_XPVIO();
2010 Zero(SvANY(sv), 1, XPVIO);
2011 IoPAGE_LEN(sv) = 60;
2012 goto set_magic_common;
2014 SvANY(sv) = new_XPVFM();
2015 Zero(SvANY(sv), 1, XPVFM);
2016 goto set_magic_common;
2018 SvANY(sv) = new_XPVBM();
2022 goto set_magic_common;
2024 SvANY(sv) = new_XPVGV();
2030 goto set_magic_common;
2032 SvANY(sv) = new_XPVCV();
2033 Zero(SvANY(sv), 1, XPVCV);
2034 goto set_magic_common;
2036 SvANY(sv) = new_XPVLV();
2049 SvANY(sv) = new_XPVMG();
2052 SvMAGIC_set(sv, magic);
2053 SvSTASH_set(sv, stash);
2057 SvANY(sv) = new_XPVNV();
2063 SvANY(sv) = new_XPVIV();
2072 SvANY(sv) = new_XPV();
2083 =for apidoc sv_backoff
2085 Remove any string offset. You should normally use the C<SvOOK_off> macro
2092 Perl_sv_backoff(pTHX_ register SV *sv)
2096 char *s = SvPVX(sv);
2097 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
2098 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
2100 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
2102 SvFLAGS(sv) &= ~SVf_OOK;
2109 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
2110 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
2111 Use the C<SvGROW> wrapper instead.
2117 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
2121 #ifdef HAS_64K_LIMIT
2122 if (newlen >= 0x10000) {
2123 PerlIO_printf(Perl_debug_log,
2124 "Allocation too large: %"UVxf"\n", (UV)newlen);
2127 #endif /* HAS_64K_LIMIT */
2130 if (SvTYPE(sv) < SVt_PV) {
2131 sv_upgrade(sv, SVt_PV);
2134 else if (SvOOK(sv)) { /* pv is offset? */
2137 if (newlen > SvLEN(sv))
2138 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
2139 #ifdef HAS_64K_LIMIT
2140 if (newlen >= 0x10000)
2147 if (newlen > SvLEN(sv)) { /* need more room? */
2148 if (SvLEN(sv) && s) {
2150 const STRLEN l = malloced_size((void*)SvPVX(sv));
2156 Renew(s,newlen,char);
2159 New(703, s, newlen, char);
2160 if (SvPVX(sv) && SvCUR(sv)) {
2161 Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
2165 SvLEN_set(sv, newlen);
2171 =for apidoc sv_setiv
2173 Copies an integer into the given SV, upgrading first if necessary.
2174 Does not handle 'set' magic. See also C<sv_setiv_mg>.
2180 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
2182 SV_CHECK_THINKFIRST_COW_DROP(sv);
2183 switch (SvTYPE(sv)) {
2185 sv_upgrade(sv, SVt_IV);
2188 sv_upgrade(sv, SVt_PVNV);
2192 sv_upgrade(sv, SVt_PVIV);
2201 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
2204 (void)SvIOK_only(sv); /* validate number */
2210 =for apidoc sv_setiv_mg
2212 Like C<sv_setiv>, but also handles 'set' magic.
2218 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
2225 =for apidoc sv_setuv
2227 Copies an unsigned integer into the given SV, upgrading first if necessary.
2228 Does not handle 'set' magic. See also C<sv_setuv_mg>.
2234 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
2236 /* With these two if statements:
2237 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2240 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2242 If you wish to remove them, please benchmark to see what the effect is
2244 if (u <= (UV)IV_MAX) {
2245 sv_setiv(sv, (IV)u);
2254 =for apidoc sv_setuv_mg
2256 Like C<sv_setuv>, but also handles 'set' magic.
2262 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
2264 /* With these two if statements:
2265 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
2268 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
2270 If you wish to remove them, please benchmark to see what the effect is
2272 if (u <= (UV)IV_MAX) {
2273 sv_setiv(sv, (IV)u);
2283 =for apidoc sv_setnv
2285 Copies a double into the given SV, upgrading first if necessary.
2286 Does not handle 'set' magic. See also C<sv_setnv_mg>.
2292 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
2294 SV_CHECK_THINKFIRST_COW_DROP(sv);
2295 switch (SvTYPE(sv)) {
2298 sv_upgrade(sv, SVt_NV);
2303 sv_upgrade(sv, SVt_PVNV);
2312 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
2316 (void)SvNOK_only(sv); /* validate number */
2321 =for apidoc sv_setnv_mg
2323 Like C<sv_setnv>, but also handles 'set' magic.
2329 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
2335 /* Print an "isn't numeric" warning, using a cleaned-up,
2336 * printable version of the offending string
2340 S_not_a_number(pTHX_ SV *sv)
2347 dsv = sv_2mortal(newSVpv("", 0));
2348 pv = sv_uni_display(dsv, sv, 10, 0);
2351 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
2352 /* each *s can expand to 4 chars + "...\0",
2353 i.e. need room for 8 chars */
2356 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
2358 if (ch & 128 && !isPRINT_LC(ch)) {
2367 else if (ch == '\r') {
2371 else if (ch == '\f') {
2375 else if (ch == '\\') {
2379 else if (ch == '\0') {
2383 else if (isPRINT_LC(ch))
2400 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2401 "Argument \"%s\" isn't numeric in %s", pv,
2404 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
2405 "Argument \"%s\" isn't numeric", pv);
2409 =for apidoc looks_like_number
2411 Test if the content of an SV looks like a number (or is a number).
2412 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
2413 non-numeric warning), even if your atof() doesn't grok them.
2419 Perl_looks_like_number(pTHX_ SV *sv)
2421 register const char *sbegin;
2428 else if (SvPOKp(sv))
2429 sbegin = SvPV(sv, len);
2431 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
2432 return grok_number(sbegin, len, NULL);
2435 /* Actually, ISO C leaves conversion of UV to IV undefined, but
2436 until proven guilty, assume that things are not that bad... */
2441 As 64 bit platforms often have an NV that doesn't preserve all bits of
2442 an IV (an assumption perl has been based on to date) it becomes necessary
2443 to remove the assumption that the NV always carries enough precision to
2444 recreate the IV whenever needed, and that the NV is the canonical form.
2445 Instead, IV/UV and NV need to be given equal rights. So as to not lose
2446 precision as a side effect of conversion (which would lead to insanity
2447 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
2448 1) to distinguish between IV/UV/NV slots that have cached a valid
2449 conversion where precision was lost and IV/UV/NV slots that have a
2450 valid conversion which has lost no precision
2451 2) to ensure that if a numeric conversion to one form is requested that
2452 would lose precision, the precise conversion (or differently
2453 imprecise conversion) is also performed and cached, to prevent
2454 requests for different numeric formats on the same SV causing
2455 lossy conversion chains. (lossless conversion chains are perfectly
2460 SvIOKp is true if the IV slot contains a valid value
2461 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
2462 SvNOKp is true if the NV slot contains a valid value
2463 SvNOK is true only if the NV value is accurate
2466 while converting from PV to NV, check to see if converting that NV to an
2467 IV(or UV) would lose accuracy over a direct conversion from PV to
2468 IV(or UV). If it would, cache both conversions, return NV, but mark
2469 SV as IOK NOKp (ie not NOK).
2471 While converting from PV to IV, check to see if converting that IV to an
2472 NV would lose accuracy over a direct conversion from PV to NV. If it
2473 would, cache both conversions, flag similarly.
2475 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2476 correctly because if IV & NV were set NV *always* overruled.
2477 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2478 changes - now IV and NV together means that the two are interchangeable:
2479 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
2481 The benefit of this is that operations such as pp_add know that if
2482 SvIOK is true for both left and right operands, then integer addition
2483 can be used instead of floating point (for cases where the result won't
2484 overflow). Before, floating point was always used, which could lead to
2485 loss of precision compared with integer addition.
2487 * making IV and NV equal status should make maths accurate on 64 bit
2489 * may speed up maths somewhat if pp_add and friends start to use
2490 integers when possible instead of fp. (Hopefully the overhead in
2491 looking for SvIOK and checking for overflow will not outweigh the
2492 fp to integer speedup)
2493 * will slow down integer operations (callers of SvIV) on "inaccurate"
2494 values, as the change from SvIOK to SvIOKp will cause a call into
2495 sv_2iv each time rather than a macro access direct to the IV slot
2496 * should speed up number->string conversion on integers as IV is
2497 favoured when IV and NV are equally accurate
2499 ####################################################################
2500 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2501 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2502 On the other hand, SvUOK is true iff UV.
2503 ####################################################################
2505 Your mileage will vary depending your CPU's relative fp to integer
2509 #ifndef NV_PRESERVES_UV
2510 # define IS_NUMBER_UNDERFLOW_IV 1
2511 # define IS_NUMBER_UNDERFLOW_UV 2
2512 # define IS_NUMBER_IV_AND_UV 2
2513 # define IS_NUMBER_OVERFLOW_IV 4
2514 # define IS_NUMBER_OVERFLOW_UV 5
2516 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2518 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2520 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2522 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
2523 if (SvNVX(sv) < (NV)IV_MIN) {
2524 (void)SvIOKp_on(sv);
2526 SvIV_set(sv, IV_MIN);
2527 return IS_NUMBER_UNDERFLOW_IV;
2529 if (SvNVX(sv) > (NV)UV_MAX) {
2530 (void)SvIOKp_on(sv);
2533 SvUV_set(sv, UV_MAX);
2534 return IS_NUMBER_OVERFLOW_UV;
2536 (void)SvIOKp_on(sv);
2538 /* Can't use strtol etc to convert this string. (See truth table in
2540 if (SvNVX(sv) <= (UV)IV_MAX) {
2541 SvIV_set(sv, I_V(SvNVX(sv)));
2542 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2543 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2545 /* Integer is imprecise. NOK, IOKp */
2547 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2550 SvUV_set(sv, U_V(SvNVX(sv)));
2551 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2552 if (SvUVX(sv) == UV_MAX) {
2553 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2554 possibly be preserved by NV. Hence, it must be overflow.
2556 return IS_NUMBER_OVERFLOW_UV;
2558 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2560 /* Integer is imprecise. NOK, IOKp */
2562 return IS_NUMBER_OVERFLOW_IV;
2564 #endif /* !NV_PRESERVES_UV*/
2566 /* sv_2iv() is now a macro using Perl_sv_2iv_flags();
2567 * this function provided for binary compatibility only
2571 Perl_sv_2iv(pTHX_ register SV *sv)
2573 return sv_2iv_flags(sv, SV_GMAGIC);
2577 =for apidoc sv_2iv_flags
2579 Return the integer value of an SV, doing any necessary string
2580 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2581 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2587 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2591 if (SvGMAGICAL(sv)) {
2592 if (flags & SV_GMAGIC)
2597 return I_V(SvNVX(sv));
2599 if (SvPOKp(sv) && SvLEN(sv))
2602 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2603 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2609 if (SvTHINKFIRST(sv)) {
2612 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2613 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2614 return SvIV(tmpstr);
2615 return PTR2IV(SvRV(sv));
2618 sv_force_normal_flags(sv, 0);
2620 if (SvREADONLY(sv) && !SvOK(sv)) {
2621 if (ckWARN(WARN_UNINITIALIZED))
2628 return (IV)(SvUVX(sv));
2635 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2636 * without also getting a cached IV/UV from it at the same time
2637 * (ie PV->NV conversion should detect loss of accuracy and cache
2638 * IV or UV at same time to avoid this. NWC */
2640 if (SvTYPE(sv) == SVt_NV)
2641 sv_upgrade(sv, SVt_PVNV);
2643 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2644 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2645 certainly cast into the IV range at IV_MAX, whereas the correct
2646 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2648 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2649 SvIV_set(sv, I_V(SvNVX(sv)));
2650 if (SvNVX(sv) == (NV) SvIVX(sv)
2651 #ifndef NV_PRESERVES_UV
2652 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2653 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2654 /* Don't flag it as "accurately an integer" if the number
2655 came from a (by definition imprecise) NV operation, and
2656 we're outside the range of NV integer precision */
2659 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2660 DEBUG_c(PerlIO_printf(Perl_debug_log,
2661 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2667 /* IV not precise. No need to convert from PV, as NV
2668 conversion would already have cached IV if it detected
2669 that PV->IV would be better than PV->NV->IV
2670 flags already correct - don't set public IOK. */
2671 DEBUG_c(PerlIO_printf(Perl_debug_log,
2672 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2677 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2678 but the cast (NV)IV_MIN rounds to a the value less (more
2679 negative) than IV_MIN which happens to be equal to SvNVX ??
2680 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2681 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2682 (NV)UVX == NVX are both true, but the values differ. :-(
2683 Hopefully for 2s complement IV_MIN is something like
2684 0x8000000000000000 which will be exact. NWC */
2687 SvUV_set(sv, U_V(SvNVX(sv)));
2689 (SvNVX(sv) == (NV) SvUVX(sv))
2690 #ifndef NV_PRESERVES_UV
2691 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2692 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2693 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2694 /* Don't flag it as "accurately an integer" if the number
2695 came from a (by definition imprecise) NV operation, and
2696 we're outside the range of NV integer precision */
2702 DEBUG_c(PerlIO_printf(Perl_debug_log,
2703 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2707 return (IV)SvUVX(sv);
2710 else if (SvPOKp(sv) && SvLEN(sv)) {
2712 const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2713 /* We want to avoid a possible problem when we cache an IV which
2714 may be later translated to an NV, and the resulting NV is not
2715 the same as the direct translation of the initial string
2716 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2717 be careful to ensure that the value with the .456 is around if the
2718 NV value is requested in the future).
2720 This means that if we cache such an IV, we need to cache the
2721 NV as well. Moreover, we trade speed for space, and do not
2722 cache the NV if we are sure it's not needed.
2725 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2726 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2727 == IS_NUMBER_IN_UV) {
2728 /* It's definitely an integer, only upgrade to PVIV */
2729 if (SvTYPE(sv) < SVt_PVIV)
2730 sv_upgrade(sv, SVt_PVIV);
2732 } else if (SvTYPE(sv) < SVt_PVNV)
2733 sv_upgrade(sv, SVt_PVNV);
2735 /* If NV preserves UV then we only use the UV value if we know that
2736 we aren't going to call atof() below. If NVs don't preserve UVs
2737 then the value returned may have more precision than atof() will
2738 return, even though value isn't perfectly accurate. */
2739 if ((numtype & (IS_NUMBER_IN_UV
2740 #ifdef NV_PRESERVES_UV
2743 )) == IS_NUMBER_IN_UV) {
2744 /* This won't turn off the public IOK flag if it was set above */
2745 (void)SvIOKp_on(sv);
2747 if (!(numtype & IS_NUMBER_NEG)) {
2749 if (value <= (UV)IV_MAX) {
2750 SvIV_set(sv, (IV)value);
2752 SvUV_set(sv, value);
2756 /* 2s complement assumption */
2757 if (value <= (UV)IV_MIN) {
2758 SvIV_set(sv, -(IV)value);
2760 /* Too negative for an IV. This is a double upgrade, but
2761 I'm assuming it will be rare. */
2762 if (SvTYPE(sv) < SVt_PVNV)
2763 sv_upgrade(sv, SVt_PVNV);
2767 SvNV_set(sv, -(NV)value);
2768 SvIV_set(sv, IV_MIN);
2772 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2773 will be in the previous block to set the IV slot, and the next
2774 block to set the NV slot. So no else here. */
2776 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2777 != IS_NUMBER_IN_UV) {
2778 /* It wasn't an (integer that doesn't overflow the UV). */
2779 SvNV_set(sv, Atof(SvPVX(sv)));
2781 if (! numtype && ckWARN(WARN_NUMERIC))
2784 #if defined(USE_LONG_DOUBLE)
2785 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2786 PTR2UV(sv), SvNVX(sv)));
2788 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2789 PTR2UV(sv), SvNVX(sv)));
2793 #ifdef NV_PRESERVES_UV
2794 (void)SvIOKp_on(sv);
2796 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2797 SvIV_set(sv, I_V(SvNVX(sv)));
2798 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2801 /* Integer is imprecise. NOK, IOKp */
2803 /* UV will not work better than IV */
2805 if (SvNVX(sv) > (NV)UV_MAX) {
2807 /* Integer is inaccurate. NOK, IOKp, is UV */
2808 SvUV_set(sv, UV_MAX);
2811 SvUV_set(sv, U_V(SvNVX(sv)));
2812 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2813 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2817 /* Integer is imprecise. NOK, IOKp, is UV */
2823 #else /* NV_PRESERVES_UV */
2824 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2825 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2826 /* The IV slot will have been set from value returned by
2827 grok_number above. The NV slot has just been set using
2830 assert (SvIOKp(sv));
2832 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2833 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2834 /* Small enough to preserve all bits. */
2835 (void)SvIOKp_on(sv);
2837 SvIV_set(sv, I_V(SvNVX(sv)));
2838 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2840 /* Assumption: first non-preserved integer is < IV_MAX,
2841 this NV is in the preserved range, therefore: */
2842 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2844 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);
2848 0 0 already failed to read UV.
2849 0 1 already failed to read UV.
2850 1 0 you won't get here in this case. IV/UV
2851 slot set, public IOK, Atof() unneeded.
2852 1 1 already read UV.
2853 so there's no point in sv_2iuv_non_preserve() attempting
2854 to use atol, strtol, strtoul etc. */
2855 if (sv_2iuv_non_preserve (sv, numtype)
2856 >= IS_NUMBER_OVERFLOW_IV)
2860 #endif /* NV_PRESERVES_UV */
2863 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2865 if (SvTYPE(sv) < SVt_IV)
2866 /* Typically the caller expects that sv_any is not NULL now. */
2867 sv_upgrade(sv, SVt_IV);
2870 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2871 PTR2UV(sv),SvIVX(sv)));
2872 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2875 /* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2876 * this function provided for binary compatibility only
2880 Perl_sv_2uv(pTHX_ register SV *sv)
2882 return sv_2uv_flags(sv, SV_GMAGIC);
2886 =for apidoc sv_2uv_flags
2888 Return the unsigned integer value of an SV, doing any necessary string
2889 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2890 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2896 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2900 if (SvGMAGICAL(sv)) {
2901 if (flags & SV_GMAGIC)
2906 return U_V(SvNVX(sv));
2907 if (SvPOKp(sv) && SvLEN(sv))
2910 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2911 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2917 if (SvTHINKFIRST(sv)) {
2920 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2921 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2922 return SvUV(tmpstr);
2923 return PTR2UV(SvRV(sv));
2926 sv_force_normal_flags(sv, 0);
2928 if (SvREADONLY(sv) && !SvOK(sv)) {
2929 if (ckWARN(WARN_UNINITIALIZED))
2939 return (UV)SvIVX(sv);
2943 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2944 * without also getting a cached IV/UV from it at the same time
2945 * (ie PV->NV conversion should detect loss of accuracy and cache
2946 * IV or UV at same time to avoid this. */
2947 /* IV-over-UV optimisation - choose to cache IV if possible */
2949 if (SvTYPE(sv) == SVt_NV)
2950 sv_upgrade(sv, SVt_PVNV);
2952 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2953 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2954 SvIV_set(sv, I_V(SvNVX(sv)));
2955 if (SvNVX(sv) == (NV) SvIVX(sv)
2956 #ifndef NV_PRESERVES_UV
2957 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2958 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2959 /* Don't flag it as "accurately an integer" if the number
2960 came from a (by definition imprecise) NV operation, and
2961 we're outside the range of NV integer precision */
2964 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2965 DEBUG_c(PerlIO_printf(Perl_debug_log,
2966 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2972 /* IV not precise. No need to convert from PV, as NV
2973 conversion would already have cached IV if it detected
2974 that PV->IV would be better than PV->NV->IV
2975 flags already correct - don't set public IOK. */
2976 DEBUG_c(PerlIO_printf(Perl_debug_log,
2977 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2982 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2983 but the cast (NV)IV_MIN rounds to a the value less (more
2984 negative) than IV_MIN which happens to be equal to SvNVX ??
2985 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2986 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2987 (NV)UVX == NVX are both true, but the values differ. :-(
2988 Hopefully for 2s complement IV_MIN is something like
2989 0x8000000000000000 which will be exact. NWC */
2992 SvUV_set(sv, U_V(SvNVX(sv)));
2994 (SvNVX(sv) == (NV) SvUVX(sv))
2995 #ifndef NV_PRESERVES_UV
2996 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2997 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2998 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2999 /* Don't flag it as "accurately an integer" if the number
3000 came from a (by definition imprecise) NV operation, and
3001 we're outside the range of NV integer precision */
3006 DEBUG_c(PerlIO_printf(Perl_debug_log,
3007 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
3013 else if (SvPOKp(sv) && SvLEN(sv)) {
3015 const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3017 /* We want to avoid a possible problem when we cache a UV which
3018 may be later translated to an NV, and the resulting NV is not
3019 the translation of the initial data.
3021 This means that if we cache such a UV, we need to cache the
3022 NV as well. Moreover, we trade speed for space, and do not
3023 cache the NV if not needed.
3026 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
3027 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3028 == IS_NUMBER_IN_UV) {
3029 /* It's definitely an integer, only upgrade to PVIV */
3030 if (SvTYPE(sv) < SVt_PVIV)
3031 sv_upgrade(sv, SVt_PVIV);
3033 } else if (SvTYPE(sv) < SVt_PVNV)
3034 sv_upgrade(sv, SVt_PVNV);
3036 /* If NV preserves UV then we only use the UV value if we know that
3037 we aren't going to call atof() below. If NVs don't preserve UVs
3038 then the value returned may have more precision than atof() will
3039 return, even though it isn't accurate. */
3040 if ((numtype & (IS_NUMBER_IN_UV
3041 #ifdef NV_PRESERVES_UV
3044 )) == IS_NUMBER_IN_UV) {
3045 /* This won't turn off the public IOK flag if it was set above */
3046 (void)SvIOKp_on(sv);
3048 if (!(numtype & IS_NUMBER_NEG)) {
3050 if (value <= (UV)IV_MAX) {
3051 SvIV_set(sv, (IV)value);
3053 /* it didn't overflow, and it was positive. */
3054 SvUV_set(sv, value);
3058 /* 2s complement assumption */
3059 if (value <= (UV)IV_MIN) {
3060 SvIV_set(sv, -(IV)value);
3062 /* Too negative for an IV. This is a double upgrade, but
3063 I'm assuming it will be rare. */
3064 if (SvTYPE(sv) < SVt_PVNV)
3065 sv_upgrade(sv, SVt_PVNV);
3069 SvNV_set(sv, -(NV)value);
3070 SvIV_set(sv, IV_MIN);
3075 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3076 != IS_NUMBER_IN_UV) {
3077 /* It wasn't an integer, or it overflowed the UV. */
3078 SvNV_set(sv, Atof(SvPVX(sv)));
3080 if (! numtype && ckWARN(WARN_NUMERIC))
3083 #if defined(USE_LONG_DOUBLE)
3084 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
3085 PTR2UV(sv), SvNVX(sv)));
3087 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
3088 PTR2UV(sv), SvNVX(sv)));
3091 #ifdef NV_PRESERVES_UV
3092 (void)SvIOKp_on(sv);
3094 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3095 SvIV_set(sv, I_V(SvNVX(sv)));
3096 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
3099 /* Integer is imprecise. NOK, IOKp */
3101 /* UV will not work better than IV */
3103 if (SvNVX(sv) > (NV)UV_MAX) {
3105 /* Integer is inaccurate. NOK, IOKp, is UV */
3106 SvUV_set(sv, UV_MAX);
3109 SvUV_set(sv, U_V(SvNVX(sv)));
3110 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
3111 NV preservse UV so can do correct comparison. */
3112 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
3116 /* Integer is imprecise. NOK, IOKp, is UV */
3121 #else /* NV_PRESERVES_UV */
3122 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3123 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
3124 /* The UV slot will have been set from value returned by
3125 grok_number above. The NV slot has just been set using
3128 assert (SvIOKp(sv));
3130 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3131 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3132 /* Small enough to preserve all bits. */
3133 (void)SvIOKp_on(sv);
3135 SvIV_set(sv, I_V(SvNVX(sv)));
3136 if ((NV)(SvIVX(sv)) == SvNVX(sv))
3138 /* Assumption: first non-preserved integer is < IV_MAX,
3139 this NV is in the preserved range, therefore: */
3140 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
3142 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);
3145 sv_2iuv_non_preserve (sv, numtype);
3147 #endif /* NV_PRESERVES_UV */
3151 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3152 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3155 if (SvTYPE(sv) < SVt_IV)
3156 /* Typically the caller expects that sv_any is not NULL now. */
3157 sv_upgrade(sv, SVt_IV);
3161 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
3162 PTR2UV(sv),SvUVX(sv)));
3163 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
3169 Return the num value of an SV, doing any necessary string or integer
3170 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
3177 Perl_sv_2nv(pTHX_ register SV *sv)
3181 if (SvGMAGICAL(sv)) {
3185 if (SvPOKp(sv) && SvLEN(sv)) {
3186 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
3187 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
3189 return Atof(SvPVX(sv));
3193 return (NV)SvUVX(sv);
3195 return (NV)SvIVX(sv);
3198 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3199 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3205 if (SvTHINKFIRST(sv)) {
3208 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
3209 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
3210 return SvNV(tmpstr);
3211 return PTR2NV(SvRV(sv));
3214 sv_force_normal_flags(sv, 0);
3216 if (SvREADONLY(sv) && !SvOK(sv)) {
3217 if (ckWARN(WARN_UNINITIALIZED))
3222 if (SvTYPE(sv) < SVt_NV) {
3223 if (SvTYPE(sv) == SVt_IV)
3224 sv_upgrade(sv, SVt_PVNV);
3226 sv_upgrade(sv, SVt_NV);
3227 #ifdef USE_LONG_DOUBLE
3229 STORE_NUMERIC_LOCAL_SET_STANDARD();
3230 PerlIO_printf(Perl_debug_log,
3231 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
3232 PTR2UV(sv), SvNVX(sv));
3233 RESTORE_NUMERIC_LOCAL();
3237 STORE_NUMERIC_LOCAL_SET_STANDARD();
3238 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
3239 PTR2UV(sv), SvNVX(sv));
3240 RESTORE_NUMERIC_LOCAL();
3244 else if (SvTYPE(sv) < SVt_PVNV)
3245 sv_upgrade(sv, SVt_PVNV);
3250 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
3251 #ifdef NV_PRESERVES_UV
3254 /* Only set the public NV OK flag if this NV preserves the IV */
3255 /* Check it's not 0xFFFFFFFFFFFFFFFF */
3256 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
3257 : (SvIVX(sv) == I_V(SvNVX(sv))))
3263 else if (SvPOKp(sv) && SvLEN(sv)) {
3265 const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3266 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
3268 #ifdef NV_PRESERVES_UV
3269 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3270 == IS_NUMBER_IN_UV) {
3271 /* It's definitely an integer */
3272 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
3274 SvNV_set(sv, Atof(SvPVX(sv)));
3277 SvNV_set(sv, Atof(SvPVX(sv)));
3278 /* Only set the public NV OK flag if this NV preserves the value in
3279 the PV at least as well as an IV/UV would.
3280 Not sure how to do this 100% reliably. */
3281 /* if that shift count is out of range then Configure's test is
3282 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
3284 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3285 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3286 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
3287 } else if (!(numtype & IS_NUMBER_IN_UV)) {
3288 /* Can't use strtol etc to convert this string, so don't try.
3289 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
3292 /* value has been set. It may not be precise. */
3293 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
3294 /* 2s complement assumption for (UV)IV_MIN */
3295 SvNOK_on(sv); /* Integer is too negative. */
3300 if (numtype & IS_NUMBER_NEG) {
3301 SvIV_set(sv, -(IV)value);
3302 } else if (value <= (UV)IV_MAX) {
3303 SvIV_set(sv, (IV)value);
3305 SvUV_set(sv, value);
3309 if (numtype & IS_NUMBER_NOT_INT) {
3310 /* I believe that even if the original PV had decimals,
3311 they are lost beyond the limit of the FP precision.
3312 However, neither is canonical, so both only get p
3313 flags. NWC, 2000/11/25 */
3314 /* Both already have p flags, so do nothing */
3317 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3318 if (SvIVX(sv) == I_V(nv)) {
3323 /* It had no "." so it must be integer. */
3326 /* between IV_MAX and NV(UV_MAX).
3327 Could be slightly > UV_MAX */
3329 if (numtype & IS_NUMBER_NOT_INT) {
3330 /* UV and NV both imprecise. */
3332 UV nv_as_uv = U_V(nv);
3334 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
3345 #endif /* NV_PRESERVES_UV */
3348 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3350 if (SvTYPE(sv) < SVt_NV)
3351 /* Typically the caller expects that sv_any is not NULL now. */
3352 /* XXX Ilya implies that this is a bug in callers that assume this
3353 and ideally should be fixed. */
3354 sv_upgrade(sv, SVt_NV);
3357 #if defined(USE_LONG_DOUBLE)
3359 STORE_NUMERIC_LOCAL_SET_STANDARD();
3360 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
3361 PTR2UV(sv), SvNVX(sv));
3362 RESTORE_NUMERIC_LOCAL();
3366 STORE_NUMERIC_LOCAL_SET_STANDARD();
3367 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
3368 PTR2UV(sv), SvNVX(sv));
3369 RESTORE_NUMERIC_LOCAL();
3375 /* asIV(): extract an integer from the string value of an SV.
3376 * Caller must validate PVX */
3379 S_asIV(pTHX_ SV *sv)
3382 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3384 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3385 == IS_NUMBER_IN_UV) {
3386 /* It's definitely an integer */
3387 if (numtype & IS_NUMBER_NEG) {
3388 if (value < (UV)IV_MIN)
3391 if (value < (UV)IV_MAX)
3396 if (ckWARN(WARN_NUMERIC))
3399 return I_V(Atof(SvPVX(sv)));
3402 /* asUV(): extract an unsigned integer from the string value of an SV
3403 * Caller must validate PVX */
3406 S_asUV(pTHX_ SV *sv)
3409 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3411 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3412 == IS_NUMBER_IN_UV) {
3413 /* It's definitely an integer */
3414 if (!(numtype & IS_NUMBER_NEG))
3418 if (ckWARN(WARN_NUMERIC))
3421 return U_V(Atof(SvPVX(sv)));
3425 =for apidoc sv_2pv_nolen
3427 Like C<sv_2pv()>, but doesn't return the length too. You should usually
3428 use the macro wrapper C<SvPV_nolen(sv)> instead.
3433 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
3436 return sv_2pv(sv, &n_a);
3439 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
3440 * UV as a string towards the end of buf, and return pointers to start and
3443 * We assume that buf is at least TYPE_CHARS(UV) long.
3447 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
3449 char *ptr = buf + TYPE_CHARS(UV);
3463 *--ptr = '0' + (char)(uv % 10);
3471 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
3472 * this function provided for binary compatibility only
3476 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
3478 return sv_2pv_flags(sv, lp, SV_GMAGIC);
3482 =for apidoc sv_2pv_flags
3484 Returns a pointer to the string value of an SV, and sets *lp to its length.
3485 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
3487 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
3488 usually end up here too.
3494 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3499 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3500 char *tmpbuf = tbuf;
3506 if (SvGMAGICAL(sv)) {
3507 if (flags & SV_GMAGIC)
3515 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
3517 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
3522 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3527 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3528 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
3535 if (SvTHINKFIRST(sv)) {
3538 register const char *typestr;
3539 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3540 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3541 char *pv = SvPV(tmpstr, *lp);
3551 typestr = "NULLREF";
3555 switch (SvTYPE(sv)) {
3557 if ( ((SvFLAGS(sv) &
3558 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3559 == (SVs_OBJECT|SVs_SMG))
3560 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3561 const regexp *re = (regexp *)mg->mg_obj;
3564 const char *fptr = "msix";
3569 char need_newline = 0;
3570 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3572 while((ch = *fptr++)) {
3574 reflags[left++] = ch;
3577 reflags[right--] = ch;
3582 reflags[left] = '-';
3586 mg->mg_len = re->prelen + 4 + left;
3588 * If /x was used, we have to worry about a regex
3589 * ending with a comment later being embedded
3590 * within another regex. If so, we don't want this
3591 * regex's "commentization" to leak out to the
3592 * right part of the enclosing regex, we must cap
3593 * it with a newline.
3595 * So, if /x was used, we scan backwards from the
3596 * end of the regex. If we find a '#' before we
3597 * find a newline, we need to add a newline
3598 * ourself. If we find a '\n' first (or if we
3599 * don't find '#' or '\n'), we don't need to add
3600 * anything. -jfriedl
3602 if (PMf_EXTENDED & re->reganch)
3604 const char *endptr = re->precomp + re->prelen;
3605 while (endptr >= re->precomp)
3607 const char c = *(endptr--);
3609 break; /* don't need another */
3611 /* we end while in a comment, so we
3613 mg->mg_len++; /* save space for it */
3614 need_newline = 1; /* note to add it */
3620 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3621 Copy("(?", mg->mg_ptr, 2, char);
3622 Copy(reflags, mg->mg_ptr+2, left, char);
3623 Copy(":", mg->mg_ptr+left+2, 1, char);
3624 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3626 mg->mg_ptr[mg->mg_len - 2] = '\n';
3627 mg->mg_ptr[mg->mg_len - 1] = ')';
3628 mg->mg_ptr[mg->mg_len] = 0;
3630 PL_reginterp_cnt += re->program[0].next_off;
3632 if (re->reganch & ROPT_UTF8)
3647 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3648 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3649 /* tied lvalues should appear to be
3650 * scalars for backwards compatitbility */
3651 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3652 ? "SCALAR" : "LVALUE"; break;
3653 case SVt_PVAV: typestr = "ARRAY"; break;
3654 case SVt_PVHV: typestr = "HASH"; break;
3655 case SVt_PVCV: typestr = "CODE"; break;
3656 case SVt_PVGV: typestr = "GLOB"; break;
3657 case SVt_PVFM: typestr = "FORMAT"; break;
3658 case SVt_PVIO: typestr = "IO"; break;
3659 default: typestr = "UNKNOWN"; break;
3663 const char *name = HvNAME(SvSTASH(sv));
3664 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3665 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3668 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3671 *lp = strlen(typestr);
3672 return (char *)typestr;
3674 if (SvREADONLY(sv) && !SvOK(sv)) {
3675 if (ckWARN(WARN_UNINITIALIZED))
3681 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3682 /* I'm assuming that if both IV and NV are equally valid then
3683 converting the IV is going to be more efficient */
3684 const U32 isIOK = SvIOK(sv);
3685 const U32 isUIOK = SvIsUV(sv);
3686 char buf[TYPE_CHARS(UV)];
3689 if (SvTYPE(sv) < SVt_PVIV)
3690 sv_upgrade(sv, SVt_PVIV);
3692 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3694 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3695 SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */
3696 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3697 SvCUR_set(sv, ebuf - ptr);
3707 else if (SvNOKp(sv)) {
3708 if (SvTYPE(sv) < SVt_PVNV)
3709 sv_upgrade(sv, SVt_PVNV);
3710 /* The +20 is pure guesswork. Configure test needed. --jhi */
3711 SvGROW(sv, NV_DIG + 20);
3713 olderrno = errno; /* some Xenix systems wipe out errno here */
3715 if (SvNVX(sv) == 0.0)
3716 (void)strcpy(s,"0");
3720 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3723 #ifdef FIXNEGATIVEZERO
3724 if (*s == '-' && s[1] == '0' && !s[2])
3734 if (ckWARN(WARN_UNINITIALIZED)
3735 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3738 if (SvTYPE(sv) < SVt_PV)
3739 /* Typically the caller expects that sv_any is not NULL now. */
3740 sv_upgrade(sv, SVt_PV);
3743 *lp = s - SvPVX(sv);
3746 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3747 PTR2UV(sv),SvPVX(sv)));
3751 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3752 /* Sneaky stuff here */
3756 tsv = newSVpv(tmpbuf, 0);
3773 len = strlen(tmpbuf);
3775 #ifdef FIXNEGATIVEZERO
3776 if (len == 2 && t[0] == '-' && t[1] == '0') {
3781 (void)SvUPGRADE(sv, SVt_PV);
3783 s = SvGROW(sv, len + 1);
3786 return strcpy(s, t);
3791 =for apidoc sv_copypv
3793 Copies a stringified representation of the source SV into the
3794 destination SV. Automatically performs any necessary mg_get and
3795 coercion of numeric values into strings. Guaranteed to preserve
3796 UTF-8 flag even from overloaded objects. Similar in nature to
3797 sv_2pv[_flags] but operates directly on an SV instead of just the
3798 string. Mostly uses sv_2pv_flags to do its work, except when that
3799 would lose the UTF-8'ness of the PV.
3805 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3810 sv_setpvn(dsv,s,len);
3818 =for apidoc sv_2pvbyte_nolen
3820 Return a pointer to the byte-encoded representation of the SV.
3821 May cause the SV to be downgraded from UTF-8 as a side-effect.
3823 Usually accessed via the C<SvPVbyte_nolen> macro.
3829 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3832 return sv_2pvbyte(sv, &n_a);
3836 =for apidoc sv_2pvbyte
3838 Return a pointer to the byte-encoded representation of the SV, and set *lp
3839 to its length. May cause the SV to be downgraded from UTF-8 as a
3842 Usually accessed via the C<SvPVbyte> macro.
3848 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3850 sv_utf8_downgrade(sv,0);
3851 return SvPV(sv,*lp);
3855 =for apidoc sv_2pvutf8_nolen
3857 Return a pointer to the UTF-8-encoded representation of the SV.
3858 May cause the SV to be upgraded to UTF-8 as a side-effect.
3860 Usually accessed via the C<SvPVutf8_nolen> macro.
3866 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3869 return sv_2pvutf8(sv, &n_a);
3873 =for apidoc sv_2pvutf8
3875 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3876 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3878 Usually accessed via the C<SvPVutf8> macro.
3884 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3886 sv_utf8_upgrade(sv);
3887 return SvPV(sv,*lp);
3891 =for apidoc sv_2bool
3893 This function is only called on magical items, and is only used by
3894 sv_true() or its macro equivalent.
3900 Perl_sv_2bool(pTHX_ register SV *sv)
3909 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3910 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3911 return (bool)SvTRUE(tmpsv);
3912 return SvRV(sv) != 0;
3915 register XPV* Xpvtmp;
3916 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3917 (*Xpvtmp->xpv_pv > '0' ||
3918 Xpvtmp->xpv_cur > 1 ||
3919 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3926 return SvIVX(sv) != 0;
3929 return SvNVX(sv) != 0.0;
3936 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3937 * this function provided for binary compatibility only
3942 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3944 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3948 =for apidoc sv_utf8_upgrade
3950 Converts the PV of an SV to its UTF-8-encoded form.
3951 Forces the SV to string form if it is not already.
3952 Always sets the SvUTF8 flag to avoid future validity checks even
3953 if all the bytes have hibit clear.
3955 This is not as a general purpose byte encoding to Unicode interface:
3956 use the Encode extension for that.
3958 =for apidoc sv_utf8_upgrade_flags
3960 Converts the PV of an SV to its UTF-8-encoded form.
3961 Forces the SV to string form if it is not already.
3962 Always sets the SvUTF8 flag to avoid future validity checks even
3963 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3964 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3965 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3967 This is not as a general purpose byte encoding to Unicode interface:
3968 use the Encode extension for that.
3974 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3976 if (sv == &PL_sv_undef)
3980 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3981 (void) sv_2pv_flags(sv,&len, flags);
3985 (void) SvPV_force(sv,len);
3994 sv_force_normal_flags(sv, 0);
3997 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3998 sv_recode_to_utf8(sv, PL_encoding);
3999 else { /* Assume Latin-1/EBCDIC */
4000 /* This function could be much more efficient if we
4001 * had a FLAG in SVs to signal if there are any hibit
4002 * chars in the PV. Given that there isn't such a flag
4003 * make the loop as fast as possible. */
4004 U8 *s = (U8 *) SvPVX(sv);
4005 U8 *e = (U8 *) SvEND(sv);
4011 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
4015 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
4016 s = bytes_to_utf8((U8*)s, &len);
4018 SvPV_free(sv); /* No longer using what was there before. */
4020 SvPV_set(sv, (char*)s);
4021 SvCUR_set(sv, len - 1);
4022 SvLEN_set(sv, len); /* No longer know the real size. */
4024 /* Mark as UTF-8 even if no hibit - saves scanning loop */
4031 =for apidoc sv_utf8_downgrade
4033 Attempts to convert the PV of an SV from characters to bytes.
4034 If the PV contains a character beyond byte, this conversion will fail;
4035 in this case, either returns false or, if C<fail_ok> is not
4038 This is not as a general purpose Unicode to byte encoding interface:
4039 use the Encode extension for that.
4045 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
4047 if (SvPOKp(sv) && SvUTF8(sv)) {
4053 sv_force_normal_flags(sv, 0);
4055 s = (U8 *) SvPV(sv, len);
4056 if (!utf8_to_bytes(s, &len)) {
4061 Perl_croak(aTHX_ "Wide character in %s",
4064 Perl_croak(aTHX_ "Wide character");
4075 =for apidoc sv_utf8_encode
4077 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
4078 flag off so that it looks like octets again.
4084 Perl_sv_utf8_encode(pTHX_ register SV *sv)
4086 (void) sv_utf8_upgrade(sv);
4088 sv_force_normal_flags(sv, 0);
4090 if (SvREADONLY(sv)) {
4091 Perl_croak(aTHX_ PL_no_modify);
4097 =for apidoc sv_utf8_decode
4099 If the PV of the SV is an octet sequence in UTF-8
4100 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
4101 so that it looks like a character. If the PV contains only single-byte
4102 characters, the C<SvUTF8> flag stays being off.
4103 Scans PV for validity and returns false if the PV is invalid UTF-8.
4109 Perl_sv_utf8_decode(pTHX_ register SV *sv)
4115 /* The octets may have got themselves encoded - get them back as
4118 if (!sv_utf8_downgrade(sv, TRUE))
4121 /* it is actually just a matter of turning the utf8 flag on, but
4122 * we want to make sure everything inside is valid utf8 first.
4124 c = (U8 *) SvPVX(sv);
4125 if (!is_utf8_string(c, SvCUR(sv)+1))
4127 e = (U8 *) SvEND(sv);
4130 if (!UTF8_IS_INVARIANT(ch)) {
4139 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
4140 * this function provided for binary compatibility only
4144 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
4146 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
4150 =for apidoc sv_setsv
4152 Copies the contents of the source SV C<ssv> into the destination SV
4153 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4154 function if the source SV needs to be reused. Does not handle 'set' magic.
4155 Loosely speaking, it performs a copy-by-value, obliterating any previous
4156 content of the destination.
4158 You probably want to use one of the assortment of wrappers, such as
4159 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4160 C<SvSetMagicSV_nosteal>.
4162 =for apidoc sv_setsv_flags
4164 Copies the contents of the source SV C<ssv> into the destination SV
4165 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
4166 function if the source SV needs to be reused. Does not handle 'set' magic.
4167 Loosely speaking, it performs a copy-by-value, obliterating any previous
4168 content of the destination.
4169 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
4170 C<ssv> if appropriate, else not. If the C<flags> parameter has the
4171 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
4172 and C<sv_setsv_nomg> are implemented in terms of this function.
4174 You probably want to use one of the assortment of wrappers, such as
4175 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
4176 C<SvSetMagicSV_nosteal>.
4178 This is the primary function for copying scalars, and most other
4179 copy-ish functions and macros use this underneath.
4185 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
4187 register U32 sflags;
4193 SV_CHECK_THINKFIRST_COW_DROP(dstr);
4195 sstr = &PL_sv_undef;
4196 stype = SvTYPE(sstr);
4197 dtype = SvTYPE(dstr);
4202 /* need to nuke the magic */
4204 SvRMAGICAL_off(dstr);
4207 /* There's a lot of redundancy below but we're going for speed here */
4212 if (dtype != SVt_PVGV) {
4213 (void)SvOK_off(dstr);
4221 sv_upgrade(dstr, SVt_IV);
4224 sv_upgrade(dstr, SVt_PVNV);
4228 sv_upgrade(dstr, SVt_PVIV);
4231 (void)SvIOK_only(dstr);
4232 SvIV_set(dstr, SvIVX(sstr));
4235 if (SvTAINTED(sstr))
4246 sv_upgrade(dstr, SVt_NV);
4251 sv_upgrade(dstr, SVt_PVNV);
4254 SvNV_set(dstr, SvNVX(sstr));
4255 (void)SvNOK_only(dstr);
4256 if (SvTAINTED(sstr))
4264 sv_upgrade(dstr, SVt_RV);
4265 else if (dtype == SVt_PVGV &&
4266 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
4269 if (GvIMPORTED(dstr) != GVf_IMPORTED
4270 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4272 GvIMPORTED_on(dstr);
4281 #ifdef PERL_COPY_ON_WRITE
4282 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
4283 if (dtype < SVt_PVIV)
4284 sv_upgrade(dstr, SVt_PVIV);
4291 sv_upgrade(dstr, SVt_PV);
4294 if (dtype < SVt_PVIV)
4295 sv_upgrade(dstr, SVt_PVIV);
4298 if (dtype < SVt_PVNV)
4299 sv_upgrade(dstr, SVt_PVNV);
4306 const char * const type = sv_reftype(sstr,0);
4308 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
4310 Perl_croak(aTHX_ "Bizarre copy of %s", type);
4315 if (dtype <= SVt_PVGV) {
4317 if (dtype != SVt_PVGV) {
4318 const char * const name = GvNAME(sstr);
4319 const STRLEN len = GvNAMELEN(sstr);
4320 /* don't upgrade SVt_PVLV: it can hold a glob */
4321 if (dtype != SVt_PVLV)
4322 sv_upgrade(dstr, SVt_PVGV);
4323 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
4324 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
4325 GvNAME(dstr) = savepvn(name, len);
4326 GvNAMELEN(dstr) = len;
4327 SvFAKE_on(dstr); /* can coerce to non-glob */
4329 /* ahem, death to those who redefine active sort subs */
4330 else if (PL_curstackinfo->si_type == PERLSI_SORT
4331 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
4332 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
4335 #ifdef GV_UNIQUE_CHECK
4336 if (GvUNIQUE((GV*)dstr)) {
4337 Perl_croak(aTHX_ PL_no_modify);
4341 (void)SvOK_off(dstr);
4342 GvINTRO_off(dstr); /* one-shot flag */
4344 GvGP(dstr) = gp_ref(GvGP(sstr));
4345 if (SvTAINTED(sstr))
4347 if (GvIMPORTED(dstr) != GVf_IMPORTED
4348 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4350 GvIMPORTED_on(dstr);
4358 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4360 if ((int)SvTYPE(sstr) != stype) {
4361 stype = SvTYPE(sstr);
4362 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
4366 if (stype == SVt_PVLV)
4367 (void)SvUPGRADE(dstr, SVt_PVNV);
4369 (void)SvUPGRADE(dstr, (U32)stype);
4372 sflags = SvFLAGS(sstr);
4374 if (sflags & SVf_ROK) {
4375 if (dtype >= SVt_PV) {
4376 if (dtype == SVt_PVGV) {
4377 SV *sref = SvREFCNT_inc(SvRV(sstr));
4379 const int intro = GvINTRO(dstr);
4381 #ifdef GV_UNIQUE_CHECK
4382 if (GvUNIQUE((GV*)dstr)) {
4383 Perl_croak(aTHX_ PL_no_modify);
4388 GvINTRO_off(dstr); /* one-shot flag */
4389 GvLINE(dstr) = CopLINE(PL_curcop);
4390 GvEGV(dstr) = (GV*)dstr;
4393 switch (SvTYPE(sref)) {
4396 SAVEGENERICSV(GvAV(dstr));
4398 dref = (SV*)GvAV(dstr);
4399 GvAV(dstr) = (AV*)sref;
4400 if (!GvIMPORTED_AV(dstr)
4401 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4403 GvIMPORTED_AV_on(dstr);
4408 SAVEGENERICSV(GvHV(dstr));
4410 dref = (SV*)GvHV(dstr);
4411 GvHV(dstr) = (HV*)sref;
4412 if (!GvIMPORTED_HV(dstr)
4413 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4415 GvIMPORTED_HV_on(dstr);
4420 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
4421 SvREFCNT_dec(GvCV(dstr));
4422 GvCV(dstr) = Nullcv;
4423 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4424 PL_sub_generation++;
4426 SAVEGENERICSV(GvCV(dstr));
4429 dref = (SV*)GvCV(dstr);
4430 if (GvCV(dstr) != (CV*)sref) {
4431 CV* cv = GvCV(dstr);
4433 if (!GvCVGEN((GV*)dstr) &&
4434 (CvROOT(cv) || CvXSUB(cv)))
4436 /* ahem, death to those who redefine
4437 * active sort subs */
4438 if (PL_curstackinfo->si_type == PERLSI_SORT &&
4439 PL_sortcop == CvSTART(cv))
4441 "Can't redefine active sort subroutine %s",
4442 GvENAME((GV*)dstr));
4443 /* Redefining a sub - warning is mandatory if
4444 it was a const and its value changed. */
4445 if (ckWARN(WARN_REDEFINE)
4447 && (!CvCONST((CV*)sref)
4448 || sv_cmp(cv_const_sv(cv),
4449 cv_const_sv((CV*)sref)))))
4451 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4453 ? "Constant subroutine %s::%s redefined"
4454 : "Subroutine %s::%s redefined",
4455 HvNAME(GvSTASH((GV*)dstr)),
4456 GvENAME((GV*)dstr));
4460 cv_ckproto(cv, (GV*)dstr,
4461 SvPOK(sref) ? SvPVX(sref) : Nullch);
4463 GvCV(dstr) = (CV*)sref;
4464 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4465 GvASSUMECV_on(dstr);
4466 PL_sub_generation++;
4468 if (!GvIMPORTED_CV(dstr)
4469 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4471 GvIMPORTED_CV_on(dstr);
4476 SAVEGENERICSV(GvIOp(dstr));
4478 dref = (SV*)GvIOp(dstr);
4479 GvIOp(dstr) = (IO*)sref;
4483 SAVEGENERICSV(GvFORM(dstr));
4485 dref = (SV*)GvFORM(dstr);
4486 GvFORM(dstr) = (CV*)sref;
4490 SAVEGENERICSV(GvSV(dstr));
4492 dref = (SV*)GvSV(dstr);
4494 if (!GvIMPORTED_SV(dstr)
4495 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4497 GvIMPORTED_SV_on(dstr);
4503 if (SvTAINTED(sstr))
4513 (void)SvOK_off(dstr);
4514 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4516 if (sflags & SVp_NOK) {
4518 /* Only set the public OK flag if the source has public OK. */
4519 if (sflags & SVf_NOK)
4520 SvFLAGS(dstr) |= SVf_NOK;
4521 SvNV_set(dstr, SvNVX(sstr));
4523 if (sflags & SVp_IOK) {
4524 (void)SvIOKp_on(dstr);
4525 if (sflags & SVf_IOK)
4526 SvFLAGS(dstr) |= SVf_IOK;
4527 if (sflags & SVf_IVisUV)
4529 SvIV_set(dstr, SvIVX(sstr));
4531 if (SvAMAGIC(sstr)) {
4535 else if (sflags & SVp_POK) {
4539 * Check to see if we can just swipe the string. If so, it's a
4540 * possible small lose on short strings, but a big win on long ones.
4541 * It might even be a win on short strings if SvPVX(dstr)
4542 * has to be allocated and SvPVX(sstr) has to be freed.
4545 /* Whichever path we take through the next code, we want this true,
4546 and doing it now facilitates the COW check. */
4547 (void)SvPOK_only(dstr);
4550 #ifdef PERL_COPY_ON_WRITE
4551 (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
4555 (sflags & SVs_TEMP) && /* slated for free anyway? */
4556 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4557 (!(flags & SV_NOSTEAL)) &&
4558 /* and we're allowed to steal temps */
4559 SvREFCNT(sstr) == 1 && /* and no other references to it? */
4560 SvLEN(sstr) && /* and really is a string */
4561 /* and won't be needed again, potentially */
4562 !(PL_op && PL_op->op_type == OP_AASSIGN))
4563 #ifdef PERL_COPY_ON_WRITE
4564 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4565 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4566 && SvTYPE(sstr) >= SVt_PVIV)
4569 /* Failed the swipe test, and it's not a shared hash key either.
4570 Have to copy the string. */
4571 STRLEN len = SvCUR(sstr);
4572 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4573 Move(SvPVX(sstr),SvPVX(dstr),len,char);
4574 SvCUR_set(dstr, len);
4575 *SvEND(dstr) = '\0';
4577 /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
4579 #ifdef PERL_COPY_ON_WRITE
4580 /* Either it's a shared hash key, or it's suitable for
4581 copy-on-write or we can swipe the string. */
4583 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4588 /* I believe I should acquire a global SV mutex if
4589 it's a COW sv (not a shared hash key) to stop
4590 it going un copy-on-write.
4591 If the source SV has gone un copy on write between up there
4592 and down here, then (assert() that) it is of the correct
4593 form to make it copy on write again */
4594 if ((sflags & (SVf_FAKE | SVf_READONLY))
4595 != (SVf_FAKE | SVf_READONLY)) {
4596 SvREADONLY_on(sstr);
4598 /* Make the source SV into a loop of 1.
4599 (about to become 2) */
4600 SV_COW_NEXT_SV_SET(sstr, sstr);
4604 /* Initial code is common. */
4605 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
4607 SvFLAGS(dstr) &= ~SVf_OOK;
4608 Safefree(SvPVX(dstr) - SvIVX(dstr));
4610 else if (SvLEN(dstr))
4611 Safefree(SvPVX(dstr));
4614 #ifdef PERL_COPY_ON_WRITE
4616 /* making another shared SV. */
4617 STRLEN cur = SvCUR(sstr);
4618 STRLEN len = SvLEN(sstr);
4619 assert (SvTYPE(dstr) >= SVt_PVIV);
4621 /* SvIsCOW_normal */
4622 /* splice us in between source and next-after-source. */
4623 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4624 SV_COW_NEXT_SV_SET(sstr, dstr);
4625 SvPV_set(dstr, SvPVX(sstr));
4627 /* SvIsCOW_shared_hash */
4628 UV hash = SvUVX(sstr);
4629 DEBUG_C(PerlIO_printf(Perl_debug_log,
4630 "Copy on write: Sharing hash\n"));
4632 sharepvn(SvPVX(sstr),
4633 (sflags & SVf_UTF8?-cur:cur), hash));
4634 SvUV_set(dstr, hash);
4636 SvLEN_set(dstr, len);
4637 SvCUR_set(dstr, cur);
4638 SvREADONLY_on(dstr);
4640 /* Relesase a global SV mutex. */
4644 { /* Passes the swipe test. */
4645 SvPV_set(dstr, SvPVX(sstr));
4646 SvLEN_set(dstr, SvLEN(sstr));
4647 SvCUR_set(dstr, SvCUR(sstr));
4650 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4651 SvPV_set(sstr, Nullch);
4657 if (sflags & SVf_UTF8)
4660 if (sflags & SVp_NOK) {
4662 if (sflags & SVf_NOK)
4663 SvFLAGS(dstr) |= SVf_NOK;
4664 SvNV_set(dstr, SvNVX(sstr));
4666 if (sflags & SVp_IOK) {
4667 (void)SvIOKp_on(dstr);
4668 if (sflags & SVf_IOK)
4669 SvFLAGS(dstr) |= SVf_IOK;
4670 if (sflags & SVf_IVisUV)
4672 SvIV_set(dstr, SvIVX(sstr));
4675 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4676 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4677 smg->mg_ptr, smg->mg_len);
4678 SvRMAGICAL_on(dstr);
4681 else if (sflags & SVp_IOK) {
4682 if (sflags & SVf_IOK)
4683 (void)SvIOK_only(dstr);
4685 (void)SvOK_off(dstr);
4686 (void)SvIOKp_on(dstr);
4688 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4689 if (sflags & SVf_IVisUV)
4691 SvIV_set(dstr, SvIVX(sstr));
4692 if (sflags & SVp_NOK) {
4693 if (sflags & SVf_NOK)
4694 (void)SvNOK_on(dstr);
4696 (void)SvNOKp_on(dstr);
4697 SvNV_set(dstr, SvNVX(sstr));
4700 else if (sflags & SVp_NOK) {
4701 if (sflags & SVf_NOK)
4702 (void)SvNOK_only(dstr);
4704 (void)SvOK_off(dstr);
4707 SvNV_set(dstr, SvNVX(sstr));
4710 if (dtype == SVt_PVGV) {
4711 if (ckWARN(WARN_MISC))
4712 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4715 (void)SvOK_off(dstr);
4717 if (SvTAINTED(sstr))
4722 =for apidoc sv_setsv_mg
4724 Like C<sv_setsv>, but also handles 'set' magic.
4730 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4732 sv_setsv(dstr,sstr);
4736 #ifdef PERL_COPY_ON_WRITE
4738 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4740 STRLEN cur = SvCUR(sstr);
4741 STRLEN len = SvLEN(sstr);
4742 register char *new_pv;
4745 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4753 if (SvTHINKFIRST(dstr))
4754 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4755 else if (SvPVX(dstr))
4756 Safefree(SvPVX(dstr));
4760 (void)SvUPGRADE (dstr, SVt_PVIV);
4762 assert (SvPOK(sstr));
4763 assert (SvPOKp(sstr));
4764 assert (!SvIOK(sstr));
4765 assert (!SvIOKp(sstr));
4766 assert (!SvNOK(sstr));
4767 assert (!SvNOKp(sstr));
4769 if (SvIsCOW(sstr)) {
4771 if (SvLEN(sstr) == 0) {
4772 /* source is a COW shared hash key. */
4773 UV hash = SvUVX(sstr);
4774 DEBUG_C(PerlIO_printf(Perl_debug_log,
4775 "Fast copy on write: Sharing hash\n"));
4776 SvUV_set(dstr, hash);
4777 new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash);
4780 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4782 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4783 (void)SvUPGRADE (sstr, SVt_PVIV);
4784 SvREADONLY_on(sstr);
4786 DEBUG_C(PerlIO_printf(Perl_debug_log,
4787 "Fast copy on write: Converting sstr to COW\n"));
4788 SV_COW_NEXT_SV_SET(dstr, sstr);
4790 SV_COW_NEXT_SV_SET(sstr, dstr);
4791 new_pv = SvPVX(sstr);
4794 SvPV_set(dstr, new_pv);
4795 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4798 SvLEN_set(dstr, len);
4799 SvCUR_set(dstr, cur);
4808 =for apidoc sv_setpvn
4810 Copies a string into an SV. The C<len> parameter indicates the number of
4811 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4812 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4818 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4820 register char *dptr;
4822 SV_CHECK_THINKFIRST_COW_DROP(sv);
4828 /* len is STRLEN which is unsigned, need to copy to signed */
4831 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4833 (void)SvUPGRADE(sv, SVt_PV);
4835 SvGROW(sv, len + 1);
4837 Move(ptr,dptr,len,char);
4840 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4845 =for apidoc sv_setpvn_mg
4847 Like C<sv_setpvn>, but also handles 'set' magic.
4853 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4855 sv_setpvn(sv,ptr,len);
4860 =for apidoc sv_setpv
4862 Copies a string into an SV. The string must be null-terminated. Does not
4863 handle 'set' magic. See C<sv_setpv_mg>.
4869 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4871 register STRLEN len;
4873 SV_CHECK_THINKFIRST_COW_DROP(sv);
4879 (void)SvUPGRADE(sv, SVt_PV);
4881 SvGROW(sv, len + 1);
4882 Move(ptr,SvPVX(sv),len+1,char);
4884 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4889 =for apidoc sv_setpv_mg
4891 Like C<sv_setpv>, but also handles 'set' magic.
4897 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4904 =for apidoc sv_usepvn
4906 Tells an SV to use C<ptr> to find its string value. Normally the string is
4907 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4908 The C<ptr> should point to memory that was allocated by C<malloc>. The
4909 string length, C<len>, must be supplied. This function will realloc the
4910 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4911 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4912 See C<sv_usepvn_mg>.
4918 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4920 SV_CHECK_THINKFIRST_COW_DROP(sv);
4921 (void)SvUPGRADE(sv, SVt_PV);
4928 Renew(ptr, len+1, char);
4931 SvLEN_set(sv, len+1);
4933 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4938 =for apidoc sv_usepvn_mg
4940 Like C<sv_usepvn>, but also handles 'set' magic.
4946 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4948 sv_usepvn(sv,ptr,len);
4952 #ifdef PERL_COPY_ON_WRITE
4953 /* Need to do this *after* making the SV normal, as we need the buffer
4954 pointer to remain valid until after we've copied it. If we let go too early,
4955 another thread could invalidate it by unsharing last of the same hash key
4956 (which it can do by means other than releasing copy-on-write Svs)
4957 or by changing the other copy-on-write SVs in the loop. */
4959 S_sv_release_COW(pTHX_ register SV *sv, char *pvx, STRLEN cur, STRLEN len,
4960 U32 hash, SV *after)
4962 if (len) { /* this SV was SvIsCOW_normal(sv) */
4963 /* we need to find the SV pointing to us. */
4964 SV *current = SV_COW_NEXT_SV(after);
4966 if (current == sv) {
4967 /* The SV we point to points back to us (there were only two of us
4969 Hence other SV is no longer copy on write either. */
4971 SvREADONLY_off(after);
4973 /* We need to follow the pointers around the loop. */
4975 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4978 /* don't loop forever if the structure is bust, and we have
4979 a pointer into a closed loop. */
4980 assert (current != after);
4981 assert (SvPVX(current) == pvx);
4983 /* Make the SV before us point to the SV after us. */
4984 SV_COW_NEXT_SV_SET(current, after);
4987 unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash);
4992 Perl_sv_release_IVX(pTHX_ register SV *sv)
4995 sv_force_normal_flags(sv, 0);
5001 =for apidoc sv_force_normal_flags
5003 Undo various types of fakery on an SV: if the PV is a shared string, make
5004 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5005 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
5006 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
5007 then a copy-on-write scalar drops its PV buffer (if any) and becomes
5008 SvPOK_off rather than making a copy. (Used where this scalar is about to be
5009 set to some other value.) In addition, the C<flags> parameter gets passed to
5010 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
5011 with flags set to 0.
5017 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
5019 #ifdef PERL_COPY_ON_WRITE
5020 if (SvREADONLY(sv)) {
5021 /* At this point I believe I should acquire a global SV mutex. */
5023 char *pvx = SvPVX(sv);
5024 STRLEN len = SvLEN(sv);
5025 STRLEN cur = SvCUR(sv);
5026 U32 hash = SvUVX(sv);
5027 SV *next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
5029 PerlIO_printf(Perl_debug_log,
5030 "Copy on write: Force normal %ld\n",
5036 /* This SV doesn't own the buffer, so need to New() a new one: */
5037 SvPV_set(sv, (char*)0);
5039 if (flags & SV_COW_DROP_PV) {
5040 /* OK, so we don't need to copy our buffer. */
5043 SvGROW(sv, cur + 1);
5044 Move(pvx,SvPVX(sv),cur,char);
5048 sv_release_COW(sv, pvx, cur, len, hash, next);
5053 else if (IN_PERL_RUNTIME)
5054 Perl_croak(aTHX_ PL_no_modify);
5055 /* At this point I believe that I can drop the global SV mutex. */
5058 if (SvREADONLY(sv)) {
5060 char *pvx = SvPVX(sv);
5061 int is_utf8 = SvUTF8(sv);
5062 STRLEN len = SvCUR(sv);
5063 U32 hash = SvUVX(sv);
5066 SvPV_set(sv, (char*)0);
5068 SvGROW(sv, len + 1);
5069 Move(pvx,SvPVX(sv),len,char);
5071 unsharepvn(pvx, is_utf8 ? -(I32)len : len, hash);
5073 else if (IN_PERL_RUNTIME)
5074 Perl_croak(aTHX_ PL_no_modify);
5078 sv_unref_flags(sv, flags);
5079 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
5084 =for apidoc sv_force_normal
5086 Undo various types of fakery on an SV: if the PV is a shared string, make
5087 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
5088 an xpvmg. See also C<sv_force_normal_flags>.
5094 Perl_sv_force_normal(pTHX_ register SV *sv)
5096 sv_force_normal_flags(sv, 0);
5102 Efficient removal of characters from the beginning of the string buffer.
5103 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
5104 the string buffer. The C<ptr> becomes the first character of the adjusted
5105 string. Uses the "OOK hack".
5106 Beware: after this function returns, C<ptr> and SvPVX(sv) may no longer
5107 refer to the same chunk of data.
5113 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
5115 register STRLEN delta;
5116 if (!ptr || !SvPOKp(sv))
5118 delta = ptr - SvPVX(sv);
5119 SV_CHECK_THINKFIRST(sv);
5120 if (SvTYPE(sv) < SVt_PVIV)
5121 sv_upgrade(sv,SVt_PVIV);
5124 if (!SvLEN(sv)) { /* make copy of shared string */
5125 const char *pvx = SvPVX(sv);
5126 STRLEN len = SvCUR(sv);
5127 SvGROW(sv, len + 1);
5128 Move(pvx,SvPVX(sv),len,char);
5132 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
5133 and we do that anyway inside the SvNIOK_off
5135 SvFLAGS(sv) |= SVf_OOK;
5138 SvLEN_set(sv, SvLEN(sv) - delta);
5139 SvCUR_set(sv, SvCUR(sv) - delta);
5140 SvPV_set(sv, SvPVX(sv) + delta);
5141 SvIV_set(sv, SvIVX(sv) + delta);
5144 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
5145 * this function provided for binary compatibility only
5149 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
5151 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
5155 =for apidoc sv_catpvn
5157 Concatenates the string onto the end of the string which is in the SV. The
5158 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5159 status set, then the bytes appended should be valid UTF-8.
5160 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
5162 =for apidoc sv_catpvn_flags
5164 Concatenates the string onto the end of the string which is in the SV. The
5165 C<len> indicates number of bytes to copy. If the SV has the UTF-8
5166 status set, then the bytes appended should be valid UTF-8.
5167 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
5168 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5169 in terms of this function.
5175 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
5178 const char *dstr = SvPV_force_flags(dsv, dlen, flags);
5180 SvGROW(dsv, dlen + slen + 1);
5183 Move(sstr, SvPVX(dsv) + dlen, slen, char);
5184 SvCUR_set(dsv, SvCUR(dsv) + slen);
5186 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
5191 =for apidoc sv_catpvn_mg
5193 Like C<sv_catpvn>, but also handles 'set' magic.
5199 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
5201 sv_catpvn(sv,ptr,len);
5205 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
5206 * this function provided for binary compatibility only
5210 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
5212 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
5216 =for apidoc sv_catsv
5218 Concatenates the string from SV C<ssv> onto the end of the string in
5219 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
5220 not 'set' magic. See C<sv_catsv_mg>.
5222 =for apidoc sv_catsv_flags
5224 Concatenates the string from SV C<ssv> onto the end of the string in
5225 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
5226 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
5227 and C<sv_catsv_nomg> are implemented in terms of this function.
5232 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
5238 if ((spv = SvPV(ssv, slen))) {
5239 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
5240 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
5241 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
5242 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
5243 dsv->sv_flags doesn't have that bit set.
5244 Andy Dougherty 12 Oct 2001
5246 I32 sutf8 = DO_UTF8(ssv);
5249 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
5251 dutf8 = DO_UTF8(dsv);
5253 if (dutf8 != sutf8) {
5255 /* Not modifying source SV, so taking a temporary copy. */
5256 SV* csv = sv_2mortal(newSVpvn(spv, slen));
5258 sv_utf8_upgrade(csv);
5259 spv = SvPV(csv, slen);
5262 sv_utf8_upgrade_nomg(dsv);
5264 sv_catpvn_nomg(dsv, spv, slen);
5269 =for apidoc sv_catsv_mg
5271 Like C<sv_catsv>, but also handles 'set' magic.
5277 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
5284 =for apidoc sv_catpv
5286 Concatenates the string onto the end of the string which is in the SV.
5287 If the SV has the UTF-8 status set, then the bytes appended should be
5288 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
5293 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
5295 register STRLEN len;
5301 junk = SvPV_force(sv, tlen);
5303 SvGROW(sv, tlen + len + 1);
5306 Move(ptr,SvPVX(sv)+tlen,len+1,char);
5307 SvCUR_set(sv, SvCUR(sv) + len);
5308 (void)SvPOK_only_UTF8(sv); /* validate pointer */
5313 =for apidoc sv_catpv_mg
5315 Like C<sv_catpv>, but also handles 'set' magic.
5321 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
5330 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
5331 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
5338 Perl_newSV(pTHX_ STRLEN len)
5344 sv_upgrade(sv, SVt_PV);
5345 SvGROW(sv, len + 1);
5350 =for apidoc sv_magicext
5352 Adds magic to an SV, upgrading it if necessary. Applies the
5353 supplied vtable and returns a pointer to the magic added.
5355 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5356 In particular, you can add magic to SvREADONLY SVs, and add more than
5357 one instance of the same 'how'.
5359 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5360 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5361 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5362 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5364 (This is now used as a subroutine by C<sv_magic>.)
5369 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
5370 const char* name, I32 namlen)
5374 if (SvTYPE(sv) < SVt_PVMG) {
5375 (void)SvUPGRADE(sv, SVt_PVMG);
5377 Newz(702,mg, 1, MAGIC);
5378 mg->mg_moremagic = SvMAGIC(sv);
5379 SvMAGIC_set(sv, mg);
5381 /* Sometimes a magic contains a reference loop, where the sv and
5382 object refer to each other. To prevent a reference loop that
5383 would prevent such objects being freed, we look for such loops
5384 and if we find one we avoid incrementing the object refcount.
5386 Note we cannot do this to avoid self-tie loops as intervening RV must
5387 have its REFCNT incremented to keep it in existence.
5390 if (!obj || obj == sv ||
5391 how == PERL_MAGIC_arylen ||
5392 how == PERL_MAGIC_qr ||
5393 how == PERL_MAGIC_symtab ||
5394 (SvTYPE(obj) == SVt_PVGV &&
5395 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
5396 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
5397 GvFORM(obj) == (CV*)sv)))
5402 mg->mg_obj = SvREFCNT_inc(obj);
5403 mg->mg_flags |= MGf_REFCOUNTED;
5406 /* Normal self-ties simply pass a null object, and instead of
5407 using mg_obj directly, use the SvTIED_obj macro to produce a
5408 new RV as needed. For glob "self-ties", we are tieing the PVIO
5409 with an RV obj pointing to the glob containing the PVIO. In
5410 this case, to avoid a reference loop, we need to weaken the
5414 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5415 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
5421 mg->mg_len = namlen;
5424 mg->mg_ptr = savepvn(name, namlen);
5425 else if (namlen == HEf_SVKEY)
5426 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
5428 mg->mg_ptr = (char *) name;
5430 mg->mg_virtual = vtable;
5434 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
5439 =for apidoc sv_magic
5441 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
5442 then adds a new magic item of type C<how> to the head of the magic list.
5444 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5445 handling of the C<name> and C<namlen> arguments.
5447 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5448 to add more than one instance of the same 'how'.
5454 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
5456 const MGVTBL *vtable = 0;
5459 #ifdef PERL_COPY_ON_WRITE
5461 sv_force_normal_flags(sv, 0);
5463 if (SvREADONLY(sv)) {
5465 && how != PERL_MAGIC_regex_global
5466 && how != PERL_MAGIC_bm
5467 && how != PERL_MAGIC_fm
5468 && how != PERL_MAGIC_sv
5469 && how != PERL_MAGIC_backref
5472 Perl_croak(aTHX_ PL_no_modify);
5475 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5476 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5477 /* sv_magic() refuses to add a magic of the same 'how' as an
5480 if (how == PERL_MAGIC_taint)
5488 vtable = &PL_vtbl_sv;
5490 case PERL_MAGIC_overload:
5491 vtable = &PL_vtbl_amagic;
5493 case PERL_MAGIC_overload_elem:
5494 vtable = &PL_vtbl_amagicelem;
5496 case PERL_MAGIC_overload_table:
5497 vtable = &PL_vtbl_ovrld;
5500 vtable = &PL_vtbl_bm;
5502 case PERL_MAGIC_regdata:
5503 vtable = &PL_vtbl_regdata;
5505 case PERL_MAGIC_regdatum:
5506 vtable = &PL_vtbl_regdatum;
5508 case PERL_MAGIC_env:
5509 vtable = &PL_vtbl_env;
5512 vtable = &PL_vtbl_fm;
5514 case PERL_MAGIC_envelem:
5515 vtable = &PL_vtbl_envelem;
5517 case PERL_MAGIC_regex_global:
5518 vtable = &PL_vtbl_mglob;
5520 case PERL_MAGIC_isa:
5521 vtable = &PL_vtbl_isa;
5523 case PERL_MAGIC_isaelem:
5524 vtable = &PL_vtbl_isaelem;
5526 case PERL_MAGIC_nkeys:
5527 vtable = &PL_vtbl_nkeys;
5529 case PERL_MAGIC_dbfile:
5532 case PERL_MAGIC_dbline:
5533 vtable = &PL_vtbl_dbline;
5535 #ifdef USE_LOCALE_COLLATE
5536 case PERL_MAGIC_collxfrm:
5537 vtable = &PL_vtbl_collxfrm;
5539 #endif /* USE_LOCALE_COLLATE */
5540 case PERL_MAGIC_tied:
5541 vtable = &PL_vtbl_pack;
5543 case PERL_MAGIC_tiedelem:
5544 case PERL_MAGIC_tiedscalar:
5545 vtable = &PL_vtbl_packelem;
5548 vtable = &PL_vtbl_regexp;
5550 case PERL_MAGIC_sig:
5551 vtable = &PL_vtbl_sig;
5553 case PERL_MAGIC_sigelem:
5554 vtable = &PL_vtbl_sigelem;
5556 case PERL_MAGIC_taint:
5557 vtable = &PL_vtbl_taint;
5559 case PERL_MAGIC_uvar:
5560 vtable = &PL_vtbl_uvar;
5562 case PERL_MAGIC_vec:
5563 vtable = &PL_vtbl_vec;
5565 case PERL_MAGIC_symtab:
5566 case PERL_MAGIC_vstring:
5569 case PERL_MAGIC_utf8:
5570 vtable = &PL_vtbl_utf8;
5572 case PERL_MAGIC_substr:
5573 vtable = &PL_vtbl_substr;
5575 case PERL_MAGIC_defelem:
5576 vtable = &PL_vtbl_defelem;
5578 case PERL_MAGIC_glob:
5579 vtable = &PL_vtbl_glob;
5581 case PERL_MAGIC_arylen:
5582 vtable = &PL_vtbl_arylen;
5584 case PERL_MAGIC_pos:
5585 vtable = &PL_vtbl_pos;
5587 case PERL_MAGIC_backref:
5588 vtable = &PL_vtbl_backref;
5590 case PERL_MAGIC_ext:
5591 /* Reserved for use by extensions not perl internals. */
5592 /* Useful for attaching extension internal data to perl vars. */
5593 /* Note that multiple extensions may clash if magical scalars */
5594 /* etc holding private data from one are passed to another. */
5597 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5600 /* Rest of work is done else where */
5601 mg = sv_magicext(sv,obj,how,(MGVTBL*)vtable,name,namlen);
5604 case PERL_MAGIC_taint:
5607 case PERL_MAGIC_ext:
5608 case PERL_MAGIC_dbfile:
5615 =for apidoc sv_unmagic
5617 Removes all magic of type C<type> from an SV.
5623 Perl_sv_unmagic(pTHX_ SV *sv, int type)
5627 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5630 for (mg = *mgp; mg; mg = *mgp) {
5631 if (mg->mg_type == type) {
5632 const MGVTBL* const vtbl = mg->mg_virtual;
5633 *mgp = mg->mg_moremagic;
5634 if (vtbl && vtbl->svt_free)
5635 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5636 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5638 Safefree(mg->mg_ptr);
5639 else if (mg->mg_len == HEf_SVKEY)
5640 SvREFCNT_dec((SV*)mg->mg_ptr);
5641 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
5642 Safefree(mg->mg_ptr);
5644 if (mg->mg_flags & MGf_REFCOUNTED)
5645 SvREFCNT_dec(mg->mg_obj);
5649 mgp = &mg->mg_moremagic;
5653 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5660 =for apidoc sv_rvweaken
5662 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5663 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5664 push a back-reference to this RV onto the array of backreferences
5665 associated with that magic.
5671 Perl_sv_rvweaken(pTHX_ SV *sv)
5674 if (!SvOK(sv)) /* let undefs pass */
5677 Perl_croak(aTHX_ "Can't weaken a nonreference");
5678 else if (SvWEAKREF(sv)) {
5679 if (ckWARN(WARN_MISC))
5680 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5684 sv_add_backref(tsv, sv);
5690 /* Give tsv backref magic if it hasn't already got it, then push a
5691 * back-reference to sv onto the array associated with the backref magic.
5695 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
5699 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
5700 av = (AV*)mg->mg_obj;
5703 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5704 /* av now has a refcnt of 2, which avoids it getting freed
5705 * before us during global cleanup. The extra ref is removed
5706 * by magic_killbackrefs() when tsv is being freed */
5708 if (AvFILLp(av) >= AvMAX(av)) {
5710 SV **svp = AvARRAY(av);
5711 for (i = AvFILLp(av); i >= 0; i--)
5713 svp[i] = sv; /* reuse the slot */
5716 av_extend(av, AvFILLp(av)+1);
5718 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5721 /* delete a back-reference to ourselves from the backref magic associated
5722 * with the SV we point to.
5726 S_sv_del_backref(pTHX_ SV *sv)
5733 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
5734 Perl_croak(aTHX_ "panic: del_backref");
5735 av = (AV *)mg->mg_obj;
5737 for (i = AvFILLp(av); i >= 0; i--)
5738 if (svp[i] == sv) svp[i] = Nullsv;
5742 =for apidoc sv_insert
5744 Inserts a string at the specified offset/length within the SV. Similar to
5745 the Perl substr() function.
5751 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
5755 register char *midend;
5756 register char *bigend;
5762 Perl_croak(aTHX_ "Can't modify non-existent substring");
5763 SvPV_force(bigstr, curlen);
5764 (void)SvPOK_only_UTF8(bigstr);
5765 if (offset + len > curlen) {
5766 SvGROW(bigstr, offset+len+1);
5767 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5768 SvCUR_set(bigstr, offset+len);
5772 i = littlelen - len;
5773 if (i > 0) { /* string might grow */
5774 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5775 mid = big + offset + len;
5776 midend = bigend = big + SvCUR(bigstr);
5779 while (midend > mid) /* shove everything down */
5780 *--bigend = *--midend;
5781 Move(little,big+offset,littlelen,char);
5782 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5787 Move(little,SvPVX(bigstr)+offset,len,char);
5792 big = SvPVX(bigstr);
5795 bigend = big + SvCUR(bigstr);
5797 if (midend > bigend)
5798 Perl_croak(aTHX_ "panic: sv_insert");
5800 if (mid - big > bigend - midend) { /* faster to shorten from end */
5802 Move(little, mid, littlelen,char);
5805 i = bigend - midend;
5807 Move(midend, mid, i,char);
5811 SvCUR_set(bigstr, mid - big);
5814 else if ((i = mid - big)) { /* faster from front */
5815 midend -= littlelen;
5817 sv_chop(bigstr,midend-i);
5822 Move(little, mid, littlelen,char);
5824 else if (littlelen) {
5825 midend -= littlelen;
5826 sv_chop(bigstr,midend);
5827 Move(little,midend,littlelen,char);
5830 sv_chop(bigstr,midend);
5836 =for apidoc sv_replace
5838 Make the first argument a copy of the second, then delete the original.
5839 The target SV physically takes over ownership of the body of the source SV
5840 and inherits its flags; however, the target keeps any magic it owns,
5841 and any magic in the source is discarded.
5842 Note that this is a rather specialist SV copying operation; most of the
5843 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5849 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5851 const U32 refcnt = SvREFCNT(sv);
5852 SV_CHECK_THINKFIRST_COW_DROP(sv);
5853 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
5854 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
5855 if (SvMAGICAL(sv)) {
5859 sv_upgrade(nsv, SVt_PVMG);
5860 SvMAGIC_set(nsv, SvMAGIC(sv));
5861 SvFLAGS(nsv) |= SvMAGICAL(sv);
5863 SvMAGIC_set(sv, NULL);
5867 assert(!SvREFCNT(sv));
5868 #ifdef DEBUG_LEAKING_SCALARS
5869 sv->sv_flags = nsv->sv_flags;
5870 sv->sv_any = nsv->sv_any;
5871 sv->sv_refcnt = nsv->sv_refcnt;
5873 StructCopy(nsv,sv,SV);
5876 #ifdef PERL_COPY_ON_WRITE
5877 if (SvIsCOW_normal(nsv)) {
5878 /* We need to follow the pointers around the loop to make the
5879 previous SV point to sv, rather than nsv. */
5882 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5885 assert(SvPVX(current) == SvPVX(nsv));
5887 /* Make the SV before us point to the SV after us. */
5889 PerlIO_printf(Perl_debug_log, "previous is\n");
5891 PerlIO_printf(Perl_debug_log,
5892 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5893 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5895 SV_COW_NEXT_SV_SET(current, sv);
5898 SvREFCNT(sv) = refcnt;
5899 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5905 =for apidoc sv_clear
5907 Clear an SV: call any destructors, free up any memory used by the body,
5908 and free the body itself. The SV's head is I<not> freed, although
5909 its type is set to all 1's so that it won't inadvertently be assumed
5910 to be live during global destruction etc.
5911 This function should only be called when REFCNT is zero. Most of the time
5912 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5919 Perl_sv_clear(pTHX_ register SV *sv)
5924 assert(SvREFCNT(sv) == 0);
5927 if (PL_defstash) { /* Still have a symbol table? */
5934 stash = SvSTASH(sv);
5935 destructor = StashHANDLER(stash,DESTROY);
5937 SV* tmpref = newRV(sv);
5938 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5940 PUSHSTACKi(PERLSI_DESTROY);
5945 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5951 if(SvREFCNT(tmpref) < 2) {
5952 /* tmpref is not kept alive! */
5954 SvRV_set(tmpref, NULL);
5957 SvREFCNT_dec(tmpref);
5959 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5963 if (PL_in_clean_objs)
5964 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5966 /* DESTROY gave object new lease on life */
5972 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5973 SvOBJECT_off(sv); /* Curse the object. */
5974 if (SvTYPE(sv) != SVt_PVIO)
5975 --PL_sv_objcount; /* XXX Might want something more general */
5978 if (SvTYPE(sv) >= SVt_PVMG) {
5981 if (SvTYPE(sv) == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
5982 SvREFCNT_dec(SvSTASH(sv));
5985 switch (SvTYPE(sv)) {
5988 IoIFP(sv) != PerlIO_stdin() &&
5989 IoIFP(sv) != PerlIO_stdout() &&
5990 IoIFP(sv) != PerlIO_stderr())
5992 io_close((IO*)sv, FALSE);
5994 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5995 PerlDir_close(IoDIRP(sv));
5996 IoDIRP(sv) = (DIR*)NULL;
5997 Safefree(IoTOP_NAME(sv));
5998 Safefree(IoFMT_NAME(sv));
5999 Safefree(IoBOTTOM_NAME(sv));
6014 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
6015 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
6016 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
6017 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
6019 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
6020 SvREFCNT_dec(LvTARG(sv));
6024 Safefree(GvNAME(sv));
6025 /* cannot decrease stash refcount yet, as we might recursively delete
6026 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
6027 of stash until current sv is completely gone.
6028 -- JohnPC, 27 Mar 1998 */
6029 stash = GvSTASH(sv);
6035 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
6037 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
6038 /* Don't even bother with turning off the OOK flag. */
6047 SvREFCNT_dec(SvRV(sv));
6049 #ifdef PERL_COPY_ON_WRITE
6050 else if (SvPVX(sv)) {
6052 /* I believe I need to grab the global SV mutex here and
6053 then recheck the COW status. */
6055 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6058 sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(sv),
6059 SvUVX(sv), SV_COW_NEXT_SV(sv));
6060 /* And drop it here. */
6062 } else if (SvLEN(sv)) {
6063 Safefree(SvPVX(sv));
6067 else if (SvPVX(sv) && SvLEN(sv))
6068 Safefree(SvPVX(sv));
6069 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
6070 unsharepvn(SvPVX(sv),
6071 SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
6085 switch (SvTYPE(sv)) {
6101 del_XPVIV(SvANY(sv));
6104 del_XPVNV(SvANY(sv));
6107 del_XPVMG(SvANY(sv));
6110 del_XPVLV(SvANY(sv));
6113 del_XPVAV(SvANY(sv));
6116 del_XPVHV(SvANY(sv));
6119 del_XPVCV(SvANY(sv));
6122 del_XPVGV(SvANY(sv));
6123 /* code duplication for increased performance. */
6124 SvFLAGS(sv) &= SVf_BREAK;
6125 SvFLAGS(sv) |= SVTYPEMASK;
6126 /* decrease refcount of the stash that owns this GV, if any */
6128 SvREFCNT_dec(stash);
6129 return; /* not break, SvFLAGS reset already happened */
6131 del_XPVBM(SvANY(sv));
6134 del_XPVFM(SvANY(sv));
6137 del_XPVIO(SvANY(sv));
6140 SvFLAGS(sv) &= SVf_BREAK;
6141 SvFLAGS(sv) |= SVTYPEMASK;
6145 =for apidoc sv_newref
6147 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
6154 Perl_sv_newref(pTHX_ SV *sv)
6164 Decrement an SV's reference count, and if it drops to zero, call
6165 C<sv_clear> to invoke destructors and free up any memory used by
6166 the body; finally, deallocate the SV's head itself.
6167 Normally called via a wrapper macro C<SvREFCNT_dec>.
6173 Perl_sv_free(pTHX_ SV *sv)
6178 if (SvREFCNT(sv) == 0) {
6179 if (SvFLAGS(sv) & SVf_BREAK)
6180 /* this SV's refcnt has been artificially decremented to
6181 * trigger cleanup */
6183 if (PL_in_clean_all) /* All is fair */
6185 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6186 /* make sure SvREFCNT(sv)==0 happens very seldom */
6187 SvREFCNT(sv) = (~(U32)0)/2;
6190 if (ckWARN_d(WARN_INTERNAL))
6191 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
6192 "Attempt to free unreferenced scalar: SV 0x%"UVxf
6193 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6196 if (--(SvREFCNT(sv)) > 0)
6198 Perl_sv_free2(aTHX_ sv);
6202 Perl_sv_free2(pTHX_ SV *sv)
6207 if (ckWARN_d(WARN_DEBUGGING))
6208 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
6209 "Attempt to free temp prematurely: SV 0x%"UVxf
6210 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
6214 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
6215 /* make sure SvREFCNT(sv)==0 happens very seldom */
6216 SvREFCNT(sv) = (~(U32)0)/2;
6227 Returns the length of the string in the SV. Handles magic and type
6228 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
6234 Perl_sv_len(pTHX_ register SV *sv)
6242 len = mg_length(sv);
6244 (void)SvPV(sv, len);
6249 =for apidoc sv_len_utf8
6251 Returns the number of characters in the string in an SV, counting wide
6252 UTF-8 bytes as a single character. Handles magic and type coercion.
6258 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
6259 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
6260 * (Note that the mg_len is not the length of the mg_ptr field.)
6265 Perl_sv_len_utf8(pTHX_ register SV *sv)
6271 return mg_length(sv);
6275 const U8 *s = (U8*)SvPV(sv, len);
6276 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
6278 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
6280 #ifdef PERL_UTF8_CACHE_ASSERT
6281 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
6285 ulen = Perl_utf8_length(aTHX_ s, s + len);
6286 if (!mg && !SvREADONLY(sv)) {
6287 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6288 mg = mg_find(sv, PERL_MAGIC_utf8);
6298 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
6299 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
6300 * between UTF-8 and byte offsets. There are two (substr offset and substr
6301 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
6302 * and byte offset) cache positions.
6304 * The mg_len field is used by sv_len_utf8(), see its comments.
6305 * Note that the mg_len is not the length of the mg_ptr field.
6309 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 offsetp, U8 *s, U8 *start)
6313 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6315 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
6319 *cachep = (STRLEN *) (*mgp)->mg_ptr;
6321 Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6322 (*mgp)->mg_ptr = (char *) *cachep;
6326 (*cachep)[i] = offsetp;
6327 (*cachep)[i+1] = s - start;
6335 * S_utf8_mg_pos() is used to query and update mg_ptr field of
6336 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
6337 * between UTF-8 and byte offsets. See also the comments of
6338 * S_utf8_mg_pos_init().
6342 S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, U8 **sp, U8 *start, U8 *send)
6346 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6348 *mgp = mg_find(sv, PERL_MAGIC_utf8);
6349 if (*mgp && (*mgp)->mg_ptr) {
6350 *cachep = (STRLEN *) (*mgp)->mg_ptr;
6351 ASSERT_UTF8_CACHE(*cachep);
6352 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
6354 else { /* We will skip to the right spot. */
6359 /* The assumption is that going backward is half
6360 * the speed of going forward (that's where the
6361 * 2 * backw in the below comes from). (The real
6362 * figure of course depends on the UTF-8 data.) */
6364 if ((*cachep)[i] > (STRLEN)uoff) {
6366 backw = (*cachep)[i] - (STRLEN)uoff;
6368 if (forw < 2 * backw)
6371 p = start + (*cachep)[i+1];
6373 /* Try this only for the substr offset (i == 0),
6374 * not for the substr length (i == 2). */
6375 else if (i == 0) { /* (*cachep)[i] < uoff */
6376 const STRLEN ulen = sv_len_utf8(sv);
6378 if ((STRLEN)uoff < ulen) {
6379 forw = (STRLEN)uoff - (*cachep)[i];
6380 backw = ulen - (STRLEN)uoff;
6382 if (forw < 2 * backw)
6383 p = start + (*cachep)[i+1];
6388 /* If the string is not long enough for uoff,
6389 * we could extend it, but not at this low a level. */
6393 if (forw < 2 * backw) {
6400 while (UTF8_IS_CONTINUATION(*p))
6405 /* Update the cache. */
6406 (*cachep)[i] = (STRLEN)uoff;
6407 (*cachep)[i+1] = p - start;
6409 /* Drop the stale "length" cache */
6418 if (found) { /* Setup the return values. */
6419 *offsetp = (*cachep)[i+1];
6420 *sp = start + *offsetp;
6423 *offsetp = send - start;
6425 else if (*sp < start) {
6431 #ifdef PERL_UTF8_CACHE_ASSERT
6436 while (n-- && s < send)
6440 assert(*offsetp == s - start);
6441 assert((*cachep)[0] == (STRLEN)uoff);
6442 assert((*cachep)[1] == *offsetp);
6444 ASSERT_UTF8_CACHE(*cachep);
6453 =for apidoc sv_pos_u2b
6455 Converts the value pointed to by offsetp from a count of UTF-8 chars from
6456 the start of the string, to a count of the equivalent number of bytes; if
6457 lenp is non-zero, it does the same to lenp, but this time starting from
6458 the offset, rather than from the start of the string. Handles magic and
6465 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
6466 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6467 * byte offsets. See also the comments of S_utf8_mg_pos().
6472 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
6483 start = s = (U8*)SvPV(sv, len);
6485 I32 uoffset = *offsetp;
6490 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
6492 if (!found && uoffset > 0) {
6493 while (s < send && uoffset--)
6497 if (utf8_mg_pos_init(sv, &mg, &cache, 0, *offsetp, s, start))
6499 *offsetp = s - start;
6504 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) {
6508 if (!found && *lenp > 0) {
6511 while (s < send && ulen--)
6515 utf8_mg_pos_init(sv, &mg, &cache, 2, *lenp, s, start);
6519 ASSERT_UTF8_CACHE(cache);
6531 =for apidoc sv_pos_b2u
6533 Converts the value pointed to by offsetp from a count of bytes from the
6534 start of the string, to a count of the equivalent number of UTF-8 chars.
6535 Handles magic and type coercion.
6541 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6542 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6543 * byte offsets. See also the comments of S_utf8_mg_pos().
6548 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
6556 s = (U8*)SvPV(sv, len);
6557 if ((I32)len < *offsetp)
6558 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6560 U8* send = s + *offsetp;
6562 STRLEN *cache = NULL;
6566 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
6567 mg = mg_find(sv, PERL_MAGIC_utf8);
6568 if (mg && mg->mg_ptr) {
6569 cache = (STRLEN *) mg->mg_ptr;
6570 if (cache[1] == (STRLEN)*offsetp) {
6571 /* An exact match. */
6572 *offsetp = cache[0];
6576 else if (cache[1] < (STRLEN)*offsetp) {
6577 /* We already know part of the way. */
6580 /* Let the below loop do the rest. */
6582 else { /* cache[1] > *offsetp */
6583 /* We already know all of the way, now we may
6584 * be able to walk back. The same assumption
6585 * is made as in S_utf8_mg_pos(), namely that
6586 * walking backward is twice slower than
6587 * walking forward. */
6588 STRLEN forw = *offsetp;
6589 STRLEN backw = cache[1] - *offsetp;
6591 if (!(forw < 2 * backw)) {
6592 U8 *p = s + cache[1];
6599 while (UTF8_IS_CONTINUATION(*p)) {
6607 *offsetp = cache[0];
6609 /* Drop the stale "length" cache */
6617 ASSERT_UTF8_CACHE(cache);
6623 /* Call utf8n_to_uvchr() to validate the sequence
6624 * (unless a simple non-UTF character) */
6625 if (!UTF8_IS_INVARIANT(*s))
6626 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
6635 if (!SvREADONLY(sv)) {
6637 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6638 mg = mg_find(sv, PERL_MAGIC_utf8);
6643 Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6644 mg->mg_ptr = (char *) cache;
6649 cache[1] = *offsetp;
6650 /* Drop the stale "length" cache */
6663 Returns a boolean indicating whether the strings in the two SVs are
6664 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6665 coerce its args to strings if necessary.
6671 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6679 SV* svrecode = Nullsv;
6686 pv1 = SvPV(sv1, cur1);
6693 pv2 = SvPV(sv2, cur2);
6695 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6696 /* Differing utf8ness.
6697 * Do not UTF8size the comparands as a side-effect. */
6700 svrecode = newSVpvn(pv2, cur2);
6701 sv_recode_to_utf8(svrecode, PL_encoding);
6702 pv2 = SvPV(svrecode, cur2);
6705 svrecode = newSVpvn(pv1, cur1);
6706 sv_recode_to_utf8(svrecode, PL_encoding);
6707 pv1 = SvPV(svrecode, cur1);
6709 /* Now both are in UTF-8. */
6711 SvREFCNT_dec(svrecode);
6716 bool is_utf8 = TRUE;
6719 /* sv1 is the UTF-8 one,
6720 * if is equal it must be downgrade-able */
6721 char *pv = (char*)bytes_from_utf8((const U8*)pv1,
6727 /* sv2 is the UTF-8 one,
6728 * if is equal it must be downgrade-able */
6729 char *pv = (char *)bytes_from_utf8((const U8*)pv2,
6735 /* Downgrade not possible - cannot be eq */
6743 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6746 SvREFCNT_dec(svrecode);
6757 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6758 string in C<sv1> is less than, equal to, or greater than the string in
6759 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6760 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6766 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6769 const char *pv1, *pv2;
6772 SV *svrecode = Nullsv;
6779 pv1 = SvPV(sv1, cur1);
6786 pv2 = SvPV(sv2, cur2);
6788 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6789 /* Differing utf8ness.
6790 * Do not UTF8size the comparands as a side-effect. */
6793 svrecode = newSVpvn(pv2, cur2);
6794 sv_recode_to_utf8(svrecode, PL_encoding);
6795 pv2 = SvPV(svrecode, cur2);
6798 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6803 svrecode = newSVpvn(pv1, cur1);
6804 sv_recode_to_utf8(svrecode, PL_encoding);
6805 pv1 = SvPV(svrecode, cur1);
6808 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6814 cmp = cur2 ? -1 : 0;
6818 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6821 cmp = retval < 0 ? -1 : 1;
6822 } else if (cur1 == cur2) {
6825 cmp = cur1 < cur2 ? -1 : 1;
6830 SvREFCNT_dec(svrecode);
6839 =for apidoc sv_cmp_locale
6841 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6842 'use bytes' aware, handles get magic, and will coerce its args to strings
6843 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6849 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6851 #ifdef USE_LOCALE_COLLATE
6857 if (PL_collation_standard)
6861 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6863 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6865 if (!pv1 || !len1) {
6876 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6879 return retval < 0 ? -1 : 1;
6882 * When the result of collation is equality, that doesn't mean
6883 * that there are no differences -- some locales exclude some
6884 * characters from consideration. So to avoid false equalities,
6885 * we use the raw string as a tiebreaker.
6891 #endif /* USE_LOCALE_COLLATE */
6893 return sv_cmp(sv1, sv2);
6897 #ifdef USE_LOCALE_COLLATE
6900 =for apidoc sv_collxfrm
6902 Add Collate Transform magic to an SV if it doesn't already have it.
6904 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6905 scalar data of the variable, but transformed to such a format that a normal
6906 memory comparison can be used to compare the data according to the locale
6913 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6917 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6918 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6923 Safefree(mg->mg_ptr);
6925 if ((xf = mem_collxfrm(s, len, &xlen))) {
6926 if (SvREADONLY(sv)) {
6929 return xf + sizeof(PL_collation_ix);
6932 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6933 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6946 if (mg && mg->mg_ptr) {
6948 return mg->mg_ptr + sizeof(PL_collation_ix);
6956 #endif /* USE_LOCALE_COLLATE */
6961 Get a line from the filehandle and store it into the SV, optionally
6962 appending to the currently-stored string.
6968 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6972 register STDCHAR rslast;
6973 register STDCHAR *bp;
6979 if (SvTHINKFIRST(sv))
6980 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6981 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6983 However, perlbench says it's slower, because the existing swipe code
6984 is faster than copy on write.
6985 Swings and roundabouts. */
6986 (void)SvUPGRADE(sv, SVt_PV);
6991 if (PerlIO_isutf8(fp)) {
6993 sv_utf8_upgrade_nomg(sv);
6994 sv_pos_u2b(sv,&append,0);
6996 } else if (SvUTF8(sv)) {
6997 SV *tsv = NEWSV(0,0);
6998 sv_gets(tsv, fp, 0);
6999 sv_utf8_upgrade_nomg(tsv);
7000 SvCUR_set(sv,append);
7003 goto return_string_or_null;
7008 if (PerlIO_isutf8(fp))
7011 if (IN_PERL_COMPILETIME) {
7012 /* we always read code in line mode */
7016 else if (RsSNARF(PL_rs)) {
7017 /* If it is a regular disk file use size from stat() as estimate
7018 of amount we are going to read - may result in malloc-ing
7019 more memory than we realy need if layers bellow reduce
7020 size we read (e.g. CRLF or a gzip layer)
7023 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
7024 const Off_t offset = PerlIO_tell(fp);
7025 if (offset != (Off_t) -1 && st.st_size + append > offset) {
7026 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
7032 else if (RsRECORD(PL_rs)) {
7036 /* Grab the size of the record we're getting */
7037 recsize = SvIV(SvRV(PL_rs));
7038 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
7041 /* VMS wants read instead of fread, because fread doesn't respect */
7042 /* RMS record boundaries. This is not necessarily a good thing to be */
7043 /* doing, but we've got no other real choice - except avoid stdio
7044 as implementation - perhaps write a :vms layer ?
7046 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
7048 bytesread = PerlIO_read(fp, buffer, recsize);
7052 SvCUR_set(sv, bytesread += append);
7053 buffer[bytesread] = '\0';
7054 goto return_string_or_null;
7056 else if (RsPARA(PL_rs)) {
7062 /* Get $/ i.e. PL_rs into same encoding as stream wants */
7063 if (PerlIO_isutf8(fp)) {
7064 rsptr = SvPVutf8(PL_rs, rslen);
7067 if (SvUTF8(PL_rs)) {
7068 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
7069 Perl_croak(aTHX_ "Wide character in $/");
7072 rsptr = SvPV(PL_rs, rslen);
7076 rslast = rslen ? rsptr[rslen - 1] : '\0';
7078 if (rspara) { /* have to do this both before and after */
7079 do { /* to make sure file boundaries work right */
7082 i = PerlIO_getc(fp);
7086 PerlIO_ungetc(fp,i);
7092 /* See if we know enough about I/O mechanism to cheat it ! */
7094 /* This used to be #ifdef test - it is made run-time test for ease
7095 of abstracting out stdio interface. One call should be cheap
7096 enough here - and may even be a macro allowing compile
7100 if (PerlIO_fast_gets(fp)) {
7103 * We're going to steal some values from the stdio struct
7104 * and put EVERYTHING in the innermost loop into registers.
7106 register STDCHAR *ptr;
7110 #if defined(VMS) && defined(PERLIO_IS_STDIO)
7111 /* An ungetc()d char is handled separately from the regular
7112 * buffer, so we getc() it back out and stuff it in the buffer.
7114 i = PerlIO_getc(fp);
7115 if (i == EOF) return 0;
7116 *(--((*fp)->_ptr)) = (unsigned char) i;
7120 /* Here is some breathtakingly efficient cheating */
7122 cnt = PerlIO_get_cnt(fp); /* get count into register */
7123 /* make sure we have the room */
7124 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
7125 /* Not room for all of it
7126 if we are looking for a separator and room for some
7128 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
7129 /* just process what we have room for */
7130 shortbuffered = cnt - SvLEN(sv) + append + 1;
7131 cnt -= shortbuffered;
7135 /* remember that cnt can be negative */
7136 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
7141 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
7142 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
7143 DEBUG_P(PerlIO_printf(Perl_debug_log,
7144 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7145 DEBUG_P(PerlIO_printf(Perl_debug_log,
7146 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7147 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7148 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
7153 while (cnt > 0) { /* this | eat */
7155 if ((*bp++ = *ptr++) == rslast) /* really | dust */
7156 goto thats_all_folks; /* screams | sed :-) */
7160 Copy(ptr, bp, cnt, char); /* this | eat */
7161 bp += cnt; /* screams | dust */
7162 ptr += cnt; /* louder | sed :-) */
7167 if (shortbuffered) { /* oh well, must extend */
7168 cnt = shortbuffered;
7170 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
7172 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
7173 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
7177 DEBUG_P(PerlIO_printf(Perl_debug_log,
7178 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
7179 PTR2UV(ptr),(long)cnt));
7180 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
7182 DEBUG_P(PerlIO_printf(Perl_debug_log,
7183 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7184 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7185 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7187 /* This used to call 'filbuf' in stdio form, but as that behaves like
7188 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
7189 another abstraction. */
7190 i = PerlIO_getc(fp); /* get more characters */
7192 DEBUG_P(PerlIO_printf(Perl_debug_log,
7193 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7194 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7195 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7197 cnt = PerlIO_get_cnt(fp);
7198 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
7199 DEBUG_P(PerlIO_printf(Perl_debug_log,
7200 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7202 if (i == EOF) /* all done for ever? */
7203 goto thats_really_all_folks;
7205 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
7207 SvGROW(sv, bpx + cnt + 2);
7208 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
7210 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
7212 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
7213 goto thats_all_folks;
7217 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) ||
7218 memNE((char*)bp - rslen, rsptr, rslen))
7219 goto screamer; /* go back to the fray */
7220 thats_really_all_folks:
7222 cnt += shortbuffered;
7223 DEBUG_P(PerlIO_printf(Perl_debug_log,
7224 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
7225 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
7226 DEBUG_P(PerlIO_printf(Perl_debug_log,
7227 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
7228 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
7229 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
7231 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
7232 DEBUG_P(PerlIO_printf(Perl_debug_log,
7233 "Screamer: done, len=%ld, string=|%.*s|\n",
7234 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
7238 /*The big, slow, and stupid way. */
7239 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
7241 New(0, buf, 8192, STDCHAR);
7249 const register STDCHAR *bpe = buf + sizeof(buf);
7251 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
7252 ; /* keep reading */
7256 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
7257 /* Accomodate broken VAXC compiler, which applies U8 cast to
7258 * both args of ?: operator, causing EOF to change into 255
7261 i = (U8)buf[cnt - 1];
7267 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
7269 sv_catpvn(sv, (char *) buf, cnt);
7271 sv_setpvn(sv, (char *) buf, cnt);
7273 if (i != EOF && /* joy */
7275 SvCUR(sv) < rslen ||
7276 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
7280 * If we're reading from a TTY and we get a short read,
7281 * indicating that the user hit his EOF character, we need
7282 * to notice it now, because if we try to read from the TTY
7283 * again, the EOF condition will disappear.
7285 * The comparison of cnt to sizeof(buf) is an optimization
7286 * that prevents unnecessary calls to feof().
7290 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
7294 #ifdef USE_HEAP_INSTEAD_OF_STACK
7299 if (rspara) { /* have to do this both before and after */
7300 while (i != EOF) { /* to make sure file boundaries work right */
7301 i = PerlIO_getc(fp);
7303 PerlIO_ungetc(fp,i);
7309 return_string_or_null:
7310 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
7316 Auto-increment of the value in the SV, doing string to numeric conversion
7317 if necessary. Handles 'get' magic.
7323 Perl_sv_inc(pTHX_ register SV *sv)
7332 if (SvTHINKFIRST(sv)) {
7334 sv_force_normal_flags(sv, 0);
7335 if (SvREADONLY(sv)) {
7336 if (IN_PERL_RUNTIME)
7337 Perl_croak(aTHX_ PL_no_modify);
7341 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
7343 i = PTR2IV(SvRV(sv));
7348 flags = SvFLAGS(sv);
7349 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
7350 /* It's (privately or publicly) a float, but not tested as an
7351 integer, so test it to see. */
7353 flags = SvFLAGS(sv);
7355 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7356 /* It's publicly an integer, or privately an integer-not-float */
7357 #ifdef PERL_PRESERVE_IVUV
7361 if (SvUVX(sv) == UV_MAX)
7362 sv_setnv(sv, UV_MAX_P1);
7364 (void)SvIOK_only_UV(sv);
7365 SvUV_set(sv, SvUVX(sv) + 1);
7367 if (SvIVX(sv) == IV_MAX)
7368 sv_setuv(sv, (UV)IV_MAX + 1);
7370 (void)SvIOK_only(sv);
7371 SvIV_set(sv, SvIVX(sv) + 1);
7376 if (flags & SVp_NOK) {
7377 (void)SvNOK_only(sv);
7378 SvNV_set(sv, SvNVX(sv) + 1.0);
7382 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
7383 if ((flags & SVTYPEMASK) < SVt_PVIV)
7384 sv_upgrade(sv, SVt_IV);
7385 (void)SvIOK_only(sv);
7390 while (isALPHA(*d)) d++;
7391 while (isDIGIT(*d)) d++;
7393 #ifdef PERL_PRESERVE_IVUV
7394 /* Got to punt this as an integer if needs be, but we don't issue
7395 warnings. Probably ought to make the sv_iv_please() that does
7396 the conversion if possible, and silently. */
7397 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
7398 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7399 /* Need to try really hard to see if it's an integer.
7400 9.22337203685478e+18 is an integer.
7401 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7402 so $a="9.22337203685478e+18"; $a+0; $a++
7403 needs to be the same as $a="9.22337203685478e+18"; $a++
7410 /* sv_2iv *should* have made this an NV */
7411 if (flags & SVp_NOK) {
7412 (void)SvNOK_only(sv);
7413 SvNV_set(sv, SvNVX(sv) + 1.0);
7416 /* I don't think we can get here. Maybe I should assert this
7417 And if we do get here I suspect that sv_setnv will croak. NWC
7419 #if defined(USE_LONG_DOUBLE)
7420 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",
7421 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7423 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7424 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7427 #endif /* PERL_PRESERVE_IVUV */
7428 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
7432 while (d >= SvPVX(sv)) {
7440 /* MKS: The original code here died if letters weren't consecutive.
7441 * at least it didn't have to worry about non-C locales. The
7442 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7443 * arranged in order (although not consecutively) and that only
7444 * [A-Za-z] are accepted by isALPHA in the C locale.
7446 if (*d != 'z' && *d != 'Z') {
7447 do { ++*d; } while (!isALPHA(*d));
7450 *(d--) -= 'z' - 'a';
7455 *(d--) -= 'z' - 'a' + 1;
7459 /* oh,oh, the number grew */
7460 SvGROW(sv, SvCUR(sv) + 2);
7461 SvCUR_set(sv, SvCUR(sv) + 1);
7462 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
7473 Auto-decrement of the value in the SV, doing string to numeric conversion
7474 if necessary. Handles 'get' magic.
7480 Perl_sv_dec(pTHX_ register SV *sv)
7488 if (SvTHINKFIRST(sv)) {
7490 sv_force_normal_flags(sv, 0);
7491 if (SvREADONLY(sv)) {
7492 if (IN_PERL_RUNTIME)
7493 Perl_croak(aTHX_ PL_no_modify);
7497 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7499 i = PTR2IV(SvRV(sv));
7504 /* Unlike sv_inc we don't have to worry about string-never-numbers
7505 and keeping them magic. But we mustn't warn on punting */
7506 flags = SvFLAGS(sv);
7507 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7508 /* It's publicly an integer, or privately an integer-not-float */
7509 #ifdef PERL_PRESERVE_IVUV
7513 if (SvUVX(sv) == 0) {
7514 (void)SvIOK_only(sv);
7518 (void)SvIOK_only_UV(sv);
7519 SvUV_set(sv, SvUVX(sv) + 1);
7522 if (SvIVX(sv) == IV_MIN)
7523 sv_setnv(sv, (NV)IV_MIN - 1.0);
7525 (void)SvIOK_only(sv);
7526 SvIV_set(sv, SvIVX(sv) - 1);
7531 if (flags & SVp_NOK) {
7532 SvNV_set(sv, SvNVX(sv) - 1.0);
7533 (void)SvNOK_only(sv);
7536 if (!(flags & SVp_POK)) {
7537 if ((flags & SVTYPEMASK) < SVt_PVNV)
7538 sv_upgrade(sv, SVt_NV);
7540 (void)SvNOK_only(sv);
7543 #ifdef PERL_PRESERVE_IVUV
7545 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
7546 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7547 /* Need to try really hard to see if it's an integer.
7548 9.22337203685478e+18 is an integer.
7549 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7550 so $a="9.22337203685478e+18"; $a+0; $a--
7551 needs to be the same as $a="9.22337203685478e+18"; $a--
7558 /* sv_2iv *should* have made this an NV */
7559 if (flags & SVp_NOK) {
7560 (void)SvNOK_only(sv);
7561 SvNV_set(sv, SvNVX(sv) - 1.0);
7564 /* I don't think we can get here. Maybe I should assert this
7565 And if we do get here I suspect that sv_setnv will croak. NWC
7567 #if defined(USE_LONG_DOUBLE)
7568 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",
7569 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7571 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7572 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
7576 #endif /* PERL_PRESERVE_IVUV */
7577 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
7581 =for apidoc sv_mortalcopy
7583 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7584 The new SV is marked as mortal. It will be destroyed "soon", either by an
7585 explicit call to FREETMPS, or by an implicit call at places such as
7586 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
7591 /* Make a string that will exist for the duration of the expression
7592 * evaluation. Actually, it may have to last longer than that, but
7593 * hopefully we won't free it until it has been assigned to a
7594 * permanent location. */
7597 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
7602 sv_setsv(sv,oldstr);
7604 PL_tmps_stack[++PL_tmps_ix] = sv;
7610 =for apidoc sv_newmortal
7612 Creates a new null SV which is mortal. The reference count of the SV is
7613 set to 1. It will be destroyed "soon", either by an explicit call to
7614 FREETMPS, or by an implicit call at places such as statement boundaries.
7615 See also C<sv_mortalcopy> and C<sv_2mortal>.
7621 Perl_sv_newmortal(pTHX)
7626 SvFLAGS(sv) = SVs_TEMP;
7628 PL_tmps_stack[++PL_tmps_ix] = sv;
7633 =for apidoc sv_2mortal
7635 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7636 by an explicit call to FREETMPS, or by an implicit call at places such as
7637 statement boundaries. SvTEMP() is turned on which means that the SV's
7638 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7639 and C<sv_mortalcopy>.
7645 Perl_sv_2mortal(pTHX_ register SV *sv)
7650 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7653 PL_tmps_stack[++PL_tmps_ix] = sv;
7661 Creates a new SV and copies a string into it. The reference count for the
7662 SV is set to 1. If C<len> is zero, Perl will compute the length using
7663 strlen(). For efficiency, consider using C<newSVpvn> instead.
7669 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
7676 sv_setpvn(sv,s,len);
7681 =for apidoc newSVpvn
7683 Creates a new SV and copies a string into it. The reference count for the
7684 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7685 string. You are responsible for ensuring that the source string is at least
7686 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7692 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7697 sv_setpvn(sv,s,len);
7702 =for apidoc newSVpvn_share
7704 Creates a new SV with its SvPVX pointing to a shared string in the string
7705 table. If the string does not already exist in the table, it is created
7706 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
7707 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
7708 otherwise the hash is computed. The idea here is that as the string table
7709 is used for shared hash keys these strings will have SvPVX == HeKEY and
7710 hash lookup will avoid string compare.
7716 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7719 bool is_utf8 = FALSE;
7721 STRLEN tmplen = -len;
7723 /* See the note in hv.c:hv_fetch() --jhi */
7724 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7728 PERL_HASH(hash, src, len);
7730 sv_upgrade(sv, SVt_PVIV);
7731 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7744 #if defined(PERL_IMPLICIT_CONTEXT)
7746 /* pTHX_ magic can't cope with varargs, so this is a no-context
7747 * version of the main function, (which may itself be aliased to us).
7748 * Don't access this version directly.
7752 Perl_newSVpvf_nocontext(const char* pat, ...)
7757 va_start(args, pat);
7758 sv = vnewSVpvf(pat, &args);
7765 =for apidoc newSVpvf
7767 Creates a new SV and initializes it with the string formatted like
7774 Perl_newSVpvf(pTHX_ const char* pat, ...)
7778 va_start(args, pat);
7779 sv = vnewSVpvf(pat, &args);
7784 /* backend for newSVpvf() and newSVpvf_nocontext() */
7787 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7791 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7798 Creates a new SV and copies a floating point value into it.
7799 The reference count for the SV is set to 1.
7805 Perl_newSVnv(pTHX_ NV n)
7817 Creates a new SV and copies an integer into it. The reference count for the
7824 Perl_newSViv(pTHX_ IV i)
7836 Creates a new SV and copies an unsigned integer into it.
7837 The reference count for the SV is set to 1.
7843 Perl_newSVuv(pTHX_ UV u)
7853 =for apidoc newRV_noinc
7855 Creates an RV wrapper for an SV. The reference count for the original
7856 SV is B<not> incremented.
7862 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7867 sv_upgrade(sv, SVt_RV);
7869 SvRV_set(sv, tmpRef);
7874 /* newRV_inc is the official function name to use now.
7875 * newRV_inc is in fact #defined to newRV in sv.h
7879 Perl_newRV(pTHX_ SV *tmpRef)
7881 return newRV_noinc(SvREFCNT_inc(tmpRef));
7887 Creates a new SV which is an exact duplicate of the original SV.
7894 Perl_newSVsv(pTHX_ register SV *old)
7900 if (SvTYPE(old) == SVTYPEMASK) {
7901 if (ckWARN_d(WARN_INTERNAL))
7902 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7906 /* SV_GMAGIC is the default for sv_setv()
7907 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7908 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7909 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7914 =for apidoc sv_reset
7916 Underlying implementation for the C<reset> Perl function.
7917 Note that the perl-level function is vaguely deprecated.
7923 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
7931 char todo[PERL_UCHAR_MAX+1];
7936 if (!*s) { /* reset ?? searches */
7937 MAGIC *mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
7939 PMOP *pm = (PMOP *) mg->mg_obj;
7941 pm->op_pmdynflags &= ~PMdf_USED;
7948 /* reset variables */
7950 if (!HvARRAY(stash))
7953 Zero(todo, 256, char);
7955 i = (unsigned char)*s;
7959 max = (unsigned char)*s++;
7960 for ( ; i <= max; i++) {
7963 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7964 for (entry = HvARRAY(stash)[i];
7966 entry = HeNEXT(entry))
7968 if (!todo[(U8)*HeKEY(entry)])
7970 gv = (GV*)HeVAL(entry);
7972 if (SvTHINKFIRST(sv)) {
7973 if (!SvREADONLY(sv) && SvROK(sv))
7978 if (SvTYPE(sv) >= SVt_PV) {
7980 if (SvPVX(sv) != Nullch)
7987 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
7990 #ifdef USE_ENVIRON_ARRAY
7992 # ifdef USE_ITHREADS
7993 && PL_curinterp == aTHX
7997 environ[0] = Nullch;
8000 #endif /* !PERL_MICRO */
8010 Using various gambits, try to get an IO from an SV: the IO slot if its a
8011 GV; or the recursive result if we're an RV; or the IO slot of the symbol
8012 named after the PV if we're a string.
8018 Perl_sv_2io(pTHX_ SV *sv)
8023 switch (SvTYPE(sv)) {
8031 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
8035 Perl_croak(aTHX_ PL_no_usym, "filehandle");
8037 return sv_2io(SvRV(sv));
8038 gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
8044 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
8053 Using various gambits, try to get a CV from an SV; in addition, try if
8054 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
8060 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
8067 return *gvp = Nullgv, Nullcv;
8068 switch (SvTYPE(sv)) {
8087 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
8088 tryAMAGICunDEREF(to_cv);
8091 if (SvTYPE(sv) == SVt_PVCV) {
8100 Perl_croak(aTHX_ "Not a subroutine reference");
8105 gv = gv_fetchsv(sv, lref, SVt_PVCV);
8111 if (lref && !GvCVu(gv)) {
8114 tmpsv = NEWSV(704,0);
8115 gv_efullname3(tmpsv, gv, Nullch);
8116 /* XXX this is probably not what they think they're getting.
8117 * It has the same effect as "sub name;", i.e. just a forward
8119 newSUB(start_subparse(FALSE, 0),
8120 newSVOP(OP_CONST, 0, tmpsv),
8125 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
8135 Returns true if the SV has a true value by Perl's rules.
8136 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
8137 instead use an in-line version.
8143 Perl_sv_true(pTHX_ register SV *sv)
8148 const register XPV* tXpv;
8149 if ((tXpv = (XPV*)SvANY(sv)) &&
8150 (tXpv->xpv_cur > 1 ||
8151 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
8158 return SvIVX(sv) != 0;
8161 return SvNVX(sv) != 0.0;
8163 return sv_2bool(sv);
8171 A private implementation of the C<SvIVx> macro for compilers which can't
8172 cope with complex macro expressions. Always use the macro instead.
8178 Perl_sv_iv(pTHX_ register SV *sv)
8182 return (IV)SvUVX(sv);
8191 A private implementation of the C<SvUVx> macro for compilers which can't
8192 cope with complex macro expressions. Always use the macro instead.
8198 Perl_sv_uv(pTHX_ register SV *sv)
8203 return (UV)SvIVX(sv);
8211 A private implementation of the C<SvNVx> macro for compilers which can't
8212 cope with complex macro expressions. Always use the macro instead.
8218 Perl_sv_nv(pTHX_ register SV *sv)
8225 /* sv_pv() is now a macro using SvPV_nolen();
8226 * this function provided for binary compatibility only
8230 Perl_sv_pv(pTHX_ SV *sv)
8237 return sv_2pv(sv, &n_a);
8243 Use the C<SvPV_nolen> macro instead
8247 A private implementation of the C<SvPV> macro for compilers which can't
8248 cope with complex macro expressions. Always use the macro instead.
8254 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
8260 return sv_2pv(sv, lp);
8265 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
8271 return sv_2pv_flags(sv, lp, 0);
8274 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
8275 * this function provided for binary compatibility only
8279 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
8281 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
8285 =for apidoc sv_pvn_force
8287 Get a sensible string out of the SV somehow.
8288 A private implementation of the C<SvPV_force> macro for compilers which
8289 can't cope with complex macro expressions. Always use the macro instead.
8291 =for apidoc sv_pvn_force_flags
8293 Get a sensible string out of the SV somehow.
8294 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
8295 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
8296 implemented in terms of this function.
8297 You normally want to use the various wrapper macros instead: see
8298 C<SvPV_force> and C<SvPV_force_nomg>
8304 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
8307 if (SvTHINKFIRST(sv) && !SvROK(sv))
8308 sv_force_normal_flags(sv, 0);
8315 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
8316 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8320 s = sv_2pv_flags(sv, lp, flags);
8321 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
8322 const STRLEN len = *lp;
8326 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
8327 SvGROW(sv, len + 1);
8328 Move(s,SvPVX(sv),len,char);
8333 SvPOK_on(sv); /* validate pointer */
8335 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8336 PTR2UV(sv),SvPVX(sv)));
8342 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
8343 * this function provided for binary compatibility only
8347 Perl_sv_pvbyte(pTHX_ SV *sv)
8349 sv_utf8_downgrade(sv,0);
8354 =for apidoc sv_pvbyte
8356 Use C<SvPVbyte_nolen> instead.
8358 =for apidoc sv_pvbyten
8360 A private implementation of the C<SvPVbyte> macro for compilers
8361 which can't cope with complex macro expressions. Always use the macro
8368 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
8370 sv_utf8_downgrade(sv,0);
8371 return sv_pvn(sv,lp);
8375 =for apidoc sv_pvbyten_force
8377 A private implementation of the C<SvPVbytex_force> macro for compilers
8378 which can't cope with complex macro expressions. Always use the macro
8385 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
8387 sv_pvn_force(sv,lp);
8388 sv_utf8_downgrade(sv,0);
8393 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
8394 * this function provided for binary compatibility only
8398 Perl_sv_pvutf8(pTHX_ SV *sv)
8400 sv_utf8_upgrade(sv);
8405 =for apidoc sv_pvutf8
8407 Use the C<SvPVutf8_nolen> macro instead
8409 =for apidoc sv_pvutf8n
8411 A private implementation of the C<SvPVutf8> macro for compilers
8412 which can't cope with complex macro expressions. Always use the macro
8419 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
8421 sv_utf8_upgrade(sv);
8422 return sv_pvn(sv,lp);
8426 =for apidoc sv_pvutf8n_force
8428 A private implementation of the C<SvPVutf8_force> macro for compilers
8429 which can't cope with complex macro expressions. Always use the macro
8436 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
8438 sv_pvn_force(sv,lp);
8439 sv_utf8_upgrade(sv);
8445 =for apidoc sv_reftype
8447 Returns a string describing what the SV is a reference to.
8453 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
8455 /* The fact that I don't need to downcast to char * everywhere, only in ?:
8456 inside return suggests a const propagation bug in g++. */
8457 if (ob && SvOBJECT(sv)) {
8458 char *name = HvNAME(SvSTASH(sv));
8459 return name ? name : (char *) "__ANON__";
8462 switch (SvTYPE(sv)) {
8479 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
8480 /* tied lvalues should appear to be
8481 * scalars for backwards compatitbility */
8482 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8483 ? "SCALAR" : "LVALUE");
8484 case SVt_PVAV: return "ARRAY";
8485 case SVt_PVHV: return "HASH";
8486 case SVt_PVCV: return "CODE";
8487 case SVt_PVGV: return "GLOB";
8488 case SVt_PVFM: return "FORMAT";
8489 case SVt_PVIO: return "IO";
8490 default: return "UNKNOWN";
8496 =for apidoc sv_isobject
8498 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8499 object. If the SV is not an RV, or if the object is not blessed, then this
8506 Perl_sv_isobject(pTHX_ SV *sv)
8523 Returns a boolean indicating whether the SV is blessed into the specified
8524 class. This does not check for subtypes; use C<sv_derived_from> to verify
8525 an inheritance relationship.
8531 Perl_sv_isa(pTHX_ SV *sv, const char *name)
8542 if (!HvNAME(SvSTASH(sv)))
8545 return strEQ(HvNAME(SvSTASH(sv)), name);
8551 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
8552 it will be upgraded to one. If C<classname> is non-null then the new SV will
8553 be blessed in the specified package. The new SV is returned and its
8554 reference count is 1.
8560 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
8566 SV_CHECK_THINKFIRST_COW_DROP(rv);
8569 if (SvTYPE(rv) >= SVt_PVMG) {
8570 const U32 refcnt = SvREFCNT(rv);
8574 SvREFCNT(rv) = refcnt;
8577 if (SvTYPE(rv) < SVt_RV)
8578 sv_upgrade(rv, SVt_RV);
8579 else if (SvTYPE(rv) > SVt_RV) {
8590 HV* stash = gv_stashpv(classname, TRUE);
8591 (void)sv_bless(rv, stash);
8597 =for apidoc sv_setref_pv
8599 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
8600 argument will be upgraded to an RV. That RV will be modified to point to
8601 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8602 into the SV. The C<classname> argument indicates the package for the
8603 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8604 will have a reference count of 1, and the RV will be returned.
8606 Do not use with other Perl types such as HV, AV, SV, CV, because those
8607 objects will become corrupted by the pointer copy process.
8609 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8615 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
8618 sv_setsv(rv, &PL_sv_undef);
8622 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8627 =for apidoc sv_setref_iv
8629 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
8630 argument will be upgraded to an RV. That RV will be modified to point to
8631 the new SV. The C<classname> argument indicates the package for the
8632 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8633 will have a reference count of 1, and the RV will be returned.
8639 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
8641 sv_setiv(newSVrv(rv,classname), iv);
8646 =for apidoc sv_setref_uv
8648 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
8649 argument will be upgraded to an RV. That RV will be modified to point to
8650 the new SV. The C<classname> argument indicates the package for the
8651 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8652 will have a reference count of 1, and the RV will be returned.
8658 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
8660 sv_setuv(newSVrv(rv,classname), uv);
8665 =for apidoc sv_setref_nv
8667 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8668 argument will be upgraded to an RV. That RV will be modified to point to
8669 the new SV. The C<classname> argument indicates the package for the
8670 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8671 will have a reference count of 1, and the RV will be returned.
8677 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
8679 sv_setnv(newSVrv(rv,classname), nv);
8684 =for apidoc sv_setref_pvn
8686 Copies a string into a new SV, optionally blessing the SV. The length of the
8687 string must be specified with C<n>. The C<rv> argument will be upgraded to
8688 an RV. That RV will be modified to point to the new SV. The C<classname>
8689 argument indicates the package for the blessing. Set C<classname> to
8690 C<Nullch> to avoid the blessing. The new SV will have a reference count
8691 of 1, and the RV will be returned.
8693 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8699 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
8701 sv_setpvn(newSVrv(rv,classname), pv, n);
8706 =for apidoc sv_bless
8708 Blesses an SV into a specified package. The SV must be an RV. The package
8709 must be designated by its stash (see C<gv_stashpv()>). The reference count
8710 of the SV is unaffected.
8716 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8720 Perl_croak(aTHX_ "Can't bless non-reference value");
8722 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8723 if (SvREADONLY(tmpRef))
8724 Perl_croak(aTHX_ PL_no_modify);
8725 if (SvOBJECT(tmpRef)) {
8726 if (SvTYPE(tmpRef) != SVt_PVIO)
8728 SvREFCNT_dec(SvSTASH(tmpRef));
8731 SvOBJECT_on(tmpRef);
8732 if (SvTYPE(tmpRef) != SVt_PVIO)
8734 (void)SvUPGRADE(tmpRef, SVt_PVMG);
8735 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
8742 if(SvSMAGICAL(tmpRef))
8743 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8751 /* Downgrades a PVGV to a PVMG.
8755 S_sv_unglob(pTHX_ SV *sv)
8759 assert(SvTYPE(sv) == SVt_PVGV);
8764 SvREFCNT_dec(GvSTASH(sv));
8765 GvSTASH(sv) = Nullhv;
8767 sv_unmagic(sv, PERL_MAGIC_glob);
8768 Safefree(GvNAME(sv));
8771 /* need to keep SvANY(sv) in the right arena */
8772 xpvmg = new_XPVMG();
8773 StructCopy(SvANY(sv), xpvmg, XPVMG);
8774 del_XPVGV(SvANY(sv));
8777 SvFLAGS(sv) &= ~SVTYPEMASK;
8778 SvFLAGS(sv) |= SVt_PVMG;
8782 =for apidoc sv_unref_flags
8784 Unsets the RV status of the SV, and decrements the reference count of
8785 whatever was being referenced by the RV. This can almost be thought of
8786 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8787 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8788 (otherwise the decrementing is conditional on the reference count being
8789 different from one or the reference being a readonly SV).
8796 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
8800 if (SvWEAKREF(sv)) {
8808 /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
8809 assigned to as BEGIN {$a = \"Foo"} will fail. */
8810 if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
8812 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8813 sv_2mortal(rv); /* Schedule for freeing later */
8817 =for apidoc sv_unref
8819 Unsets the RV status of the SV, and decrements the reference count of
8820 whatever was being referenced by the RV. This can almost be thought of
8821 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
8822 being zero. See C<SvROK_off>.
8828 Perl_sv_unref(pTHX_ SV *sv)
8830 sv_unref_flags(sv, 0);
8834 =for apidoc sv_taint
8836 Taint an SV. Use C<SvTAINTED_on> instead.
8841 Perl_sv_taint(pTHX_ SV *sv)
8843 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
8847 =for apidoc sv_untaint
8849 Untaint an SV. Use C<SvTAINTED_off> instead.
8854 Perl_sv_untaint(pTHX_ SV *sv)
8856 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8857 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8864 =for apidoc sv_tainted
8866 Test an SV for taintedness. Use C<SvTAINTED> instead.
8871 Perl_sv_tainted(pTHX_ SV *sv)
8873 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8874 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8875 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
8882 =for apidoc sv_setpviv
8884 Copies an integer into the given SV, also updating its string value.
8885 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8891 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8893 char buf[TYPE_CHARS(UV)];
8895 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8897 sv_setpvn(sv, ptr, ebuf - ptr);
8901 =for apidoc sv_setpviv_mg
8903 Like C<sv_setpviv>, but also handles 'set' magic.
8909 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8911 char buf[TYPE_CHARS(UV)];
8913 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8915 sv_setpvn(sv, ptr, ebuf - ptr);
8919 #if defined(PERL_IMPLICIT_CONTEXT)
8921 /* pTHX_ magic can't cope with varargs, so this is a no-context
8922 * version of the main function, (which may itself be aliased to us).
8923 * Don't access this version directly.
8927 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8931 va_start(args, pat);
8932 sv_vsetpvf(sv, pat, &args);
8936 /* pTHX_ magic can't cope with varargs, so this is a no-context
8937 * version of the main function, (which may itself be aliased to us).
8938 * Don't access this version directly.
8942 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8946 va_start(args, pat);
8947 sv_vsetpvf_mg(sv, pat, &args);
8953 =for apidoc sv_setpvf
8955 Works like C<sv_catpvf> but copies the text into the SV instead of
8956 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8962 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8965 va_start(args, pat);
8966 sv_vsetpvf(sv, pat, &args);
8971 =for apidoc sv_vsetpvf
8973 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8974 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8976 Usually used via its frontend C<sv_setpvf>.
8982 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8984 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8988 =for apidoc sv_setpvf_mg
8990 Like C<sv_setpvf>, but also handles 'set' magic.
8996 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8999 va_start(args, pat);
9000 sv_vsetpvf_mg(sv, pat, &args);
9005 =for apidoc sv_vsetpvf_mg
9007 Like C<sv_vsetpvf>, but also handles 'set' magic.
9009 Usually used via its frontend C<sv_setpvf_mg>.
9015 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
9017 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9021 #if defined(PERL_IMPLICIT_CONTEXT)
9023 /* pTHX_ magic can't cope with varargs, so this is a no-context
9024 * version of the main function, (which may itself be aliased to us).
9025 * Don't access this version directly.
9029 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
9033 va_start(args, pat);
9034 sv_vcatpvf(sv, pat, &args);
9038 /* pTHX_ magic can't cope with varargs, so this is a no-context
9039 * version of the main function, (which may itself be aliased to us).
9040 * Don't access this version directly.
9044 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
9048 va_start(args, pat);
9049 sv_vcatpvf_mg(sv, pat, &args);
9055 =for apidoc sv_catpvf
9057 Processes its arguments like C<sprintf> and appends the formatted
9058 output to an SV. If the appended data contains "wide" characters
9059 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
9060 and characters >255 formatted with %c), the original SV might get
9061 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
9062 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
9063 valid UTF-8; if the original SV was bytes, the pattern should be too.
9068 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
9071 va_start(args, pat);
9072 sv_vcatpvf(sv, pat, &args);
9077 =for apidoc sv_vcatpvf
9079 Processes its arguments like C<vsprintf> and appends the formatted output
9080 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
9082 Usually used via its frontend C<sv_catpvf>.
9088 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
9090 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9094 =for apidoc sv_catpvf_mg
9096 Like C<sv_catpvf>, but also handles 'set' magic.
9102 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
9105 va_start(args, pat);
9106 sv_vcatpvf_mg(sv, pat, &args);
9111 =for apidoc sv_vcatpvf_mg
9113 Like C<sv_vcatpvf>, but also handles 'set' magic.
9115 Usually used via its frontend C<sv_catpvf_mg>.
9121 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
9123 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
9128 =for apidoc sv_vsetpvfn
9130 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
9133 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
9139 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
9141 sv_setpvn(sv, "", 0);
9142 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
9145 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
9148 S_expect_number(pTHX_ char** pattern)
9151 switch (**pattern) {
9152 case '1': case '2': case '3':
9153 case '4': case '5': case '6':
9154 case '7': case '8': case '9':
9155 while (isDIGIT(**pattern))
9156 var = var * 10 + (*(*pattern)++ - '0');
9160 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
9163 F0convert(NV nv, char *endbuf, STRLEN *len)
9165 const int neg = nv < 0;
9174 if (uv & 1 && uv == nv)
9175 uv--; /* Round to even */
9177 const unsigned dig = uv % 10;
9190 =for apidoc sv_vcatpvfn
9192 Processes its arguments like C<vsprintf> and appends the formatted output
9193 to an SV. Uses an array of SVs if the C style variable argument list is
9194 missing (NULL). When running with taint checks enabled, indicates via
9195 C<maybe_tainted> if results are untrustworthy (often due to the use of
9198 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
9203 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
9206 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
9213 static const char nullstr[] = "(null)";
9215 bool has_utf8; /* has the result utf8? */
9216 bool pat_utf8; /* the pattern is in utf8? */
9218 /* Times 4: a decimal digit takes more than 3 binary digits.
9219 * NV_DIG: mantissa takes than many decimal digits.
9220 * Plus 32: Playing safe. */
9221 char ebuf[IV_DIG * 4 + NV_DIG + 32];
9222 /* large enough for "%#.#f" --chip */
9223 /* what about long double NVs? --jhi */
9225 has_utf8 = pat_utf8 = DO_UTF8(sv);
9227 /* no matter what, this is a string now */
9228 (void)SvPV_force(sv, origlen);
9230 /* special-case "", "%s", and "%-p" (SVf) */
9233 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
9235 const char *s = va_arg(*args, char*);
9236 sv_catpv(sv, s ? s : nullstr);
9238 else if (svix < svmax) {
9239 sv_catsv(sv, *svargs);
9240 if (DO_UTF8(*svargs))
9245 if (patlen == 3 && pat[0] == '%' &&
9246 pat[1] == '-' && pat[2] == 'p') {
9248 argsv = va_arg(*args, SV*);
9249 sv_catsv(sv, argsv);
9256 #ifndef USE_LONG_DOUBLE
9257 /* special-case "%.<number>[gf]" */
9258 if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
9259 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
9260 unsigned digits = 0;
9264 while (*pp >= '0' && *pp <= '9')
9265 digits = 10 * digits + (*pp++ - '0');
9266 if (pp - pat == (int)patlen - 1) {
9270 nv = (NV)va_arg(*args, double);
9271 else if (svix < svmax)
9276 /* Add check for digits != 0 because it seems that some
9277 gconverts are buggy in this case, and we don't yet have
9278 a Configure test for this. */
9279 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
9280 /* 0, point, slack */
9281 Gconvert(nv, (int)digits, 0, ebuf);
9283 if (*ebuf) /* May return an empty string for digits==0 */
9286 } else if (!digits) {
9289 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
9290 sv_catpvn(sv, p, l);
9296 #endif /* !USE_LONG_DOUBLE */
9298 if (!args && svix < svmax && DO_UTF8(*svargs))
9301 patend = (char*)pat + patlen;
9302 for (p = (char*)pat; p < patend; p = q) {
9305 bool vectorize = FALSE;
9306 bool vectorarg = FALSE;
9307 bool vec_utf8 = FALSE;
9313 bool has_precis = FALSE;
9316 bool is_utf8 = FALSE; /* is this item utf8? */
9317 #ifdef HAS_LDBL_SPRINTF_BUG
9318 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9319 with sfio - Allen <allens@cpan.org> */
9320 bool fix_ldbl_sprintf_bug = FALSE;
9324 U8 utf8buf[UTF8_MAXBYTES+1];
9325 STRLEN esignlen = 0;
9327 char *eptr = Nullch;
9330 U8 *vecstr = Null(U8*);
9337 /* we need a long double target in case HAS_LONG_DOUBLE but
9340 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9348 const char *dotstr = ".";
9349 STRLEN dotstrlen = 1;
9350 I32 efix = 0; /* explicit format parameter index */
9351 I32 ewix = 0; /* explicit width index */
9352 I32 epix = 0; /* explicit precision index */
9353 I32 evix = 0; /* explicit vector index */
9354 bool asterisk = FALSE;
9356 /* echo everything up to the next format specification */
9357 for (q = p; q < patend && *q != '%'; ++q) ;
9359 if (has_utf8 && !pat_utf8)
9360 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9362 sv_catpvn(sv, p, q - p);
9369 We allow format specification elements in this order:
9370 \d+\$ explicit format parameter index
9372 v|\*(\d+\$)?v vector with optional (optionally specified) arg
9373 0 flag (as above): repeated to allow "v02"
9374 \d+|\*(\d+\$)? width using optional (optionally specified) arg
9375 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9377 [%bcdefginopsux_DFOUX] format (mandatory)
9379 if (EXPECT_NUMBER(q, width)) {
9420 if (EXPECT_NUMBER(q, ewix))
9429 if ((vectorarg = asterisk)) {
9441 EXPECT_NUMBER(q, width);
9446 vecsv = va_arg(*args, SV*);
9448 vecsv = (evix ? evix <= svmax : svix < svmax) ?
9449 svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
9450 dotstr = SvPVx(vecsv, dotstrlen);
9455 vecsv = va_arg(*args, SV*);
9456 vecstr = (U8*)SvPVx(vecsv,veclen);
9457 vec_utf8 = DO_UTF8(vecsv);
9459 else if (efix ? efix <= svmax : svix < svmax) {
9460 vecsv = svargs[efix ? efix-1 : svix++];
9461 vecstr = (U8*)SvPVx(vecsv,veclen);
9462 vec_utf8 = DO_UTF8(vecsv);
9463 /* if this is a version object, we need to return the
9464 * stringified representation (which the SvPVX has
9465 * already done for us), but not vectorize the args
9467 if ( *q == 'd' && sv_derived_from(vecsv,"version") )
9469 q++; /* skip past the rest of the %vd format */
9470 eptr = (char *) vecstr;
9471 elen = strlen(eptr);
9484 i = va_arg(*args, int);
9486 i = (ewix ? ewix <= svmax : svix < svmax) ?
9487 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9489 width = (i < 0) ? -i : i;
9499 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
9501 /* XXX: todo, support specified precision parameter */
9505 i = va_arg(*args, int);
9507 i = (ewix ? ewix <= svmax : svix < svmax)
9508 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9509 precis = (i < 0) ? 0 : i;
9514 precis = precis * 10 + (*q++ - '0');
9523 case 'I': /* Ix, I32x, and I64x */
9525 if (q[1] == '6' && q[2] == '4') {
9531 if (q[1] == '3' && q[2] == '2') {
9541 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9552 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9553 if (*(q + 1) == 'l') { /* lld, llf */
9578 argsv = (efix ? efix <= svmax : svix < svmax) ?
9579 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
9586 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
9588 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9590 eptr = (char*)utf8buf;
9591 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9602 if (args && !vectorize) {
9603 eptr = va_arg(*args, char*);
9605 #ifdef MACOS_TRADITIONAL
9606 /* On MacOS, %#s format is used for Pascal strings */
9611 elen = strlen(eptr);
9613 eptr = (char *)nullstr;
9614 elen = sizeof nullstr - 1;
9618 eptr = SvPVx(argsv, elen);
9619 if (DO_UTF8(argsv)) {
9620 if (has_precis && precis < elen) {
9622 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9625 if (width) { /* fudge width (can't fudge elen) */
9626 width += elen - sv_len_utf8(argsv);
9634 if (has_precis && elen > precis)
9641 if (left && args) { /* SVf */
9650 argsv = va_arg(*args, SV*);
9651 eptr = SvPVx(argsv, elen);
9656 if (alt || vectorize)
9658 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9676 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9685 esignbuf[esignlen++] = plus;
9689 case 'h': iv = (short)va_arg(*args, int); break;
9690 case 'l': iv = va_arg(*args, long); break;
9691 case 'V': iv = va_arg(*args, IV); break;
9692 default: iv = va_arg(*args, int); break;
9694 case 'q': iv = va_arg(*args, Quad_t); break;
9699 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
9701 case 'h': iv = (short)tiv; break;
9702 case 'l': iv = (long)tiv; break;
9704 default: iv = tiv; break;
9706 case 'q': iv = (Quad_t)tiv; break;
9710 if ( !vectorize ) /* we already set uv above */
9715 esignbuf[esignlen++] = plus;
9719 esignbuf[esignlen++] = '-';
9762 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9773 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9774 case 'l': uv = va_arg(*args, unsigned long); break;
9775 case 'V': uv = va_arg(*args, UV); break;
9776 default: uv = va_arg(*args, unsigned); break;
9778 case 'q': uv = va_arg(*args, Uquad_t); break;
9783 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9785 case 'h': uv = (unsigned short)tuv; break;
9786 case 'l': uv = (unsigned long)tuv; break;
9788 default: uv = tuv; break;
9790 case 'q': uv = (Uquad_t)tuv; break;
9796 eptr = ebuf + sizeof ebuf;
9802 p = (char*)((c == 'X')
9803 ? "0123456789ABCDEF" : "0123456789abcdef");
9809 esignbuf[esignlen++] = '0';
9810 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9816 *--eptr = '0' + dig;
9818 if (alt && *eptr != '0')
9824 *--eptr = '0' + dig;
9827 esignbuf[esignlen++] = '0';
9828 esignbuf[esignlen++] = 'b';
9831 default: /* it had better be ten or less */
9834 *--eptr = '0' + dig;
9835 } while (uv /= base);
9838 elen = (ebuf + sizeof ebuf) - eptr;
9841 zeros = precis - elen;
9842 else if (precis == 0 && elen == 1 && *eptr == '0')
9847 /* FLOATING POINT */
9850 c = 'f'; /* maybe %F isn't supported here */
9856 /* This is evil, but floating point is even more evil */
9858 /* for SV-style calling, we can only get NV
9859 for C-style calling, we assume %f is double;
9860 for simplicity we allow any of %Lf, %llf, %qf for long double
9864 #if defined(USE_LONG_DOUBLE)
9868 /* [perl #20339] - we should accept and ignore %lf rather than die */
9872 #if defined(USE_LONG_DOUBLE)
9873 intsize = args ? 0 : 'q';
9877 #if defined(HAS_LONG_DOUBLE)
9886 /* now we need (long double) if intsize == 'q', else (double) */
9887 nv = (args && !vectorize) ?
9888 #if LONG_DOUBLESIZE > DOUBLESIZE
9890 va_arg(*args, long double) :
9891 va_arg(*args, double)
9893 va_arg(*args, double)
9899 if (c != 'e' && c != 'E') {
9901 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9902 will cast our (long double) to (double) */
9903 (void)Perl_frexp(nv, &i);
9904 if (i == PERL_INT_MIN)
9905 Perl_die(aTHX_ "panic: frexp");
9907 need = BIT_DIGITS(i);
9909 need += has_precis ? precis : 6; /* known default */
9914 #ifdef HAS_LDBL_SPRINTF_BUG
9915 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9916 with sfio - Allen <allens@cpan.org> */
9919 # define MY_DBL_MAX DBL_MAX
9920 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9921 # if DOUBLESIZE >= 8
9922 # define MY_DBL_MAX 1.7976931348623157E+308L
9924 # define MY_DBL_MAX 3.40282347E+38L
9928 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9929 # define MY_DBL_MAX_BUG 1L
9931 # define MY_DBL_MAX_BUG MY_DBL_MAX
9935 # define MY_DBL_MIN DBL_MIN
9936 # else /* XXX guessing! -Allen */
9937 # if DOUBLESIZE >= 8
9938 # define MY_DBL_MIN 2.2250738585072014E-308L
9940 # define MY_DBL_MIN 1.17549435E-38L
9944 if ((intsize == 'q') && (c == 'f') &&
9945 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9947 /* it's going to be short enough that
9948 * long double precision is not needed */
9950 if ((nv <= 0L) && (nv >= -0L))
9951 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9953 /* would use Perl_fp_class as a double-check but not
9954 * functional on IRIX - see perl.h comments */
9956 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9957 /* It's within the range that a double can represent */
9958 #if defined(DBL_MAX) && !defined(DBL_MIN)
9959 if ((nv >= ((long double)1/DBL_MAX)) ||
9960 (nv <= (-(long double)1/DBL_MAX)))
9962 fix_ldbl_sprintf_bug = TRUE;
9965 if (fix_ldbl_sprintf_bug == TRUE) {
9975 # undef MY_DBL_MAX_BUG
9978 #endif /* HAS_LDBL_SPRINTF_BUG */
9980 need += 20; /* fudge factor */
9981 if (PL_efloatsize < need) {
9982 Safefree(PL_efloatbuf);
9983 PL_efloatsize = need + 20; /* more fudge */
9984 New(906, PL_efloatbuf, PL_efloatsize, char);
9985 PL_efloatbuf[0] = '\0';
9988 if ( !(width || left || plus || alt) && fill != '0'
9989 && has_precis && intsize != 'q' ) { /* Shortcuts */
9990 /* See earlier comment about buggy Gconvert when digits,
9992 if ( c == 'g' && precis) {
9993 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9994 if (*PL_efloatbuf) /* May return an empty string for digits==0 */
9995 goto float_converted;
9996 } else if ( c == 'f' && !precis) {
9997 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
10001 eptr = ebuf + sizeof ebuf;
10004 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
10005 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
10006 if (intsize == 'q') {
10007 /* Copy the one or more characters in a long double
10008 * format before the 'base' ([efgEFG]) character to
10009 * the format string. */
10010 static char const prifldbl[] = PERL_PRIfldbl;
10011 char const *p = prifldbl + sizeof(prifldbl) - 3;
10012 while (p >= prifldbl) { *--eptr = *p--; }
10017 do { *--eptr = '0' + (base % 10); } while (base /= 10);
10022 do { *--eptr = '0' + (base % 10); } while (base /= 10);
10034 /* No taint. Otherwise we are in the strange situation
10035 * where printf() taints but print($float) doesn't.
10037 #if defined(HAS_LONG_DOUBLE)
10038 if (intsize == 'q')
10039 (void)sprintf(PL_efloatbuf, eptr, nv);
10041 (void)sprintf(PL_efloatbuf, eptr, (double)nv);
10043 (void)sprintf(PL_efloatbuf, eptr, nv);
10046 eptr = PL_efloatbuf;
10047 elen = strlen(PL_efloatbuf);
10053 i = SvCUR(sv) - origlen;
10054 if (args && !vectorize) {
10056 case 'h': *(va_arg(*args, short*)) = i; break;
10057 default: *(va_arg(*args, int*)) = i; break;
10058 case 'l': *(va_arg(*args, long*)) = i; break;
10059 case 'V': *(va_arg(*args, IV*)) = i; break;
10061 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
10066 sv_setuv_mg(argsv, (UV)i);
10068 continue; /* not "break" */
10074 if (!args && ckWARN(WARN_PRINTF) &&
10075 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
10076 SV *msg = sv_newmortal();
10077 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
10078 (PL_op->op_type == OP_PRTF) ? "" : "s");
10081 Perl_sv_catpvf(aTHX_ msg,
10082 "\"%%%c\"", c & 0xFF);
10084 Perl_sv_catpvf(aTHX_ msg,
10085 "\"%%\\%03"UVof"\"",
10088 sv_catpv(msg, "end of string");
10089 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
10092 /* output mangled stuff ... */
10098 /* ... right here, because formatting flags should not apply */
10099 SvGROW(sv, SvCUR(sv) + elen + 1);
10101 Copy(eptr, p, elen, char);
10104 SvCUR_set(sv, p - SvPVX(sv));
10106 continue; /* not "break" */
10109 /* calculate width before utf8_upgrade changes it */
10110 have = esignlen + zeros + elen;
10112 if (is_utf8 != has_utf8) {
10115 sv_utf8_upgrade(sv);
10118 SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
10119 sv_utf8_upgrade(nsv);
10123 SvGROW(sv, SvCUR(sv) + elen + 1);
10128 need = (have > width ? have : width);
10131 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
10133 if (esignlen && fill == '0') {
10134 for (i = 0; i < (int)esignlen; i++)
10135 *p++ = esignbuf[i];
10137 if (gap && !left) {
10138 memset(p, fill, gap);
10141 if (esignlen && fill != '0') {
10142 for (i = 0; i < (int)esignlen; i++)
10143 *p++ = esignbuf[i];
10146 for (i = zeros; i; i--)
10150 Copy(eptr, p, elen, char);
10154 memset(p, ' ', gap);
10159 Copy(dotstr, p, dotstrlen, char);
10163 vectorize = FALSE; /* done iterating over vecstr */
10170 SvCUR_set(sv, p - SvPVX(sv));
10178 /* =========================================================================
10180 =head1 Cloning an interpreter
10182 All the macros and functions in this section are for the private use of
10183 the main function, perl_clone().
10185 The foo_dup() functions make an exact copy of an existing foo thinngy.
10186 During the course of a cloning, a hash table is used to map old addresses
10187 to new addresses. The table is created and manipulated with the
10188 ptr_table_* functions.
10192 ============================================================================*/
10195 #if defined(USE_ITHREADS)
10197 #ifndef GpREFCNT_inc
10198 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
10202 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
10203 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
10204 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10205 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
10206 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10207 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
10208 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10209 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
10210 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
10211 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
10212 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
10213 #define SAVEPV(p) (p ? savepv(p) : Nullch)
10214 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
10217 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
10218 regcomp.c. AMS 20010712 */
10221 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
10226 struct reg_substr_datum *s;
10229 return (REGEXP *)NULL;
10231 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
10234 len = r->offsets[0];
10235 npar = r->nparens+1;
10237 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
10238 Copy(r->program, ret->program, len+1, regnode);
10240 New(0, ret->startp, npar, I32);
10241 Copy(r->startp, ret->startp, npar, I32);
10242 New(0, ret->endp, npar, I32);
10243 Copy(r->startp, ret->startp, npar, I32);
10245 New(0, ret->substrs, 1, struct reg_substr_data);
10246 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
10247 s->min_offset = r->substrs->data[i].min_offset;
10248 s->max_offset = r->substrs->data[i].max_offset;
10249 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
10250 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
10253 ret->regstclass = NULL;
10255 struct reg_data *d;
10256 const int count = r->data->count;
10258 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
10259 char, struct reg_data);
10260 New(0, d->what, count, U8);
10263 for (i = 0; i < count; i++) {
10264 d->what[i] = r->data->what[i];
10265 switch (d->what[i]) {
10266 /* legal options are one of: sfpont
10267 see also regcomp.h and pregfree() */
10269 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
10272 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
10275 /* This is cheating. */
10276 New(0, d->data[i], 1, struct regnode_charclass_class);
10277 StructCopy(r->data->data[i], d->data[i],
10278 struct regnode_charclass_class);
10279 ret->regstclass = (regnode*)d->data[i];
10282 /* Compiled op trees are readonly, and can thus be
10283 shared without duplication. */
10285 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
10289 d->data[i] = r->data->data[i];
10292 d->data[i] = r->data->data[i];
10294 ((reg_trie_data*)d->data[i])->refcount++;
10298 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
10307 New(0, ret->offsets, 2*len+1, U32);
10308 Copy(r->offsets, ret->offsets, 2*len+1, U32);
10310 ret->precomp = SAVEPVN(r->precomp, r->prelen);
10311 ret->refcnt = r->refcnt;
10312 ret->minlen = r->minlen;
10313 ret->prelen = r->prelen;
10314 ret->nparens = r->nparens;
10315 ret->lastparen = r->lastparen;
10316 ret->lastcloseparen = r->lastcloseparen;
10317 ret->reganch = r->reganch;
10319 ret->sublen = r->sublen;
10321 if (RX_MATCH_COPIED(ret))
10322 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
10324 ret->subbeg = Nullch;
10325 #ifdef PERL_COPY_ON_WRITE
10326 ret->saved_copy = Nullsv;
10329 ptr_table_store(PL_ptr_table, r, ret);
10333 /* duplicate a file handle */
10336 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
10342 return (PerlIO*)NULL;
10344 /* look for it in the table first */
10345 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10349 /* create anew and remember what it is */
10350 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10351 ptr_table_store(PL_ptr_table, fp, ret);
10355 /* duplicate a directory handle */
10358 Perl_dirp_dup(pTHX_ DIR *dp)
10366 /* duplicate a typeglob */
10369 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
10374 /* look for it in the table first */
10375 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10379 /* create anew and remember what it is */
10380 Newz(0, ret, 1, GP);
10381 ptr_table_store(PL_ptr_table, gp, ret);
10384 ret->gp_refcnt = 0; /* must be before any other dups! */
10385 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
10386 ret->gp_io = io_dup_inc(gp->gp_io, param);
10387 ret->gp_form = cv_dup_inc(gp->gp_form, param);
10388 ret->gp_av = av_dup_inc(gp->gp_av, param);
10389 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
10390 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10391 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
10392 ret->gp_cvgen = gp->gp_cvgen;
10393 ret->gp_flags = gp->gp_flags;
10394 ret->gp_line = gp->gp_line;
10395 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
10399 /* duplicate a chain of magic */
10402 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
10404 MAGIC *mgprev = (MAGIC*)NULL;
10407 return (MAGIC*)NULL;
10408 /* look for it in the table first */
10409 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
10413 for (; mg; mg = mg->mg_moremagic) {
10415 Newz(0, nmg, 1, MAGIC);
10417 mgprev->mg_moremagic = nmg;
10420 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
10421 nmg->mg_private = mg->mg_private;
10422 nmg->mg_type = mg->mg_type;
10423 nmg->mg_flags = mg->mg_flags;
10424 if (mg->mg_type == PERL_MAGIC_qr) {
10425 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
10427 else if(mg->mg_type == PERL_MAGIC_backref) {
10428 const AV * const av = (AV*) mg->mg_obj;
10431 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
10433 for (i = AvFILLp(av); i >= 0; i--) {
10434 if (!svp[i]) continue;
10435 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
10438 else if (mg->mg_type == PERL_MAGIC_symtab) {
10439 nmg->mg_obj = mg->mg_obj;
10442 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
10443 ? sv_dup_inc(mg->mg_obj, param)
10444 : sv_dup(mg->mg_obj, param);
10446 nmg->mg_len = mg->mg_len;
10447 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
10448 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
10449 if (mg->mg_len > 0) {
10450 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
10451 if (mg->mg_type == PERL_MAGIC_overload_table &&
10452 AMT_AMAGIC((AMT*)mg->mg_ptr))
10454 AMT *amtp = (AMT*)mg->mg_ptr;
10455 AMT *namtp = (AMT*)nmg->mg_ptr;
10457 for (i = 1; i < NofAMmeth; i++) {
10458 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
10462 else if (mg->mg_len == HEf_SVKEY)
10463 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
10465 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
10466 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10473 /* create a new pointer-mapping table */
10476 Perl_ptr_table_new(pTHX)
10479 Newz(0, tbl, 1, PTR_TBL_t);
10480 tbl->tbl_max = 511;
10481 tbl->tbl_items = 0;
10482 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10487 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
10489 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
10497 struct ptr_tbl_ent* pte;
10498 struct ptr_tbl_ent* pteend;
10499 New(0, pte, PERL_ARENA_SIZE/sizeof(struct ptr_tbl_ent), struct ptr_tbl_ent);
10500 pte->next = PL_pte_arenaroot;
10501 PL_pte_arenaroot = pte;
10503 pteend = &pte[PERL_ARENA_SIZE / sizeof(struct ptr_tbl_ent) - 1];
10504 PL_pte_root = ++pte;
10505 while (pte < pteend) {
10506 pte->next = pte + 1;
10512 STATIC struct ptr_tbl_ent*
10515 struct ptr_tbl_ent* pte;
10519 PL_pte_root = pte->next;
10524 S_del_pte(pTHX_ struct ptr_tbl_ent*p)
10526 p->next = PL_pte_root;
10530 /* map an existing pointer using a table */
10533 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
10535 PTR_TBL_ENT_t *tblent;
10536 const UV hash = PTR_TABLE_HASH(sv);
10538 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10539 for (; tblent; tblent = tblent->next) {
10540 if (tblent->oldval == sv)
10541 return tblent->newval;
10543 return (void*)NULL;
10546 /* add a new entry to a pointer-mapping table */
10549 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
10551 PTR_TBL_ENT_t *tblent, **otblent;
10552 /* XXX this may be pessimal on platforms where pointers aren't good
10553 * hash values e.g. if they grow faster in the most significant
10555 const UV hash = PTR_TABLE_HASH(oldv);
10559 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
10560 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
10561 if (tblent->oldval == oldv) {
10562 tblent->newval = newv;
10566 tblent = S_new_pte(aTHX);
10567 tblent->oldval = oldv;
10568 tblent->newval = newv;
10569 tblent->next = *otblent;
10572 if (!empty && tbl->tbl_items > tbl->tbl_max)
10573 ptr_table_split(tbl);
10576 /* double the hash bucket size of an existing ptr table */
10579 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
10581 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10582 const UV oldsize = tbl->tbl_max + 1;
10583 UV newsize = oldsize * 2;
10586 Renew(ary, newsize, PTR_TBL_ENT_t*);
10587 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10588 tbl->tbl_max = --newsize;
10589 tbl->tbl_ary = ary;
10590 for (i=0; i < oldsize; i++, ary++) {
10591 PTR_TBL_ENT_t **curentp, **entp, *ent;
10594 curentp = ary + oldsize;
10595 for (entp = ary, ent = *ary; ent; ent = *entp) {
10596 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10598 ent->next = *curentp;
10608 /* remove all the entries from a ptr table */
10611 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
10613 register PTR_TBL_ENT_t **array;
10614 register PTR_TBL_ENT_t *entry;
10618 if (!tbl || !tbl->tbl_items) {
10622 array = tbl->tbl_ary;
10624 max = tbl->tbl_max;
10628 PTR_TBL_ENT_t *oentry = entry;
10629 entry = entry->next;
10630 S_del_pte(aTHX_ oentry);
10633 if (++riter > max) {
10636 entry = array[riter];
10640 tbl->tbl_items = 0;
10643 /* clear and free a ptr table */
10646 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
10651 ptr_table_clear(tbl);
10652 Safefree(tbl->tbl_ary);
10656 /* attempt to make everything in the typeglob readonly */
10659 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
10661 GV *gv = (GV*)sstr;
10662 SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */
10664 if (GvIO(gv) || GvFORM(gv)) {
10665 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
10667 else if (!GvCV(gv)) {
10668 GvCV(gv) = (CV*)sv;
10671 /* CvPADLISTs cannot be shared */
10672 if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
10677 if (!GvUNIQUE(gv)) {
10679 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
10680 HvNAME(GvSTASH(gv)), GvNAME(gv));
10686 * write attempts will die with
10687 * "Modification of a read-only value attempted"
10693 SvREADONLY_on(GvSV(gv));
10697 GvAV(gv) = (AV*)sv;
10700 SvREADONLY_on(GvAV(gv));
10704 GvHV(gv) = (HV*)sv;
10707 SvREADONLY_on(GvHV(gv));
10710 return sstr; /* he_dup() will SvREFCNT_inc() */
10713 /* duplicate an SV of any type (including AV, HV etc) */
10716 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
10719 SvRV_set(dstr, SvWEAKREF(sstr)
10720 ? sv_dup(SvRV(sstr), param)
10721 : sv_dup_inc(SvRV(sstr), param));
10724 else if (SvPVX(sstr)) {
10725 /* Has something there */
10727 /* Normal PV - clone whole allocated space */
10728 SvPV_set(dstr, SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1));
10729 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10730 /* Not that normal - actually sstr is copy on write.
10731 But we are a true, independant SV, so: */
10732 SvREADONLY_off(dstr);
10737 /* Special case - not normally malloced for some reason */
10738 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10739 /* A "shared" PV - clone it as unshared string */
10740 if(SvPADTMP(sstr)) {
10741 /* However, some of them live in the pad
10742 and they should not have these flags
10745 SvPV_set(dstr, sharepvn(SvPVX(sstr), SvCUR(sstr),
10747 SvUV_set(dstr, SvUVX(sstr));
10750 SvPV_set(dstr, SAVEPVN(SvPVX(sstr), SvCUR(sstr)));
10752 SvREADONLY_off(dstr);
10756 /* Some other special case - random pointer */
10757 SvPV_set(dstr, SvPVX(sstr));
10762 /* Copy the Null */
10763 if (SvTYPE(dstr) == SVt_RV)
10764 SvRV_set(dstr, NULL);
10771 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
10776 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
10778 /* look for it in the table first */
10779 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10783 if(param->flags & CLONEf_JOIN_IN) {
10784 /** We are joining here so we don't want do clone
10785 something that is bad **/
10787 if(SvTYPE(sstr) == SVt_PVHV &&
10789 /** don't clone stashes if they already exist **/
10790 HV* old_stash = gv_stashpv(HvNAME(sstr),0);
10791 return (SV*) old_stash;
10795 /* create anew and remember what it is */
10798 #ifdef DEBUG_LEAKING_SCALARS
10799 dstr->sv_debug_optype = sstr->sv_debug_optype;
10800 dstr->sv_debug_line = sstr->sv_debug_line;
10801 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10802 dstr->sv_debug_cloned = 1;
10804 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10806 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
10810 ptr_table_store(PL_ptr_table, sstr, dstr);
10813 SvFLAGS(dstr) = SvFLAGS(sstr);
10814 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10815 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10818 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
10819 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10820 PL_watch_pvx, SvPVX(sstr));
10823 /* don't clone objects whose class has asked us not to */
10824 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10825 SvFLAGS(dstr) &= ~SVTYPEMASK;
10826 SvOBJECT_off(dstr);
10830 switch (SvTYPE(sstr)) {
10832 SvANY(dstr) = NULL;
10835 SvANY(dstr) = new_XIV();
10836 SvIV_set(dstr, SvIVX(sstr));
10839 SvANY(dstr) = new_XNV();
10840 SvNV_set(dstr, SvNVX(sstr));
10843 SvANY(dstr) = new_XRV();
10844 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10847 SvANY(dstr) = new_XPV();
10848 SvCUR_set(dstr, SvCUR(sstr));
10849 SvLEN_set(dstr, SvLEN(sstr));
10850 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10853 SvANY(dstr) = new_XPVIV();
10854 SvCUR_set(dstr, SvCUR(sstr));
10855 SvLEN_set(dstr, SvLEN(sstr));
10856 SvIV_set(dstr, SvIVX(sstr));
10857 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10860 SvANY(dstr) = new_XPVNV();
10861 SvCUR_set(dstr, SvCUR(sstr));
10862 SvLEN_set(dstr, SvLEN(sstr));
10863 SvIV_set(dstr, SvIVX(sstr));
10864 SvNV_set(dstr, SvNVX(sstr));
10865 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10868 SvANY(dstr) = new_XPVMG();
10869 SvCUR_set(dstr, SvCUR(sstr));
10870 SvLEN_set(dstr, SvLEN(sstr));
10871 SvIV_set(dstr, SvIVX(sstr));
10872 SvNV_set(dstr, SvNVX(sstr));
10873 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10874 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10875 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10878 SvANY(dstr) = new_XPVBM();
10879 SvCUR_set(dstr, SvCUR(sstr));
10880 SvLEN_set(dstr, SvLEN(sstr));
10881 SvIV_set(dstr, SvIVX(sstr));
10882 SvNV_set(dstr, SvNVX(sstr));
10883 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10884 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10885 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10886 BmRARE(dstr) = BmRARE(sstr);
10887 BmUSEFUL(dstr) = BmUSEFUL(sstr);
10888 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
10891 SvANY(dstr) = new_XPVLV();
10892 SvCUR_set(dstr, SvCUR(sstr));
10893 SvLEN_set(dstr, SvLEN(sstr));
10894 SvIV_set(dstr, SvIVX(sstr));
10895 SvNV_set(dstr, SvNVX(sstr));
10896 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10897 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10898 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10899 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
10900 LvTARGLEN(dstr) = LvTARGLEN(sstr);
10901 if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */
10902 LvTARG(dstr) = dstr;
10903 else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */
10904 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param);
10906 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
10907 LvTYPE(dstr) = LvTYPE(sstr);
10910 if (GvUNIQUE((GV*)sstr)) {
10912 if ((share = gv_share(sstr, param))) {
10915 ptr_table_store(PL_ptr_table, sstr, dstr);
10917 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
10918 HvNAME(GvSTASH(share)), GvNAME(share));
10923 SvANY(dstr) = new_XPVGV();
10924 SvCUR_set(dstr, SvCUR(sstr));
10925 SvLEN_set(dstr, SvLEN(sstr));
10926 SvIV_set(dstr, SvIVX(sstr));
10927 SvNV_set(dstr, SvNVX(sstr));
10928 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10929 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10930 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10931 GvNAMELEN(dstr) = GvNAMELEN(sstr);
10932 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
10933 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
10934 GvFLAGS(dstr) = GvFLAGS(sstr);
10935 GvGP(dstr) = gp_dup(GvGP(sstr), param);
10936 (void)GpREFCNT_inc(GvGP(dstr));
10939 SvANY(dstr) = new_XPVIO();
10940 SvCUR_set(dstr, SvCUR(sstr));
10941 SvLEN_set(dstr, SvLEN(sstr));
10942 SvIV_set(dstr, SvIVX(sstr));
10943 SvNV_set(dstr, SvNVX(sstr));
10944 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10945 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10946 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10947 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
10948 if (IoOFP(sstr) == IoIFP(sstr))
10949 IoOFP(dstr) = IoIFP(dstr);
10951 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
10952 /* PL_rsfp_filters entries have fake IoDIRP() */
10953 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
10954 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
10956 IoDIRP(dstr) = IoDIRP(sstr);
10957 IoLINES(dstr) = IoLINES(sstr);
10958 IoPAGE(dstr) = IoPAGE(sstr);
10959 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
10960 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
10961 if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
10962 /* I have no idea why fake dirp (rsfps)
10963 should be treaded differently but otherwise
10964 we end up with leaks -- sky*/
10965 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(sstr), param);
10966 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(sstr), param);
10967 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(sstr), param);
10969 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
10970 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
10971 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
10973 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
10974 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
10975 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
10976 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
10977 IoTYPE(dstr) = IoTYPE(sstr);
10978 IoFLAGS(dstr) = IoFLAGS(sstr);
10981 SvANY(dstr) = new_XPVAV();
10982 SvCUR_set(dstr, SvCUR(sstr));
10983 SvLEN_set(dstr, SvLEN(sstr));
10984 SvIV_set(dstr, SvIVX(sstr));
10985 SvNV_set(dstr, SvNVX(sstr));
10986 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
10987 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
10988 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
10989 if (AvARRAY((AV*)sstr)) {
10990 SV **dst_ary, **src_ary;
10991 SSize_t items = AvFILLp((AV*)sstr) + 1;
10993 src_ary = AvARRAY((AV*)sstr);
10994 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
10995 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10996 SvPV_set(dstr, (char*)dst_ary);
10997 AvALLOC((AV*)dstr) = dst_ary;
10998 if (AvREAL((AV*)sstr)) {
10999 while (items-- > 0)
11000 *dst_ary++ = sv_dup_inc(*src_ary++, param);
11003 while (items-- > 0)
11004 *dst_ary++ = sv_dup(*src_ary++, param);
11006 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
11007 while (items-- > 0) {
11008 *dst_ary++ = &PL_sv_undef;
11012 SvPV_set(dstr, Nullch);
11013 AvALLOC((AV*)dstr) = (SV**)NULL;
11017 SvANY(dstr) = new_XPVHV();
11018 SvCUR_set(dstr, SvCUR(sstr));
11019 SvLEN_set(dstr, SvLEN(sstr));
11020 SvIV_set(dstr, SvIVX(sstr));
11021 SvNV_set(dstr, SvNVX(sstr));
11022 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
11023 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
11024 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
11025 if (HvARRAY((HV*)sstr)) {
11027 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
11028 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
11029 Newz(0, dxhv->xhv_array,
11030 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
11031 while (i <= sxhv->xhv_max) {
11032 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
11033 (bool)!!HvSHAREKEYS(sstr),
11037 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
11038 (bool)!!HvSHAREKEYS(sstr), param);
11041 SvPV_set(dstr, Nullch);
11042 HvEITER((HV*)dstr) = (HE*)NULL;
11044 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
11045 /* Record stashes for possible cloning in Perl_clone(). */
11046 if(HvNAME((HV*)dstr))
11047 av_push(param->stashes, dstr);
11050 SvANY(dstr) = new_XPVFM();
11051 FmLINES(dstr) = FmLINES(sstr);
11055 SvANY(dstr) = new_XPVCV();
11057 SvCUR_set(dstr, SvCUR(sstr));
11058 SvLEN_set(dstr, SvLEN(sstr));
11059 SvIV_set(dstr, SvIVX(sstr));
11060 SvNV_set(dstr, SvNVX(sstr));
11061 SvMAGIC_set(dstr, mg_dup(SvMAGIC(sstr), param));
11062 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(sstr), param));
11063 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
11064 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
11065 CvSTART(dstr) = CvSTART(sstr);
11067 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
11069 CvXSUB(dstr) = CvXSUB(sstr);
11070 CvXSUBANY(dstr) = CvXSUBANY(sstr);
11071 if (CvCONST(sstr)) {
11072 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
11073 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
11074 sv_dup_inc((SV *)CvXSUBANY(sstr).any_ptr, param);
11076 /* don't dup if copying back - CvGV isn't refcounted, so the
11077 * duped GV may never be freed. A bit of a hack! DAPM */
11078 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
11079 Nullgv : gv_dup(CvGV(sstr), param) ;
11080 if (param->flags & CLONEf_COPY_STACKS) {
11081 CvDEPTH(dstr) = CvDEPTH(sstr);
11085 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
11086 CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
11088 CvWEAKOUTSIDE(sstr)
11089 ? cv_dup( CvOUTSIDE(sstr), param)
11090 : cv_dup_inc(CvOUTSIDE(sstr), param);
11091 CvFLAGS(dstr) = CvFLAGS(sstr);
11092 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
11095 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
11099 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
11105 /* duplicate a context */
11108 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
11110 PERL_CONTEXT *ncxs;
11113 return (PERL_CONTEXT*)NULL;
11115 /* look for it in the table first */
11116 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
11120 /* create anew and remember what it is */
11121 Newz(56, ncxs, max + 1, PERL_CONTEXT);
11122 ptr_table_store(PL_ptr_table, cxs, ncxs);
11125 PERL_CONTEXT *cx = &cxs[ix];
11126 PERL_CONTEXT *ncx = &ncxs[ix];
11127 ncx->cx_type = cx->cx_type;
11128 if (CxTYPE(cx) == CXt_SUBST) {
11129 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
11132 ncx->blk_oldsp = cx->blk_oldsp;
11133 ncx->blk_oldcop = cx->blk_oldcop;
11134 ncx->blk_oldmarksp = cx->blk_oldmarksp;
11135 ncx->blk_oldscopesp = cx->blk_oldscopesp;
11136 ncx->blk_oldpm = cx->blk_oldpm;
11137 ncx->blk_gimme = cx->blk_gimme;
11138 switch (CxTYPE(cx)) {
11140 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
11141 ? cv_dup_inc(cx->blk_sub.cv, param)
11142 : cv_dup(cx->blk_sub.cv,param));
11143 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
11144 ? av_dup_inc(cx->blk_sub.argarray, param)
11146 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
11147 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
11148 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
11149 ncx->blk_sub.lval = cx->blk_sub.lval;
11150 ncx->blk_sub.retop = cx->blk_sub.retop;
11153 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
11154 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
11155 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
11156 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
11157 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
11158 ncx->blk_eval.retop = cx->blk_eval.retop;
11161 ncx->blk_loop.label = cx->blk_loop.label;
11162 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
11163 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
11164 ncx->blk_loop.next_op = cx->blk_loop.next_op;
11165 ncx->blk_loop.last_op = cx->blk_loop.last_op;
11166 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
11167 ? cx->blk_loop.iterdata
11168 : gv_dup((GV*)cx->blk_loop.iterdata, param));
11169 ncx->blk_loop.oldcomppad
11170 = (PAD*)ptr_table_fetch(PL_ptr_table,
11171 cx->blk_loop.oldcomppad);
11172 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
11173 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
11174 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
11175 ncx->blk_loop.iterix = cx->blk_loop.iterix;
11176 ncx->blk_loop.itermax = cx->blk_loop.itermax;
11179 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
11180 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
11181 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
11182 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
11183 ncx->blk_sub.retop = cx->blk_sub.retop;
11195 /* duplicate a stack info structure */
11198 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
11203 return (PERL_SI*)NULL;
11205 /* look for it in the table first */
11206 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
11210 /* create anew and remember what it is */
11211 Newz(56, nsi, 1, PERL_SI);
11212 ptr_table_store(PL_ptr_table, si, nsi);
11214 nsi->si_stack = av_dup_inc(si->si_stack, param);
11215 nsi->si_cxix = si->si_cxix;
11216 nsi->si_cxmax = si->si_cxmax;
11217 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
11218 nsi->si_type = si->si_type;
11219 nsi->si_prev = si_dup(si->si_prev, param);
11220 nsi->si_next = si_dup(si->si_next, param);
11221 nsi->si_markoff = si->si_markoff;
11226 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
11227 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
11228 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
11229 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
11230 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
11231 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
11232 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
11233 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
11234 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
11235 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
11236 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
11237 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
11238 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
11239 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
11242 #define pv_dup_inc(p) SAVEPV(p)
11243 #define pv_dup(p) SAVEPV(p)
11244 #define svp_dup_inc(p,pp) any_dup(p,pp)
11246 /* map any object to the new equivent - either something in the
11247 * ptr table, or something in the interpreter structure
11251 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
11256 return (void*)NULL;
11258 /* look for it in the table first */
11259 ret = ptr_table_fetch(PL_ptr_table, v);
11263 /* see if it is part of the interpreter structure */
11264 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
11265 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
11273 /* duplicate the save stack */
11276 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
11278 ANY *ss = proto_perl->Tsavestack;
11279 I32 ix = proto_perl->Tsavestack_ix;
11280 I32 max = proto_perl->Tsavestack_max;
11293 void (*dptr) (void*);
11294 void (*dxptr) (pTHX_ void*);
11297 Newz(54, nss, max, ANY);
11301 TOPINT(nss,ix) = i;
11303 case SAVEt_ITEM: /* normal string */
11304 sv = (SV*)POPPTR(ss,ix);
11305 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11306 sv = (SV*)POPPTR(ss,ix);
11307 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11309 case SAVEt_SV: /* scalar reference */
11310 sv = (SV*)POPPTR(ss,ix);
11311 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11312 gv = (GV*)POPPTR(ss,ix);
11313 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11315 case SAVEt_GENERIC_PVREF: /* generic char* */
11316 c = (char*)POPPTR(ss,ix);
11317 TOPPTR(nss,ix) = pv_dup(c);
11318 ptr = POPPTR(ss,ix);
11319 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11321 case SAVEt_SHARED_PVREF: /* char* in shared space */
11322 c = (char*)POPPTR(ss,ix);
11323 TOPPTR(nss,ix) = savesharedpv(c);
11324 ptr = POPPTR(ss,ix);
11325 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11327 case SAVEt_GENERIC_SVREF: /* generic sv */
11328 case SAVEt_SVREF: /* scalar reference */
11329 sv = (SV*)POPPTR(ss,ix);
11330 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11331 ptr = POPPTR(ss,ix);
11332 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11334 case SAVEt_AV: /* array reference */
11335 av = (AV*)POPPTR(ss,ix);
11336 TOPPTR(nss,ix) = av_dup_inc(av, param);
11337 gv = (GV*)POPPTR(ss,ix);
11338 TOPPTR(nss,ix) = gv_dup(gv, param);
11340 case SAVEt_HV: /* hash reference */
11341 hv = (HV*)POPPTR(ss,ix);
11342 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11343 gv = (GV*)POPPTR(ss,ix);
11344 TOPPTR(nss,ix) = gv_dup(gv, param);
11346 case SAVEt_INT: /* int reference */
11347 ptr = POPPTR(ss,ix);
11348 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11349 intval = (int)POPINT(ss,ix);
11350 TOPINT(nss,ix) = intval;
11352 case SAVEt_LONG: /* long reference */
11353 ptr = POPPTR(ss,ix);
11354 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11355 longval = (long)POPLONG(ss,ix);
11356 TOPLONG(nss,ix) = longval;
11358 case SAVEt_I32: /* I32 reference */
11359 case SAVEt_I16: /* I16 reference */
11360 case SAVEt_I8: /* I8 reference */
11361 ptr = POPPTR(ss,ix);
11362 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11364 TOPINT(nss,ix) = i;
11366 case SAVEt_IV: /* IV reference */
11367 ptr = POPPTR(ss,ix);
11368 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11370 TOPIV(nss,ix) = iv;
11372 case SAVEt_SPTR: /* SV* reference */
11373 ptr = POPPTR(ss,ix);
11374 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11375 sv = (SV*)POPPTR(ss,ix);
11376 TOPPTR(nss,ix) = sv_dup(sv, param);
11378 case SAVEt_VPTR: /* random* reference */
11379 ptr = POPPTR(ss,ix);
11380 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11381 ptr = POPPTR(ss,ix);
11382 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11384 case SAVEt_PPTR: /* char* reference */
11385 ptr = POPPTR(ss,ix);
11386 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11387 c = (char*)POPPTR(ss,ix);
11388 TOPPTR(nss,ix) = pv_dup(c);
11390 case SAVEt_HPTR: /* HV* reference */
11391 ptr = POPPTR(ss,ix);
11392 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11393 hv = (HV*)POPPTR(ss,ix);
11394 TOPPTR(nss,ix) = hv_dup(hv, param);
11396 case SAVEt_APTR: /* AV* reference */
11397 ptr = POPPTR(ss,ix);
11398 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11399 av = (AV*)POPPTR(ss,ix);
11400 TOPPTR(nss,ix) = av_dup(av, param);
11403 gv = (GV*)POPPTR(ss,ix);
11404 TOPPTR(nss,ix) = gv_dup(gv, param);
11406 case SAVEt_GP: /* scalar reference */
11407 gp = (GP*)POPPTR(ss,ix);
11408 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11409 (void)GpREFCNT_inc(gp);
11410 gv = (GV*)POPPTR(ss,ix);
11411 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11412 c = (char*)POPPTR(ss,ix);
11413 TOPPTR(nss,ix) = pv_dup(c);
11415 TOPIV(nss,ix) = iv;
11417 TOPIV(nss,ix) = iv;
11420 case SAVEt_MORTALIZESV:
11421 sv = (SV*)POPPTR(ss,ix);
11422 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11425 ptr = POPPTR(ss,ix);
11426 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11427 /* these are assumed to be refcounted properly */
11428 switch (((OP*)ptr)->op_type) {
11430 case OP_LEAVESUBLV:
11434 case OP_LEAVEWRITE:
11435 TOPPTR(nss,ix) = ptr;
11440 TOPPTR(nss,ix) = Nullop;
11445 TOPPTR(nss,ix) = Nullop;
11448 c = (char*)POPPTR(ss,ix);
11449 TOPPTR(nss,ix) = pv_dup_inc(c);
11451 case SAVEt_CLEARSV:
11452 longval = POPLONG(ss,ix);
11453 TOPLONG(nss,ix) = longval;
11456 hv = (HV*)POPPTR(ss,ix);
11457 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11458 c = (char*)POPPTR(ss,ix);
11459 TOPPTR(nss,ix) = pv_dup_inc(c);
11461 TOPINT(nss,ix) = i;
11463 case SAVEt_DESTRUCTOR:
11464 ptr = POPPTR(ss,ix);
11465 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11466 dptr = POPDPTR(ss,ix);
11467 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
11469 case SAVEt_DESTRUCTOR_X:
11470 ptr = POPPTR(ss,ix);
11471 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
11472 dxptr = POPDXPTR(ss,ix);
11473 TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
11475 case SAVEt_REGCONTEXT:
11478 TOPINT(nss,ix) = i;
11481 case SAVEt_STACK_POS: /* Position on Perl stack */
11483 TOPINT(nss,ix) = i;
11485 case SAVEt_AELEM: /* array element */
11486 sv = (SV*)POPPTR(ss,ix);
11487 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11489 TOPINT(nss,ix) = i;
11490 av = (AV*)POPPTR(ss,ix);
11491 TOPPTR(nss,ix) = av_dup_inc(av, param);
11493 case SAVEt_HELEM: /* hash element */
11494 sv = (SV*)POPPTR(ss,ix);
11495 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11496 sv = (SV*)POPPTR(ss,ix);
11497 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11498 hv = (HV*)POPPTR(ss,ix);
11499 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11502 ptr = POPPTR(ss,ix);
11503 TOPPTR(nss,ix) = ptr;
11507 TOPINT(nss,ix) = i;
11509 case SAVEt_COMPPAD:
11510 av = (AV*)POPPTR(ss,ix);
11511 TOPPTR(nss,ix) = av_dup(av, param);
11514 longval = (long)POPLONG(ss,ix);
11515 TOPLONG(nss,ix) = longval;
11516 ptr = POPPTR(ss,ix);
11517 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11518 sv = (SV*)POPPTR(ss,ix);
11519 TOPPTR(nss,ix) = sv_dup(sv, param);
11522 ptr = POPPTR(ss,ix);
11523 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11524 longval = (long)POPBOOL(ss,ix);
11525 TOPBOOL(nss,ix) = (bool)longval;
11527 case SAVEt_SET_SVFLAGS:
11529 TOPINT(nss,ix) = i;
11531 TOPINT(nss,ix) = i;
11532 sv = (SV*)POPPTR(ss,ix);
11533 TOPPTR(nss,ix) = sv_dup(sv, param);
11536 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
11544 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11545 * flag to the result. This is done for each stash before cloning starts,
11546 * so we know which stashes want their objects cloned */
11549 do_mark_cloneable_stash(pTHX_ SV *sv)
11551 if (HvNAME((HV*)sv)) {
11552 GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
11553 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11554 if (cloner && GvCV(cloner)) {
11561 XPUSHs(sv_2mortal(newSVpv(HvNAME((HV*)sv), 0)));
11563 call_sv((SV*)GvCV(cloner), G_SCALAR);
11570 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11578 =for apidoc perl_clone
11580 Create and return a new interpreter by cloning the current one.
11582 perl_clone takes these flags as parameters:
11584 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11585 without it we only clone the data and zero the stacks,
11586 with it we copy the stacks and the new perl interpreter is
11587 ready to run at the exact same point as the previous one.
11588 The pseudo-fork code uses COPY_STACKS while the
11589 threads->new doesn't.
11591 CLONEf_KEEP_PTR_TABLE
11592 perl_clone keeps a ptr_table with the pointer of the old
11593 variable as a key and the new variable as a value,
11594 this allows it to check if something has been cloned and not
11595 clone it again but rather just use the value and increase the
11596 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11597 the ptr_table using the function
11598 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11599 reason to keep it around is if you want to dup some of your own
11600 variable who are outside the graph perl scans, example of this
11601 code is in threads.xs create
11604 This is a win32 thing, it is ignored on unix, it tells perls
11605 win32host code (which is c++) to clone itself, this is needed on
11606 win32 if you want to run two threads at the same time,
11607 if you just want to do some stuff in a separate perl interpreter
11608 and then throw it away and return to the original one,
11609 you don't need to do anything.
11614 /* XXX the above needs expanding by someone who actually understands it ! */
11615 EXTERN_C PerlInterpreter *
11616 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11619 perl_clone(PerlInterpreter *proto_perl, UV flags)
11622 #ifdef PERL_IMPLICIT_SYS
11624 /* perlhost.h so we need to call into it
11625 to clone the host, CPerlHost should have a c interface, sky */
11627 if (flags & CLONEf_CLONE_HOST) {
11628 return perl_clone_host(proto_perl,flags);
11630 return perl_clone_using(proto_perl, flags,
11632 proto_perl->IMemShared,
11633 proto_perl->IMemParse,
11635 proto_perl->IStdIO,
11639 proto_perl->IProc);
11643 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11644 struct IPerlMem* ipM, struct IPerlMem* ipMS,
11645 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11646 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11647 struct IPerlDir* ipD, struct IPerlSock* ipS,
11648 struct IPerlProc* ipP)
11650 /* XXX many of the string copies here can be optimized if they're
11651 * constants; they need to be allocated as common memory and just
11652 * their pointers copied. */
11655 CLONE_PARAMS clone_params;
11656 CLONE_PARAMS* param = &clone_params;
11658 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11659 /* for each stash, determine whether its objects should be cloned */
11660 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11661 PERL_SET_THX(my_perl);
11664 Poison(my_perl, 1, PerlInterpreter);
11666 PL_curcop = (COP *)Nullop;
11670 PL_savestack_ix = 0;
11671 PL_savestack_max = -1;
11672 PL_sig_pending = 0;
11673 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11674 # else /* !DEBUGGING */
11675 Zero(my_perl, 1, PerlInterpreter);
11676 # endif /* DEBUGGING */
11678 /* host pointers */
11680 PL_MemShared = ipMS;
11681 PL_MemParse = ipMP;
11688 #else /* !PERL_IMPLICIT_SYS */
11690 CLONE_PARAMS clone_params;
11691 CLONE_PARAMS* param = &clone_params;
11692 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11693 /* for each stash, determine whether its objects should be cloned */
11694 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11695 PERL_SET_THX(my_perl);
11698 Poison(my_perl, 1, PerlInterpreter);
11700 PL_curcop = (COP *)Nullop;
11704 PL_savestack_ix = 0;
11705 PL_savestack_max = -1;
11706 PL_sig_pending = 0;
11707 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11708 # else /* !DEBUGGING */
11709 Zero(my_perl, 1, PerlInterpreter);
11710 # endif /* DEBUGGING */
11711 #endif /* PERL_IMPLICIT_SYS */
11712 param->flags = flags;
11713 param->proto_perl = proto_perl;
11716 PL_xiv_arenaroot = NULL;
11717 PL_xiv_root = NULL;
11718 PL_xnv_arenaroot = NULL;
11719 PL_xnv_root = NULL;
11720 PL_xrv_arenaroot = NULL;
11721 PL_xrv_root = NULL;
11722 PL_xpv_arenaroot = NULL;
11723 PL_xpv_root = NULL;
11724 PL_xpviv_arenaroot = NULL;
11725 PL_xpviv_root = NULL;
11726 PL_xpvnv_arenaroot = NULL;
11727 PL_xpvnv_root = NULL;
11728 PL_xpvcv_arenaroot = NULL;
11729 PL_xpvcv_root = NULL;
11730 PL_xpvav_arenaroot = NULL;
11731 PL_xpvav_root = NULL;
11732 PL_xpvhv_arenaroot = NULL;
11733 PL_xpvhv_root = NULL;
11734 PL_xpvmg_arenaroot = NULL;
11735 PL_xpvmg_root = NULL;
11736 PL_xpvgv_arenaroot = NULL;
11737 PL_xpvgv_root = NULL;
11738 PL_xpvlv_arenaroot = NULL;
11739 PL_xpvlv_root = NULL;
11740 PL_xpvbm_arenaroot = NULL;
11741 PL_xpvbm_root = NULL;
11742 PL_he_arenaroot = NULL;
11744 #if defined(USE_ITHREADS)
11745 PL_pte_arenaroot = NULL;
11746 PL_pte_root = NULL;
11748 PL_nice_chunk = NULL;
11749 PL_nice_chunk_size = 0;
11751 PL_sv_objcount = 0;
11752 PL_sv_root = Nullsv;
11753 PL_sv_arenaroot = Nullsv;
11755 PL_debug = proto_perl->Idebug;
11757 #ifdef USE_REENTRANT_API
11758 /* XXX: things like -Dm will segfault here in perlio, but doing
11759 * PERL_SET_CONTEXT(proto_perl);
11760 * breaks too many other things
11762 Perl_reentrant_init(aTHX);
11765 /* create SV map for pointer relocation */
11766 PL_ptr_table = ptr_table_new();
11768 /* initialize these special pointers as early as possible */
11769 SvANY(&PL_sv_undef) = NULL;
11770 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
11771 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
11772 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11774 SvANY(&PL_sv_no) = new_XPVNV();
11775 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
11776 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11777 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11778 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
11779 SvCUR_set(&PL_sv_no, 0);
11780 SvLEN_set(&PL_sv_no, 1);
11781 SvIV_set(&PL_sv_no, 0);
11782 SvNV_set(&PL_sv_no, 0);
11783 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11785 SvANY(&PL_sv_yes) = new_XPVNV();
11786 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
11787 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11788 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11789 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
11790 SvCUR_set(&PL_sv_yes, 1);
11791 SvLEN_set(&PL_sv_yes, 2);
11792 SvIV_set(&PL_sv_yes, 1);
11793 SvNV_set(&PL_sv_yes, 1);
11794 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11796 /* create (a non-shared!) shared string table */
11797 PL_strtab = newHV();
11798 HvSHAREKEYS_off(PL_strtab);
11799 hv_ksplit(PL_strtab, 512);
11800 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11802 PL_compiling = proto_perl->Icompiling;
11804 /* These two PVs will be free'd special way so must set them same way op.c does */
11805 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11806 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11808 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
11809 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11811 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11812 if (!specialWARN(PL_compiling.cop_warnings))
11813 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
11814 if (!specialCopIO(PL_compiling.cop_io))
11815 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
11816 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
11818 /* pseudo environmental stuff */
11819 PL_origargc = proto_perl->Iorigargc;
11820 PL_origargv = proto_perl->Iorigargv;
11822 param->stashes = newAV(); /* Setup array of objects to call clone on */
11824 #ifdef PERLIO_LAYERS
11825 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11826 PerlIO_clone(aTHX_ proto_perl, param);
11829 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
11830 PL_incgv = gv_dup(proto_perl->Iincgv, param);
11831 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
11832 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
11833 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
11834 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
11837 PL_minus_c = proto_perl->Iminus_c;
11838 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
11839 PL_localpatches = proto_perl->Ilocalpatches;
11840 PL_splitstr = proto_perl->Isplitstr;
11841 PL_preprocess = proto_perl->Ipreprocess;
11842 PL_minus_n = proto_perl->Iminus_n;
11843 PL_minus_p = proto_perl->Iminus_p;
11844 PL_minus_l = proto_perl->Iminus_l;
11845 PL_minus_a = proto_perl->Iminus_a;
11846 PL_minus_F = proto_perl->Iminus_F;
11847 PL_doswitches = proto_perl->Idoswitches;
11848 PL_dowarn = proto_perl->Idowarn;
11849 PL_doextract = proto_perl->Idoextract;
11850 PL_sawampersand = proto_perl->Isawampersand;
11851 PL_unsafe = proto_perl->Iunsafe;
11852 PL_inplace = SAVEPV(proto_perl->Iinplace);
11853 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
11854 PL_perldb = proto_perl->Iperldb;
11855 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11856 PL_exit_flags = proto_perl->Iexit_flags;
11858 /* magical thingies */
11859 /* XXX time(&PL_basetime) when asked for? */
11860 PL_basetime = proto_perl->Ibasetime;
11861 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
11863 PL_maxsysfd = proto_perl->Imaxsysfd;
11864 PL_multiline = proto_perl->Imultiline;
11865 PL_statusvalue = proto_perl->Istatusvalue;
11867 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
11869 PL_encoding = sv_dup(proto_perl->Iencoding, param);
11871 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
11872 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
11873 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
11875 /* Clone the regex array */
11876 PL_regex_padav = newAV();
11878 const I32 len = av_len((AV*)proto_perl->Iregex_padav);
11879 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11880 av_push(PL_regex_padav,
11881 sv_dup_inc(regexen[0],param));
11882 for(i = 1; i <= len; i++) {
11883 if(SvREPADTMP(regexen[i])) {
11884 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11886 av_push(PL_regex_padav,
11888 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11889 SvIVX(regexen[i])), param)))
11894 PL_regex_pad = AvARRAY(PL_regex_padav);
11896 /* shortcuts to various I/O objects */
11897 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11898 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11899 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11900 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11901 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11902 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11904 /* shortcuts to regexp stuff */
11905 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11907 /* shortcuts to misc objects */
11908 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11910 /* shortcuts to debugging objects */
11911 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11912 PL_DBline = gv_dup(proto_perl->IDBline, param);
11913 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11914 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11915 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11916 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11917 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11918 PL_lineary = av_dup(proto_perl->Ilineary, param);
11919 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11921 /* symbol tables */
11922 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11923 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11924 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11925 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11926 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11928 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11929 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11930 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11931 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11932 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11933 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11935 PL_sub_generation = proto_perl->Isub_generation;
11937 /* funky return mechanisms */
11938 PL_forkprocess = proto_perl->Iforkprocess;
11940 /* subprocess state */
11941 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11943 /* internal state */
11944 PL_tainting = proto_perl->Itainting;
11945 PL_taint_warn = proto_perl->Itaint_warn;
11946 PL_maxo = proto_perl->Imaxo;
11947 if (proto_perl->Iop_mask)
11948 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11950 PL_op_mask = Nullch;
11951 /* PL_asserting = proto_perl->Iasserting; */
11953 /* current interpreter roots */
11954 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11955 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11956 PL_main_start = proto_perl->Imain_start;
11957 PL_eval_root = proto_perl->Ieval_root;
11958 PL_eval_start = proto_perl->Ieval_start;
11960 /* runtime control stuff */
11961 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11962 PL_copline = proto_perl->Icopline;
11964 PL_filemode = proto_perl->Ifilemode;
11965 PL_lastfd = proto_perl->Ilastfd;
11966 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11969 PL_gensym = proto_perl->Igensym;
11970 PL_preambled = proto_perl->Ipreambled;
11971 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11972 PL_laststatval = proto_perl->Ilaststatval;
11973 PL_laststype = proto_perl->Ilaststype;
11974 PL_mess_sv = Nullsv;
11976 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11977 PL_ofmt = SAVEPV(proto_perl->Iofmt);
11979 /* interpreter atexit processing */
11980 PL_exitlistlen = proto_perl->Iexitlistlen;
11981 if (PL_exitlistlen) {
11982 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11983 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11986 PL_exitlist = (PerlExitListEntry*)NULL;
11987 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11988 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11989 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11991 PL_profiledata = NULL;
11992 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
11993 /* PL_rsfp_filters entries have fake IoDIRP() */
11994 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
11996 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11998 PAD_CLONE_VARS(proto_perl, param);
12000 #ifdef HAVE_INTERP_INTERN
12001 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
12004 /* more statics moved here */
12005 PL_generation = proto_perl->Igeneration;
12006 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
12008 PL_in_clean_objs = proto_perl->Iin_clean_objs;
12009 PL_in_clean_all = proto_perl->Iin_clean_all;
12011 PL_uid = proto_perl->Iuid;
12012 PL_euid = proto_perl->Ieuid;
12013 PL_gid = proto_perl->Igid;
12014 PL_egid = proto_perl->Iegid;
12015 PL_nomemok = proto_perl->Inomemok;
12016 PL_an = proto_perl->Ian;
12017 PL_evalseq = proto_perl->Ievalseq;
12018 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
12019 PL_origalen = proto_perl->Iorigalen;
12020 PL_pidstatus = newHV(); /* XXX flag for cloning? */
12021 PL_osname = SAVEPV(proto_perl->Iosname);
12022 PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */
12023 PL_sighandlerp = proto_perl->Isighandlerp;
12026 PL_runops = proto_perl->Irunops;
12028 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
12031 PL_cshlen = proto_perl->Icshlen;
12032 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
12035 PL_lex_state = proto_perl->Ilex_state;
12036 PL_lex_defer = proto_perl->Ilex_defer;
12037 PL_lex_expect = proto_perl->Ilex_expect;
12038 PL_lex_formbrack = proto_perl->Ilex_formbrack;
12039 PL_lex_dojoin = proto_perl->Ilex_dojoin;
12040 PL_lex_starts = proto_perl->Ilex_starts;
12041 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
12042 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
12043 PL_lex_op = proto_perl->Ilex_op;
12044 PL_lex_inpat = proto_perl->Ilex_inpat;
12045 PL_lex_inwhat = proto_perl->Ilex_inwhat;
12046 PL_lex_brackets = proto_perl->Ilex_brackets;
12047 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
12048 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
12049 PL_lex_casemods = proto_perl->Ilex_casemods;
12050 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
12051 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
12053 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
12054 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
12055 PL_nexttoke = proto_perl->Inexttoke;
12057 /* XXX This is probably masking the deeper issue of why
12058 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
12059 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
12060 * (A little debugging with a watchpoint on it may help.)
12062 if (SvANY(proto_perl->Ilinestr)) {
12063 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
12064 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
12065 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12066 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
12067 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12068 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
12069 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12070 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
12071 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12074 PL_linestr = NEWSV(65,79);
12075 sv_upgrade(PL_linestr,SVt_PVIV);
12076 sv_setpvn(PL_linestr,"",0);
12077 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
12079 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12080 PL_pending_ident = proto_perl->Ipending_ident;
12081 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
12083 PL_expect = proto_perl->Iexpect;
12085 PL_multi_start = proto_perl->Imulti_start;
12086 PL_multi_end = proto_perl->Imulti_end;
12087 PL_multi_open = proto_perl->Imulti_open;
12088 PL_multi_close = proto_perl->Imulti_close;
12090 PL_error_count = proto_perl->Ierror_count;
12091 PL_subline = proto_perl->Isubline;
12092 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
12094 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
12095 if (SvANY(proto_perl->Ilinestr)) {
12096 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
12097 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12098 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
12099 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
12100 PL_last_lop_op = proto_perl->Ilast_lop_op;
12103 PL_last_uni = SvPVX(PL_linestr);
12104 PL_last_lop = SvPVX(PL_linestr);
12105 PL_last_lop_op = 0;
12107 PL_in_my = proto_perl->Iin_my;
12108 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
12110 PL_cryptseen = proto_perl->Icryptseen;
12113 PL_hints = proto_perl->Ihints;
12115 PL_amagic_generation = proto_perl->Iamagic_generation;
12117 #ifdef USE_LOCALE_COLLATE
12118 PL_collation_ix = proto_perl->Icollation_ix;
12119 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
12120 PL_collation_standard = proto_perl->Icollation_standard;
12121 PL_collxfrm_base = proto_perl->Icollxfrm_base;
12122 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
12123 #endif /* USE_LOCALE_COLLATE */
12125 #ifdef USE_LOCALE_NUMERIC
12126 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
12127 PL_numeric_standard = proto_perl->Inumeric_standard;
12128 PL_numeric_local = proto_perl->Inumeric_local;
12129 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
12130 #endif /* !USE_LOCALE_NUMERIC */
12132 /* utf8 character classes */
12133 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
12134 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
12135 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
12136 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
12137 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
12138 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
12139 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
12140 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
12141 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
12142 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
12143 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
12144 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
12145 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
12146 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
12147 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
12148 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
12149 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
12150 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
12151 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
12152 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
12154 /* Did the locale setup indicate UTF-8? */
12155 PL_utf8locale = proto_perl->Iutf8locale;
12156 /* Unicode features (see perlrun/-C) */
12157 PL_unicode = proto_perl->Iunicode;
12159 /* Pre-5.8 signals control */
12160 PL_signals = proto_perl->Isignals;
12162 /* times() ticks per second */
12163 PL_clocktick = proto_perl->Iclocktick;
12165 /* Recursion stopper for PerlIO_find_layer */
12166 PL_in_load_module = proto_perl->Iin_load_module;
12168 /* sort() routine */
12169 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
12171 /* Not really needed/useful since the reenrant_retint is "volatile",
12172 * but do it for consistency's sake. */
12173 PL_reentrant_retint = proto_perl->Ireentrant_retint;
12175 /* Hooks to shared SVs and locks. */
12176 PL_sharehook = proto_perl->Isharehook;
12177 PL_lockhook = proto_perl->Ilockhook;
12178 PL_unlockhook = proto_perl->Iunlockhook;
12179 PL_threadhook = proto_perl->Ithreadhook;
12181 PL_runops_std = proto_perl->Irunops_std;
12182 PL_runops_dbg = proto_perl->Irunops_dbg;
12184 #ifdef THREADS_HAVE_PIDS
12185 PL_ppid = proto_perl->Ippid;
12189 PL_last_swash_hv = Nullhv; /* reinits on demand */
12190 PL_last_swash_klen = 0;
12191 PL_last_swash_key[0]= '\0';
12192 PL_last_swash_tmps = (U8*)NULL;
12193 PL_last_swash_slen = 0;
12195 PL_glob_index = proto_perl->Iglob_index;
12196 PL_srand_called = proto_perl->Isrand_called;
12197 PL_hash_seed = proto_perl->Ihash_seed;
12198 PL_rehash_seed = proto_perl->Irehash_seed;
12199 PL_uudmap['M'] = 0; /* reinits on demand */
12200 PL_bitcount = Nullch; /* reinits on demand */
12202 if (proto_perl->Ipsig_pend) {
12203 Newz(0, PL_psig_pend, SIG_SIZE, int);
12206 PL_psig_pend = (int*)NULL;
12209 if (proto_perl->Ipsig_ptr) {
12210 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
12211 Newz(0, PL_psig_name, SIG_SIZE, SV*);
12212 for (i = 1; i < SIG_SIZE; i++) {
12213 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
12214 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
12218 PL_psig_ptr = (SV**)NULL;
12219 PL_psig_name = (SV**)NULL;
12222 /* thrdvar.h stuff */
12224 if (flags & CLONEf_COPY_STACKS) {
12225 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
12226 PL_tmps_ix = proto_perl->Ttmps_ix;
12227 PL_tmps_max = proto_perl->Ttmps_max;
12228 PL_tmps_floor = proto_perl->Ttmps_floor;
12229 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
12231 while (i <= PL_tmps_ix) {
12232 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
12236 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
12237 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
12238 Newz(54, PL_markstack, i, I32);
12239 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
12240 - proto_perl->Tmarkstack);
12241 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
12242 - proto_perl->Tmarkstack);
12243 Copy(proto_perl->Tmarkstack, PL_markstack,
12244 PL_markstack_ptr - PL_markstack + 1, I32);
12246 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
12247 * NOTE: unlike the others! */
12248 PL_scopestack_ix = proto_perl->Tscopestack_ix;
12249 PL_scopestack_max = proto_perl->Tscopestack_max;
12250 Newz(54, PL_scopestack, PL_scopestack_max, I32);
12251 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
12253 /* NOTE: si_dup() looks at PL_markstack */
12254 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
12256 /* PL_curstack = PL_curstackinfo->si_stack; */
12257 PL_curstack = av_dup(proto_perl->Tcurstack, param);
12258 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
12260 /* next PUSHs() etc. set *(PL_stack_sp+1) */
12261 PL_stack_base = AvARRAY(PL_curstack);
12262 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
12263 - proto_perl->Tstack_base);
12264 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
12266 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
12267 * NOTE: unlike the others! */
12268 PL_savestack_ix = proto_perl->Tsavestack_ix;
12269 PL_savestack_max = proto_perl->Tsavestack_max;
12270 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
12271 PL_savestack = ss_dup(proto_perl, param);
12275 ENTER; /* perl_destruct() wants to LEAVE; */
12278 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
12279 PL_top_env = &PL_start_env;
12281 PL_op = proto_perl->Top;
12284 PL_Xpv = (XPV*)NULL;
12285 PL_na = proto_perl->Tna;
12287 PL_statbuf = proto_perl->Tstatbuf;
12288 PL_statcache = proto_perl->Tstatcache;
12289 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
12290 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
12292 PL_timesbuf = proto_perl->Ttimesbuf;
12295 PL_tainted = proto_perl->Ttainted;
12296 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
12297 PL_rs = sv_dup_inc(proto_perl->Trs, param);
12298 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
12299 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
12300 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
12301 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
12302 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
12303 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
12304 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
12306 PL_restartop = proto_perl->Trestartop;
12307 PL_in_eval = proto_perl->Tin_eval;
12308 PL_delaymagic = proto_perl->Tdelaymagic;
12309 PL_dirty = proto_perl->Tdirty;
12310 PL_localizing = proto_perl->Tlocalizing;
12312 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
12313 PL_hv_fetch_ent_mh = Nullhe;
12314 PL_modcount = proto_perl->Tmodcount;
12315 PL_lastgotoprobe = Nullop;
12316 PL_dumpindent = proto_perl->Tdumpindent;
12318 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
12319 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
12320 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
12321 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
12322 PL_sortcxix = proto_perl->Tsortcxix;
12323 PL_efloatbuf = Nullch; /* reinits on demand */
12324 PL_efloatsize = 0; /* reinits on demand */
12328 PL_screamfirst = NULL;
12329 PL_screamnext = NULL;
12330 PL_maxscream = -1; /* reinits on demand */
12331 PL_lastscream = Nullsv;
12333 PL_watchaddr = NULL;
12334 PL_watchok = Nullch;
12336 PL_regdummy = proto_perl->Tregdummy;
12337 PL_regprecomp = Nullch;
12340 PL_colorset = 0; /* reinits PL_colors[] */
12341 /*PL_colors[6] = {0,0,0,0,0,0};*/
12342 PL_reginput = Nullch;
12343 PL_regbol = Nullch;
12344 PL_regeol = Nullch;
12345 PL_regstartp = (I32*)NULL;
12346 PL_regendp = (I32*)NULL;
12347 PL_reglastparen = (U32*)NULL;
12348 PL_reglastcloseparen = (U32*)NULL;
12349 PL_regtill = Nullch;
12350 PL_reg_start_tmp = (char**)NULL;
12351 PL_reg_start_tmpl = 0;
12352 PL_regdata = (struct reg_data*)NULL;
12355 PL_reg_eval_set = 0;
12357 PL_regprogram = (regnode*)NULL;
12359 PL_regcc = (CURCUR*)NULL;
12360 PL_reg_call_cc = (struct re_cc_state*)NULL;
12361 PL_reg_re = (regexp*)NULL;
12362 PL_reg_ganch = Nullch;
12363 PL_reg_sv = Nullsv;
12364 PL_reg_match_utf8 = FALSE;
12365 PL_reg_magic = (MAGIC*)NULL;
12367 PL_reg_oldcurpm = (PMOP*)NULL;
12368 PL_reg_curpm = (PMOP*)NULL;
12369 PL_reg_oldsaved = Nullch;
12370 PL_reg_oldsavedlen = 0;
12371 #ifdef PERL_COPY_ON_WRITE
12374 PL_reg_maxiter = 0;
12375 PL_reg_leftiter = 0;
12376 PL_reg_poscache = Nullch;
12377 PL_reg_poscache_size= 0;
12379 /* RE engine - function pointers */
12380 PL_regcompp = proto_perl->Tregcompp;
12381 PL_regexecp = proto_perl->Tregexecp;
12382 PL_regint_start = proto_perl->Tregint_start;
12383 PL_regint_string = proto_perl->Tregint_string;
12384 PL_regfree = proto_perl->Tregfree;
12386 PL_reginterp_cnt = 0;
12387 PL_reg_starttry = 0;
12389 /* Pluggable optimizer */
12390 PL_peepp = proto_perl->Tpeepp;
12392 PL_stashcache = newHV();
12394 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12395 ptr_table_free(PL_ptr_table);
12396 PL_ptr_table = NULL;
12399 /* Call the ->CLONE method, if it exists, for each of the stashes
12400 identified by sv_dup() above.
12402 while(av_len(param->stashes) != -1) {
12403 HV* stash = (HV*) av_shift(param->stashes);
12404 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12405 if (cloner && GvCV(cloner)) {
12410 XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
12412 call_sv((SV*)GvCV(cloner), G_DISCARD);
12418 SvREFCNT_dec(param->stashes);
12420 /* orphaned? eg threads->new inside BEGIN or use */
12421 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
12422 (void)SvREFCNT_inc(PL_compcv);
12423 SAVEFREESV(PL_compcv);
12429 #endif /* USE_ITHREADS */
12432 =head1 Unicode Support
12434 =for apidoc sv_recode_to_utf8
12436 The encoding is assumed to be an Encode object, on entry the PV
12437 of the sv is assumed to be octets in that encoding, and the sv
12438 will be converted into Unicode (and UTF-8).
12440 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12441 is not a reference, nothing is done to the sv. If the encoding is not
12442 an C<Encode::XS> Encoding object, bad things will happen.
12443 (See F<lib/encoding.pm> and L<Encode>).
12445 The PV of the sv is returned.
12450 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12453 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12467 Passing sv_yes is wrong - it needs to be or'ed set of constants
12468 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12469 remove converted chars from source.
12471 Both will default the value - let them.
12473 XPUSHs(&PL_sv_yes);
12476 call_method("decode", G_SCALAR);
12480 s = SvPV(uni, len);
12481 if (s != SvPVX(sv)) {
12482 SvGROW(sv, len + 1);
12483 Move(s, SvPVX(sv), len, char);
12484 SvCUR_set(sv, len);
12485 SvPVX(sv)[len] = 0;
12492 return SvPOKp(sv) ? SvPVX(sv) : NULL;
12496 =for apidoc sv_cat_decode
12498 The encoding is assumed to be an Encode object, the PV of the ssv is
12499 assumed to be octets in that encoding and decoding the input starts
12500 from the position which (PV + *offset) pointed to. The dsv will be
12501 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
12502 when the string tstr appears in decoding output or the input ends on
12503 the PV of the ssv. The value which the offset points will be modified
12504 to the last input position on the ssv.
12506 Returns TRUE if the terminator was found, else returns FALSE.
12511 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12512 SV *ssv, int *offset, char *tstr, int tlen)
12516 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12527 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
12528 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
12530 call_method("cat_decode", G_SCALAR);
12532 ret = SvTRUE(TOPs);
12533 *offset = SvIV(offsv);
12539 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12545 * c-indentation-style: bsd
12546 * c-basic-offset: 4
12547 * indent-tabs-mode: t
12550 * ex: set ts=8 sts=4 sw=4 noet: